'From Squeak3.8alpha of 8 September 2004 [latest update: #5993] on 3 November 2004 at 7:27:59 pm'!

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'!
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: 'jm 12/14/2001 11:21'!
reset

	self resetForMono.
! !

!ADPCMCodec methodsFor: 'private' stamp: 'jm 11/21/2001 11:35'!
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: 'zz 3/2/2004 07:58' prior: 16787369!
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: 'ar 4/23/2001 15:11'!
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: 'ar 4/23/2001 15:11'!
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: 'ar 4/23/2001 15:11'!
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 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 class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'!
newBitsPerSample: bitsPerSample

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

!AIFFFileReader methodsFor: 'reading' stamp: 'jm 10/17/2001 17:20'!
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'!
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: 'accessing' stamp: 'jm 10/20/2001 15:07'!
channelDataOffset

	^ channelDataOffset
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 10/20/2001 15:07'!
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.
! !

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

!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 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 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: 'accessing' stamp: 'NS 1/16/2004 14:08'!
allChangeKinds
	"AbstractEvent allChangeKinds"

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

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/29/2003 15:14'!
allItemKinds
	"SystemEvent 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: '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: 'rw 11/4/2003 14:32'!
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 |
	filename := 'SystemchangeNotification'.
	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'.

	(SARChangeSetDumper
		on: Project current changeSet
		including: (ChangeSorter allChangeSetNames
				select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText;
		 readmeText: readmeText;
		 fileOutAsZipNamed: filename , aNumber printString , '.sar'! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'sd 3/9/2004 19:42' prior: 33583975!
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: (ChangeSorter allChangeSetNames
				select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText;
		 readmeText: readmeText;
		 fileOutAsZipNamed: filename , aNumber printString , '.sar'! !

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

!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'!
derivativeFonts
	^#()! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:51'!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self ascent + self descent! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 12/20/2002 18:59'!
isL2R

	self subclassResponsibility
! !

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

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:07'!
lineGrid
	"Answer the relative space between lines"
	^ self ascent + self descent! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/25/2004 15:29'!
pixelSize
	"Make sure that we don't return a Fraction"
	^ self pointSize * 96.0 / 72.0.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33' prior: 33588592!
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 7/11/2004 21:15' prior: 33589047!
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: 'nk 3/22/2004 15:15' prior: 33589477!
textStyleName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self familyName! !

!AbstractFont methodsFor: 'displaying' stamp: 'yo 12/20/2002 18:58'!
displayStringR2L: 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: 'measuring' stamp: 'sps 3/23/2004 15:49'!
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
        from: 1
        to: aText size.

     "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 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: 'testing' stamp: 'nk 6/25/2003 12:54'!
isTTCFont
	^false! !

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

!AbstractFont commentStamp: '<historical>' prior: 0!
AbstractFont defines the generic interface that all fonts need to implement.!
!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: '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 class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55' prior: 16841786!
extractParameters
	
	^ SmalltalkImage current extractParameters! !

!AbstractLauncher class methodsFor: 'activation'!
deactivate
	"Unregister this launcher with the auto start class"
	self autoStarter removeLauncher: self! !

!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' prior: 16843275!
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! !

!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: '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: '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: 'playing' stamp: 'gk 2/24/2004 22:23' prior: 16851715!
play
	"Play this sound to the sound output port in real time."

	SoundPlayer playSound: 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: 'file i/o' stamp: 'jm 12/16/2001 21:51'!
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: 'jm 12/16/2001 22:31'!
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: 'jm 12/17/2001 08:36'!
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 ~= (Smalltalk endianness = #big).

	'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: 'sd 9/30/2003 13:41' prior: 33596947!
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: 'jm 12/16/2001 21:47'!
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: 'jm 12/16/2001 22:32'!
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: 'jm 12/16/2001 20:03'!
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: 'jm 12/16/2001 22:32'!
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.
! !

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

!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: 'sw 3/4/2004 02:40'!
soundNameFromUser
	"Pop up a list of available sound names and answer the one the user chooses, or nil if no choice made"

	^ (SelectionMenu selections: self sampledSoundChoices asSortedArray) startUpWithCaption: 'Sounds' translated

"
SoundService default soundNameFromUser
"! !

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

	self subclassResponsibility! !

!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.!
!AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 22:26'!
at: index 

	^ super at: index.

! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 22:27'!
at: index put: aCharacter 

	super at: index put: Character asciiValue.
! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:21'!
byteAt: index

	^ super at: index.
! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'!
byteAt: index put: value

	^ super at: index put: value.
! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:31'!
byteSize
	^self size! !

!AbstractString 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]
"! !

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findAnySubStr: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters.  delimiters is an Array of Strings (Characters are permitted also).  If the receiver does not contain any of the delimiters, answer size + 1."

	| min ind |
	min _ self size + 1.
	delimiters do: [:delim |	"May be a char, a string of length 1, or a substring"
		delim class == Character 
			ifTrue: [ind _ self indexOfSubCollection: (String with: delim) 
						startingAt: start ifAbsent: [min]]
			ifFalse: [ind _ self indexOfSubCollection: delim 
						startingAt: start ifAbsent: [min]].
			min _ min min: ind].
	^ min! !

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

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

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

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

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

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

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findTokens: delimiters
	"Answer the collection of tokens that result from parsing self.  Return strings between the delimiters.  Any character in the Collection delimiters marks a border.  Several delimiters in a row are considered as just one separation.  Also, allow delimiters to be a single character."

	| tokens keyStart keyStop separators |

	tokens _ OrderedCollection new.
	separators _ delimiters class == Character 
		ifTrue: [Array with: delimiters]
		ifFalse: [delimiters].
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipDelimiters: separators startingAt: keyStop.
		keyStop _ self findDelimiters: separators startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

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

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

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
includesSubString: subString
	^ (self findString: subString startingAt: 1) > 0! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
includesSubstring: aString caseSensitive: caseSensitive
	
	^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOf: aCharacter

	(aCharacter class == Character) ifFalse: [^ 0].
	^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: 1! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:45' prior: 33614752!
indexOf: aCharacter

	aCharacter isCharacter ifFalse: [^ 0].
	^ self class
		indexOfAscii: aCharacter asciiValue
		inString: self
		startingAt: 1.
! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOf: aCharacter  startingAt: start

	(aCharacter class == Character) ifFalse: [^ 0].
	^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOf: aCharacter  startingAt: start  ifAbsent: aBlock
	| ans |
	(aCharacter class == Character) ifFalse: [ ^ aBlock value ].
	ans _ String indexOfAscii: aCharacter asciiValue inString: self  startingAt: start.
	ans = 0
		ifTrue: [ ^ aBlock value ]
		ifFalse: [ ^ ans ]! !

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

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

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfAnyOf: aCharacterSet  startingAt: start ifAbsent: aBlock
	"returns the index of the first character in the given set, starting from start"

	| ans |
	ans _ String findFirstInString: self  inSet: aCharacterSet byteArrayMap startingAt: start.

	ans = 0 
		ifTrue: [ ^aBlock value ]
		ifFalse: [ ^ans ]! !

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

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

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

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:33' prior: 33618363!
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! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
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
"! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34' prior: 33619400!
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
"! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
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
"! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34' prior: 33620146!
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
"! !

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

!AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
skipAnySubStr: delimiters startingAt: start 
	"Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed).  If the receiver is all delimiters, answer size + 1."
	| any this ind ii |
	ii _ start-1.
	[(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match"
		any _ false.
		delimiters do: [:delim |
			delim class == Character 
				ifTrue: [(self at: ii) == delim ifTrue: [any _ true]]
				ifFalse: ["a substring"
					delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was."
						[ind _ 0.
						this _ true.
						delim do: [:dd | 
							dd == (self at: ii+ind) ifFalse: [this _ false].
							ind _ ind + 1].
						this ifTrue: [ii _ ii + delim size - 1.  any _ true]]
							ifTrue: [any _ false] "if the delim is too big, it can't match"]].
		any ifFalse: [^ ii]].
	^ self size + 1! !

!AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:28' prior: 33621712!
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! !

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

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

!AbstractString 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]
"! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'!
< aString 
	"Answer whether the receiver sorts before aString.
	The collation order is simple ascii (with case differences)."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'!
<= aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is simple ascii (with case differences)."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
= aString 
	"Answer whether the receiver sorts equally as aString.
	The collation order is simple ascii (with case differences)."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
> aString 
	"Answer whether the receiver sorts after aString.
	The collation order is simple ascii (with case differences)."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
>= aString 
	"Answer whether the receiver sorts after or equal to aString.
	The collation order is simple ascii (with case differences)."

	self subclassResponsibility.
! !

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

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

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
caseInsensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case insensitive."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
caseSensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case sensitive."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 8/27/2002 14:15' prior: 33627860!
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! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
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 subclassResponsibility.
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
crc16
	"Compute a 16 bit cyclic redundancy check."

	| crc |
	crc := 0.
	self do: [:c |
		crc := (crc bitShift: -8) bitXor: (
		 #(	16r0000	16rC0C1	16rC181	16r0140	16rC301	16r03C0	16r0280	16rC241
			16rC601	16r06C0	16r0780	16rC741	16r0500	16rC5C1	16rC481	16r0440
			16rCC01	16r0CC0	16r0D80	16rCD41	16r0F00	16rCFC1	16rCE81	16r0E40
			16r0A00	16rCAC1	16rCB81	16r0B40	16rC901	16r09C0	16r0880	16rC841
			16rD801	16r18C0	16r1980	16rD941	16r1B00	16rDBC1	16rDA81	16r1A40
			16r1E00	16rDEC1	16rDF81	16r1F40	16rDD01	16r1DC0	16r1C80	16rDC41
			16r1400	16rD4C1	16rD581	16r1540	16rD701	16r17C0	16r1680	16rD641
			16rD201	16r12C0	16r1380	16rD341	16r1100	16rD1C1	16rD081	16r1040
			16rF001	16r30C0	16r3180	16rF141	16r3300	16rF3C1	16rF281	16r3240
			16r3600	16rF6C1	16rF781	16r3740	16rF501	16r35C0	16r3480	16rF441
			16r3C00	16rFCC1	16rFD81	16r3D40	16rFF01	16r3FC0	16r3E80	16rFE41
			16rFA01	16r3AC0	16r3B80	16rFB41	16r3900	16rF9C1	16rF881	16r3840
			16r2800	16rE8C1	16rE981	16r2940	16rEB01	16r2BC0	16r2A80	16rEA41
			16rEE01	16r2EC0	16r2F80	16rEF41	16r2D00	16rEDC1	16rEC81	16r2C40
			16rE401	16r24C0	16r2580	16rE541	16r2700	16rE7C1	16rE681	16r2640
			16r2200	16rE2C1	16rE381	16r2340	16rE101	16r21C0	16r2080	16rE041
			16rA001	16r60C0	16r6180	16rA141	16r6300	16rA3C1	16rA281	16r6240
			16r6600	16rA6C1	16rA781	16r6740	16rA501	16r65C0	16r6480	16rA441
			16r6C00	16rACC1	16rAD81	16r6D40	16rAF01	16r6FC0	16r6E80	16rAE41
			16rAA01	16r6AC0	16r6B80	16rAB41	16r6900	16rA9C1	16rA881	16r6840
			16r7800	16rB8C1	16rB981	16r7940	16rBB01	16r7BC0	16r7A80	16rBA41
			16rBE01	16r7EC0	16r7F80	16rBF41	16r7D00	16rBDC1	16rBC81	16r7C40
			16rB401	16r74C0	16r7580	16rB541	16r7700	16rB7C1	16rB681	16r7640
			16r7200	16rB2C1	16rB381	16r7340	16rB101	16r71C0	16r7080	16rB041
			16r5000	16r90C1	16r9181	16r5140	16r9301	16r53C0	16r5280	16r9241
			16r9601	16r56C0	16r5780	16r9741	16r5500	16r95C1	16r9481	16r5440
			16r9C01	16r5CC0	16r5D80	16r9D41	16r5F00	16r9FC1	16r9E81	16r5E40
			16r5A00	16r9AC1	16r9B81	16r5B40	16r9901	16r59C0	16r5880	16r9841
			16r8801	16r48C0	16r4980	16r8941	16r4B00	16r8BC1	16r8A81	16r4A40
			16r4E00	16r8EC1	16r8F81	16r4F40	16r8D01	16r4DC0	16r4C80	16r8C41
			16r4400	16r84C1	16r8581	16r4540	16r8701	16r47C0	16r4680	16r8641
			16r8201	16r42C0	16r4380	16r8341	16r4100	16r81C1	16r8081	16r4040)
			 at: ((crc bitXor: c asciiValue) bitAnd: 16rFF) + 1) ].
	^crc! !

!AbstractString 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'
"! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
endsWithAnyOf: aCollection
	aCollection do:[:suffix|
		(self endsWith: suffix) ifTrue:[^true].
	].
	^false! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
hash
	"#hash is implemented, because #= is implemented"

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

!AbstractString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:43' prior: 33632019!
hash
	"#hash is implemented, because #= is implemented"

	^ self class stringHash: self initialHash: self species hash
! !

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

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

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

!AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'!
sameAs: aString 
	"Answer whether the receiver sorts equal to aString. The 
	collation sequence is ascii with case differences ignored."

	self subclassResponsibility.
! !

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

!AbstractString 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'"! !

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

!AbstractString 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)].! !

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

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

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asCharacter
	"Answer the receiver's first character, or '•' if none.  Idiosyncratic, provisional."

	^ self size > 0 ifTrue: [self first] ifFalse: [$•]! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/4/2003 14:37' prior: 33637966!
asCharacter
	"Answer the receiver's first character, or '*' if none.  Idiosyncratic, provisional."

	^ self size > 0 ifTrue: [self first] ifFalse: [$*]! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDate
	"Many allowed forms, see Date>>#readFrom:"

	^ Date fromString: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDateAndTime

	"Convert from UTC format" 	^ DateAndTime fromString: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 10/22/2002 17:38'!
asDefaultDecodedString

	^ self
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDisplayText
	"Answer a DisplayText whose text string is the receiver."

	^DisplayText text: self asText! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDuration
	"convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements"

	^ Duration fromString: self
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asFileName
	"Answer a String made up from the receiver that is an acceptable file 
	name."

	^FileDirectory checkName: self fixErrors: true! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:38' prior: 33639434!
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
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asHex
	| stream |
	stream _ WriteStream on: (String new: self size * 2).
	self do: [ :ch | stream nextPutAll: ch hex ].
	^stream contents! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 23:06' prior: 33640272!
asHex
	| stream |
	stream _ WriteStream on: (String new: self size * 4).
	self do: [ :ch | stream nextPutAll: ch hex ].
	^stream contents! !

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

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

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

"! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asInteger 
	"Answer the Integer created by interpreting the receiver as the string representation of an integer.  Answer nil if no digits, else find the first digit and then all consecutive digits after that"

	| startPosition tail endPosition |
	startPosition _ self findFirst: [:ch | ch isDigit].
	startPosition == 0 ifTrue: [^ nil].
	tail _ self copyFrom: startPosition to: self size.
	endPosition _ tail findFirst: [:ch | ch isDigit not].
	endPosition == 0 ifTrue: [endPosition _ tail size + 1].
	^ Number readFromString: (tail copyFrom: 1 to: endPosition - 1)

"
'1796exportFixes-tkMX' asInteger
'1848recentLogFile-sw'  asInteger
'donald' asInteger
'abc234def567' asInteger
"! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asMorph 
	"Answer the receiver as a StringMorph"

	^ StringMorph contents: self

"'bugs black blood' asMorph openInHand"! !

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

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:51'!
asOctetString

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asPacked
	"Convert to a longinteger that describes the string"
	^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:39' prior: 33644336!
asPacked
	"Convert to a longinteger that describes the string"

	^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asParagraph
	"Answer a Paragraph whose text string is the receiver."

	^Paragraph withText: self asText! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asSignedInteger
	"Answer the Integer created by interpreting the receiver as the string representation of an integer, possibly with a leading minus sign.  Answer nil if no digits, else find the first digit and then all consecutive digits after that"

	| startPosition tail endPosition |
	startPosition _ self findFirst: [:ch | ch isDigit or: [ch == $-]].
	startPosition == 0 ifTrue: [^ nil].
	tail _ self copyFrom: startPosition to: self size.
	endPosition _ tail findFirst: [:ch | ch isDigit not and: [ch ~~ $-]].
	endPosition == 0 ifTrue: [endPosition _ tail size + 1].
	^ Number readFromString: (tail copyFrom: 1 to: endPosition - 1)

"
'znak -58 to wit' asSignedInteger
"! !

!AbstractString 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: $".
	].
	! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asString
	"Answer this string."

	^ self
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asStringOrText
	"Answer this string."

	^ self
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asSymbol
	"Answer the unique Symbol whose characters are the characters of the 
	string."

	^Symbol intern: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:53' prior: 33646817!
asSymbol
	"Answer the unique Symbol whose characters are the characters of the 
	string."

	^ self class correspondingSymbolClass intern: self.
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asText
	"Answer a Text whose string is the receiver."

	^Text fromString: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asTime
	"Many allowed forms, see Time>>readFrom:"

	^ Time fromString: self.! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asTimeStamp
	"Convert from obsolete TimeStamp format"

	^ TimeStamp fromString: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/8/2002 11:33'!
asTranslatedWording

	self subclassResponsibility
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 20:31' prior: 33647828!
asUnHtml
	"Strip out all Html stuff (commands in angle brackets <>) and convert
the characters &<> back to their real value.  Leave actual cr and tab as
they were in text."
	| in out char rest did |
	in _ ReadStream on: self.
	out _ WriteStream on: (String new: self size).
	[in atEnd] whileFalse:
		[in peek = $<
			ifTrue: [in unCommand] 	"Absorb <...><...>"
			ifFalse: [(char _ in next) = $&
						ifTrue: [rest _ in upTo: $;.
								did _ out position.
								rest = 'lt' ifTrue: [out nextPut: $<].
								rest = 'gt' ifTrue: [out nextPut: $>].
								rest = 'amp' ifTrue: [out nextPut: $&].
								did = out position ifTrue: [
									self error: 'new HTML char encoding'.
									"Please add it to this code"]]
						ifFalse: [out nextPut: char]].
		].
	^ out contents! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asUrlRelativeTo: aUrl
	^aUrl newFromRelativeText: self! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
askIfAddStyle: priorMethod req: requestor
	^ self   "we are a string with no text style"! !

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

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

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

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

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
encodeForHTTP
	"change dangerous characters to their %XX form, for use in HTTP transactions"
	| encodedStream |
	encodedStream _ WriteStream on: (String new).
	
	self do: [ :c |
		c isSafeForHTTP ifTrue: [ encodedStream nextPut: c ] ifFalse: [
			encodedStream nextPut: $%.
			encodedStream nextPut: (c asciiValue // 16) asHexDigit.
			encodedStream nextPut: (c asciiValue \\ 16) asHexDigit.
		]
	].
	^encodedStream contents. ! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:58' prior: 33653822!
encodeForHTTP
	"change dangerous characters to their %XX form, for use in HTTP  
	transactions"
	| encodedStream |
	encodedStream _ WriteStream on: String new.
	self do: [:character | character isSafeForHTTP
			ifTrue: [encodedStream nextPut: character]
			ifFalse: [character == Character space
					ifTrue: [encodedStream nextPut: $+]
					ifFalse: 
						[encodedStream nextPut: $%.
						encodedStream nextPut: (character asciiValue // 16) asHexDigit.
						encodedStream nextPut: (character asciiValue \\ 16) asHexDigit]]].
	^ encodedStream contents.
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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 _ String streamContents:
			[:s | level _ 0.
			possibleParens do:
				[:token |
				(level = 0 and: [token endsWith: ':'])
					ifTrue: [s nextPutAll: token]
					ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n].
							(n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]].

	sel isEmpty ifTrue: [^ nil].
	Symbol hasInterned: sel ifTrue:
		[:aSymbol | ^ aSymbol].
	^ nil! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:52' prior: 33654970!
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].
	self class correspondingSymbolClass hasInterned: sel ifTrue:
		[:aSymbol | ^ aSymbol].
	^ nil! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
numericSuffix
	^ self stemAndNumericSuffix last

"
'abc98' numericSuffix
'98abc' numericSuffix
"! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
onlyLetters
	"answer the receiver with only letters"
	^ self select:[:each | each isLetter]! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
openAsMorph
	"Open the receiver as a morph"

	^ self asMorph openInHand ! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:13' prior: 33659823!
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! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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 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! !

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
surroundedBySingleQuotes
	"Answer the receiver with leading and trailing quotes.  "

	^ $' asString, self, $' asString! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateFrom: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	String translate: self  from: start to: stop table: table! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:14' prior: 33663767!
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! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateToLowercase
	"Translate all characters to lowercase, in place"

	self translateWith: LowercasingTable! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateToUppercase
	"Translate all characters to lowercase, in place"

	self translateWith: UppercasingTable! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateWith: table
	"translate the characters in the string by the given table, in place"
	^self translateFrom: 1 to: self size table: table! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:13' prior: 33664654!
translateWith: table
	"translate the characters in the string by the given table, in place"
	^ self translateFrom: 1 to: self size table: table! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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

"
		! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:20' prior: 33665699!
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

"
		! !

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

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withBlanksTrimmed
	"Return a copy of the receiver from which leading and trailing blanks have been trimmed."

	| first |
	first _ self findFirst: [:c | c isSeparator not].
	first = 0 ifTrue: [^ ''].  "no non-separator character"
	^ self
		copyFrom: first
		to: (self findLast: [:c | c isSeparator not])

	" ' abc  d   ' withBlanksTrimmed"
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withFirstCharacterDownshifted
	"Answer an object like the receiver but with first character downshifted if necesary"
	"'MElViN' withFirstCharacterDownshifted"
	"#Will withFirstCharacterDownshifted"
	| answer |
	self isEmpty ifTrue: [^ self].
	answer _ self isString
				ifTrue: ["don't change receiver"
					self copy]
				ifFalse: [self asString].
	answer at: 1 put: (answer at: 1) asLowercase.
	^ self isString
		ifTrue: [answer]
		ifFalse: [answer as: self class]! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 20:31' prior: 33667579!
withFirstCharacterDownshifted
	"Answer an object like the receiver but with first character downshifted if necesary"
	"'MElViN' withFirstCharacterDownshifted"
	"#Will withFirstCharacterDownshifted"
	| answer |
	answer _ self isString
				ifTrue: ["don't change receiver"
					self copy]
				ifFalse: [self asString].
	answer at: 1 put: (answer at: 1) asLowercase.
	^ self isString
		ifTrue: [answer]
		ifFalse: [answer as: self class]! !

!AbstractString 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]"! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withSeparatorsCompacted
	"replace each sequences of whitespace by a single space character"
	| out pos textEnd |

	self isEmpty ifTrue: [ ^self ].

	out _ WriteStream on: (String new: self size).
	pos _ 1.   "current position in a scan through aString"


	"handle the case of initial separators"
	self first isSeparator ifTrue: [
		out nextPut: Character space.
		pos _ self indexOfAnyOf: CSNonSeparators ifAbsent: [ self size + 1 ] ].


	"central loop: handle a segment of text, followed possibly by a segment of whitespace"
	[ pos <= self size ] whileTrue: [ 
		"handle a segment of text..."

		textEnd _ self 
			indexOfAnyOf: CSSeparators
			startingAt: pos 
			ifAbsent: [ self size + 1 ].

		textEnd _ textEnd - 1.
		out nextPutAll: (self copyFrom: pos to: textEnd).
		pos _ textEnd + 1.

		pos <= self size ifTrue: [
			pos _ self 
				indexOfAnyOf: CSNonSeparators
				startingAt: pos
				ifAbsent: [ self size + 1 ].

			out nextPut: Character space  ] ].

	^out contents! !

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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
"
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06' prior: 33671171!
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
"
! !

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

!AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
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
"
! !

!AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06' prior: 33672802!
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
"
! !

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

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

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

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

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

!AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
newTileMorphRepresentative
	^ TileMorph new setLiteral: self! !

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

!AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
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: $'! !

!AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:57' prior: 33676491!
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: $'! !

!AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
isLiteral

	^true! !

!AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
printOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."

	self storeOn: aStream! !

!AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
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: $'! !

!AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:58' prior: 33677387!
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: $'! !

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

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

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

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

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

!AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'!
stringhash
	^self hash! !

!AbstractString methodsFor: 'private' stamp: 'yo 8/28/2002 15:22' prior: 33680698!
stringhash

	^ self hash.
! !

!AbstractString methodsFor: 'system primitives' stamp: 'yo 11/5/2002 15:32'!
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."

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'system primitives' stamp: 'yo 11/3/2004 19:24'!
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
"! !

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

!AbstractString methodsFor: 'Celeste' 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 ]].! !

!AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
decodeMimeHeader
	"See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII Text.
	Text containing non-ASCII characters is encoded by the sequence
		=?character-set?encoding?encoded-text?=
	Encoding is Q (quoted printable) or B (Base64), handled by Base64MimeConverter / RFC2047MimeConverter. The character-set (usually iso-8859-1) is ignored"

	| input output temp decoder encoding pos | 
	input _ ReadStream on: self.
	output _ WriteStream on: String new.

	[output nextPutAll: (input upTo: $=).	"ASCII Text"
	input atEnd] whileFalse: [
		(temp _ input next) = $?
			ifFalse: [output nextPut: $=; nextPut: temp]
			ifTrue: [
				input skipTo: $?. "Skip charset"
				encoding _ (input upTo: $?) asUppercase.
				temp _ input upTo: $?.
				input next.	"Skip final ="
				decoder _ encoding = 'B'
					ifTrue: [Base64MimeConverter new]
					ifFalse: [RFC2047MimeConverter new].
				decoder
					mimeStream: (ReadStream on: temp);
					dataStream: output;
					mimeDecode.
				pos _ input position.
				input skipSeparators.	"Delete spaces if followed by ="
				input peek = $= ifFalse: [input position: pos]]].
	^output contents! !

!AbstractString methodsFor: 'internet' stamp: 'yo 11/23/2003 20:35' prior: 33684339!
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 ="
					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! !

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

!AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
isoToSqueak
	^ self collect: [:each | each isoToSqueak]! !

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

!AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
squeakToIso
	^self collect: [:c | c squeakToIso ]! !

!AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
unescapePercents
	"change each %XY substring to the character with ASCII value XY in hex.  This is the opposite of #encodeForHTTP"
	| ans c asciiVal pos oldPos specialChars |
	ans _ WriteStream on: String new.
	oldPos _ 1.
	specialChars _ '+%' asCharacterSet.

	[pos _ self indexOfAnyOf: specialChars startingAt: oldPos. pos > 0]
	whileTrue: [
		ans nextPutAll: (self copyFrom: oldPos to: pos - 1).
		c _ self at: pos.
		c = $+ ifTrue: [ans nextPut: $ ] ifFalse: [
			(c = $% and: [pos + 2 <= self size]) ifTrue: [
				asciiVal _ (self at: pos+1) asUppercase digitValue * 16 +
					(self at: pos+2) asUppercase digitValue.
				pos _ pos + 2.
				asciiVal > 255 ifTrue: [^self].	"not really an escaped string"
				ans nextPut: (Character value: asciiVal)]
			ifFalse: [ans nextPut: c]].
		oldPos _ pos+1].
	ans nextPutAll: (self copyFrom: oldPos to: self size).
	^ ans contents! !

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

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

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

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

!AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
hasContentsInExplorer

	^false! !

!AbstractString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:09'!
includesUnifiedCharacter

	self subclassResponsibility.
! !

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

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

!AbstractString methodsFor: 'testing' stamp: 'yo 8/4/2003 12:26'!
isAsciiString

	| c |
	c _ self detect: [:each | each asciiValue > 127] ifNone: [nil].
	^ c isNil.
! !

!AbstractString methodsFor: 'testing' stamp: 'yo 8/28/2002 15:19'!
isOctetString

	self subclassResponsibility.
! !

!AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
isString
	^ true! !

!AbstractString methodsFor: 'testing' stamp: 'yo 12/29/2002 10:30'!
isUnicodeString

	^ false.
! !

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

!AbstractString methodsFor: 'paragraph support' stamp: 'yo 11/3/2004 19:24'!
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! !

!AbstractString methodsFor: 'paragraph support' stamp: 'yo 8/26/2002 22:19' prior: 33693208!
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.
! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
* arg

	^ arg adaptToString: self andSend: #*! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
+ arg

	^ arg adaptToString: self andSend: #+! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
- arg

	^ arg adaptToString: self andSend: #-! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
/ arg

	^ arg adaptToString: self andSend: #/! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
// arg

	^ arg adaptToString: self andSend: #//! !

!AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
\\ arg

	^ arg adaptToString: self andSend: #\\! !

!AbstractString methodsFor: 'filter streaming' stamp: 'yo 11/3/2004 19:24'!
byteEncode:aStream
	^aStream writeString:self.! !

!AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31' prior: 33695448!
byteEncode:aStream

	^aStream writeString: self.
! !

!AbstractString methodsFor: 'filter streaming' stamp: 'yo 11/3/2004 19:24'!
putOn:aStream
	^aStream nextPutAll:self.
! !

!AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31' prior: 33695721!
putOn:aStream

	^aStream nextPutAll: self.
! !

!AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'!
getInteger32: location
	| integer |
	<primitive: 'getInteger' module: 'IntegerPokerPlugin'>
	"^IntegerPokerPlugin doPrimitive: #getInteger"

	"the following is about 7x faster than interpreting the plugin if not compiled"

	integer := 
		((self byteAt: location) bitShift: 24) +
		((self byteAt: location+1) bitShift: 16) +
		((self byteAt: location+2) bitShift: 8) +
		(self byteAt: location+3).

	integer > 1073741824 ifTrue: [
		^1073741824 - integer ].
	^integer
! !

!AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'!
putInteger32: anInteger at: location
	| integer |
	<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
	"IntegerPokerPlugin doPrimitive: #putInteger"

	"the following is close to 20x faster than the above if the primitive is not compiled"
	"PUTCOUNTER _ PUTCOUNTER + 1."
	integer _ anInteger.
	integer < 0 ifTrue: [integer :=  1073741824 - integer. ].
	self byteAt: location+3 put: (integer \\ 256).
	self byteAt: location+2 put: (integer bitShift: -8) \\ 256.
	self byteAt: location+1 put: (integer bitShift: -16) \\ 256.
	self byteAt: location put: (integer bitShift: -24) \\ 256.

"Smalltalk at: #PUTCOUNTER put: 0"! !

!AbstractString methodsFor: 'user interface' stamp: 'yo 11/3/2004 19:24'!
asExplorerString
	^ self printString! !

!AbstractString methodsFor: 'user interface' stamp: 'yo 8/26/2002 22:20' prior: 33697215!
asExplorerString

	^ self asString! !

!AbstractString methodsFor: 'user interface' stamp: 'yo 11/3/2004 19:24'!
openInWorkspaceWithTitle: aTitle
	"Open up a workspace with the receiver as its contents, with the given title"

	(Workspace new contents: self) openLabel: aTitle! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'!
sunitAsSymbol
 
        ^self asSymbol! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33697700!
sunitAsSymbol

        ^self asSymbol! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'!
sunitMatch: aString
 
        ^self match: aString! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33697951!
sunitMatch: aString

        ^self match: aString! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'!
sunitSubStrings
 
        ^self substrings! !

!AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33698226!
sunitSubStrings

        ^self substrings! !

!AbstractString methodsFor: '*packageinfo-base' stamp: 'yo 11/3/2004 19:24'!
escapeEntities
	^ String streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]]
! !

!AbstractString methodsFor: 'translating' stamp: 'yo 11/3/2004 19:24'!
translated
	"answer the receiver translated to the default language"
	^ Language defaultLanguage translationFor: self! !

!AbstractString methodsFor: 'translating' stamp: 'yo 11/3/2004 19:24'!
translatedTo: languageNameSymbol 
	"answer the receiver translated to the language named 
	languageNameSymbol "
	^ (Language languageNamed: languageNameSymbol)
		translationFor: self! !

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

!AbstractString methodsFor: '*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! !

!AbstractString methodsFor: '*versionnumber' stamp: 'yo 11/3/2004 19:24'!
asVersion
	"Answer a VersionNumber"

	^VersionNumber fromString: self! !

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 14:50'!
correspondingSymbolClass

	^ self subclassResponsibility.
! !

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

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

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
crlfcrlf
	^self crlf , self crlf.
! !

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

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

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

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
readFrom: inStream
	"Answer an instance of me that is determined by reading the stream, 
	inStream. Embedded double quotes become the quote Character."

	| outStream char done |
	outStream _ WriteStream on: (String new: 16).
	"go to first quote"
	inStream skipTo: $'.
	done _ false.
	[done or: [inStream atEnd]]
		whileFalse: 
			[char _ inStream next.
			char = $'
				ifTrue: 
					[char _ inStream next.
					char = $'
						ifTrue: [outStream nextPut: char]
						ifFalse: [done _ true]]
				ifFalse: [outStream nextPut: char]].
	^outStream contents! !

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:27' prior: 33701876!
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! !

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
tab
	"Answer a string containing a single tab character."

	^ self with: Character tab
! !

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
value: anInteger
	^self with: (Character value: anInteger)! !

!AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:29' prior: 33703347!
value: anInteger

	^ self with: (Character value: anInteger).
! !

!AbstractString class methodsFor: 'initialization' stamp: 'yo 11/3/2004 19:24'!
initialize   "String initialize"

	| order |
	AsciiOrder _ (0 to: 255) as: ByteArray.

	CaseInsensitiveOrder _ AsciiOrder copy.
	($a to: $z) do:
		[:c | CaseInsensitiveOrder at: c asciiValue + 1
				put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)].

	"Case-sensitive compare sorts space, digits, letters, all the rest..."
	CaseSensitiveOrder _ ByteArray new: 256 withAll: 255.
	order _ -1.
	' 0123456789' do:  "0..10"
		[:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	($a to: $z) do:     "11-64"
		[:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1).
		CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	1 to: CaseSensitiveOrder size do:
		[:i | (CaseSensitiveOrder at: i) = 255 ifTrue:
			[CaseSensitiveOrder at: i put: (order _ order+1)]].
	order = 255 ifFalse: [self error: 'order problem'].

	"a table for translating to lower case"
	LowercasingTable _ String withAll: (Character allCharacters collect: [:c | c asLowercase]).

	"a table for translating to upper case"
	UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]).

	"a table for testing tokenish (for fast numArgs)"
	Tokenish _ String withAll: (Character allCharacters collect:
									[:c | c tokenish ifTrue: [c] ifFalse: [$~]]).

	"CR and LF--characters that terminate a line"
	CSLineEnders _ CharacterSet empty.
	CSLineEnders add: Character cr.
	CSLineEnders add: Character lf.

 	"separators and non-separators"
	CSSeparators _ CharacterSet separators.
	CSNonSeparators _ CSSeparators complement.! !

!AbstractString class methodsFor: 'initialization' stamp: 'yo 8/28/2002 13:31' prior: 33703656!
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 allCharacters collect: [:c | c asLowercase]).

	"a table for translating to upper case"
	UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]).

	"a table for testing tokenish (for fast numArgs)"
	Tokenish _ String withAll: (Character allCharacters collect:
									[:c | c tokenish ifTrue: [c] ifFalse: [$~]]).

	"CR and LF--characters that terminate a line"
	CSLineEnders _ CharacterSet empty.
	CSLineEnders add: Character cr.
	CSLineEnders add: Character lf.

 	"separators and non-separators"
	CSSeparators _ CharacterSet separators.
	CSNonSeparators _ CSSeparators complement.! !

!AbstractString class methodsFor: 'initialization' stamp: 'yo 11/3/2004 19:24'!
initializeHtmlEntities
	"String initializeHtmlEntities"

	HtmlEntities _ (Dictionary new: 128)
		at: 'amp'	put: $&;
		at: 'lt'		put: $<;
		at: 'gt'		put: $>;
		at: 'quot'	put: $";
		at: 'euro'	put: Character euro;
		yourself.
	#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | 
		"filter out base characters CdG 1/8/2004 15:17"
		| char |
		char _ (index + 159) asCharacter isoToSqueak. 
		char >= (Character value: 128) ifTrue: [
			HtmlEntities at: each put: char]]! !

!AbstractString class methodsFor: 'initialization' stamp: 'yo 8/11/2003 21:11' prior: 33707006!
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]! !

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

!AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'!
findFirstInString: aString  inSet: inclusionMap  startingAt: start

	self subclassResponsibility.
! !

!AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:06'!
indexOfAscii: anInteger inString: aString startingAt: start

	self subclassResponsibility.
! !

!AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'!
stringHash: aString initialHash: speciesHash

	self subclassResponsibility.
! !

!AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'!
translate: aString from: start  to: stop  table: table

	self subclassResponsibility.
! !

!AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50' prior: 16902486!
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]! !

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 6/7/2003 09:56'!
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]]! !

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 8/2/2003 19:34' prior: 33710991!
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]]! !

!AcornFileDirectory methodsFor: 'private' stamp: 'tpr 12/21/2002 13:37'!
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 isEmpty
		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.
			(entries findFirst: [:ent | ent name = extraPath fullName] ) > 0
				ifFalse: [entries _ entries
								copyWith: (DirectoryEntry
										name: extraPath fullName
										creationTime: 0
										modificationTime: 0
										isDirectory: true
										fileSize: 0)]].
	^ entries
! !

!AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 12/3/2002 19:35'!
directoryExists: filenameOrPath
"if the path is a root,we have to treat it carefully"
	(filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists].
	^super directoryExists: filenameOrPath! !

!AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54' prior: 33713094!
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: '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 class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16' prior: 16903456!
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! !

!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: $)! !

!ActorState methodsFor: 'pen' stamp: 'nk 6/12/2004 16:36' prior: 16912750!
choosePenColor: evt
	owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer getPenColor hand: evt hand.! !

!ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:42'!
getPenArrowheads
	^ penArrowheads == true! !

!ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:43'!
setPenArrowheads: aBoolean
	penArrowheads _ aBoolean! !

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

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

	^true! !

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

	aStream nextPutAll: 'Added'! !

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

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:49'!
addGeeMailMenuItemsTo: menu

	self flag: #convertToBook.	"<-- no longer used"
	menu 
		addUpdating: #showPageBreaksString action: #togglePageBreaks;
		addUpdating: #keepScrollbarString action: #toggleKeepScrollbar;
		addLine;
		add: 'Print...' action: #printPSToFile;
		addLine.
	thePasteUp allTextPlusMorphs size = 1 ifTrue: [
		menu add: 'make 1-column book' selector: #makeBookStyle: argument: 1.
		menu add: 'make 2-column book' selector: #makeBookStyle: argument: 2.
		menu add: 'make 3-column book' selector: #makeBookStyle: argument: 3.
		menu add: 'make 4-column book' selector: #makeBookStyle: argument: 4.
	] ifFalse: [
		menu add: 'make a galley of me' action: #makeGalleyStyle.
	].
	^menu! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 20:50' prior: 33717857!
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! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:42'!
allTextPlusMorphs

	^thePasteUp allTextPlusMorphs! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:57'!
keepScrollBarAlways

	^self valueOfProperty: #keepScrollBarAlways ifAbsent: [false]! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:59'!
keepScrollbarString

	^self keepScrollBarAlways ifTrue: ['<on>scrollbar stays up'] ifFalse: ['<off>scrollbar stays up']! !

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

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

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

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

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

!AlansTextPlusMorph 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).
! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:10'!
showPageBreaksString

	^(thePasteUp ifNil: [^'???']) showPageBreaksString! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:58'!
toggleKeepScrollbar

	self setProperty: #keepScrollBarAlways toValue: self keepScrollBarAlways not! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:12'!
togglePageBreaks

	(thePasteUp ifNil: [^self]) togglePageBreaks! !

!AlansTextPlusMorph methodsFor: 'event handling' stamp: 'RAA 5/3/2001 17:33'!
handlesMouseDown: evt

	^evt yellowButtonPressed ! !

!AlansTextPlusMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:54'!
extraScrollRange
	^ bounds height
! !

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

!AlansTextPlusMorph methodsFor: 'initialization' stamp: 'RAA 5/2/2001 14:11'!
initialize

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

!AlansTextPlusMorph methodsFor: 'initialization' stamp: 'gm 3/10/2003 22:58' prior: 33725704!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self initializeThePasteUp.
	self position: 100@100.
	self extent: Display extent // 3.
	self useRoundedCorners.
	! !

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

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

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

!AlansTextPlusMorph methodsFor: 'menus' stamp: 'RAA 5/3/2001 17:50'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addGeeMailMenuItemsTo: aCustomMenu.! !

!AlansTextPlusMorph methodsFor: 'scroll bar events' stamp: 'RAA 5/3/2001 16:16'!
scrollBarValue: scrollValue

	| newPt pageBreaks topOfPage |

	scroller hasSubmorphs ifFalse: [^ self].
	newPt _ -3 @ (self leftoverScrollRange * 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 leftoverScrollRange.
	].
	scroller offset: newPt.! !

!AlansTextPlusMorph methodsFor: 'scroll bar events' stamp: 'nk 4/28/2004 10:22' prior: 33727291!
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.! !

!AlansTextPlusMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:14'!
vHideScrollBar

	self keepScrollBarAlways ifTrue: [^self].
	^super vHideScrollBar! !

!AlansTextPlusMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 5/7/2001 12:20'!
printPSToFile

	thePasteUp printer
		geeMail: self;
		doPages! !

!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' prior: 16933662!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 25 @ 25.
! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'sw 8/12/2001 02:48'!
basicInitialize
	"Do basic generic initialization of the instance variables"

	super basicInitialize.
	borderWidth _ 0.
	self layoutPolicy: TableLayout new.
	self listDirection: #leftToRight.
	self wrapCentering: #topLeft.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	self layoutInset: 2.
	color _ Color r: 0.8 g: 1.0 b: 0.8.
	self rubberBandCells: true.! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:02' prior: 33729549!
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 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' prior: 16989545!
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: 'object fileIn' stamp: 'gm 2/22/2003 13:12' prior: 16990771!
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: '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 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 class methodsFor: 'instance creation' stamp: 'sw 11/16/2001 09:34'!
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!!'.
	^ aColumn! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05' prior: 33734018!
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: 'sw 11/16/2001 09:36'!
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!!'.
	aRow color: Color veryVeryLightGray.
	^ aRow

			"AlignmentMorph rowPrototype openInHand"! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05' prior: 33736616!
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: '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 class methodsFor: '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:)
		)))
! !

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

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/14/2001 00:31'!
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') lock.
	outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown'.
	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') 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.'.
	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 9/19/2003 14:34' prior: 33740976!
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: 'sw 11/13/2001 19:42'!
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'.
	^ aButton! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 8/31/2003 19:43' prior: 33745120!
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 11/13/2001 19:43'!
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 |
	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.
	aRow addMorphFront: self dismissButton.
	aRow addMorphBack: ScriptingSystem scriptControlButtons.
	aRow addMorphBack: self openUpButton.
	self addMorphFront: aRow.

! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/13/2001 16:51'!
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)
		openLabel: 'About the All Scripts tool'! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:35' prior: 33746757!
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: 'sw 8/12/2001 02:57'!
initializeToStandAlone
	super initializeToStandAlone.
	self layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill;
		rubberBandCells: true;
		yourself.

	self initializeFor: self currentWorld presenter! !

!AllScriptsTool methodsFor: 'parts bin' stamp: 'dgd 2/22/2003 19:37' prior: 33752331!
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: 'toggles' stamp: 'sw 11/13/2001 18:35'!
openUpButton
	"Answer a button whose action would be to open up the receiver or snap it back closed"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self topRendererOrSelf;
		color: (Color r: 0.452 g: 0.839 b: 0.935);
		label: 'º' font: Preferences standardButtonFont;
		actionSelector: #toggleWhetherShowingOnlyTopControls;
		setBalloonText: 'open or close the lower portion that shows individual scripts'.
	^ aButton! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'dgd 9/19/2003 14:37' prior: 33753283!
openUpButton
	"Answer a button whose action would be to open up the receiver or snap it back closed"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self topRendererOrSelf;
		color: (Color r: 0.452 g: 0.839 b: 0.935);
		label: 'º' font: Preferences standardButtonFont;
		actionSelector: #toggleWhetherShowingOnlyTopControls;
		setBalloonText: 'open or close the lower portion that shows individual scripts' translated.
	^ aButton! !

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

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

!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: 'ar 8/8/2001 14:24'!
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: 31
			alpha: alpha.
	].
	rule = Form over ifTrue:[
		^myCanvas
			image: aForm
			at: aPoint
			sourceRect: sourceRect
			rule: 30
			alpha: alpha.
	].! !

!AlphaBlendingCanvas methodsFor: 'private' stamp: 'bf 10/28/2003 15:46' prior: 33758366!
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)! !

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
dependenciesForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict values
		do: [:cm | (cm literals
				select: [:l | l isKindOf: LookupKey]) 
				do: [:ll | ll key
						ifNotNil: [r add: ll key]]].
	^ r! !

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
externalReference
	^ self ! !

!Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'!
externalReferenceOf: aCollectionOfClass 
	| r |
	r := Set new.
	aCollectionOfClass
		do: [:cls | r
				addAll: (self dependenciesForClass: cls)].
	aCollectionOfClass 
		do: [:clss | r
				remove: clss name
				ifAbsent: []].
	^ r! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
doesClass: cls define: aSelector 
	^ cls methodDict includesKey: aSelector ! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
methodsCalledAndCalleeForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict
		associationsDo: [:assoc | (assoc value literals
				select: [:l | l isKindOf: Symbol])
				do: [:ll | r 
						add: (Array with: assoc key with: ll)]].
	^ r! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
methodsCalledForClass: aClass 
	| r |
	r := Set new.
	aClass methodDict values 
		do: [:cm | (cm literals
				select: [:l | l isKindOf: Symbol])
				do: [:ll | r add: ll]].
	^ r! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'!
methodsDefinedForClass: aClass 
	^ aClass methodDict keys ! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'!
methodsIn: cls callingMethodsDefinedIn: classes 
	"Give collection matching (m1, m2) where: 
	
		- m1 is defined in C 
	
		- m2 is defined in classes 
	
		- m2 called in m1 of C, 

		- and m2 not defined in C"
	
	"We made the following assumption: If a method foo is in defined in cls  
	and in classes, then if cls call foo, then it calls its own"

	| methodsCalled allMethodsDefined ans |
	methodsCalled := self methodsCalledAndCalleeForClass: cls.
	allMethodsDefined := Set new.
	classes
		do: [:clss | allMethodsDefined
				addAll: (self methodsDefinedForClass: clss)].
	ans := methodsCalled
				select: [:calleeCalled | (self doesClass: cls define: calleeCalled second) not
						and: [allMethodsDefined includes: calleeCalled second]].
	^ ans! !

!Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'!
referingMethodsDefinedInSubclasses: aClass 
	| r |
	r := self methodsCalledForClass: aClass. 
	subclasses := aClass allSubclasses.
	subclasses remove: aClass! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example1
	"self example1"
	Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class )
			collect: [:clsname | Smalltalk at: clsname]) inspect ! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example2
	"self example2"
	(Analyzer 
		externalReferenceOf: (#(#Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname])) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example3
	"self example3"
	(((Analyzer
		externalReferenceOf: (#(#Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname]))
		select: [:clsName | (Smalltalk includesKey: clsName) 
				and: [(Smalltalk at: clsName)
						isKindOf: Class]])
		select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example4 
	"self example4"
	(((Analyzer
		externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname]))
		select: [:clsName | (Smalltalk includesKey: clsName)
				and: [(Smalltalk at: clsName)
						isKindOf: Class]])
		select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! !

!Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'!
example5
	"self example5"
	| classes | 
	classes := #(#ClassBuilder #ClassDescription #Class )
				collect: [:clsname | Smalltalk at: clsname].
	(Analyzer methodsIn: Behavior callingMethodsDefinedIn: classes) inspect! !

!AnalyzerTest methodsFor: 'utility' stamp: 'ab 3/8/2003 13:55'!
createClass: aClassname
	^ self createClass: aClassname superclass: Object 
! !

!AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:42'!
createClass: aClassname superclass: aClass 
	| r |
	r _ aClass
		subclass: aClassname
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Tests-KCP'.
	classesCreated add: r.
	^ r! !

!AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:41'!
removeClassIfExists: aClassname 
	Smalltalk
		at: aClassname
		ifPresent: [:cls | cls removeFromSystem] ! !

!AnalyzerTest methodsFor: 'utility' stamp: 'rw 5/12/2003 11:56'!
removeClassNamedIfExists: aClassname

	Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem].
	Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! !

!AnalyzerTest methodsFor: 'running' stamp: 'ab 3/8/2003 13:54'!
setUp
	classesCreated _ OrderedCollection new! !

!AnalyzerTest methodsFor: 'running' stamp: 'sd 5/23/2003 14:51'!
tearDown

	| name |
	classesCreated
		do: [:cls | 
			name _ cls name.
			self removeClassNamedIfExists: name.
			ChangeSet current removeClassChanges: name].
	classesCreated _ nil! !

!AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'!
testDependenciesForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	"-------"
	r _ Analyzer dependenciesForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection )).
! !

!AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'!
testExternalReferenceOf
	| r cls1 cls2 cls3 |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2.
	cls3 _ self createClass: #MyClass3.
	"-------"
	cls1 compile: 'foo ^ MyClass2'.
	cls1 compile: 'bar MyClass1 show: ''blah blah'''.
	cls1 compile: 'zork OrderedCollection new'.
	cls1 compile: 'baz Morph new openInWorld'.
	"-------"
	cls2 compile: 'foo ^ Object'.
	cls2 compile: 'bar Transcript show: ''blah blah'''.
	cls2 compile: 'zork OrderedCollection new'.
	"-------"
	cls3 compile: 'foo ^ Object'.
	cls3 compile: 'bar Transcript show: ''blah blah'''.
	cls3 compile: 'zork MyClass3 new'.
	"-------"
	r _ Analyzer
				externalReferenceOf: (#(#MyClass1 #MyClass2 #MyClass3 )
						collect: [:clsName | Smalltalk at: clsName]).
	self assert: r size = 4.
	self
		assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection #Morph )).
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodCallDefinedInSubclasses
	| cls1 cls2 r |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2 superclass: cls1.
	"-------"
	cls1 compile: 'foo ^ self bar'.
	cls2 compile: 'bar ^ true'.
	"-------"
	self assert: cls2 new foo.
	r _ Analyzer
				methodsIn: cls1
				callingMethodsDefinedIn: (Array with: cls2).
	r _ r asOrderedCollection.
	self assert: r size = 1.
	self assert: r first size = 2.
	self assert: r first first == #foo.
	self assert: r first second == #bar.
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodCallDefinedInSubclasses2
	| cls1 cls2 r cls3 cls4 |
	cls1 _ self createClass: #MyClass1.
	cls2 _ self createClass: #MyClass2 superclass: cls1.
	cls3 _ self createClass: #MyClass3.
	cls4 _ self createClass: #MyClass4 superclass: cls3.
	"-------"
	cls1 compile: 'foo ^ self f1; f2'.
	cls1 compile: 'bar ^ self f3; foo'.
	cls1 compile: 'zork ^ self bar; blah'.
	cls2 compile: 'f1 ^ true'.
	cls2 compile: 'f2 ^ true'.
	cls3 compile: 'f3 ^ true'.
	cls3 compile: 'foo ^ true'.
	cls4 compile: 'f3 ^ true'.
	cls4 compile: 'f4 ^ true'.
	cls4 compile: 'bleubleu ^ true'.
	cls4 compile: 'bouba ^ true'.
	"-------"
	r _ Analyzer
				methodsIn: cls1
				callingMethodsDefinedIn: (Array
						with: cls2
						with: cls3
						with: cls4).
	r _ r asOrderedCollection.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#(#foo #f1) #(#foo #f2) #(#bar #f3) )).
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodsCalledAndCalleeForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	cls compile: 'foobar Object new asMorph; beep'.
	"-------"
	r _ Analyzer methodsCalledAndCalleeForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#(#bar #show:) #(#foobar #asMorph) #(#foobar #asMorph) )).
! !

!AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'!
testMethodsCalledForClass
	| cls r |
	cls _ self createClass: #MyClass.
	"-------"
	cls compile: 'foo ^ Object'.
	cls compile: 'bar Transcript show: ''blah blah'''.
	cls compile: 'zork OrderedCollection new'.
	cls compile: 'foobar Object new asMorph; beep'.
	"-------"
	r _ Analyzer methodsCalledForClass: cls.
	self assert: r size = 3.
	self
		assert: (r includesAllOf: #(#beep #show: #asMorph )).
! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 13:30'!
allImages
	| body colorTable |
	stream class == ReadWriteStream ifFalse: [
		(stream respondsTo: #binary) ifTrue: [stream binary].
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].
	localColorTable _ nil.
	forms _ OrderedCollection new.
	offsets _ 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.
			offsets add: offset.
			delays add: delay].
	^ forms! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:15' prior: 33769038!
allImages
	| body colorTable offset |
	stream class == ReadWriteStream ifFalse: [
		stream binary.
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].
	localColorTable _ nil.
	forms _ OrderedCollection new.
	offsets _ 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.
			offsets add: offset.
			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: 'accessing' stamp: 'mir 11/19/2003 14:16'!
offsets
	^ offsets! !

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

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

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:44'!
allTypicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^ Set with: 'gif'! !

!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: 'asm 12/11/2003 21:50'!
typicalFileExtensions
	"this is called from one of my superclasses"
	^ #( )! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'!
wantsToHandleGIFs
	^true! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 14:16'!
step
	images isEmpty
		ifTrue: [^ self].
	nextTime > Time millisecondClockValue
		ifTrue: [^self].
	imageIndex _ imageIndex \\ images size + 1.
	self image: (images at: imageIndex).
	self position: self position + (offsets at: imageIndex) - previousOffset.
	previousOffset _ offsets at: imageIndex.
	nextTime := Time millisecondClockValue + (delays at: imageIndex)
! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/11/2003 22:33' prior: 33772436!
step
	| d |
	images isEmpty
		ifTrue: [^ self].
	nextTime > Time millisecondClockValue
		ifTrue: [^self].
	imageIndex _ imageIndex \\ images size + 1.
	self image: (images at: imageIndex).
	self position: self position + (offsets at: imageIndex) - previousOffset.
	previousOffset _ offsets at: imageIndex.
	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: 'mir 11/19/2003 14:16'!
wantsSteps
	^ true! !

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

!AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 14:14'!
fromGIFFileNamed: fileName
	| reader |
	reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName.
	images _ reader forms.
	offsets _ reader offsets.
	delays _ reader delays.
	self step! !

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

!AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'!
fromReader: reader
	images _ reader forms.
	offsets _ reader offsets.
	delays _ reader delays.
	self step! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'asm 12/15/2003 19:35'!
fromStream: aStream
	| reader |
	reader _ AnimatedGIFReadWriter formsFromStream: aStream.
	images _ reader forms.
	offsets _ reader offsets.
	delays _ reader delays.
	self step! !

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

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

!AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 14:29'!
initialize
	nextTime := Time millisecondClockValue.
	imageIndex := 1.
	previousOffset _ 0 @ 0.
	stepTime := 10.
	super initialize! !

!AnimatedImageMorph commentStamp: '<historical>' prior: 0!
I am an ImageMorph that can hold more than one image. Each image has its own delay time.!
!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'mir 11/19/2003 13:45'!
fromGIFFileNamed: fileName
	^self new fromGIFFileNamed: fileName! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:23' prior: 33775432!
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: 'asm 12/4/2003 23:20'!
fromStream: aStream
	^self new fromStream: aStream! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:27' prior: 33775919!
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: 'asm 12/11/2003 21:53'!
openGIFInWindow: fileName
	^(self new fromGIFFileNamed: fileName) openInWorld! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 16:57' prior: 33776382!
openGIFInWindow: aStream
	^(self fromStream: aStream binary) openInWorld! !

!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: 'asm 12/11/2003 21:34'!
fileReaderServicesForFile: fullName suffix: suffix

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

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:16'!
serviceOpenGIFInWindow
	"Answer a service for opening a gif graphic in a window"

	^ SimpleServiceEntry 
		provider: self 
		label: 'open graphic in a window'
		selector: #openGIFInWindow:
		description: 'open a gif graphic file in a window'
		buttonLabel: 'open'! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 2/15/2004 15:34' prior: 33777488!
serviceOpenGIFInWindow
	"Answer a service for opening a gif graphic in a window"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'open graphic in a window'
		selector: #openGIFInWindow:
		description: 'open a GIF graphic file in a window'
		buttonLabel: 'open')
		argumentGetter: [ :fileList | fileList directory readOnlyFileNamed: fileList fileName ]! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35' prior: 33777852!
serviceOpenGIFInWindow
	"Answer a service for opening a gif graphic in a window"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'open graphic in a window'
		selector: #openGIFInWindow:
		description: 'open a GIF graphic file in a window'
		buttonLabel: 'open')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:54'!
services
	
	^ Array with: self serviceOpenGIFInWindow
		with: Form serviceImageImports
		with: Form serviceImageAsBackground 

! !

!AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 21:19'!
callingAThirdMethod

	self inform: ';lkl;'.
	self zoulouSymbol! !

!AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:49'!
zoulouSymbol

	self callingAThirdMethod! !

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

	^ isCarryingFood
! !

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

	isCarryingFood _ aBoolean.
! !

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

	^ pheromoneDropSize
! !

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

	pheromoneDropSize _ aNumber.
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14: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: 'jm 3/8/2001 14:22'!
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: 'jm 2/7/2001 19:20'!
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].
! !

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

!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 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: 'ads 4/2/2003 15:31'!
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?'! !

!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: 'ads 3/29/2003 13:03'!
unregister: aProviderClass
	(default = aProviderClass) ifTrue: [default _ nil].
	self registeredClasses remove: aProviderClass ifAbsent: [].! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'mir 5/15/2003 15:35' prior: 17046104!
processInput
	"recieve some data"
	| inObjectData |

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

!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 12/20/2002 14:57' prior: 33785281!
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 12/20/2002 15:03' prior: 33785985!
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: 'nk 12/20/2002 15:03' prior: 33786656!
addString: aString as: aFileName
	| newMember |
	newMember _ self memberClass newFromString: aString named: aFileName.
	self addMember: newMember.
	newMember localFileName: aFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'!
addTree: aFileNameOrDirectory removingFirstCharacters: n
	| dir newMember fullPath relativePath |
	dir _ (aFileNameOrDirectory isString)
		ifTrue: [ FileDirectory on: aFileNameOrDirectory ]
		ifFalse: [ aFileNameOrDirectory ].
	fullPath _ dir fullNameFor: ''.	"this could be a bug..."
	relativePath _ fullPath copyFrom: n + 1 to: fullPath size.
	dir entries 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 ].
	].
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03' prior: 33787216!
addTree: aFileNameOrDirectory removingFirstCharacters: n
	| dir newMember fullPath relativePath |
	dir _ (aFileNameOrDirectory isString)
		ifTrue: [ FileDirectory on: aFileNameOrDirectory ]
		ifFalse: [ aFileNameOrDirectory ].
	fullPath _ dir fullNameFor: ''.	"this could be a bug..."
	relativePath _ fullPath copyFrom: n + 1 to: fullPath size.
	dir entries 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 ].
	].
! !

!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 12/20/2002 14:48' prior: 33789251!
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 11/11/2002 14:09' prior: 33790037!
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:48' prior: 33790449!
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 12/20/2002 14:50' prior: 33791073!
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 12/20/2002 14:50' prior: 33791866!
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! !

!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.!
!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: 'accessing' stamp: 'nk 12/20/2002 15:02' prior: 33794779!
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: '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 methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'!
close
! !

!ArchiveMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:00'!
initialize
	fileName _ ''! !

!ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05' prior: 33795648!
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: 'printing' stamp: 'nk 12/20/2002 15:11' prior: 33795885!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: self fileName;
		nextPut: $)! !

!ArchiveMember commentStamp: '<historical>' prior: 0!
This is the abstract superclass for archive members, which are files or directories stored in archives.!
!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! !

!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: 'nk 4/29/2004 10:53'!
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: 'nk 2/24/2001 14:56'!
canExtractAll
	^self members size > 0! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'dgd 2/21/2003 22:36' prior: 33798461!
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: 'nk 2/24/2001 13:49'!
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: 'nk 2/24/2001 23:29'!
createNewArchive
	self setLabel: '(new archive)'.
	archive _ ZipArchive new.
	self memberIndex: 0.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:42'!
extractAll
	"Extracts all in a directory of the users' choosing."
	| directory |
	self canExtractAll
		ifFalse: [^ self].
	directory _ FileList2 modalFolderSelector
				ifNil: [^ self].
	[self extractAllPossibleInDirectory: directory]
		whileFalse: [self confirm: 'Try a different directory?'].
	[["first extract directories if any"
	self extractDirectoriesIntoDirectory: directory.
	"then files"
	self extractFilesIntoDirectory: directory]
		on: FileStreamException
		do: [:ex | (self confirm: ex class name, ': ' , ex messageText , '. Continue?')
				ifTrue: [ex resume]
				ifFalse: [^ self]]] on: Error do: [ :ex | self inform: 'Error: ', ex messageText ].! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:42' prior: 33799543!
extractAll
	"Extracts all in a directory of the users' choosing."
	| directory |
	self canExtractAll
		ifFalse: [^ self].
	directory _ FileList2 modalFolderSelector
				ifNil: [^ self].
	[self extractAllPossibleInDirectory: directory]
		whileFalse: [self confirm: 'Try a different directory?'].
	[["first extract directories if any"
	self extractDirectoriesIntoDirectory: directory.
	"then files"
	self extractFilesIntoDirectory: directory]
		on: FileStreamException
		do: [:ex | (self confirm: ex class name, ': ' , ex messageText , '. Continue?')
				ifTrue: [ex resume]
				ifFalse: [^ self]]] on: Error do: [ :ex | self inform: 'Error: ', ex messageText ].! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20' prior: 33800302!
extractAll
	| directory |

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

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51'!
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?'.
		^PopUpMenu confirm: str contents.
	].
	^true.
! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51' prior: 33801301!
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?'.
		^PopUpMenu 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:14' prior: 33803879!
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: 'nk 11/11/2002 22:13' prior: 33804337!
extractFilesIntoDirectory: directory 
	(self members reject: [:ea | ea isDirectory]) 
		do: [:ea | ea extractInDirectory: directory]! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:27'!
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: 'nk 4/19/2002 09:08'!
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: 'nk 3/27/2002 12:57'!
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: 'nk 2/24/2001 23:28'!
archive: aZipArchive
	archive _ aZipArchive.
	self setLabel: 'New Zip Archive'.
	self memberIndex: 0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 10/24/2001 08:53'!
backgroundColor
	^self defaultBackgroundColor! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'KLC 12/6/2003 10:40'!
briefContents
	"Trim to 5000 characters if longer then point out that it is trimmed"
	self selectedMember ifNil: [^ ''].
	^self selectedMember contents size > 5000
		ifTrue: [ | subContents 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].
			'File ''', self selectedMember fileName, ''' is ', self selectedMember contents size printString, ' bytes long.
Toggle the ''View All Contents'' button above to see the entire file.

Here are the first ', subContents size printString , ' characters...
------------------------------------------
', subContents , '
------------------------------------------
... end of the first ', subContents size printString , ' characters.'
			]
		ifFalse: [self selectedMember contents]
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:43' prior: 33807064!
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 2/24/2001 09:48'!
buttonColor
	^self backgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 09:49'!
buttonOffColor
	^self backgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 09:49'!
buttonOnColor
	^self backgroundColor! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/5/2002 14:43'!
contents
	self selectedMember ifNil: [^ ''].
	viewAllContents ifFalse: [^ self selectedMember contentsFrom: 1 to: 500].

 	^ self selectedMember contents! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'KLC 12/6/2003 10:21' prior: 33810628!
contents
	self selectedMember ifNil: [^ ''].
	viewAllContents ifFalse: [^ self briefContents].

 	^ self selectedMember contents! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:45' prior: 33810876!
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: 'nk 5/9/2002 16:00'!
createButtonBar
	| bar button narrowFont |
	narrowFont _ StrikeFont allSubInstances detectMin: [ :ea | ea widthOfString: 'Contents' from: 1 to: 8 ].
	bar _ AlignmentMorph newRow.
	bar color: self backgroundColor;
		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;
			yourself.
		bar addMorphBack: button.
		buttonLabel composeToBounds].
	^ bar.
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:38' prior: 33811808!
createButtonBar
	| bar button narrowFont |
	narrowFont := StrikeFont allSubInstances detectMin: 
					[:ea | 
					ea 
						widthOfString: 'Contents'
						from: 1
						to: 8].
	bar := AlignmentMorph newRow.
	bar
		color: self backgroundColor;
		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: 'di 12/10/2003 10:17' prior: 33813831!
createButtonBar
	| bar button narrowFont registeredFonts |
	registeredFonts _ OrderedCollection new.
	TextStyle knownTextStyles 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 backgroundColor;
		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: 'yo 7/16/2003 15:40' prior: 33815933!
createButtonBar
	| bar button narrowFont asciiFont |
	asciiFont := StrikeFont allSubInstances select: [:each | each maxAscii < 256].
	narrowFont := asciiFont detectMin: [ :ea | ea widthOfString: 'Contents' from: 1 to: 8 ].
	bar := AlignmentMorph newRow.
	bar
		color: self backgroundColor;
		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: 'nk 2/24/2001 22:33'!
createListHeadingUsingFont: font
	| sm |
	sm _ StringMorph contents: '  uncomp     comp   CRC-32       date     time  file name'.
	font ifNotNil: [ sm font: font ].
	^(AlignmentMorph newColumn)
		color: self backgroundColor;
		addMorph: sm;
		yourself.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 5/9/2002 16:05'!
createWindow
	| list heading font text buttonBar |
	self color: self backgroundColor.

	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 backgroundColor.
	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: 'nk 2/24/2001 23:28'!
fileName: aString
	archive _ ZipArchive new readFrom: aString.
	self setLabel: aString.
	self memberIndex:  0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:46'!
initialize
	super initialize.
	memberIndex _ 0.
	viewAllContents _ false.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 12/16/2002 17:12'!
windowIsClosing
	archive close.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 12/16/2002 17:12' prior: 33822207!
windowIsClosing
	archive close.! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 22:32'!
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: 'nk 2/24/2001 23:46'!
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: 'nk 2/24/2001 13:42'!
memberMenu: menu shifted: shifted

	^ menu
		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';
		add: 'Comment archive' target: self selector: #commentArchive;
		balloonTextForLastItem: 'Add a comment for the entire archive';
		yourself! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 4/29/2004 10:20' prior: 33823728!
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: 'nk 2/24/2001 23:28'!
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: 'nk 2/24/2001 23: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: 'nk 2/24/2001 23:29'!
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: 'nk 2/24/2001 23:59'!
changeViewAllContents

	(viewAllContents not and: [ self selectedMember uncompressedSize > 50000 ])
		ifTrue: [ (PopUpMenu 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: 'nk 3/7/2004 16:47' prior: 33827010!
changeViewAllContents

	(viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]])
		ifTrue: [ (PopUpMenu 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: 'nk 2/24/2001 13:50'!
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: 'nk 2/24/2001 14:53'!
extractMember
	| result name |
	self canExtractMember 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 extracting to another file name'.
			^self ].
	self selectedMember extractToFileNamed: name.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 4/29/2004 10:46' prior: 33828555!
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: 'nk 2/24/2001 14:53'!
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: 'nk 3/27/2002 12:48'!
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: 'panes' stamp: 'nk 10/24/2001 09:43'!
paneColor
	^self backgroundColor darker darker! !

!ArchiveViewer methodsFor: 'panes' stamp: 'nk 2/24/2001 10:09'!
paneColorToUse
	^self backgroundColor! !

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

!ArchiveViewer methodsFor: 'user interface' stamp: 'nk 10/24/2001 08:53'!
defaultBackgroundColor
	^Color white! !

!ArchiveViewer commentStamp: '<historical>' prior: 0!
This is a viewer window that allows editing and viewing of Zip archives.!
!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:05'!
deleteTemporaryDirectory
	"
	ArchiveViewer deleteTemporaryDirectory
	"

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

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 1/30/2002 10:13'!
initialize
	"ArchiveViewer initialize"

	FileList registerFileReader: self! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 10:56' prior: 33831457!
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: 'nk 11/26/2002 13:15'!
fileReaderServicesForFile: fullName suffix: suffix 

	|  services |
	services _ OrderedCollection new.
	services add: self serviceAddToNewZip.
	(suffix = 'zip' or: [suffix = 'sar'])
		ifTrue: [services add: self serviceOpenInZipViewer.
				services add: self serviceExtractAll].
	^ services! !

!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:42' prior: 33833163!
fileReaderServicesForFile: fullName suffix: suffix 

	|  services |
	services _ OrderedCollection new.
	services add: self serviceAddToNewZip.
	({'zip'.'sar'.'pr'.'*'} 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: 'nk 11/26/2002 12:45'!
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'
! !

!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: 'ajh 9/8/2002 17:45' prior: 17052624!
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'].

	"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' prior: 17053233!
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: 'yo 9/2/2002 18:23' prior: 17053709!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        ((each class == String) or: [each class == MultiString]) 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: '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]! !

!ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'!
tearDown
	self class removeSelector: #array! !

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

!ArrayLiteralTest methodsFor: 'as yet unclassified' 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}.! !

!ArrayTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:29'!
setUp
	example1 := #(1 2 3 4 5).! !

!ArrayTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:36'!
testIsLiteral
	
	self assert: example1 isLiteral.
	example1 at: 1 put: self class.
	self deny: example1 isLiteral.
	example1 at: 1 put: 1.! !

!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!
!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: 'ar 1/25/2002 01:46'!
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].

	Smalltalk endianness == #little 
		ifTrue: [self swapBytesFrom: 1 to: self basicSize]
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'sd 6/28/2003 09:49' prior: 33842125!
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].

	Smalltalk isLittleEndian 
		ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:45'!
swapBytesFrom: 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 |

	self class isPointers | self class isWords not ifTrue: [^ self].

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

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'sd 6/28/2003 09:50' prior: 33843140!
swapBytesFrom: 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 |
	self deprecatedExplanation: 'Use BitMap class>>swapBytesIn:from:to:'.
	self class isPointers | self class isWords not ifTrue: [^ self].

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

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'md 12/12/2003 17:01' prior: 33844023!
swapBytesFrom: 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 |
	self deprecated: 'Use BitMap class>>swapBytesIn:from:to:'.
	self class isPointers | self class isWords not ifTrue: [^ self].

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

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

!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.!
!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: '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: 'printing' stamp: 'brp 10/8/2003 14:55' prior: 17076704!
printOn: aStream indent: level 
	aStream dialect = #SQ00
		ifTrue: [aStream
				withStyleFor: #setOrReturn
				do: [aStream nextPutAll: 'Set '].
			variable printOn: aStream indent: level.
			aStream
				withStyleFor: #setOrReturn
				do: [aStream nextPutAll: ' to '].
			value printOn: aStream indent: level + 2]
		ifFalse: [variable printOn: aStream indent: level.
			aStream
				nextPutAll: (Preferences ansiAssignmentOperatorWhenPrettyPrinting
						ifTrue: [' := ']
						ifFalse: [' _ ']).
			value printOn: aStream indent: level + 2]! !

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

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

!AssignmentTileMorph methodsFor: 'arrow' stamp: 'sw 9/27/2001 16:40'!
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]]! !

!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: 'sw 2/6/2002 01:26'!
storeCodeOn: aStream indent: tabCount
	"Generate code for an assignment statement.  The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now"

	assignmentSuffix = ':'
		ifTrue:   "Simple assignment, don't need existing value"
			[aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
			aStream space]
		ifFalse:  "Assignments that require that old values be retrieved"
			[aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
			aStream space.
			self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
			aStream space.
			aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot).
			aStream space.
			aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
			aStream space]! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'aoy 2/15/2003 21:09' prior: 33851285!
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: 'sw 9/12/2001 22:49'!
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 elementWording] ifNil: [assignmentRoot copyWithout: $:].
	(anInterface notNil and: [(doc _ anInterface documentation) notNil])
		ifTrue:
			[self setBalloonText: doc].
	operatorReadoutString _ wording, ' ', aSuffix.
 	self line1: operatorReadoutString.
	self addArrowsIfAppropriate! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44' prior: 17078865!
initialize
"initialize the state of the receiver"
	super initialize.
""
	type _ #operator.
	assignmentSuffix _ ':'! !

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

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

!AssociationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 20:20'!
testEquality

	| a b |
	a _ 1 -> 'one'.
	b _ 1 -> 'een'.
	
	self 
		assert: (a key = b key);
		deny: (a value = b value);
		deny: (a = b)

! !

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

! !

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

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

!AssociationTest methodsFor: 'setup' stamp: 'md 3/8/2004 16:37'!
setUp

	a _ 1 -> 'one'.
	b _ 1 -> 'een'.! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'JMM 11/24/2001 17:23'!
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'
! !

!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' prior: 17099526!
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! !

!AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'!
setUp
	
	morph := AtomMorph new.! !

!AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'!
tearDown
	morph delete.! !

!AtomMorphTest methodsFor: 'testing ' stamp: 'md 4/17/2003 19:06'!
testVelocity
	morph velocity: 0@0.
	self assert: ( (morph velocity) = (0@0) ).! !

!AtomMorphTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class AtomMorph. 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!
!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! !

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

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

!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: 'dgd 2/14/2003 19:48' prior: 17108065!
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: 'stuff' stamp: 'aoy 2/17/2003 01:01' prior: 17103851!
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 class methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:35'!
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 uers'
		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)! !

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

! !

!AutoStart class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'!
initialize
	"AutoStart initialize"
	"Order: ExternalSettings, SecurityManager, AutoStart"
	Smalltalk addToStartUpList: AutoStart after: SecurityManager.! !

!AutoStart class methodsFor: 'class initialization' stamp: 'nk 12/2/2003 09:00'!
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 |
	resuming ifFalse: [ ^self ].

	startupParameters _ AbstractLauncher extractParameters.
	(startupParameters includesKey: 'apiSupported' asUppercase )
		ifTrue: [HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = '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]]]! !

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 3/5/2004 20:46' prior: 33884252!
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 |
	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]]]! !

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

!AutoStart class methodsFor: 'updating' stamp: 'mir 7/14/2001 13:09'!
checkForPluginUpdate
	| pluginVersion updateURL |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient determineIfRunningInBrowser.
	HTTPClient isRunningInBrowser
		ifFalse: [^false].
	pluginVersion _ AbstractLauncher extractParameters
		at: (Smalltalk 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: 'sd 9/30/2003 13:55' prior: 33886302!
checkForPluginUpdate
	| pluginVersion updateURL |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient determineIfRunningInBrowser.
	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 3/5/2004 20:43' prior: 33886914!
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 8/10/2001 12:31'!
checkForUpdates
	| availableUpdate updateServer |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient determineIfRunningInBrowser.
	HTTPClient isRunningInBrowser
		ifFalse: [^self processUpdates].
	availableUpdate _ (AbstractLauncher extractParameters
		at: 'UPDATE'
		ifAbsent: [''] ) asInteger.
	availableUpdate
		ifNil: [^false].
	updateServer _ AbstractLauncher extractParameters
		at: 'UPDATE_SERVER'
		ifAbsent: ['Squeakland'].
	Utilities setUpdateServer: updateServer.
	^SystemVersion checkAndApplyUpdates: availableUpdate! !

!AutoStart class methodsFor: 'updating' stamp: 'mir 11/13/2003 19:09' prior: 33888108!
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: 'ar 4/24/2001 15:59'!
processUpdates
	"Process update files from a well-known update server.  This method is called at system startup time,   Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically"
	| choice |
	(Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue:
		[choice _ (PopUpMenu labels: 'Yes, Update\No, Not now' withCRs)
			startUpWithCaption: 'Shall I look for new code\updates on the server?' withCRs.
		choice = 1 ifTrue: [Utilities updateFromServer]].
	^false! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:29'!
test01metaclassName


	self assert: Dictionary class  name = 'Dictionary class'.
	self assert: OrderedCollection class name = 'OrderedCollection class'.
	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:28'!
test02metaclassNumberOfInstances


	self assert: Dictionary class allInstances size  = 1.
	self assert: OrderedCollection class allInstances size  = 1.! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:36'!
test03superclass


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

	
	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:39'!
test04metaclassSuperclass


	| s |
	self assert: Dictionary class superclass == Set class.
	self assert: OrderedCollection class superclass == SequenceableCollection class.

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'!
test05metaclassSuperclassHierarchy


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



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'!
test06ClassDescriptionAllSubInstances


	
	| cdNo clsNo metaclsNo |

	cdNo _ ClassDescription allSubInstances size.
	clsNo _ Class allSubInstances size .
	metaclsNo _ Metaclass allSubInstances size.

	self assert: cdNo = (clsNo + metaclsNo).

	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 13:02'!
test07bmetaclassPointOfCircularity

	

	self assert: Metaclass class instanceCount = 1.
	self assert: Metaclass class someInstance == Metaclass.


	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:16'!
test07metaclass

	

	self assert: OrderedCollection class class == Metaclass.
	self assert: OrderedCollection class class = Metaclass.

	self assert: Dictionary class class == Metaclass.
	self assert: Dictionary class class = Metaclass.


	self assert: Object class class == Metaclass.
	self assert: Object class class = Metaclass.



	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:25'!
test08BCCMhierarchy

	

	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.




	
	
	



	
	

	! !

!BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:43'!
test09ObjectAllSubclasses

	| n2 |
	n2 _ Object allSubclasses size.
	self assert: n2 = (Object allSubclasses
			select: [:cls | cls class class == Metaclass
					or: [cls class == Metaclass]]) size! !

!BCCMTest commentStamp: '<historical>' prior: 0!
This class contains some tests regarding the classes 
	Behavior
		ClassDescription
			Class
			Metaclass
---
	!
!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:45'!
errorFileFormat
	self error: 'malformed bdf format'! !

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

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:43'!
getLine
	^self upTo: Character cr.! !

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

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/23/2000 18:58'!
read
	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret dwidth cell cellBlt |
	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.
	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.
		form _ array at: 1.
		encoding _ array at: 2.
		bbx _ array at: 3.
		dwidth _ array at: 4.

		"form isNil ifFalse: [form morphEdit]."
		"self halt."
		
		form ifNotNil: [
			dwidth _ dwidth - 1.
			width _ dwidth max: (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"

	xTable _ (Array new: 258) atAllPut: 0.

	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	lastAscii _ 0.
	
	1 to: charsNum do: [:i | 
		| unspliceArray |
		unspliceArray _ chars at: i.
		form _ unspliceArray at: 1.
		encoding _ unspliceArray at: 2.
		bbx _ unspliceArray at: 3.
		dwidth _ (unspliceArray at: 4).
		width _ dwidth max: (bbx at: 1).
		lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].

		"I should be able to do all of this in one blit, but I'm too confused.  Create
		a Form of the proper size for this glyph, render the BDF bitmap into it, then 
		stamp it into the StrikeFont glyphs form."
		cell _ Form extent: width@height.
		cellBlt _ BitBlt toForm: cell.

		cellBlt copy: ((bbx at: 3)@((ascent - (bbx at: 2) - (bbx at: 4)))
				extent: (bbx at: 1)@(bbx at: 2))
			from: 0@0 in: form.

		blt copyForm: cell to: (xTable at: encoding+1)@0 rule: Form over.		

		"blt copy: (( ((xTable at: encoding+1)+(bbx at: 3))@(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)+(width).
		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: 'as yet unclassified' stamp: 'yo 8/28/2002 05:08' prior: 33894163!
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 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.
	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: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'!
readAttributes
	| str a |
	"I don't handle double-quotes correctly, but it works"
	self reset.
	[self atEnd] whileFalse: [
		str _ self getLine.
		(str beginsWith: 'STARTCHAR') ifTrue: [self skip: (0 - str size - 1). ^self].
		a _ str substrings.
		properties at: a first asSymbol put: a allButFirst.
	].
	self error: 'file seems corrupted'.! !

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 11:31'!
readChars
	| strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream |
	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.
	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: 'as yet unclassified' stamp: 'nop 1/22/2000 23:33'!
readOneCharacter
	| str a encoding bbx form bits hi low pos char dwidth |
	((str _ self getLine) beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat].
	char _ str substrings second.
	((str _ self getLine) beginsWith: 'ENCODING') ifFalse: [self errorFileFormat].
	encoding _ Integer readFromString: str substrings second.
	(self getLine beginsWith: 'SWIDTH') ifFalse: [self errorFileFormat].
	((str _ self getLine) beginsWith: 'DWIDTH') ifFalse: [self errorFileFormat].
	dwidth _ Integer readFromString: str substrings second.
	
	((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: (self next asUppercase)) - 1) bitShift: 4.
			low _ ('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1.
			
			bits byteAt: (pos+i) put: (hi+low).
		].
		self next ~= Character cr ifTrue: [self errorFileFormat].
		pos _ pos + ((((bbx at: 1) + 31) // 32) * 4).
	].

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

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

!BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 05:09' prior: 33901612!
readOneCharacter
	| str a encoding bbx form bits hi low pos char |
	((str _ self getLine) beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat].
	char _ str substrings second.
	((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: (self next asUppercase)) - 1) bitShift: 4.
			low _ ('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1.
			
			bits byteAt: (pos+i) put: (hi+low).
		].
		self 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 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 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: '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.
	].
! !

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

'.





! !

!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 6/16/2002 17:24'!
read24BmpFile
	"Read 24-bit pixel data from the given a BMP stream."
	| form formBits pixelLine bitsIndex |
	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.
	].
	^ form
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:47'!
read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width
	| pixIndex rgb bitsIndex |
	<primitive: 'primitiveRead24BmpLine' module:'BMPReadWriterPlugin'>
	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).
		rgb = 0 ifTrue:[rgb := 16rFF000001] ifFalse:[rgb := rgb + 16rFF000000].
		formBits at: (bitsIndex := bitsIndex+1) put: rgb.
	].
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:17'!
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 6/16/2002 15:35'!
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 cm word formBits |
	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:[
		"swap red and blue components"
		cm _ Bitmap new: (1 << 15).
		word _ 0.
		0 to: 31 do:[:r| 0 to: 31 do:[:g| 0 to: 31 do:[:b|
			cm at: (word _ word + 1) put: (b bitShift: 10) + (g bitShift: 5) + r]]].
		cm at: 1 put: 1.
		formBits _ form bits.
		1 to: formBits size do:[:i|
			word _ formBits at: i.
			word _ (cm at: (word bitAnd: 16r7FFF) + 1) + ((cm at: ((word bitShift: -16) bitAnd: 16r7FFF) +1) bitShift: 16).
			formBits at: i put: word.
		].
	].
	^ form
! !

!BMPReadWriter methodsFor: 'writing' stamp: 'ar 6/16/2002 17:50'!
nextPutImage: aForm
	| bhSize rowBytes rgb data colorValues depth image |
	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)]]].

	1 to: biHeight do:[:i |
		data _ (image copy: (0@(biHeight-i) extent: biWidth@1)) bits.
		depth = 32
			ifTrue: [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"]]
			ifFalse: [1 to: data size do: [:j | stream nextNumber: 4 put: (data at: j)]]].
	stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure'].
	stream close.! !

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

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

!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: 'drawing' stamp: 'RAA 6/4/2001 16:21'!
drawSubmorphsOn: aCanvas

	| t | 
	t _ [
		self drawSubmorphsOnREAL: aCanvas
	] timeToRun.
"Q1 at: 3 put: t."
! !

!BOBTransformationMorph methodsFor: 'layout' stamp: 'dgd 2/21/2003 23:02' prior: 17737952!
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"]! !

!BackgroundMorph methodsFor: 'as yet unclassified' stamp: 'aoy 2/17/2003 01:20' prior: 17742337!
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 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' prior: 17741438!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	offset _ 0 @ 0.
	delta _ 1 @ 0.
	running _ true! !

!BackgroundMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56' prior: 17739917!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	running
		ifTrue: [aCustomMenu add: 'stop' translated action: #stopRunning]
		ifFalse: [aCustomMenu add: 'start' translated action: #startRunning]! !

!BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'!
= other 
	self class = other class
		ifFalse: [^ false].
	^ 100 atRandom < 30 ! !

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

!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.!
!Bag methodsFor: 'comparing' stamp: 'raok 6/10/2002 15:28'!
= 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 class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
contentsClass
	^Dictionary! !

!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
new: nElements
	^ super new setContents: (self contentsClass new: nElements)! !

!BalloonBezierSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
!BalloonBuffer commentStamp: '<historical>' prior: 0!
BalloonBuffer is a repository for primitive data used by the BalloonEngine.!
!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: 'drawing' stamp: 'nk 5/1/2004 12:25' prior: 17771501!
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: '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: 'private' stamp: 'nk 5/1/2004 12:54' prior: 17778317!
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."! !

!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 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.!
!BalloonEngine methodsFor: 'initialize' stamp: 'nk 9/26/2003 10:52' prior: 17793378!
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: 'copying' stamp: 'ar 3/6/2001 12:06'!
copyBits
	(bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate].
	self copyLoopFaster.! !

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

!BalloonFillData commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
!BalloonFontTest methodsFor: 'testing' 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: 'testing' 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)! !

!BalloonLineSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ 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' prior: 18113931!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self beSmoothCurve.

	offsetFromTarget _ 0 @ 0! !

!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 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: 'laza 3/25/2004 23:09' prior: 18119164!
chooseBalloonFont
	"BalloonMorph chooseBalloonFont"

	Preferences chooseFontWithPrompt:  'Select the font to be
used for balloon help'
		andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! !

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

!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' prior: 18119868!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self extent: 100 @ 100! !

!BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !

!BalloonRectangleMorph commentStamp: '<historical>' prior: 0!
BalloonRectangleMorph is an example for drawing using the BalloonEngine.!
!BalloonSolidFillSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!
!BalloonState commentStamp: '<historical>' prior: 0!
This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.!
!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].

! !

!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:37'!
setUp
	message _ ReadWriteStream on: (String new: 10).
	message nextPutAll: 'Hi There!!'.! !

!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:34'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !

!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:45'!
testMimeEncodeDecode

	| encoded |

	encoded _ Base64MimeConverter mimeEncode: message.
	
	self should: [encoded contents = 'SGkgVGhlcmUh'].
     self should: [(Base64MimeConverter mimeDecodeToChars: encoded)
                      contents = message contents].! !

!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!
!BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/24/2004 23:13'!
randomBitsFromSoundInput: bitCount
	"Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes."
	"(1 to: 10) collect: [:i | 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 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 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]].! !

!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' prior: 18131735!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self label: 'Button'; useRoundedCorners! !

!BasicButton methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56' prior: 18131492!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label...' translated action: #setLabel! !

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

!BasicInspector methodsFor: 'as yet unclassified' stamp: 'ajh 1/31/2003 15:49'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''! !

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

!Beeper methodsFor: 'play interface' stamp: 'nb 6/17/2003 12:25'!
play

	self beep! !

!Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25' prior: 33964107!
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 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 class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'!
clearDefault
	"Set the primitive beep as the default beep."	

	default := nil! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51' prior: 33965622!
clearDefault
	"Clear the default playable.
	Will be lazily initialized in Beeper class >>default."

	default := nil! !

!Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'!
default
	"When the default is not defined, it is myself."
	default isNil 
		ifTrue: [default := self newDefault ].
	^ default! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55' prior: 33965974!
default
	"When the default is not defined it is
	initialized using #newDefault."

	default isNil 
		ifTrue: [default := self newDefault ].
	^ default! !

!Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'!
newDefault
	"Subclasses may override me to provide a default beep."

	^ self new! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12' prior: 33966408!
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: 'nb 6/17/2003 12:25'!
setDefault: aPlayableEntity
	"aBeepingEntity should implement the message #play."

	default := aPlayableEntity! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54' prior: 33966825!
setDefault: aPlayableEntity
	"Set the playable entity used when making a beep.
	The playable entity should implement the message #play."

	default := aPlayableEntity! !

!Beeper class methodsFor: 'beeping' stamp: 'nb 6/17/2003 12:25'!
beep
	"The preferred way of producing an audible feedback"

	Preferences soundsEnabled 
		ifTrue: [self default play]
! !

!Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38' prior: 33967258!
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: 'nb 6/17/2003 12:25'!
beepPrimitive
	"Beep in the absence of sound support"

	<primitive: 140>
	self primitiveFailed! !

!Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38' prior: 33967803!
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: '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! !

!Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17' prior: 18133988!
forgetDoIts
	"get rid of old DoIt methods"
	self 
		basicRemoveSelector: #DoIt;
		basicRemoveSelector: #DoItIn:! !

!Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07' prior: 18134178!
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: 'accessing' stamp: 'ajh 9/19/2001 17:30'!
classDepth

	superclass ifNil: [^ 1].
	^ superclass classDepth + 1! !

!Behavior methodsFor: 'accessing' stamp: 'di 3/7/2001 17:05'!
methodDict
	methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace].
	^ methodDict! !

!Behavior methodsFor: 'testing' stamp: 'sw 1/26/2001 20:06'!
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! !

!Behavior methodsFor: 'testing' stamp: 'sw 5/4/2001 07:44'!
implementsVocabulary: aVocabulary
	"Answer whether instances of the receiver respond to the messages in aVocabulary."

	(aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true].
	^ self fullyImplementsVocabulary: aVocabulary! !

!Behavior methodsFor: 'testing' stamp: 'ab 3/12/2003 17:44'!
isMeta
	^ false! !

!Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07' prior: 18140626!
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: 'printing' stamp: 'ar 8/16/2001 13:31'!
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 scopeHas: value ifTrue:
				[:assoc |
				 (assoc value isKindOf: Behavior)
					ifTrue: [^ nil->assoc value class]].
			 requestor notify: 'No such metaclass'.
			 ^false].
	(key isMemberOf: Symbol)
		ifTrue: "##<global var name>"
			[(self scopeHas: key ifTrue: [:assoc | ^assoc])
				ifFalse:
					[Undeclared at: key put: nil.
					 ^ Undeclared associationAt: key]].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !

!Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11' prior: 33970749!
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 isMemberOf: Symbol)
		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
"! !

!Behavior methodsFor: 'printing' stamp: 'tk 10/16/2001 19:35'!
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.! !

!Behavior methodsFor: 'printing' stamp: 'ar 8/16/2001 13:31'!
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 isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]])
		ifTrue:
			[aStream nextPutAll: '##'; nextPutAll: key.
			 ^self].
	aCodeLiteral storeOn: aStream! !

!Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11' prior: 33974109!
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 isMemberOf: Symbol) and: [(self bindingOf: key) notNil])
		ifTrue:
			[aStream nextPutAll: '##'; nextPutAll: key.
			 ^self].
	aCodeLiteral storeOn: aStream! !

!Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 13:59' prior: 18146187!
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
		basicCompile: code "a Text"
		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! !

!Behavior methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:07' prior: 18147146!
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].! !

!Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 11:32'!
defaultMethodTrailer
	^ #(0 0 0 0)! !

!Behavior methodsFor: 'compiling' stamp: 'ar 8/16/2001 11:44'!
recompile: selector
	"Compile the method associated with selector in the receiver's method dictionary."
	^self recompile: selector from: self! !

!Behavior methodsFor: 'compiling' stamp: 'di 5/24/2000 16:05'!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."
	"ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:"
	| method trailer methodNode |
	method _ oldClass compiledMethodAt: selector.
	trailer _ (method endPC + 1 to: method size) collect: [:i | method at: i].
	methodNode _ self compilerClass new
				compile: (oldClass sourceCodeAt: selector)
				in: self
				notifying: nil
				ifFail: [^ self].   "Assume OK after proceed from SyntaxError"
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	self addSelector: selector withMethod: (methodNode generate: trailer).
! !

!Behavior methodsFor: 'compiling' stamp: 'ajh 6/11/2001 16:59' prior: 33977240!
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 addSelector: selector withMethod: (methodNode generate: trailer).
! !

!Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 09:22' prior: 33978006!
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 addSelectorSilently: selector withMethod: (methodNode generate: trailer).
! !

!Behavior methodsFor: 'compiling' stamp: 'ajh 6/11/2001 17:05' prior: 18150117!
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
! !

!Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06' prior: 18151256!
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' prior: 18151686!
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: 'Noury Bouraqadi 8/23/2003 14:51' prior: 18152905!
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' prior: 18153241!
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: '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' prior: 18153587!
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' prior: 18154182!
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'!
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 method dictionary' stamp: 'NS 1/28/2004 09:34' prior: 18145308!
addSelector: selector withMethod: compiledMethod 
	^ self addSelector: selector withMethod: compiledMethod notifying: nil! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'!
addSelector: selector withMethod: compiledMethod notifying: requestor
	^ self addSelectorSilently: selector withMethod: compiledMethod! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:27'!
addSelectorSilently: 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.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache].
	selector flushCache.! !

!Behavior methodsFor: 'accessing method dictionary' prior: 18155416!
allSelectors
	"Answer a Set of all the message selectors that instances of the receiver  
	can understand."
	"Point allSelectors"
	| temp |
	^ superclass == nil
		ifTrue: [self selectors]
		ifFalse: [temp _ superclass allSelectors.
			temp addAll: self selectors.
			temp]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/12/2003 15:57' prior: 33985003!
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: 'sw 6/20/2001 15:46'!
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:"
	(MessageSet isPseudoSelector: 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! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 8/19/2001 12:45'!
"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:
"


	! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'!
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: "
! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/6/2001 13:26'!
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
		ifFalse:
			[aComment]
		ifTrue:
			[(self == Behavior or: [superclass == nil or:
							[(aSuper _ superclass classThatUnderstands: selector) == nil]])
				ifTrue:
					[nil]
				ifFalse:
					[aSuper precodeCommentOrInheritedCommentFor: selector]]

"ActorState precodeCommentOrInheritedCommentFor: #printOn:"! !

!Behavior methodsFor: 'accessing method dictionary' prior: 33988859!
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: 'NS 1/28/2004 11:17' prior: 18151015!
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! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:28'!
removeSelectorSilently: selector 
	"Remove selector without sending system change notifications"

	^ SystemChangeNotifier doSilently: [self basicRemoveSelector: selector].! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 3/4/2004 21:04' prior: 33990772!
removeSelectorSilently: selector 
	"Remove selector without sending system change notifications"

	^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'rw 5/12/2003 11:19' prior: 18163179!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

	| sel |
	sel _ self methodDict keyAtIdentityValue: method
				ifAbsent: 
					[superclass == nil
						ifTrue: 
							[classResultBlock value: self.
							^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: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'!
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:' '.
		].
	].
! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/28/2001 12:37'!
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 classThatUnderstands: 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' prior: 33992507!
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: 'sd 2/1/2004 19:41'!
zapAllMethods
	"Remove all methods in this class which is assumed to be obsolete"

	methodDict _ MethodDictionary new.
	self class isMeta ifTrue: [self class zapAllMethods]! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04' prior: 18166959!
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: '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: '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: 'testing class hierarchy' prior: 18170788!
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: 'ar 5/17/2003 14:06'!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"
	^superclass bindingOf: varName! !

!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' stamp: 'ar 5/17/2003 14:20' prior: 18172865!
scopeHas: varName ifTrue: aBlock
	"Obsolete. Kept around for possible spurios senders which we don't know about"
	(self bindingOf: varName) ifNotNilDo:[:binding|
		aBlock value: binding.
		^true].
	^false! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'!
thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a 
	literal. Dives into the compact literal notation, making it slow but 
	thorough "

	| who |
	who _ Set new.
	self selectorsAndMethodsDo:
		[:sel :method |
		((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isVariableBinding) not
					or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
						ifTrue: [who add: sel]]].
	^ who! !

!Behavior methodsFor: 'testing method dictionary' prior: 18173806!
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: 'sd 3/28/2003 15:07' prior: 18174799!
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: #+."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal."

	| who |
	who _ Set new.
	self selectorsAndMethodsDo: 
		[:sel :method |
		((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isVariableBinding) not
					or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
						ifTrue: [who add: sel]]].
	^ who! !

!Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'!
withAllSuperAndSubclassesDoGently: aBlock
	self allSuperclassesDo: aBlock.
	aBlock value: self.
	self allSubclassesDoGently: aBlock! !

!Behavior methodsFor: 'user interface' stamp: 'nk 5/23/2001 20:34'!
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 _ Smalltalk hasSpecialSelector: aSymbol
					ifTrueSetByte: [:b | byte _ b ].
	cls withAllSuperAndSubclassesDoGently: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte)
			do: [:sel |
				sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
	cls class withAllSuperAndSubclassesDoGently: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte)
			do: [:sel |
				sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
	^aSet! !

!Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:05' prior: 33999290!
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 ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
	cls class withAllSuperAndSubclassesDoGently: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte)
			do: [:sel |
				sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]].
	^aSet! !

!Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'!
withAllSubAndSuperclassesDo: aBlock

	self withAllSubclassesDo: aBlock.
	self allSuperclassesDo: aBlock.
! !

!Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 13:59'!
basicCompile: code 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
				notifying: requestor
				ifFail: failBlock.
	methodNode encoder requestor: requestor.
	^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! !

!Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 10:29'!
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.! !

!Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06' prior: 18183980!
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' prior: 18184999!
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' prior: 18185966!
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' stamp: 'sd 2/1/2004 15:14'!
spaceUsed
	"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."

	| space method |
	space _ 0.
	self selectorsDo: [:sel |
		space _ space + 16.  "dict and org'n space"
		method _ self compiledMethodAt: sel.
		space _ space + (method size + 6 "hdr + avg pad").
		method literals do: [:lit |
			(lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: Float) ifTrue: [space _ space + 12].
			(lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)].
			(lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]].
		^ space! !

!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: 'obsolete subclasses' stamp: 'ar 3/2/2001 00:58'!
addObsoleteSubclass: aClass
	"Weakly remember that aClass was a subclass of the receiver and is now obsolete"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	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: 'ar 3/2/2001 00:58'!
obsoleteSubclasses
	"Return all the weakly remembered obsolete subclasses of the receiver"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	obs _ ObsoleteSubclasses at: self ifAbsent:[^#()].
	obs _ obs copyWithout: nil.
	obs isEmpty
		ifTrue:[ObsoleteSubclasses removeKey: self ifAbsent:[]]
		ifFalse:[ObsoleteSubclasses at: self put: obs].
	^obs! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:13'!
removeAllObsoleteSubclasses
	"Remove all the obsolete subclasses of the receiver"
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	ObsoleteSubclasses removeKey: self ifAbsent: [].
! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:16'!
removeObsoleteSubclass: aClass
	"Remove aClass from the weakly remembered obsolete subclasses"
	| obs |
	ObsoleteSubclasses finalizeValues. "clean up if need be"
	obs _ ObsoleteSubclasses at: self ifAbsent:[^ self].
	(obs includes: aClass) ifFalse:[^self].
	obs _ obs copyWithout: aClass.
	obs _ obs copyWithout: nil.
	obs isEmpty
		ifTrue: [ObsoleteSubclasses removeKey: self ifAbsent: []]
		ifFalse: [ObsoleteSubclasses at: self put: obs].! !

!Behavior methodsFor: 'deprecated' stamp: 'sw 12/1/2000 20:11'!
allSelectorsUnderstood
	"Answer a list of all selectors understood by instances of the receiver"

	| aList |
	aList _ OrderedCollection new.
	self withAllSuperclasses do:
		[:aClass | aList addAll: aClass selectors].
	^ aList asSet asArray

"SketchMorph allSelectorsUnderstood size"! !

!Behavior methodsFor: 'deprecated' stamp: 'NS 12/12/2003 16:00' prior: 34007407!
allSelectorsUnderstood
	"Answer a list of all selectors understood by instances of the receiver"

	| aList |
	self deprecated: 'Use allSelectors instead.'.
	aList _ OrderedCollection new.
	self withAllSuperclasses do:
		[:aClass | aList addAll: aClass selectors].
	^ aList asSet asArray

"SketchMorph allSelectorsUnderstood size"! !

!Behavior methodsFor: 'deprecated' stamp: 'NS 1/28/2004 11:29' prior: 18187247!
removeSelectorSimply: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method."

	| oldMethod |
	self deprecated: 'Use basicRemoveSelector: instead.'.
	oldMethod _ self methodDict at: selector ifAbsent: [^ self].
	self methodDict removeKey: selector.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethod flushCache.
	selector flushCache.! !

!Behavior methodsFor: '*system-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: 'RAA 5/28/2001 13:29'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special byte |

	aSortedCollection _ SortedCollection new.
	special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ].
	self withAllSubclassesDo: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel |
			sel == #DoIt ifFalse: [
				aSortedCollection add: (
					MethodReference new
						setStandardClass: class 
						methodSymbol: sel
				)
			]
		]
	].
	^aSortedCollection! !

!Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:05' prior: 34009082!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special byte |

	aSortedCollection _ SortedCollection new.
	special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ].
	self withAllSubclassesDo: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel |
			sel == #DoIt ifFalse: [
				aSortedCollection add: (
					MethodReference new
						setStandardClass: class 
						methodSymbol: sel
				)
			]
		]
	].
	^aSortedCollection! !

!Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 17:45' prior: 34009718!
allCallsOn: aSymbol

	self flag: #deprecated.
	self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:from: instead'! !

!Behavior methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:12' prior: 34010361!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special byte |
	self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allCallsOn:from: instead'.
	aSortedCollection _ SortedCollection new.
	special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ].
	self withAllSubclassesDo: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel |
			sel == #DoIt ifFalse: [
				aSortedCollection add: (
					MethodReference new
						setStandardClass: class 
						methodSymbol: sel
				)
			]
		]
	].
	^aSortedCollection! !

!Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43' prior: 34010577!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."


	^ self  systemNavigation allCallsOn: aSymbol from: self .
	! !

!Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:06' prior: 18171335!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system.  5/8/96 sw"

	^ self environment allUnSentMessagesIn: self selectors! !

!Behavior methodsFor: '*system-support' stamp: 'sd 4/29/2003 20:25' prior: 34011560!
allUnsentMessages
	"this method was not used at all, required a reference to 
	systemNavigation and systemNavigation had the same functionality"
	self flag: #deprecated.
	self error: 'Method Deprecated: Use SystemNavigation>>allUnsentMessagesIn: instead'! !

!Behavior methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:13' prior: 34011840!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system.  5/8/96 sw"

	self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allUnsentMessagesIn: instead'.
	^ self environment allUnSentMessagesIn: self selectors! !

!Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43' prior: 34012184!
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: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'!
sunitAllSelectors 

        ^self allSelectors asSortedCollection asOrderedCollection! !

!Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46' prior: 34012819!
sunitAllSelectors 

        ^self allSelectors asSortedCollection asOrderedCollection! !

!Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'!
sunitSelectors
 
        ^self selectors asSortedCollection asOrderedCollection! !

!Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46' prior: 34013153!
sunitSelectors
 
        ^self selectors asSortedCollection asOrderedCollection! !

!Behavior class methodsFor: 'class initialization' stamp: 'ar 3/3/2001 00:30'!
flushObsoleteSubclasses
	"Behavior flushObsoleteSubclasses"
	ObsoleteSubclasses keys "need a copy" 
		do:[:obs| obs ifNotNil:[obs obsoleteSubclasses]]. "remove themselves"
	ObsoleteSubclasses finalizeValues.! !

!Behavior class methodsFor: 'class initialization' stamp: 'ar 3/2/2001 00:47'!
initialize	"Behavior initialize"
	"Never called for real"
	ObsoleteSubclasses ifNil:[self initializeObsoleteSubclasses].! !

!Behavior class methodsFor: 'class initialization' stamp: 'ar 3/2/2001 00:48'!
initializeObsoleteSubclasses
	ObsoleteSubclasses _ WeakIdentityKeyDictionary new.! !

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

!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: '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' stamp: 'ar 5/4/2001 15:45'!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	colorMap _ map.! !

!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: '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' stamp: 'ar 5/14/2001 23:27'!
copyBits
	"Primitive. Perform the movement of bits from the source form to the 
	destination form. Fail if any variables are not of the right type (Integer, 
	Float, or Form) or if the combination rule is not implemented. 
	In addition to the original 16 combination rules, this BitBlt supports
	16	fail (to simulate paint)
	17	fail (to simulate mask)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	rgbDiff: sourceWord with: destinationWord
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
"
	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	(combinationRule >= 30 and: [combinationRule <= 31]) ifTrue:
		["No alpha specified -- re-run with alpha = 1.0"
		^ self copyBitsTranslucent: 255].
	((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm isKindOf: Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBits].

	"Check for unimplmented rules"
	combinationRule = Form oldPaint ifTrue: [^ self paintBits].
	combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits].

	"Check if BitBlt doesn't support full color maps"
	(colorMap notNil and:[colorMap isColormap]) ifTrue:[
		colorMap _ colorMap colors.
		^self copyBits].

	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	destX _ destX asInteger.
	destY _ destY asInteger.
	width _ width asInteger.
	height _ height asInteger.
	sourceX _ sourceX asInteger.
	sourceY _ sourceY asInteger.
	clipX _ clipX asInteger.
	clipY _ clipY asInteger.
	clipWidth _ clipWidth asInteger.
	clipHeight _ clipHeight asInteger.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'ar 3/7/2003 23:57' prior: 34017169!
copyBits
	"Primitive. Perform the movement of bits from the source form to the 
	destination form. Fail if any variables are not of the right type (Integer, 
	Float, or Form) or if the combination rule is not implemented. 
	In addition to the original 16 combination rules, this BitBlt supports
	16	fail (to simulate paint)
	17	fail (to simulate mask)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	rgbDiff: sourceWord with: destinationWord
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
"
	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	(combinationRule >= 30 and: [combinationRule <= 31]) ifTrue:
		["No alpha specified -- re-run with alpha = 1.0"
		^ self copyBitsTranslucent: 255].
	((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm isKindOf: Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBits].

	"Check for unimplmented rules"
	combinationRule = Form oldPaint ifTrue: [^ self paintBits].
	combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits].

	"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 copyBits].

	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	destX _ destX asInteger.
	destY _ destY asInteger.
	width _ width asInteger.
	height _ height asInteger.
	sourceX _ sourceX asInteger.
	sourceY _ sourceY asInteger.
	clipX _ clipX asInteger.
	clipY _ clipY asInteger.
	clipWidth _ clipWidth asInteger.
	clipHeight _ clipHeight asInteger.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:41' prior: 34019420!
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 copyBits].

	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	destX _ destX asInteger.
	destY _ destY asInteger.
	width _ width asInteger.
	height _ height asInteger.
	sourceX _ sourceX asInteger.
	sourceY _ sourceY asInteger.
	clipX _ clipX asInteger.
	clipY _ clipY asInteger.
	clipWidth _ clipWidth asInteger.
	clipHeight _ clipHeight asInteger.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'ar 2/13/2001 21:12'!
copyBitsSimulated
	^Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! !

!BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42' prior: 18214279!
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' 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 9/29/2002 08:44' prior: 18216838!
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].

	(aString class == MultiString) ifTrue: [^ font characters: (startIndex to: stopIndex) in: aString displayAt: aPoint clippedBy: (clipX@clipY extent: clipWidth@clipHeight) rule: combinationRule fillColor: sourceForm kernDelta: kernDelta.].

	^self primDisplayString: aString from: startIndex to: stopIndex
			map: font characterToGlyphMap xTable: font xTable
			kern: kernDelta.! !

!BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49' prior: 18217657!
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' prior: 18217967!
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: '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 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 6/23/2003 18:07'!
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.
		^ self.
	].
! !

!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 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 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: '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"  ! !

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

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

!BitBltTest methodsFor: 'bugs' stamp: 'ar 4/6/2003 19:04'!
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: 'ar 4/6/2003 19:04'!
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: 'tpr 8/15/2003 19:00'!
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: 'tpr 8/15/2003 19:02'!
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: 'ar 3/1/2004 13:49'!
testPeekerUnhibernateBug
	| bitBlt |
	bitBlt := BitBlt bitPeekerFromForm: Display.
	bitBlt destForm hibernate.
	self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! !

!BitBltTest methodsFor: 'bugs' stamp: 'ar 3/1/2004 13:49'!
testPokerUnhibernateBug
	| bitBlt |
	bitBlt := BitBlt bitPokerToForm: Display.
	bitBlt sourceForm hibernate.
	self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! !

!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: 'btr 11/18/2002 14:57'!
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! !

!BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:21' prior: 34056381!
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 class methodsFor: 'private' stamp: 'BG 12/4/2003 10:18' prior: 18375281!
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' prior: 18377524!
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
! !

!Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02' prior: 18389619!
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: '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' stamp: 'ar 9/21/2001 23:06' prior: 18392299!
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: 'ar 6/16/2002 18:49'!
copyFromByteArray: byteArray
	"This method should work with either byte orderings"
	| myHack byteHack |
	myHack := Form new hackBits: self.
	byteHack := Form new hackBits: byteArray.
	Smalltalk isLittleEndian ifTrue:[byteHack swapEndianness].
	byteHack displayOn: myHack.
! !

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

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

!BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:34' prior: 18397248!
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 menu' stamp: 'sd 5/11/2003 22:18' prior: 18397708!
chooseNewGraphicIn: aMorph event: evt
	"Used by any morph that can be represented by a graphic"
	| reasonableForms aGraphicalMenu myGraphic |
	reasonableForms _ (SketchMorph allSubInstances collect: [:m | m form]) asOrderedCollection.
	reasonableForms addAll: Imports default images.
	reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]).
	reasonableForms _ reasonableForms asSet asOrderedCollection.
	(reasonableForms includes: (myGraphic _ self form))
		ifTrue:
			[reasonableForms remove: myGraphic].
	reasonableForms addFirst: myGraphic.

	aGraphicalMenu _ GraphicalMenu new initializeFor: self withForms: reasonableForms coexist: true.
	aGraphicalMenu selector: #newForm:forMorph:; argument: aMorph.
	evt hand attachMorph: aGraphicalMenu.! !

!BitmapFillStyle 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 class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33' prior: 18399324!
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! !

!BitmapStreamTests methodsFor: 'Running' stamp: 'nk 7/5/2003 15:22'!
setUp
	random _ Random new.! !

!BitmapStreamTests methodsFor: 'Running' stamp: 'nk 7/5/2003 15:22' prior: 34066554!
setUp
	random _ Random new.! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 17:05'!
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: 'nk 7/5/2003 18:06'!
testShortIntegerArrayWithImageSegment
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:06' prior: 34067206!
testShortIntegerArrayWithImageSegment
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:17'!
testShortIntegerArrayWithRefStream
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 18:44' prior: 34067728!
testShortIntegerArrayWithRefStream

	array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:03'!
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: 'nk 7/5/2003 18:22'!
testShortIntegerArrayWithRefStreamOnDisk
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:22' prior: 34068580!
testShortIntegerArrayWithRefStreamOnDisk
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 16:32'!
testShortIntegerArrayWithSmartRefStream
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 16:32' prior: 34069114!
testShortIntegerArrayWithSmartRefStream
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:04'!
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: 'nk 7/5/2003 18:31'!
testShortIntegerArrayWithSmartRefStreamOnDisk
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:31' prior: 34069987!
testShortIntegerArrayWithSmartRefStreamOnDisk
	array _ ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:12'!
testShortPointArrayWithImageSegment
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:12' prior: 34070539!
testShortPointArrayWithImageSegment
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:17'!
testShortPointArrayWithRefStream
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:17' prior: 34071055!
testShortPointArrayWithRefStream
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'!
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: 'nk 7/5/2003 18:22'!
testShortPointArrayWithRefStreamOnDisk
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:22' prior: 34071915!
testShortPointArrayWithRefStreamOnDisk
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 15:57'!
testShortPointArrayWithSmartRefStream
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 15:57' prior: 34072441!
testShortPointArrayWithSmartRefStream
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'!
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: 'nk 7/5/2003 18:31'!
testShortPointArrayWithSmartRefStreamOnDisk
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:31' prior: 34073287!
testShortPointArrayWithSmartRefStreamOnDisk
	array _ ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-misc' stamp: 'nk 3/17/2004 16:48'!
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-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: 'nk 7/5/2003 18:12'!
testShortRunArrayWithImageSegment
	array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]).
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34074390!
testShortRunArrayWithImageSegment
	array _ self createSampleShortRunArray.
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:17'!
testShortRunArrayWithRefStream
	array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]).
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34074830!
testShortRunArrayWithRefStream
	array _ self createSampleShortRunArray.
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:22'!
testShortRunArrayWithRefStreamOnDisk
	array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]).
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34075258!
testShortRunArrayWithRefStreamOnDisk
	array _ self createSampleShortRunArray.
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 16:40'!
testShortRunArrayWithSmartRefStream
	array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]).
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34075708!
testShortRunArrayWithSmartRefStream
	array _ self createSampleShortRunArray.
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:44'!
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: 'nk 7/5/2003 18:31'!
testShortRunArrayWithSmartRefStreamOnDisk
	array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]).
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:40' prior: 34076480!
testShortRunArrayWithSmartRefStreamOnDisk
	array _ self createSampleShortRunArray.
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:23'!
testMatrixTransform2x3WithImageSegment
	array _ MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'!
testMatrixTransform2x3WithRefStream
	array _ MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'!
testMatrixTransform2x3WithRefStreamOnDisk
	array _ MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateRefStreamOnDisk	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'!
testMatrixTransform2x3WithSmartRefStream
	array _ MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateSmartRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'!
testMatrixTransform2x3WithSmartRefStreamOnDisk
	array _ MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:25'!
testWordArrayWithImageSegment
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:25' prior: 34078205!
testWordArrayWithImageSegment
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'!
testWordArrayWithRefStream
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34078671!
testWordArrayWithRefStream
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'!
testWordArrayWithRefStreamOnDisk
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34079125!
testWordArrayWithRefStreamOnDisk
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'!
testWordArrayWithSmartRefStream
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34079603!
testWordArrayWithSmartRefStream
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:31'!
testWordArrayWithSmartRefStreamOnDisk
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:31' prior: 34080077!
testWordArrayWithSmartRefStreamOnDisk
	array _ WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 3/7/2004 14:22'!
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:33' prior: 34080733!
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: 'nk 7/5/2003 16:00' prior: 34081013!
randomShortPoint
	^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:26'!
randomWord
	"Answer a random 32-bit integer"
	| w |
	random seed: (w _ random nextValue).
	^w truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:26' prior: 34081369!
randomWord
	"Answer a random 32-bit integer"
	| w |
	random seed: (w _ random nextValue).
	^w truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:11'!
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: 'nk 7/5/2003 18:11' prior: 34081739!
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: 'nk 7/5/2003 18:17'!
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: 'nk 7/5/2003 18:17' prior: 34082727!
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: 'nk 7/5/2003 18:22'!
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: 'nk 7/5/2003 18:22' prior: 34083587!
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: 'nk 7/5/2003 16:43'!
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: 'nk 7/5/2003 16:43' prior: 34084493!
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: 'nk 7/5/2003 18:32'!
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! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:32' prior: 34085261!
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! !

!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.
!
!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'!
form
	^form! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'!
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: 'JMM 10/19/2000 15:54'!
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: 'JMM 1/4/2001 10:53'!
quadNumber: aNumber
	quadNumber _ aNumber! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:59'!
stream
	^0! !

!BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:18'!
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: 'JMM 1/4/2001 11:06'!
initialize: primaryFlag mpegPlayer: aMpegPlayerOrFileName 
	| rect sizeToOverLapBoundary |

	primary _ primaryFlag.
	rect _ self bounds.
	sizeToOverLapBoundary _ 3.0.
	primary 
		ifTrue: [form _ Form extent: 
					((sizeToOverLapBoundary * rect width) @ (sizeToOverLapBoundary * rect height)) truncated depth: 32.
				movieDrawArea _ SketchMorph withForm: form.
				mpegLogic _ MPEGPlayer playFile: aMpegPlayerOrFileName onMorph: movieDrawArea]
		ifFalse: [form _ aMpegPlayerOrFileName form.
				movieDrawArea _ aMpegPlayerOrFileName movieDrawArea.
				mpegLogic _ aMpegPlayerOrFileName mpegLogic]
! !

!BlobMPEGMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:43' prior: 34089353!
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: 'JMM 1/4/2001 11:02'!
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 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 class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:10'!
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: 'JMM 1/4/2001 11:11'!
newWithMovie: aFileName
	| primary |

	primary _ self buildMorphics: aFileName.
	primary playStream: 0.
	^primary

! !

!BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:12'!
newWithMovieNoSound: aFileName
	| primary |

	primary _ self buildMorphics: aFileName.
	primary playVideoStream: 0.
	^primary

! !

!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: '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' prior: 18401133!
initialize
	"initialize the state of the receiver"
	random _ Random new.
	sneaky _ random next < 0.75.
	super initialize.
""
	self beSmoothCurve; initializeBlobShape; setVelocity! !

!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 class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'!
descriptionForPartsBin
	^ self partName:	'Blob'
		categories:		#('Demo')
		documentation:	'A patch of primordial slime'! !

!BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'!
setUp
	morph := BlobMorph new.! !

!BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'!
tearDown
	morph delete.! !

!BlobMorphTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:26'!
testOpenInWorld
	self shouldnt: [morph openInWorld] raise: Error.! !

!BlobMorphTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class BlobMorph. 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!
!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! !

!BlockContext 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."

	nargs = 0 ifFalse: [self error: 'can only refresh block contexts that have zero arguments'].
	pc _ startpc.
	self stackp: 0.
! !

!BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49' prior: 34096985!
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: '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: 'ajh 1/31/2003 23:29'!
finalBlockHome

	^ self 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' 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' stamp: 'ajh 1/30/2003 15:45'!
reentrant
	"Copy before calling so multiple activations can exist"

	^ self copy! !

!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: 'mdr 4/10/2001 13:08'!
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 either no parameters, or two (the error message and the receiver).  The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around."
	"Examples:
		[1 whatsUpDoc] ifError: [:err :rcvr | 'huh?'].
		[1 / 0] ifError: [:err :rcvr |
			'ZeroDivide' = err
				ifTrue: [Float infinity]
				ifFalse: [self error: err]]
"
	| lastHandler val activeProcess errBlockArgs |
	errBlockArgs _ errorHandlerBlock numArgs.
	(errBlockArgs = 2) | (errBlockArgs = 0)
		ifFalse: [self error: 'error block must accept zero or two arguments (err rcvr)'].
	activeProcess _ Processor activeProcess.
	lastHandler _ activeProcess errorHandler.
	activeProcess errorHandler: [:aString :aReceiver |
		activeProcess errorHandler: lastHandler.
		(errBlockArgs = 2)
			ifTrue: [^ errorHandlerBlock value: aString value: aReceiver ]
			ifFalse: [^ errorHandlerBlock value ]].
	val _ self on: Error do: [:ex |
		activeProcess errorHandler: lastHandler.
		(errBlockArgs = 2)
			ifTrue: [^ errorHandlerBlock value: ex description value: ex receiver ]
			ifFalse: [^ errorHandlerBlock value ]].
	activeProcess errorHandler: lastHandler.
	^ val


! !

!BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36' prior: 34098836!
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'!
valueWithArguments: anArray 
	"Primitive. Evaluate the block represented by the receiver. The argument 
	is an Array whose elements are the arguments for the block. Fail if the 
	length of the Array is not the same as the the number of arguments that 
	the block was expecting. Fail if the block is already being executed. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 82>
	self numArgs = anArray size
		ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
		ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments.']! !

!BlockContext methodsFor: 'evaluating' stamp: 'mjr 9/10/2003 22:42' prior: 34100959!
valueWithArguments: anArray 
	"Primitive. Evaluate the block represented by the receiver. The argument 
	is an Array whose elements are the arguments for the block. Fail if the 
	length of the Array is not the same as the the number of arguments that 
	the block was expecting. Fail if the block is already being executed. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 82>

	self numArgs = anArray size
		ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
		ifFalse: [self error: 
			'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , 
			', but was called with ', anArray size printString, '.']

! !

!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: '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: '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: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35' prior: 18421169!
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: 'LC 1/6/2002 11:59'!
decompile
	^ Decompiler new decompileBlock: self! !

!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: 'dew 11/11/2003 01:15' prior: 18421485!
printOn: aStream
	| blockString truncatedBlockString |

	home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream.
	aStream nextPutAll: ' '.
	blockString _ ((self decompile ifNil: ['--source missing--']) 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: 'private' stamp: 'tpr 2/16/2001 18:24'!
aboutToReturn: result through: firstUnwindContext 
	"Use the passed in context as the first marked context; evaluate the 
	unwind block and then scan upwards for the next unwind marked 
	method context"
	| ctx unwindBlock |
	ctx _ firstUnwindContext.
	[ctx isNil]
		whileFalse: [unwindBlock _ ctx tempAt: 1.
			unwindBlock == nil
				ifFalse: [unwindBlock value].
			ctx _ ctx findNextUnwindContextUpTo: home].
	thisContext swapSender: home sender.
	^ result! !

!BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36' prior: 34105280!
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: '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: 'ajh 1/27/2003 21:08'!
privHome: context

	home _ context! !

!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: '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: 'exceptions' stamp: 'ar 3/6/2001 14:24'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."
	| returnValue |
	<primitive: 198>
	returnValue := self valueUninterruptably.
	"aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated"
	aBlock == nil ifFalse: [aBlock value].
	^returnValue! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 23:40' prior: 34107958!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue |
	<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: [aBlock value].
	^returnValue! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36' prior: 34108517!
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: 'ar 3/6/2001 14:25'!
ifCurtailed: aBlock
	"Evaluate the receiver with an abnormal termination action."
	<primitive: 198>
	^self valueUninterruptably! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43' prior: 34109758!
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: 'ar 3/6/2001 14:25' prior: 34110161!
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: 'ar 3/6/2001 14:55'!
valueUninterruptably
	"Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior."
	| sendingContext result homeSender |
	<primitive: 123>
	"The above indicates new EH primitives supported. In this case is identical to #value."
	sendingContext := thisContext sender sender.
	homeSender _ home swapSender: nil.
	[[result := self
				on: BlockCannotReturn
				do:
					[:ex |
					thisContext unwindTo: sendingContext.
					sendingContext home answer: ex result.
					ex return: ex result]]
						on: ExceptionAboutToReturn
						do:
							[:ex |
							home sender == nil
								ifTrue:
									[home swapSender: homeSender.
									ex resume: homeSender]
								ifFalse: [ex resume: nil]]]
		on: Exception
		do:
			[:ex |
			home swapSender: homeSender.
			ex pass].
	home swapSender: homeSender.
	^result! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53' prior: 34111060!
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: '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 methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:56'!
sunitEnsure: aBlock
 
        ^self ensure: aBlock! !

!BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:56' prior: 34112743!
sunitEnsure: aBlock
 
        ^self ensure: aBlock! !

!BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'!
sunitOn: anException do: aHandlerBlock
 
        ^self on: anException do: aHandlerBlock! !

!BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57' prior: 34113015!
sunitOn: anException do: aHandlerBlock
 
        ^self on: anException do: aHandlerBlock! !

!BlockContextTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 5/31/2004 13:49'!
testCopyStack
	self assert: aBlockContext copyStack printString = aBlockContext printString.! !

!BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:55'!
testFindContextSuchThat
	self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString.
	self assert: (aBlockContext hasContext: aBlockContext).  ! !

!BlockContextTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 5/31/2004 12:50'!
testRunSimulated
	self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! !

!BlockContextTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 5/31/2004 12:32'!
testTallyInstructions
	self assert: (ContextPart tallyInstructions: aBlockContext) size = 17.! !

!BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:30'!
testTallyMethods
	self assert: (ContextPart tallyMethods: aBlockContext) size = 4.! !

!BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:48'!
testTrace
	self assert: (ContextPart trace: aBlockContext) class = Rectangle.! !

!BlockContextTest methodsFor: 'testing' stamp: 'mjr 9/10/2003 23:01'!
testValueWithArguments
	self
		should: [[3 + 4]
				valueWithArguments: #(1 )]
		raise: Error.
	self
		shouldnt: [[3 + 4]
				valueWithArguments: #()]
		raise: Error.
	[[3 + 4]
		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: 'testing' stamp: 'tlk 5/31/2004 17:14' prior: 34116753!
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: 'Running' stamp: 'tlk 5/31/2004 12:36'!
setUp
	super setUp.
	aBlockContext _ [100@100 corner: 200@200].
	contextOfaBlockContext _ thisContext.! !

!BlockContextTest commentStamp: 'tlk 5/31/2004 12:15' 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]
 !
!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: '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: 'tiles' stamp: 'RAA 2/27/2001 09:48'!
asMorphicCollectSyntaxIn: parent

	^parent 
		blockNodeCollect: self 
		arguments: arguments 
		statements: statements! !

!BlockNode methodsFor: 'tiles' stamp: 'RAA 2/16/2001 09:08'!
asMorphicSyntaxIn: parent

	^parent 
		blockNode: self 
		arguments: arguments 
		statements: statements! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 12/12/2001 15:36'!
cardsOrPages
	"The turnable and printable entities"

	^ pages! !

!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: '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' prior: 18438846!
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: 'dgd 2/14/2003 21:09' prior: 18440840!
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: 'dgd 2/14/2003 22:07' prior: 18441843!
setInitialState
	self listDirection: #topToBottom;
	  wrapCentering: #topLeft;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  layoutInset: 5.
	pageSize _ 160 @ 300.
	self enableDragNDrop! !

!BookMorph methodsFor: 'insert and delete' stamp: 'dgd 9/21/2003 17:45' prior: 18447087!
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: 'mdr 8/13/2001 10:14'!
insertPage: aPage pageSize: aPageSize atIndex: anIndex

	| sz  predecessor |
	sz _ aPageSize
		ifNil: [currentPage == nil
			ifTrue: [pageSize]
			ifFalse: [currentPage extent]]
		ifNotNil:
			[aPageSize].
	aPage extent: sz.
	((pages isEmpty | anIndex isNil) or: [anIndex > pages size])
		ifTrue:
			[pages add: aPage]
		ifFalse:
			[anIndex <= 1
				ifTrue:
					[pages addFirst: aPage]
				ifFalse:
					[predecessor _ anIndex == nil
						ifTrue:
							[currentPage]
						ifFalse:
							[pages at: anIndex].
					self pages add: aPage after: predecessor]].

	self goToPageMorph: aPage
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:10' prior: 34122699!
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: 'tk 10/30/2001 18:40'!
insertPageColored: aColor
	"Insert a new page for the receiver, using the given color as its background color"

	| sz newPage bw bc |
	currentPage == nil
		ifTrue:
			[sz _ pageSize.
			bw _ 0.
			bc _ Color blue muchLighter]
		ifFalse:
			[sz _ currentPage extent.
			bw _ currentPage borderWidth.
			bc _ currentPage borderColor].
	newPagePrototype
		ifNil:
			[newPage _ PasteUpMorph new extent: sz; color: aColor.
			newPage borderWidth: bw; borderColor: bc]
		ifNotNil: [Cursor wait showWhile: 
				[newPage _ newPagePrototype veryDeepCopy]].
	newPage setNameTo: self defaultNameStemForNewPages.
	newPage vResizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: (currentPage _ newPage)]
		ifFalse: [pages add: newPage after: currentPage].
	self nextPage
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11' prior: 34124031!
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: 'tk 10/30/2001 18:40'!
insertPageSilentlyAtEnd
	"Create a new page at the end of the book.  Do not turn to it."

	| sz newPage bw bc cc | 
	currentPage == nil
		ifTrue: [sz _ pageSize.
			bw _ 0.
			bc _ Color blue muchLighter.
			cc _ color]
		ifFalse: [sz _ currentPage extent.
			bw _ currentPage borderWidth.
			bc _ currentPage borderColor.
			cc _ currentPage color].
	newPagePrototype
		ifNil: [newPage _ PasteUpMorph new extent: sz; color: cc.
			newPage borderWidth: bw; borderColor: bc]
		ifNotNil: [Cursor wait showWhile: 
				[newPage _ newPagePrototype veryDeepCopy]].
	newPage setNameTo: self defaultNameStemForNewPages.
	newPage vResizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: (currentPage _ newPage)]	"had been none"
		ifFalse: [pages add: newPage after: pages last].
	^ newPage! !

!BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11' prior: 34125761!
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: 'menu' stamp: 'dgd 8/30/2003 21:13' prior: 18457153!
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' prior: 18459445!
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: 'RAA 2/24/2001 13:16'!
buildThreadOfProjects

	| thisPVM projectNames threadName |

	projectNames _ pages collect: [ :each |
		(thisPVM _ each findA: ProjectViewMorph) ifNil: [
			nil
		] ifNotNil: [
			{thisPVM project name}.
		].
	].
	projectNames _ projectNames reject: [ :each | each isNil].
	threadName _ FillInTheBlank 
		request: 'Please name this thread.' 
		initialAnswer: (
			self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade']
		).
	threadName isEmptyOrNil ifTrue: [^self].
	InternalThreadNavigationMorph 
		know: projectNames as: threadName;
		openThreadNamed: threadName atIndex: nil.
! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:04' prior: 34131057!
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' prior: 18460968!
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: 'tk 5/23/2001 16:52'!
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: [rawStrings]	"normal case"
		ifNotNil: [(pages at: pageNum) isInMemory 
					ifFalse: [rawStrings]
					ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]].
	keys do: [:searchString | "each key"
		good ifTrue: [thisWord _ false.
			strings do: [:longString |
				(index _ longString findString: searchString startingAt: start 
					caseSensitive: false) > 0 ifTrue: [
						thisWord not & (searchString == (keys at: 1)) ifTrue: [
							insideOf _ longString. place _ index].
						thisWord _ true].
				start _ 1].	"only first key on first container"
			good _ thisWord]].
	good ifTrue: ["all are on this page"
		wasIn _ (pages at: pageNum) isInMemory.
		self goToPage: pageNum.
		wasIn ifFalse: ["search again, on the real current text.  Know page is in."
			^ self findText: keys 
				inStrings: ((pages at: pageNum) allStringsAfter: nil) "recompute"	
				startAt: startIndex container: oldContainer 
				pageNum: pageNum]].
	(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 at: 1) at: place in: insideOf]
			ifNotNil: [
				container userString == insideOf 
					ifFalse: [
						container _ self highlightText: (keys at: 1) at: place 
							in: insideOf]
					ifTrue: [(container isKindOf: TextMorph) ifTrue: [
						container editor selectFrom: place to: 
								(keys at: 1) size - 1 + place.
						container changed].
						]].
		self setProperty: #searchContainer toValue: container.
		self setProperty: #searchOffset toValue: place.
		self setProperty: #searchKey toValue: keys.		"override later"
		ActiveHand newKeyboardFocus: container.
		^ true].
	^ false! !

!BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17' prior: 34132715!
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: 'ar 3/17/2001 23:44'!
getStemUrl
	"Try to find the old place where this book was stored. Confirm with the 
	user. Else ask for new place."
	| initial pg url knownURL |

	knownURL _ false.
	initial _ ''.
	(pg _ currentPage valueOfProperty: #SqueakPage)
		ifNotNil: [pg contentsMorph == currentPage
				ifTrue: [initial _ pg url.
					knownURL _ true]].
	"If this page has a url"
	pages
		doWithIndex: [:aPage :ind | initial isEmpty
				ifTrue: [aPage isInMemory
						ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage)
								ifNotNil: [initial _ pg url]]]].
	"any page with a url"
	initial isEmpty
		ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp'].
	"A new legal place"
	url _ knownURL
		ifTrue: [initial]
		ifFalse: [FillInTheBlank request: 'url of the place to store a typical page in this book.
Must begin with file:// or ftp://' initialAnswer: initial].
	^ SqueakPage stemUrl: url! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:06' prior: 34137843!
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' prior: 18468374!
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' prior: 18468596!
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 9/19/2003 11:06' prior: 18469274!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	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 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: 'sw 3/3/2004 18:40' prior: 34140709!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Book' translated.
	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: 'dgd 2/21/2003 23:11' prior: 18471972!
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: (SketchMorph withForm: form).
			self pages addLast: newpage.
			filenumber := filenumber + 1].

	"After adding all, delete the first page."
	self goToPage: 1.
	self deletePageBasic.

	"Save the book"
	(self valueOfProperty: #url) isNil 
		ifTrue: [self savePagesOnURL]
		ifFalse: [self saveAsNumberedURLs]! !

!BookMorph methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25' prior: 18473157!
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: 'dgd 10/26/2003 13:39' prior: 18473452!
menuPageSoundFor: target event: evt
	| tSpec menu |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: ('Choose a sound
(it is now {1})' translated format:{tSpec first asString translated})) defaultTarget: target.
	SampledSound soundNames do:
		[:soundName |
		menu add: soundName asString 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: 'gk 2/23/2004 21:08' prior: 34147701!
menuPageSoundFor: target event: evt
	| tSpec menu |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: 'Choose a sound
(it is now ' , tSpec first , ')') defaultTarget: target.
	SoundService default sampledSoundChoices do:
		[:soundName |
		menu add: soundName target: target
			selector: #setProperty:toValue:
			argumentList: (Array with: #transitionSpec
								with: (tSpec copy at: 1 put: soundName; yourself))].

	menu popUpEvent: evt in: self world! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:39' prior: 18474275!
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: 'ar 3/17/2001 23:44'!
reload
	"Fetch the pages of this book from the server again.  For all pages that have not been modified, keep current ones.  Use new pages.  For each, look up in cache, if time there is equal to time of new, and its in, use the current morph.
	Later do fancy things when a page has changed here, and also on the server."

	| url onServer onPgs sq which |
	(url _ self valueOfProperty: #url) ifNil: ["for .bo index file"
	url _ FillInTheBlank 
		request: 'url of the place where this book''s index is stored.
Must begin with file:// or ftp://' 
		initialAnswer: (self getStemUrl, '.bo').
	url size > 0 ifTrue: [self setProperty: #url toValue: url]
				ifFalse: [^ self]].
	onServer _ self class new fromURL: url.
	"Later: test book times?"
	onPgs _ onServer pages collect: [:out |
		sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil].
		(sq ~~ nil and: [sq contentsMorph isInMemory])
			ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: 
					  [sq contentsMorph == nil]) 
						ifTrue: [SqueakPageCache atURL: out url put: out sqkPage.
							out]
						ifFalse: [sq contentsMorph]]
			ifFalse: [SqueakPageCache atURL: out url put: out sqkPage.
				out]].
	which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1.
	self newPages: onPgs currentIndex: which.
		"later stay at current page"
	self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime).
	self setProperty: #allText toValue: (onServer valueOfProperty: #allText).
	self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls).
! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:49' prior: 34149914!
reload
	"Fetch the pages of this book from the server again.  For all pages that have not been modified, keep current ones.  Use new pages.  For each, look up in cache, if time there is equal to time of new, and its in, use the current morph.
	Later do fancy things when a page has changed here, and also on the server."

	| url onServer onPgs sq which |
	(url := self valueOfProperty: #url) ifNil: 
			["for .bo index file"

			url := FillInTheBlank 
						request: 'url of the place where this book''s index is stored.
Must begin with file:// or ftp://'
						initialAnswer: self getStemUrl , '.bo'.
			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 10/26/2003 13:14' prior: 34151548!
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' prior: 18477586!
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: 'dgd 2/21/2003 23:12' prior: 18478648!
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: 'dgd 2/21/2003 23:12' prior: 18480030!
saveIndexOfOnly: aPage 
	"Modify the index of this book on a server.  Read the index, modify the entry for just this page, and write back.  See saveIndexOnURL. (page file names must be unique even if they live in different directories.)"

	| mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName |
	mine := self valueOfProperty: #url.
	mine ifNil: [^self saveIndexOnURL].
	Cursor wait showWhile: [strm := ServerFile new fullPath: mine].
	strm ifNil: [^self saveIndexOnURL].
	strm class == String ifTrue: [^self saveIndexOnURL].
	strm exists ifFalse: [^self saveIndexOnURL].	"write whole thing if missing"
	strm := strm asStream.
	strm class == String ifTrue: [^self saveIndexOnURL].
	remote := strm fileInObjectAndCode.
	dict := remote 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.'].
	(pageURL := aPage url) ifNil: [self error: 'just had one!!'].
	fName := pageURL copyAfterLast: $/.
	2 to: remote size
		do: 
			[:ii | 
			((remote at: ii) url 
				findString: fName
				startingAt: 1
				caseSensitive: false) > 0 
				ifTrue: [index := ii].	"fast"
			(remote at: ii) xxxReset].
	index ifNil: 
			["new page, what existing page does it follow?"

			num := self pageNumberOf: aPage.
			1 to: num - 1
				do: [:ii | (pages at: ii) url ifNotNil: [pre := (pages at: ii) url]].
			pre ifNil: [after := remote size + 1]
				ifNotNil: 
					["look for it on disk, put me after"

					pre := pre copyAfterLast: $/.
					2 to: remote size
						do: 
							[:ii | 
							((remote at: ii) url 
								findString: pre
								startingAt: 1
								caseSensitive: false) > 0 
								ifTrue: [after := ii + 1]].
					after ifNil: [after := remote size + 1]].
			remote := remote 
						copyReplaceFrom: after
						to: after - 1
						with: #(1).
			allText ifNotNil: 
					[dict at: #allText
						put: (allText 
								copyReplaceFrom: after - 1
								to: after - 2
								with: #(#())).
					dict at: #allTextUrls
						put: (allTextUrls 
								copyReplaceFrom: after - 1
								to: after - 2
								with: #(#()))].
			index := after].
	remote at: index put: aPage sqkPage copyForSaving.
	(dict at: #modTime ifAbsent: [0]) < Time totalSeconds 
		ifTrue: [dict at: #modTime put: Time totalSeconds].
	allText ifNotNil: 
			[(dict at: #allText) at: index - 1 put: (aPage allStringsAfter: nil).
			(dict at: #allTextUrls) at: index - 1 put: pageURL].
	sf := ServerDirectory new fullPath: mine.
	Cursor wait showWhile: 
			[remoteFile := sf fileNamed: mine.
			remoteFile fileOutClass: nil andObject: remote
			"remoteFile close"]! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:16' prior: 34156850!
saveIndexOfOnly: aPage
	"Modify the index of this book on a server.  Read the index, modify the entry for just this page, and write back.  See saveIndexOnURL. (page file names must be unique even if they live in different directories.)"

	| mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName |
	mine _ self valueOfProperty: #url.
	mine ifNil: [^ self saveIndexOnURL].
	Cursor wait showWhile: [strm _ (ServerFile new fullPath: mine)].
	strm ifNil: [^ self saveIndexOnURL].
	strm class == String ifTrue: [^ self saveIndexOnURL].
	strm exists ifFalse: [^ self saveIndexOnURL].	"write whole thing if missing"
	strm _ strm asStream.
	strm class == String ifTrue: [^ self saveIndexOnURL].
	remote _ strm fileInObjectAndCode.
	dict _ remote 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' prior: 18482661!
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 2/21/2003 23:13' prior: 18484235!
saveOnUrlPage: pageMorph 
	"Write out this single page in this book onto a server.  See savePagesOnURL.  (Don't compute the texts, only this page's is written.)"

	| stem ind response rand newPlace dir |
	(self valueOfProperty: #keepTogether) ifNotNil: 
			[self 
				inform: 'This book is marked ''keep in one file''. 
Several pages use a common Player.
Save the owner of the book instead.'.
			^self].
	"Don't give the chance to put in a different place.  Assume named by number"
	((self valueOfProperty: #url) isNil and: [pages first url notNil]) 
		ifTrue: 
			[response := (PopUpMenu 
						labels: 'Old book\New book sharing old pages' withCRs) 
							startUpWithCaption: 'Modify the old book, or make a new\book sharing its pages?' 
									withCRs.
			response = 2 
				ifTrue: 
					["Make up new url for .bo file and confirm with user."

					"Mark as shared"

					
					[rand := String new: 4.
					1 to: rand size
						do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
					(newPlace := self getStemUrl) 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?'].
	pageMorph isInMemory 
		ifTrue: 
			["not out now"

			pageMorph saveOnURL: stem , ind printString , '.sp'].
	self saveIndexOfOnly: pageMorph! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:18' prior: 34163998!
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: 'dgd 2/21/2003 23:13' prior: 18486104!
savePagesOnURL
	"Write out all pages in this book onto a server.  For any page that does not have a SqueakPage and a url already, ask the user for one.  Give the option of naming all page files by page number.  Any pages that are not in memory will stay that way.  The local disk could be the server."

	| response list firstTime newPlace rand dir bookUrl |
	(self valueOfProperty: #keepTogether) ifNotNil: 
			[self 
				inform: 'This book is marked ''keep in one file''. 
Several pages use a common Player.
Save the owner of the book instead.'.
			^self].
	self getAllText.	"stored with index later"
	response := (PopUpMenu 
				labels: 'Use page numbers\Type in file names\Save in a new place (using page numbers)\Save in a new place (typing names)\Save new book sharing old pages' 
						withCRs) 
					startUpWithCaption: 'Each page will be a file on the server.  \Do you want to page numbers be the names of the files? \or name each one yourself?' 
							withCRs.
	response = 1 
		ifTrue: 
			[self saveAsNumberedURLs.
			^self].
	response = 3 
		ifTrue: 
			[self
				forgetURLs;
				saveAsNumberedURLs.
			^self].
	response = 4 ifTrue: [self forgetURLs].
	response = 5 
		ifTrue: 
			["Make up new url for .bo file and confirm with user."

			"Mark as shared"

			
			[rand := String new: 4.
			1 to: rand size
				do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
			(newPlace := self getStemUrl) 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: 'dgd 10/26/2003 13:20' prior: 34167406!
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: 'dgd 2/21/2003 23:13' prior: 18489589!
textSearch
	"search the text on all pages of this book"

	| wanted wants list str |
	list := self valueOfProperty: #searchKey ifAbsent: [#()].
	str := String streamContents: 
					[:strm | 
					list do: 
							[:each | 
							strm
								nextPutAll: each;
								space]].
	wanted := FillInTheBlank 
				request: 'words to search for.  Order is not important.
Beginnings of words are OK.'
				initialAnswer: str.
	wants := wanted findTokens: Character separators.
	wants 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 10/26/2003 12:58' prior: 34173284!
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' prior: 18490220!
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: '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: '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' prior: 18452298!
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: 'sw 11/8/2002 13:07'!
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 == nil) or: [newPage == currentPage])
			ifTrue: [nil]
			ifFalse: [oldPageIndex < pageIndex].

	tSpec _ transitionSpec ifNil:  "If transition not specified by requestor..."
		[newPage valueOfProperty: #transitionSpec  " ... then consult new page"
			ifAbsent: [self transitionSpecFor: self  " ... otherwise this is the default"]].

	self flag: #arNote. "Probably unnecessary"
	(aWorld _ self world) ifNotNil:
		[self primaryHand releaseKeyboardFocus].

	currentPage ifNotNil: [currentPage updateCachedThumbnail].
	self currentPage ~~ nil
		ifTrue:
		[(((pages at: pageIndex) owner isKindOf: TransitionMorph)
			and: [(pages at: pageIndex) isInWorld])
			ifTrue: [^ self  "In the process of a prior pageTurn"].
		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/22/2003 18:49' prior: 34179268!
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' prior: 18455200!
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: 'dgd 2/21/2003 23:11' prior: 18455968!
nextPage
	currentPage isNil ifTrue: [^self goToPage: 1].
	self goToPage: (self pageNumberOf: currentPage) + 1! !

!BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:11' prior: 18456268!
previousPage
	currentPage isNil ifTrue: [^self goToPage: 1].
	self goToPage: (self pageNumberOf: currentPage) - 1! !

!BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 13:55' prior: 18492236!
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: '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 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: '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: 'dgd 2/21/2003 23:11' prior: 18496535!
printPSToFile
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName := 'MyBook' asFileName.
	fileName := FillInTheBlank 
				request: 'File name? (".ps" will be added to end)'
				initialAnswer: fileName.
	fileName isEmpty ifTrue: [^self beep].
	(fileName endsWith: '.ps') ifFalse: [fileName := fileName , '.ps'].
	rotateFlag := ((PopUpMenu labels: 'portrait (tall)
landscape (wide)') 
				startUpWithCaption: 'Choose orientation...') = 2.
	(FileStream newFileNamed: fileName)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag);
		close! !

!BookMorph methodsFor: 'printing' stamp: 'md 10/22/2003 16:10' prior: 34189992!
printPSToFile
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName := 'MyBook' asFileName.
	fileName := FillInTheBlank 
				request: 'File name? (".ps" will be added to end)'
				initialAnswer: fileName.
	fileName isEmpty ifTrue: [^Beeper beep].
	(fileName endsWith: '.ps') ifFalse: [fileName := fileName , '.ps'].
	rotateFlag := ((PopUpMenu labels: 'portrait (tall)
landscape (wide)') 
				startUpWithCaption: 'Choose orientation...') = 2.
	(FileStream newFileNamed: fileName)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag);
		close! !

!BookMorph methodsFor: 'printing' stamp: 'sd 11/13/2003 21:04' prior: 34190691!
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)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close.

! !

!BookMorph methodsFor: 'printing' stamp: 'nk 12/30/2003 16:40' prior: 34191392!
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)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close.

! !

!BookMorph methodsFor: 'sorting' stamp: 'dgd 2/21/2003 23:09' prior: 18442227!
acceptSortedContentsFrom: aHolder 
	"Update my page list from the given page sorter."

	| goodPages rejects toAdd sqPage |
	goodPages := OrderedCollection new.
	rejects := OrderedCollection new.
	aHolder submorphs doWithIndex: 
			[:m :i | 
			toAdd := nil.
			(m isKindOf: PasteUpMorph) ifTrue: [toAdd := m].
			(m isKindOf: BookPageThumbnailMorph) 
				ifTrue: 
					[toAdd := m page.
					m bookMorph == self 
						ifFalse: 
							["borrowed from another book. preserve the original"

							toAdd := toAdd veryDeepCopy.

							"since we came from elsewhere, cached strings are wrong"
							self removeProperty: #allTextUrls.
							self removeProperty: #allText]].
			toAdd class == String 
				ifTrue: 
					["a url"

					toAdd := pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]].
			toAdd class == String 
				ifTrue: 
					[sqPage := SqueakPageCache atURL: toAdd.
					toAdd := sqPage contentsMorph 
								ifNil: [sqPage copyForSaving	"a MorphObjectOut"]
								ifNotNil: [sqPage contentsMorph]].
			toAdd ifNil: [rejects add: m] ifNotNil: [goodPages add: toAdd]].
	self newPages: goodPages.
	goodPages isEmpty ifTrue: [self insertPage].
	rejects notEmpty 
		ifTrue: 
			[self 
				inform: rejects size printString , ' objects vanished in this process.']! !

!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 class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 17:37'!
initialize

	FileList registerFileReader: self! !

!BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:31' prior: 34195557!
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: 'SD 11/15/2001 22:20'!
unload

	FileList unregisterFileReader: self ! !

!BookMorph class methodsFor: 'initialize-release' stamp: 'asm 4/11/2003 12:31' prior: 34198270!
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 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:))))! !

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

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:27'!
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';	actionSelector: #acceptSort)).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (self wrapperFor: (bb label: 'Cancel';	actionSelector: #delete)).

	r addTransparentSpacerOfSize: 8 @ 0.
	r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)).
	aButton
		target: self;
		actionSelector: #togglePartsBinStatus;
		arguments: #();
		getSelector: #getPartsBinStatus.
	str _ StringMorph contents: 'Parts bin'.
	r addMorphBack: (self wrapperFor: str lock).

	self addMorphFront: r.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:21' prior: 34200278!
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: 'dgd 2/17/2003 19:56' prior: 18505568!
changeExtent: aPoint 
	self extent: aPoint.
	pageHolder extent: self extent - self borderWidth! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/14/2001 13:38'!
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'; actionSelector: #delete).
	self addMorphFront: r.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:22' prior: 34202515!
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: '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: 'RAA 5/25/2001 17:58'!
initialize

	super initialize.
	self extent: Display extent - 100;
		listDirection: #topToBottom;
		wrapCentering: #topLeft;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 3;
		color: Color lightGray;
		borderWidth: 2.
	pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent - borderWidth.
	pageHolder hResizing: #shrinkWrap.
	"pageHolder cursor: 0."		"causes a walkback as of 5/25/2000"
	self addControls.
	self addMorphBack: pageHolder.
! !

!BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:56' prior: 34204010!
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! !

!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: 'dgd 2/21/2003 23:07' prior: 18508964!
objectForDataStream: refStrm 
	"I am about to be written on an object file.  It would be bad to write a whole BookMorph out.  Store a string that is the url of the book or page in my inst var."

	| clone bookUrl bb stem ind |
	bookMorph class == String & (page class == String) 
		ifTrue: [^super objectForDataStream: refStrm].
	bookMorph isNil & (page class == String) 
		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'
			"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: 'dgd 10/26/2003 13:23' prior: 34205450!
objectForDataStream: refStrm
	"I am about to be written on an object file.  It would be bad to write a whole BookMorph out.  Store a string that is the url of the book or page in my inst var."

	| clone bookUrl bb stem ind |
	(bookMorph class == String) & (page class == String) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph isNil) & (page class == String) 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: 'dgd 2/21/2003 23:07' prior: 18510460!
objectsInMemory
	"See if page or bookMorph need to be brought in from a server."

	| bookUrl bk wld try |
	bookMorph ifNil: 
			["fetch the page"

			page class == String ifFalse: [^self].	"a morph"
			try := (SqueakPageCache atURL: page) fetchContents.
			try ifNotNil: [page := try].
			^self].
	bookMorph class == String 
		ifTrue: 
			[bookUrl := bookMorph.
			(wld := self world) ifNil: [wld := Smalltalk currentWorld].
			bk := BookMorph isInWorld: wld withUrl: bookUrl.
			bk == #conflict 
				ifTrue: [^self inform: 'This book is already open in some other project'].
			bk == #out ifTrue: [(bk := BookMorph new fromURL: bookUrl) ifNil: [^self]].
			bookMorph := bk].
	page class == String 
		ifTrue: 
			[page := bookMorph pages detect: [:pg | pg url = page]
						ifNone: [bookMorph pages first]]! !

!BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 10/26/2003 13:23' prior: 34208481!
objectsInMemory
	"See if page or bookMorph need to be brought in from a server."
	| bookUrl bk wld try |
	bookMorph ifNil: ["fetch the page"
		page class == String ifFalse: [^ self].	"a morph"
		try _ (SqueakPageCache atURL: page) fetchContents.
		try ifNotNil: [page _ try].
		^ self].
	bookMorph class == String ifTrue: [
		bookUrl _ bookMorph.
		(wld _ self world) ifNil: [wld _ Smalltalk currentWorld].
		bk _ BookMorph isInWorld: wld withUrl: bookUrl.
		bk == #conflict ifTrue: [
			^ self inform: 'This book is already open in some other project' translated].
		bk == #out ifTrue: [
			(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]].
		bookMorph _ bk].
	page class == String ifTrue: [
		page _ (bookMorph pages detect: [:pg | pg url = page] 
					ifNone: [bookMorph pages 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' prior: 18514735!
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' prior: 18512334!
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:]
! !

!BooklikeMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 21:13' prior: 18523107!
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: 'gk 2/24/2004 08:27' prior: 18523990!
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' prior: 18524325!
showingFullScreenString
	^ (self isInFullScreenMode
		ifTrue: ['exit full screen']
		ifFalse: ['show full screen']) translated! !

!BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04' prior: 18524512!
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: 'dgd 9/19/2003 11:34' prior: 18518227!
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 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' prior: 18520394!
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: 'dgd 2/22/2003 14:14' prior: 18520883!
showPageControls: controlSpecs 
	| spacer pageControls anIndex |
	self hidePageControls.
	anIndex := (submorphs notEmpty and: [submorphs first hasProperty: #header]) 
				ifTrue: [2]
				ifFalse: [1].
	spacer := (Morph new)
				color: color;
				extent: 0 @ 10.
	spacer setProperty: #pageControl toValue: true.
	self privateAddMorph: spacer atIndex: anIndex.
	pageControls := self makePageControlsFrom: controlSpecs.
	pageControls
		borderWidth: 0;
		layoutInset: 4.
	pageControls setProperty: #pageControl toValue: true.
	pageControls setNameTo: 'Page Controls'.
	pageControls eventHandler: (EventHandler new 
				on: #mouseDown
				send: #move
				to: self).
	self privateAddMorph: pageControls beSticky atIndex: anIndex! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 13:58' prior: 34215962!
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! !

!Boolean methodsFor: 'logical operations' stamp: 'hg 1/2/2002 13:57'!
==> aBlock
	"this is logical implicature, a ==> b, also known as b iff a (if and only if)"

	^self not or: [aBlock value]! !

!Boolean methodsFor: 'logical operations' stamp: 'PH 10/3/2003 08:10' prior: 34217490!
==> 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: 'controlling' stamp: 'di 12/5/2001 10:50'!
and: block1 and: block2
	"Nonevaluating conjunction without deep nesting.
	The reciever 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' prior: 34218331!
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: 'di 12/5/2001 10:49'!
and: block1 and: block2 and: block3
	"Nonevaluating conjunction without deep nesting.
	The reciever 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' prior: 34219256!
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: 'di 12/5/2001 10:49'!
and: block1 and: block2 and: block3 and: block4
	"Nonevaluating conjunction without deep nesting.
	The reciever 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' stamp: 'zz 3/2/2004 23:44' prior: 34220273!
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' stamp: 'di 12/5/2001 10:52'!
or: block1 or: block2
	"Nonevaluating alternation without deep nesting.
	The reciever 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' prior: 34221382!
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: 'di 12/5/2001 10:52'!
or: block1 or: block2 or: block3
	"Nonevaluating alternation without deep nesting.
	The reciever 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' prior: 34222293!
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: 'di 12/5/2001 10:52'!
or: block1 or: block2 or: block3 or: block4
	"Nonevaluating alternation without deep nesting.
	The reciever 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: 'zz 3/2/2004 23:45' prior: 34223290!
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: 'printing' stamp: 'sw 9/27/2001 17:19'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Boolean! !

!BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'sw 6/3/2002 18:00'!
wantsDroppedMorph: aMorph event: evt
	"Answer whether the receiver would be interested in accepting the morph"

	(submorphs detect: [:m | m isKindOf: AlignmentMorph] ifNone: [nil])
		ifNotNil: [^ false]. 
	^ (aMorph isKindOf: PhraseTileMorph) and: [(#(Command Unknown) includes: aMorph resultType capitalized) not]
! !

!BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 13:14' prior: 34224544!
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: PhraseTileMorph) 
		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' prior: 18531277!
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"! !

!BooleanTest methodsFor: 'testing-printing' stamp: 'md 3/5/2003 00:43'!
testBasicType
	self
		should: [true basicType = #Boolean].
	self
		should: [false basicType = #Boolean].! !

!BooleanTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:29'!
testBooleanInitializedInstance
	self should:[Boolean initializedInstance = nil].! !

!BooleanTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:52'!
testBooleanNew
	self should: [Boolean new] raise: TestResult error. 
	self should: [True new] raise: TestResult error. 
	self should: [False new] raise: TestResult error. ! !

!BooleanTest methodsFor: 'testing' stamp: 'md 3/25/2003 23:09'!
testNew
	self should: [Boolean new] raise: TestResult error. ! !

!BooleanTest methodsFor: 'testing-misc' stamp: 'md 3/6/2003 15:22'!
testNewTileMorphRepresentative
 self should: [false newTileMorphRepresentative isKindOf: TileMorph].
 self should: [false newTileMorphRepresentative literal = false].
 self should: [true newTileMorphRepresentative literal = true].! !

!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
!
!BooleanTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:19'!
resultType
	"Answer the result type of the receiver"

	^ #Boolean! !

!BooleanType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:20'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ true newTileMorphRepresentative typeColor: self typeColor! !

!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: '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)! !

!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: 'ar 8/25/2001 17:05'!
framePolyline: vertices on: aCanvas
	"Frame the given rectangle on aCanvas"
	| prev next |
	prev _ vertices at: 1.
	2 to: vertices size do:[:i|
		next _ vertices at: i.
		self drawLineFrom: prev to: next on: aCanvas.
		prev _ next].! !

!BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59' prior: 34230668!
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 commentStamp: 'kfr 10/27/2003 10:19' prior: 0!
See BorderedMorph

BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.!
!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: 'sw 11/26/2001 15:58'!
borderStyleForSymbol: sym
	"Answer a border style corresponding to the given symbol"

	| aSymbol |
	aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym].
	^ self perform: aSymbol! !

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

!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: 'ar 11/26/2001 15:04'!
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 "#raised/#inset etc" or:[
			#simple == style style and:[borderColor = style color]]]) ifFalse:[
		borderColor isColor
			ifTrue:[style _ BorderStyle width: borderWidth color: borderColor]
			ifFalse:[style _ (BorderStyle perform: borderColor "argh.") width: borderWidth].
		self setProperty: #borderStyle toValue: style.
	].
	^style trackColorFrom: self! !

!BorderedMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:19' prior: 34234614!
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: 'ar 12/11/2001 22:14'!
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 == nil or:[aBorderStyle == BorderStyle default]) ifTrue:[
		self removeProperty: #borderStyle.
		borderWidth _ 0.
		^self changed].
	self setProperty: #borderStyle toValue: aBorderStyle.
	borderWidth _ aBorderStyle width.
	aBorderStyle style == #simple 
		ifTrue:[borderColor _ aBorderStyle color]
		ifFalse:[borderColor _ aBorderStyle style].
	self changed.
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42' prior: 34236186!
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: 'drawing' stamp: 'dgd 2/17/2003 19:57' prior: 18535398!
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: 'initialization' stamp: 'sw 8/12/2001 02:11'!
basicInitialize
	"Do basic generic initialization of the instance variables"

	super basicInitialize.
	borderColor _ Color black.
	borderWidth _ 2! !

!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00' prior: 34239188!
basicInitialize
	"Do basic generic initialization of the instance variables"
	super basicInitialize.
""
	self borderInitialize! !

!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,f2c148046000,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' prior: 18532829!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	self borderInitialize! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:20'!
addBorderStyleMenuItems: aMenu hand: aHandMorph
	"Add border-style menu items"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu addTitle: 'border'.
	subMenu addStayUpItemSpecial.
	subMenu addList: 
		#(('border color...' changeBorderColor:)
		('border width...' changeBorderWidth:)).
	subMenu addLine.
	BorderStyle borderStyleChoices do:
		[:sym | (self borderStyleForSymbol: sym)
			ifNotNil:
				[subMenu add: sym target: self selector: #setBorderStyle: argument: sym]].
	aMenu add: 'border style...' subMenu: subMenu
! !

!BorderedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:47' prior: 34240469!
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 target: self selector: #setBorderStyle: argument: sym]].
	aMenu add: 'border style...' translated subMenu: subMenu
! !

!BorderedMorph methodsFor: 'menu' stamp: 'dgd 8/26/2003 21:44' prior: 18539060!
changeBorderWidth: evt
	| handle origin aHand newWidth oldWidth |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	oldWidth _ borderWidth.
	handle _ HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			newWidth _ (newPoint - origin) r asInteger // 5.
			self borderWidth: newWidth]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo doIfNotNil: [:halo | halo addHandles].
			self rememberCommand:
				(Command new cmdWording: 'border change' 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.' hand: evt hand.
	handle startStepping! !

!BorderedMorph methodsFor: 'menu' stamp: 'md 12/12/2003 16:21' prior: 34241767!
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.' hand: evt hand.
	handle startStepping! !

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


!
!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: 'ar 12/12/2001 03:03'!
initialize
	super initialize.
	self borderStyle: (SimpleBorder width: 1 color: Color white).! !

!BorderedStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 34245446!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self
		borderStyle: (SimpleBorder width: 1 color: Color white)! !

!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: 'ar 8/15/2001 23:24'!
initialize

	super initialize.
	self extent: 1@1;
		color: Color black;
		borderWidth: 0.! !

!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09' prior: 34247428!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	self extent: 1 @ 1! !

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

!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' prior: 18541805!
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' prior: 18542093!
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: 'other' stamp: 'aoy 2/15/2003 21:38' prior: 18544695!
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: 'dgd 2/22/2003 13:36' prior: 18547904!
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 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'! !

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

!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".!
!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 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: 'emm 4/24/2002 23:24'!
unInstall: breakMethod 

	| who oldMethod |
	oldMethod _ self installed at: breakMethod ifAbsent:[^self].
	who _ breakMethod who.
	(who first methodDictionary at: who last) == breakMethod
		ifTrue:[	who first methodDictionary at: who last put: oldMethod].
	self installed removeKey: breakMethod! !

!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: 'emm 5/30/2002 09:33'!
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: #(0 0 0 0).
	^method! !

!BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'!
installed
	Installed isNil ifTrue:[Installed := IdentityDictionary new].
	^Installed! !

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

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

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

!Browser methodsFor: 'accessing' stamp: 'sw 8/1/2002 14:20'!
contents
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information. This information is the
	method of the currently selected class and message."

	| comment theClass latestCompiledMethod |
	latestCompiledMethod _ currentCompiledMethod.
	currentCompiledMethod _ nil.

	editSelection == #none ifTrue: [^ ''].
	editSelection == #editSystemCategories 
		ifTrue: [^ systemOrganizer printString].
	editSelection == #newClass 
		ifTrue: [^ (theClass _ self selectedClass)
			ifNil:
				[Class template: self selectedSystemCategoryName]
			ifNotNil:
				[Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]].
	editSelection == #editClass 
		ifTrue:
			[^ (theClass _ self selectedClassOrMetaClass)
				ifNil:
					['']
				ifNotNil:
			 		[theClass definitionST80: Preferences printAlternateSyntax not]].
	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 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: 'ls 10/28/2003 12:28' prior: 34260927!
contents
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information. This information is the
	method of the currently selected class and message."

	| comment theClass latestCompiledMethod |
	latestCompiledMethod _ currentCompiledMethod.
	currentCompiledMethod _ nil.

	editSelection == #none ifTrue: [^ ''].
	editSelection == #editSystemCategories 
		ifTrue: [^ systemOrganizer printString].
	editSelection == #newClass 
		ifTrue: [^ (theClass _ self selectedClass)
			ifNil:
				[Class template: self selectedSystemCategoryName]
			ifNotNil:
				[Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]].
	editSelection == #editClass 
		ifTrue:
			[^ self 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 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: 'sw 5/23/2001 12:37'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be
	 updated. The information can be a variety of things, depending on
	 the list selections (such as templates for class or message definition,
	 methods) or the user menu commands (such as definition, comment,
	 hierarchy).  Answer the result of updating the source."

	| aString aText theClass |
	self changed: #annotation.
	aString _ input asString.
	aText _ input asText.
	editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController].
	editSelection == #editComment
		ifTrue: 
			[theClass _ self selectedClass.
			theClass
				ifNil: 
					[self inform: 'You must select a class
before giving it a comment.'.
					^ false].
			theClass comment: aText stamp: Utilities changeStamp.
			^ true].
	editSelection == #hierarchy ifTrue: [^ true].
	editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString].
	editSelection == #editMessage | (editSelection == #newMessage)
		ifTrue:
			[^ self okayToAccept
				ifFalse:
					[false]
				ifTrue:
					[self compileMessage: aText notifying: aController]].
	editSelection == #none
		ifTrue: 
			[self inform: 'This text cannot be accepted
in this part of the browser.'.
			^ false].
	self error: 'unacceptable accept'! !

!Browser methodsFor: 'accessing' stamp: 'nk 3/29/2004 10:11' prior: 34264496!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be
	 updated. The information can be a variety of things, depending on
	 the list selections (such as templates for class or message definition,
	 methods) or the user menu commands (such as definition, comment,
	 hierarchy).  Answer the result of updating the source."

	| aString aText theClass |
	self changed: #annotation.
	aString _ input asString.
	aText _ input asText.
	editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController].
	editSelection == #editComment
		ifTrue: 
			[theClass _ self selectedClass.
			theClass
				ifNil: 
					[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: 'drs 1/6/2003 16:11' prior: 18557776!
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: 'nk 2/15/2004 13:27' prior: 18559030!
editSelection: aSelection
	"Set the editSelection as requested."

	editSelection _ aSelection.
	self changed: #editSelection.! !

!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: 'sw 8/26/2002 10:00'!
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: 'nk 2/15/2004 13:19'!
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 classComment: aText].
	self changed: #classCommentText.
	^ true! !

!Browser methodsFor: 'class functions' stamp: 'sd 5/23/2003 14:23' prior: 18560657!
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' stamp: 'nk 2/14/2004 14:32'!
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: [ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red ]! !

!Browser methodsFor: 'class functions' stamp: 'ls 10/28/2003 12:34'!
classDefinitionText
	"return the text to display for the definition of the currently selected class"
	| theClass |
	theClass _ self selectedClassOrMetaClass.
	theClass ifNil: [ ^''].

	^Text streamContents: [ :str |
		str nextPutAll: (theClass definitionST80: Preferences printAlternateSyntax not).
		str cr; cr.
		theClass hasComment
			ifTrue: [ 
				str nextPutAll: '"Class comment:"'; cr.

				"ideally, this should avoid the asString, so that the text attributes are nice"
				str nextPutAll: theClass comment asString asSmalltalkComment ]
			ifFalse: [
				str withAttribute: TextColor red do: [
					str nextPutAll: '"THIS CLASS HAS NO COMMENT!!"' ] ] ].
! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:11' prior: 34271843!
classDefinitionText
	"return the text to display for the definition of the currently selected class"
	| theClass |
	theClass _ self selectedClassOrMetaClass.
	theClass ifNil: [ ^''].

	^theClass definitionST80: Preferences printAlternateSyntax not! !

!Browser methodsFor: 'class functions' stamp: 'sw 2/27/2001 12:06'!
classListMenu: aMenu shifted: shifted
	"Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"

	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)
		-
		('more...'					offerShiftedClassListMenu)).
	^ aMenu! !

!Browser methodsFor: 'class functions' stamp: 'sw 10/22/2002 16:10'!
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: 'bf 10/19/2000 11:39'!
defineClass: defString notifying: aController  
	"The receiver's textual content is a request to define a new class. The
	source code is defString. If any errors occur in compilation, notify
	aController."
	| oldClass class newClassName defTokens keywdIx envt |
	oldClass _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $').
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass name asString ~= newClassName])
		and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue:
			["Attempting to define new class over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
				ifFalse: [^ false]].
	"ar 8/29/1999: Use oldClass superclass for defining oldClass
	since oldClass superclass knows the definerClass of oldClass."
	oldClass ifNotNil:[oldClass _ oldClass superclass].
	class _ oldClass subclassDefinerClass
				evaluate: defString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: [self changed: #classList.
				self classListIndex: 
					(self classList indexOf: 
						((class isKindOf: Metaclass)
							ifTrue: [class soleInstance name]
							ifFalse: [class name])).
				self clearUserEditFlag; editClass.
				^ true]
		ifFalse: [^ false]! !

!Browser methodsFor: 'class functions' stamp: 'ls 10/9/2003 11:56' prior: 34274808!
defineClass: defString notifying: aController  
	"The receiver's textual content is a request to define a new class. The
	source code is defString. If any errors occur in compilation, notify
	aController."
	| oldClass class newClassName defTokens keywdIx envt |
	oldClass _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $').
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass name asString ~= newClassName])
		and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue:
			["Attempting to define new class over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
				ifFalse: [^ false]].
	"ar 8/29/1999: Use oldClass superclass for defining oldClass
	since oldClass superclass knows the definerClass of oldClass."
	oldClass ifNotNil:[oldClass _ oldClass superclass].
	class _ oldClass subclassDefinerClass
				evaluate: defString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: [self changed: #systemCategoryList.
				self changed: #classList.
				self clearUserEditFlag.
				self setClass: class selector: nil.
				"self clearUserEditFlag; editClass."
				^ true]
		ifFalse: [^ false]! !

!Browser methodsFor: 'class functions' stamp: 'sw 11/21/2003 21:45' prior: 34276598!
defineClass: defString notifying: aController  
	"The receiver's textual content is a request to define a new class. The
	source code is defString. If any errors occur in compilation, notify
	aController."
	| oldClass class newClassName defTokens keywdIx envt |
	oldClass _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $').
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName])
		and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue:
			["Attempting to define new class over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
				ifFalse: [^ false]].
	"ar 8/29/1999: Use oldClass superclass for defining oldClass
	since oldClass superclass knows the definerClass of oldClass."
	oldClass ifNotNil:[oldClass _ oldClass superclass].
	class _ oldClass subclassDefinerClass
				evaluate: defString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: [self changed: #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' prior: 18565762!
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: 'sw 11/22/2002 17:50'!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editComment.
	metaClassIndicated _ false.
	self changed: #classSelectionChanged.
	self decorateButtons.
	self contentsChanged! !

!Browser methodsFor: 'class functions' stamp: 'asm 7/9/2003 17:28' prior: 34280423!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	metaClassIndicated _ false.
	editSelection _ #editComment.
	self changed: #classSelectionChanged.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self decorateButtons.
	self contentsChanged
! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:08' prior: 34280827!
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: 'nb 5/6/2003 16:49' prior: 18566399!
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: 'je 12/4/2002 18:10'!
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: 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' prior: 18569305!
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' prior: 18569657!
makeNewSubclass

	self selectedClassOrMetaClass ifNil: [^ self].
	self okToChange ifFalse: [^ self].
	self editSelection: #newClass.
	self contentsChanged! !

!Browser methodsFor: 'class functions' stamp: 'sw 11/22/2002 17:49'!
plusButtonHit
	"Cycle among definition, comment, and hierachy"

	editSelection == #editComment
		ifTrue: [self hierarchy. ^ self].
	editSelection == #hierarchy
		ifTrue: [editSelection := #editClass.
			classListIndex = 0 ifTrue: [^ self].
			self okToChange ifFalse: [^ self].
			self changed: #editComment.
			self contentsChanged.
			^ self].
	self editComment! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09' prior: 34284725!
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: '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: 'RAA 5/28/2001 13:38'!
renameClass
	| oldName newName obs |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ self request: 'Please type new class name' initialAnswer: oldName.
	newName = '' ifTrue: [^ self].  " Cancel returns '' "
	newName _ newName asSymbol.
	newName = oldName ifTrue: [^ self].
	(Smalltalk includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self selectedClass rename: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
	obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName).
	obs isEmpty ifFalse: [
		Smalltalk 
			browseMessageList: obs
			name: 'Obsolete References to ' , oldName
			autoSelect: oldName
	].
! !

!Browser methodsFor: 'class functions' stamp: 'sd 4/16/2003 08:51' prior: 34285815!
renameClass
	| oldName newName obs |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ self request: 'Please type new class name' initialAnswer: oldName.
	newName = '' ifTrue: [^ self].  " Cancel returns '' "
	newName _ newName asSymbol.
	newName = oldName ifTrue: [^ self].
	(Smalltalk includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self selectedClass rename: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
	obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName).
	obs isEmpty ifFalse: [
		self systemNavigation 
			browseMessageList: obs
			name: 'Obsolete References to ' , oldName
			autoSelect: oldName
	].
! !

!Browser methodsFor: 'class functions' stamp: 'sd 4/29/2003 11:49' prior: 34286716!
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: 'sw 10/16/2002 15:41'!
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')
			-
			('fetch documentation'		fetchClassDocPane		'once, and maybe again someday, fetch up-to-date documentation for this class from the Squeak documentation repository')
			('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' stamp: 'nk 2/13/2001 13:26'!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."

	| className |
	classListIndex _ anInteger.
	self setClassOrganizer.
	messageCategoryListIndex _ 1.
	messageListIndex _ 0.
	self classCommentIndicated
		ifTrue: []
		ifFalse: [editSelection _ anInteger = 0
					ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0)
						ifTrue: [#none]
						ifFalse: [#newClass]]
					ifFalse: [#editClass]].
	contents _ nil.
	self selectedClass isNil
		ifFalse: [className _ self selectedClass name.
					(RecentClasses includes: className)
				ifTrue: [RecentClasses remove: className].
			RecentClasses addFirst: className.
			RecentClasses size > 16
				ifTrue: [RecentClasses removeLast]].
	self changed: #classSelectionChanged.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #relabel.
	self contentsChanged! !

!Browser methodsFor: 'class list' stamp: 'drs 1/5/2003 20:14' prior: 34290178!
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: [editSelection _ anInteger = 0
					ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0)
						ifTrue: [#none]
						ifFalse: [#newClass]]
					ifFalse: [#editClass]].
	contents _ nil.
	self selectedClass isNil
		ifFalse: [className _ self selectedClass name.
					(RecentClasses includes: className)
				ifTrue: [RecentClasses remove: className].
			RecentClasses addFirst: className.
			RecentClasses size > 16
				ifTrue: [RecentClasses removeLast]].
	self changed: #classSelectionChanged.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #relabel.
	self contentsChanged! !

!Browser methodsFor: 'class list' stamp: 'nk 2/14/2004 15:07' prior: 34291197!
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: 'nb 6/17/2003 12:25' prior: 18573954!
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: 'code pane' stamp: 'drs 1/29/2003 14:13' prior: 18575610!
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 == nil
		ifTrue:
			[ self selectOriginalCategoryForCurrentMethod ].

	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: 'asm 6/25/2003 22:48' prior: 34293916!
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: 'drag and drop' stamp: 'NS 4/7/2004 13:27' prior: 18578673!
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 srcClass srcSelector srcCategory |
	success _ false.
	srcType _ transferMorph dragTransferType.
	srcBrowser _ transferMorph source model.
	srcClass _ transferMorph passenger key.
	srcSelector _ transferMorph passenger value.
	srcCategory _ srcBrowser selectedMessageCategoryName.
	srcCategory ifNil: [srcCategory _ srcClass organization categoryOfElement: srcSelector].
	srcType == #messageList ifTrue: [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: 'nk 6/12/2004 17:43' prior: 34298084!
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: 'nk 2/14/2004 20:49' prior: 18583961!
dragPassengerFor: item inMorph: dragSource 
	| transferType |
	(dragSource isKindOf: PluggableListMorph)
		ifFalse: [^item].
	transferType _ self dragTransferTypeForMorph: dragSource.
	transferType == #messageList
		ifTrue: [^self selectedClassOrMetaClass-> self selectedMessageName ].
	transferType == #classList
		ifTrue: [^self selectedClass].
	^item contents! !

!Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:32' prior: 34300521!
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: 'ls 6/22/2001 23:21' prior: 18584576!
dstCategoryDstListMorph: dstListMorph
	^(dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [dstListMorph potentialDropItem ]
		ifFalse: [self selectedSystemCategoryName]! !

!Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:20' prior: 18584890!
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: 'ls 6/22/2001 23:19' prior: 18585236!
dstMessageCategoryDstListMorph: dstListMorph
	| dropItem |
	^dstListMorph getListSelector == #messageCategoryList
		ifTrue: 
			[dropItem _ dstListMorph potentialDropItem.
			dropItem ifNotNil: [dropItem asSymbol]]
		ifFalse: [self selectedMessageCategoryName]! !

!Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:16' prior: 34302118!
dstMessageCategoryDstListMorph: dstListMorph
	| dropItem |
	^dstListMorph getListSelector == #messageCategoryList
		ifTrue: 
			[dropItem _ dstListMorph potentialDropItem.
			dropItem ifNotNil: [dropItem asSymbol]]
		ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 8/15/2001 23:28'!
addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset

	| row switchHeight divider |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		layoutPolicy: ProportionalLayout new.
	switchHeight _ 25.
	row 
		addMorph: aListPane
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@0 corner: 0@switchHeight negated)
		).	
	divider _ BorderedSubpaneDividerMorph forTopEdge.
	Preferences alternativeWindowLook ifTrue:[
		divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	].
	row 
		addMorph: divider
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@switchHeight negated corner: 0@(1-switchHeight))
		).	

	self 
		addMorphicSwitchesTo: row 
		at: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-switchHeight)  corner: 0@0)
		).

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

! !

!Browser methodsFor: 'initialize-release' stamp: 'sps 3/24/2004 11:50' prior: 34302832!
addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset

	| row switchHeight divider |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		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.
	Preferences alternativeWindowLook ifTrue:[
		divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	].
	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: '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' stamp: 'RAA 2/9/2001 16:36'!
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

! !

!Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:27' prior: 34305697!
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.
	^myClassList

! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:37'!
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: 'sw 6/5/2001 20:01'!
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: 'dew 3/8/2002 00:05'!
buildMorphicSwitches

	| instanceSwitch divider1 divider2 commentSwitch classSwitch row aColor |

	instanceSwitch _ PluggableButtonMorph
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	instanceSwitch
		label: 'instance';
		askBeforeChanging: true;
		borderWidth: 0.
	commentSwitch _ PluggableButtonMorph
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
	commentSwitch
		label: '?' asText allBold;
		askBeforeChanging: true;
		setBalloonText: 'class comment';
		borderWidth: 0.
	classSwitch _ PluggableButtonMorph
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	classSwitch
		label: 'class';
		askBeforeChanging: true;
		borderWidth: 0.
	divider1 := BorderedSubpaneDividerMorph vertical.
	divider2 := BorderedSubpaneDividerMorph vertical.
	Preferences alternativeWindowLook ifTrue:[
		divider1 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent.
		divider2 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent.
	].
	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		addMorphBack: instanceSwitch;
		addMorphBack: divider1;
		addMorphBack: commentSwitch;
		addMorphBack: divider2;
		addMorphBack: classSwitch.

	aColor _ Color colorFrom: self defaultBackgroundColor.
	row color: aColor duller.  "ensure matching button divider color. (see #paneColor)"
	Preferences alternativeWindowLook ifTrue:[aColor _ aColor muchLighter].
	{instanceSwitch. commentSwitch. classSwitch} do: [:m | 
		m 
			color: aColor;
			onColor: aColor twiceDarker offColor: aColor;
			hResizing: #spaceFill;
			vResizing: #spaceFill.
	].

	^ row
! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:34'!
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: 'nk 2/13/2001 13:25'!
labelString
	^self selectedClass ifNil: [ self defaultBrowserTitle ]
		ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClass printString ].
! !

!Browser methodsFor: 'initialize-release' stamp: 'sps 4/3/2004 19:38' prior: 18597523!
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: 'sps 4/3/2004 20:41' prior: 18598981!
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: 'dew 1/7/2002 02:07'!
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 hideScrollBarIndefinitely.
	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: 'nk 4/28/2004 10:17' prior: 34313412!
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: 'BG 10/21/2002 19:29'!
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 _ PluggableTextView on: self 
                        text: #contents accept: #contents:notifying:
                        readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        browserCodeView window: (0@0 extent: 200@y).
        topView addSubView: browserCodeView below: underPane.
        aString ifNotNil: [browserCodeView editString: aString.
                        browserCodeView hasUnacceptedEdits: true].
        topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList).

        ^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'BG 10/21/2002 19:29'!
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 _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	topView setUpdatablePanesFrom: #(classList messageCategoryList messageList).
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'avi 2/21/2004 12:25' prior: 18620406!
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:
			((SystemOrganization listAtCategoryNamed: self selectedSystemCategoryName )
					indexOf: aClass name).
	self metaClassIndicated: isMeta.
	aSymbol ifNil: [^ self].
	messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: messageCatIndex + 1. "<- FIXED offset"
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol)! !

!Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 23:23' prior: 34324181!
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: (
		(SystemOrganization 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: 'nk 2/14/2004 15:08' prior: 18622082!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super initialize.
	contents _ nil.
	systemOrganizer _ aSystemOrganizer.
	systemCategoryListIndex _ 0.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	metaClassIndicated _ false.
	self setClassOrganizer.
	self editSelection: #none! !

!Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 15:00' prior: 34326049!
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 5/23/2003 14:23' prior: 18624334!
alphabetizeMessageCategories
	classListIndex = 0 ifTrue: [^ false].
	self okToChange ifFalse: [^ false].
	ChangeSet current reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer sortCategories.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 12:53' prior: 34327131!
alphabetizeMessageCategories
	classListIndex = 0 ifTrue: [^ false].
	self okToChange ifFalse: [^ false].
	self classOrMetaClassOrganizer sortCategories.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47' prior: 34327538!
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' stamp: 'sd 1/5/2002 21:11'!
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 _ self class 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: 'nk 6/13/2004 07:21' prior: 34328286!
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: 'sw 2/22/2001 06:54'!
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: 'sd 5/23/2003 14:23' prior: 18626441!
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."

	ChangeSet current reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer changeFromString: aString.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 13:00' prior: 34330923!
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.
	SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56' prior: 34331646!
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' prior: 18627148!
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: 'emm 5/30/2002 09:20' prior: 18597062!
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: 'dew 9/20/2001 00:21'!
messageCategoryMenu: 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: 'nk 4/23/2004 09:18' prior: 18628824!
removeEmptyCategories
	self okToChange ifFalse: [^ self].
	self selectedClassOrMetaClass organization removeEmptyCategories.
	self changed: #messageCategoryList
! !

!Browser methodsFor: 'message category functions' stamp: 'sd 5/23/2003 14:23' prior: 18629895!
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].
	ChangeSet current reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex.
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 13:01' prior: 34334849!
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.
	SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass.
! !

!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 23:01' prior: 34335746!
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: 'sw 10/8/2001 15:08'!
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: 'nk 11/30/2002 08:20'!
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: 'drs 1/5/2003 19:12' prior: 18631428!
messageCategoryListIndex: anInteger 
	"Set the selected message category to be the one indexed by anInteger."

	messageCategoryListIndex _ anInteger.
	messageListIndex _ 0.
	editSelection _ 
		anInteger <= 0
			ifTrue: [#editClass]
			ifFalse: [#newMessage].
	contents _ nil.
	self changed: #messageCategorySelectionChanged.
	self changed: #messageCategoryListIndex.	"update my selection"
	self changed: #messageList.
	self contentsChanged
! !

!Browser methodsFor: 'message category list' stamp: 'BG 2/4/2004 23:26' prior: 34338675!
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.
	editSelection = #newMessage
	  ifTrue: [^self].
	editSelection _ 
		anInteger <= 0
			ifTrue: [#editClass]
			ifFalse: [#newMessage].
	contents _ nil.

	self contentsChanged
! !

!Browser methodsFor: 'message category list' stamp: 'nk 2/14/2004 15:08' prior: 34339209!
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.
	editSelection = #newMessage
	  ifTrue: [^self].
	self editSelection:
		(anInteger <= 0
			ifTrue: [#editClass]
			ifFalse: [#newMessage]).
	contents _ nil.

	self contentsChanged
! !

!Browser methodsFor: 'message category list' stamp: 'rhi 5/12/2004 19:36' prior: 34339794!
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: 'nk 6/13/2004 06:20' prior: 18632560!
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: 'asm 7/9/2003 13:52' prior: 18632913!
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).
			^ true].
	^ false! !

!Browser methodsFor: 'message category list' stamp: 'BG 12/13/2003 14:23' prior: 34341296!
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.
			self contentsChanged.
			^ true].
	^ false! !

!Browser methodsFor: 'message category list' stamp: 'KLC 2/20/2004 08:08' prior: 34342017!
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 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: 'sw 8/5/2002 16:50'!
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)
			-
			('more...'								shiftedYellowButtonActivity)).
	^ aMenu! !

!Browser methodsFor: 'message functions' stamp: 'emm 5/30/2002 10:25' prior: 34344257!
messageListMenu: aMenu shifted: shifted
	"Answer the message-list menu"
	"Changed by emm to include menu-item for breakpoints"

	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' prior: 18640452!
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 _ SystemNavigation new  confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
	confirmation == 3
		ifTrue: [^ self].
	self selectedClassOrMetaClass removeSelector: self selectedMessageName.
	self messageListIndex: 0.
	self changed: #messageList.
	self setClassOrganizer.
	"In case organization not cached"
	confirmation == 2
		ifTrue: [Smalltalk browseAllCallsOn: messageName]! !

!Browser methodsFor: 'message functions' stamp: 'sd 4/15/2003 16:12' prior: 34346626!
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 removeSelector: self selectedMessageName.
	self messageListIndex: 0.
	self changed: #messageList.
	self setClassOrganizer.
	"In case organization not cached"
	confirmation == 2
		ifTrue: [Smalltalk browseAllCallsOn: messageName]! !

!Browser methodsFor: 'message functions' stamp: 'nk 6/26/2003 21:41' prior: 34347538!
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 removeSelector: self selectedMessageName.
	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: 'sd 5/11/2003 21:01' prior: 34348452!
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 removeSelector: self selectedMessageName.
	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: 'sw 1/16/2002 21:54'!
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)
		-
		('fetch documentation'					fetchDocPane)
		('more...' 								unshiftedYellowButtonActivity)).
	^ aMenu
! !

!Browser methodsFor: 'message list' stamp: 'drs 1/1/2003 23:33' prior: 18642654!
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' stamp: 'nk 2/14/2004 15:07' prior: 18643617!
messageListIndex: anInteger 
	"Set the selected message selector to be the one indexed by anInteger."

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

!Browser methodsFor: 'message list' stamp: 'rhi 5/12/2004 19:35' prior: 34352748!
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: 'sw 6/4/2001 17:31'!
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.

	(Sensor controlKeyPressed
		or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])
		ifTrue:
		["Emergency or no source file -- decompile without temp names"
		contents _ (class decompilerClass new decompile: selector in: class method: method)
			decompileString.
		contents _ contents asText makeSelectorBoldIn: class.
		^ contents copy].

	Sensor leftShiftDown ifTrue:
		["Special request to decompile, old and dubious interface"
		^ self decompiledSourceIntoContents].

	self showingDocumentation
		ifFalse:
			[contents _ self sourceStringPrettifiedAndDiffed]
		ifTrue:
			[contents _ self commentContents].
	^ contents _ contents copy asText makeSelectorBoldIn: class! !

!Browser methodsFor: 'message list' stamp: 'nk 6/19/2004 16:44' prior: 34353719!
selectedMessage
	"Answer a copy of the source code for the selected message."

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

	self showingDecompile ifTrue:
		[^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

	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: 'sw 8/26/2002 09:55'!
selectedMessageName
	"Answer the message selector of the currently selected message, if any. 
	Answer nil otherwise."

	| aList |
	editSelection == #editComment ifTrue: [^ #Comment].
	editSelection == #editClass ifTrue: [^ #Definition].

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

!Browser methodsFor: 'message list' stamp: 'sw 10/8/2001 13:37'!
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: 'metaclass' stamp: 'drs 1/6/2003 21:25' prior: 18649361!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."

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

!Browser methodsFor: 'metaclass' stamp: 'asm 6/26/2003 00:24' prior: 34356408!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."

	metaClassIndicated _ trueOrFalse.
	self setClassOrganizer.
	systemCategoryListIndex > 0 ifTrue:
		[editSelection _ classListIndex = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass]].
	messageCategoryListIndex _ 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: 'nk 2/14/2004 15:08' prior: 34357046!
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: 'system category functions' stamp: 'je 4/30/2001 17:59'!
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 1/5/2002 21:11'!
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' stamp: 'sd 1/5/2002 21:12'!
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: 'nk 2/14/2004 15:09' prior: 18653085!
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: 'brp 8/4/2003 21:32' prior: 18657609!
systemCategoryMenu: 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 list' stamp: 'rhi 12/3/2001 22:32'!
systemCategoryListIndex: anInteger 
	"Set the selected system category index to be anInteger. Update all other 
	selections to be deselected."

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

!Browser methodsFor: 'system category list' stamp: 'nk 2/14/2004 15:06' prior: 34361309!
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: 'construction' stamp: 'nk 2/15/2004 13:49'!
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 class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:07'!
fullOnClass: aClass 
	"Open a new full browser set to class."
	| brow |
	brow _ self new.
	brow setClass: aClass selector: nil.
	Browser openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 34363166!
fullOnClass: aClass 
	"Open a new full browser set to class."
	| brow |
	brow _ self new.
	brow setClass: aClass selector: nil.
	^ Browser 
		openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 2/2/2004 13:50' prior: 34363471!
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: 'nk 2/13/2001 13:47'!
fullOnClass: aClass selector: aSelector
	"Open a new full browser set to class."

	| brow classToUse |
	classToUse _ Preferences browseToolClass.
	brow _ classToUse new.
	brow setClass: aClass selector: aSelector.
	classToUse openBrowserView: (brow openEditString: nil)
		label: brow labelString! !

!Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 34364067!
fullOnClass: aClass selector: aSelector
	"Open a new full browser set to class."

	| brow classToUse |
	classToUse _ Preferences browseToolClass.
	brow _ classToUse new.
	brow setClass: aClass selector: aSelector.
	^ classToUse 
		openBrowserView: (brow openEditString: nil)
		label: brow labelString! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:08'!
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: 'jcg 10/29/2003 23:12' prior: 34364841!
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: 'sd 1/5/2002 21:09'!
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: 'jcg 10/29/2003 23:12' prior: 34365941!
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 1/5/2002 21:09'!
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: 'jcg 10/29/2003 23:12' prior: 34366614!
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: 'SD 9/15/2001 15:18'!
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: 'jcg 10/29/2003 23:11' prior: 34367352!
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: 'jcg 10/29/2003 23:11' prior: 18663700!
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: 'sps 3/9/2004 15:54' prior: 34368218!
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 1/5/2002 21:10'!
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: 'sw 6/11/2001 17:38'!
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: 'class initialization' stamp: 'asm 4/10/2003 12:27' prior: 18664736!
initialize
	"Browser initialize"

	RecentClasses := OrderedCollection new.
	self registerInFlapsRegistry.	! !

!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: 'asm 4/11/2003 12:32'!
unload
	"Unload the receiver from global registries"

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

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

!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: 'nk 2/15/2004 14:08'!
hidePane
	| win |
	self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame bottomFraction ].
	win _ self window ifNil: [ ^self ].
	self delete.
	win updatePanesFromSubmorphs.! !

!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 14:09'!
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 ]! !

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

!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 commentStamp: '<historical>' prior: 0!
I am a PluggableTextMorph that knows enough to make myself invisible when necessary.!
!ButtonPhaseType 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: #ButtonPhase.
	symbols _ #(buttonDown whilePressed buttonUp)! !

!ButtonPhaseType methodsFor: '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)	! !

!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: 'RAA 3/9/2001 11:47'!
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 "', 
		arguments first, 
		'" in player named "', 
		itsName, '"'! !

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

	self halt! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:47'!
isTileScriptingElement

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

!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: 'RAA 3/15/2001 09:13'!
privateSetLook: aSymbol to: aFormOrMorph

	| f |

	f _ (aFormOrMorph isKindOf: Form) ifTrue: [
		aFormOrMorph
	] ifFalse: [
		aFormOrMorph imageForm
	].
	self stateCostumes at: aSymbol put: f! !

!ButtonProperties methodsFor: 'accessing' stamp: 'gm 2/22/2003 14:53' prior: 34378246!
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: 'RAA 3/8/2001 07:56'!
setActWhen
	actWhen _ (SelectionMenu selections: #(mouseDown mouseUp mouseStillDown))
		startUpWithCaption: 'Choose one of the following conditions'
! !

!ButtonProperties methodsFor: 'menu'!
setActionSelector

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

!ButtonProperties methodsFor: 'menu'!
setArguments

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

!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'!
setTarget: evt

	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1
		ifTrue: [target _ rootMorphs at: 2]
		ifFalse: [target _ nil. ^ self].
! !

!ButtonProperties methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:52' prior: 34388944!
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 commentStamp: '<historical>' prior: 0!
ButtonProperties test1

ButtonProperties test2

ButtonProperties test3

!
!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: 'RAA 3/8/2001 12:21'!
test3

	| m |

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

!ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 34390649!
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'! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:25'!
acceptDroppingMorph: aMorph event: evt in: aSubmorph

	| why |

	self clearDropHighlightingEvt: evt morph: aSubmorph.
	why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
	why == #changeTargetMorph ifTrue: [
		self targetProperties replaceVisibleMorph: aMorph.
		myTarget _ aMorph.
		self rebuild.
		^true
	].
	why == #changeTargetTarget ifTrue: [
		(aMorph setAsActionInButtonProperties: self targetProperties) ifFalse: [
			^false
		].
		^true
	].
	why == #changeTargetMouseDownLook ifTrue: [
		self targetProperties mouseDownLook: aMorph.
		^false
	].
	why == #changeTargetMouseEnterLook ifTrue: [
		self targetProperties mouseEnterLook: aMorph.
		^false
	].

	^false
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:45'!
addTextToTarget

	self targetProperties currentTextInButton ifNil: [
		self targetProperties addTextToButton: '???'.
	].
	self targetProperties currentTextInButton openATextPropertySheet.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'!
adjustTargetMouseDownHaloSize: aFractionalPoint

	self targetProperties mouseDownHaloWidth: ((aFractionalPoint x * 10) rounded max: 0).
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'!
adjustTargetMouseOverHaloSize: aFractionalPoint

	self targetProperties mouseOverHaloWidth: ((aFractionalPoint x * 10) rounded max: 0).
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:14'!
adjustTargetRepeatingInterval: aFractionalPoint

	| n |

	n _ 2 raisedTo: ((aFractionalPoint x * 12) rounded max: 1).
	self targetProperties delayBetweenFirings: n.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:26'!
allowDropsInto: aMorph withIntent: aSymbol

	aMorph
		on: #mouseEnterDragging send: #mouseEnterDraggingEvt:morph: to: self;
		on: #mouseLeaveDragging send: #mouseLeaveDraggingEvt:morph: to: self;
		on: #mouseLeave send: #clearDropHighlightingEvt:morph: to: self;
		setProperty: #handlerForDrops toValue: self;
		setProperty: #intentOfDroppedMorphs toValue: aSymbol;
		borderWidth: 1;
		borderColor: Color gray
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:03'!
attachMorphOfClass: aClass to: aHand

	aHand attachMorph: aClass new! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'!
clearDropHighlightingEvt: evt morph: aMorph

	aMorph color: Color transparent.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:25'!
doEnables

	| itsName |

	self allMorphsDo: [ :each |
		itsName _ each knownName.
		itsName == #pickerForMouseDownColor ifTrue: [
			self enable: each when: self targetWantsRollover
		].
		itsName == #pickerForMouseOverColor ifTrue: [
			self enable: each when: self targetWantsRollover
		].
		itsName == #paneForRepeatingInterval ifTrue: [
			self enable: each when: self targetRepeatingWhileDown
		].
	].
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:36'!
doRemoveProperties

	myTarget buttonProperties: nil.
	self delete.! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:02'!
mouseDownEvent: evt for: aSubmorph

	| why aMenu |

	why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
	why == #changeTargetMorph ifTrue: [
		aMenu _ MenuMorph new
			defaultTarget: self.
		{
			{'Rectangle'. RectangleMorph}.
			{'Ellipse'. EllipseMorph}
		} do: [ :pair |
			aMenu	
				add: pair first 
				target: self 
				selector: #attachMorphOfClass:to: 
				argumentList: {pair second. evt hand}.
		].
		aMenu popUpEvent: evt in: self world.
		^self
	].

! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:00' prior: 34394563!
mouseDownEvent: evt for: aSubmorph

	| why aMenu |

	why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
	why == #changeTargetMorph ifTrue: [
		aMenu _ MenuMorph new
			defaultTarget: self.
		{
			{'Rectangle'. RectangleMorph}.
			{'Ellipse'. EllipseMorph}
		} do: [ :pair |
			aMenu	
				add: pair first translated
				target: self 
				selector: #attachMorphOfClass:to: 
				argumentList: {pair second. evt hand}.
		].
		aMenu popUpEvent: evt in: self world.
		^self
	].

! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:33'!
mouseEnterDraggingEvt: evt morph: aMorph

	aMorph color: (Color red alpha: 0.5)! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'!
mouseLeaveDraggingEvt: evt morph: aMorph

	self clearDropHighlightingEvt: evt morph: aMorph.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:48'!
paneForActsOnMouseDownToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetActsOnMouseDown
			setter: #toggleTargetActsOnMouseDown
			help: 'If the button is to act when the mouse goes down'.
		self lockedString: ' Mouse-down action'.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34396065!
paneForActsOnMouseDownToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetActsOnMouseDown
			setter: #toggleTargetActsOnMouseDown
			help: 'If the button is to act when the mouse goes down' translated.
		self lockedString: ' Mouse-down action' translated.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'!
paneForActsOnMouseUpToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetActsOnMouseUp
			setter: #toggleTargetActsOnMouseUp
			help: 'If the button is to act when the mouse goes up'.
		self lockedString: ' Mouse-up action'.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34396820!
paneForActsOnMouseUpToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetActsOnMouseUp
			setter: #toggleTargetActsOnMouseUp
			help: 'If the button is to act when the mouse goes up' translated.
		self lockedString: ' Mouse-up action' translated.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 09:56'!
paneForButtonSelectorReport

	^self inARow: {
		self lockedString: 'Action: '.
 		UpdatingStringMorph new
			useStringFormat;
			getSelector: #actionSelector;
			target: self targetProperties;
			growable: true;
			minimumWidth: 24;
			lock.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34397555!
paneForButtonSelectorReport

	^self inARow: {
		self lockedString: 'Action: ' translated.
 		UpdatingStringMorph new
			useStringFormat;
			getSelector: #actionSelector;
			target: self targetProperties;
			growable: true;
			minimumWidth: 24;
			lock.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:01'!
paneForButtonTargetReport

	| r |

	r _ self inARow: {
		self lockedString: 'Target: '.
 		UpdatingStringMorph new
			useStringFormat;
			getSelector: #target;
			target: self targetProperties;
			growable: true;
			minimumWidth: 24;
			lock.
	}.
	r hResizing: #shrinkWrap.
	self allowDropsInto: r withIntent: #changeTargetTarget.
	r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)'.
	^self inARow: {r}


! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34398256!
paneForButtonTargetReport

	| r |

	r _ self inARow: {
		self lockedString: 'Target: ' translated.
 		UpdatingStringMorph new
			useStringFormat;
			getSelector: #target;
			target: self targetProperties;
			growable: true;
			minimumWidth: 24;
			lock.
	}.
	r hResizing: #shrinkWrap.
	self allowDropsInto: r withIntent: #changeTargetTarget.
	r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)' translated.
	^self inARow: {r}


! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:22'!
paneForChangeMouseDownLook

	| r |
	r _ self inARow: {
		self lockedString: ' Mouse-down look '.
	}.
	self allowDropsInto: r withIntent: #changeTargetMouseDownLook.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.'.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34399428!
paneForChangeMouseDownLook

	| r |
	r _ self inARow: {
		self lockedString: ' Mouse-down look ' translated.
	}.
	self allowDropsInto: r withIntent: #changeTargetMouseDownLook.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.' translated.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:03'!
paneForChangeMouseEnterLook

	| r |
	r _ self inARow: {
		self lockedString: ' Mouse-enter look '.
	}.
	self allowDropsInto: r withIntent: #changeTargetMouseEnterLook.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.'.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34400240!
paneForChangeMouseEnterLook

	| r |
	r _ self inARow: {
		self lockedString: ' Mouse-enter look ' translated.
	}.
	self allowDropsInto: r withIntent: #changeTargetMouseEnterLook.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.' translated.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:00'!
paneForChangeVisibleMorph

	| r |
	r _ self inARow: {
		self lockedString: ' Change morph '.
	}.
	r on: #mouseDown send: #mouseDownEvent:for: to: self.
	self allowDropsInto: r withIntent: #changeTargetMorph.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.'.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34401044!
paneForChangeVisibleMorph

	| r |
	r _ self inARow: {
		self lockedString: ' Change morph ' translated.
	}.
	r on: #mouseDown send: #mouseDownEvent:for: to: self.
	self allowDropsInto: r withIntent: #changeTargetMorph.
	r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.' translated.
	^r
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:33'!
paneForMouseDownColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self targetProperties
						 getter: #mouseDownHaloColor setter: #mouseDownHaloColor:.
				self lockedString: 'mouse-down halo color'.
				self paneForMouseDownHaloWidth.
			}
			named: #pickerForMouseDownColor) layoutInset: 0.
		}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34401997!
paneForMouseDownColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self targetProperties
						 getter: #mouseDownHaloColor setter: #mouseDownHaloColor:.
				self lockedString: 'mouse-down halo color' translated.
				self paneForMouseDownHaloWidth.
			}
			named: #pickerForMouseDownColor) layoutInset: 0.
		}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:07'!
paneForMouseDownHaloWidth

	^(self inARow: {
		self
			buildFakeSlider: #valueForMouseDownHaloWidth 
			selector: #adjustTargetMouseDownHaloSize:
			help: 'Drag in here to change the halo width'
	}) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34402869!
paneForMouseDownHaloWidth

	^(self inARow: {
		self
			buildFakeSlider: #valueForMouseDownHaloWidth 
			selector: #adjustTargetMouseDownHaloSize:
			help: 'Drag in here to change the halo width' translated
	}) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:34'!
paneForMouseOverColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self targetProperties
						 getter: #mouseOverHaloColor setter: #mouseOverHaloColor:.
				self lockedString: 'mouse-over halo color'.
				self paneForMouseOverHaloWidth.
			}
			named: #pickerForMouseOverColor) layoutInset: 0.
		}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34403523!
paneForMouseOverColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self targetProperties
						 getter: #mouseOverHaloColor setter: #mouseOverHaloColor:.
				self lockedString: 'mouse-over halo color' translated.
				self paneForMouseOverHaloWidth.
			}
			named: #pickerForMouseOverColor) layoutInset: 0.
		}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:09'!
paneForMouseOverHaloWidth

	^(self inARow: {
		self
			buildFakeSlider: #valueForMouseOverHaloWidth
			selector: #adjustTargetMouseOverHaloSize:
			help: 'Drag in here to change the halo width'
	}) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34404395!
paneForMouseOverHaloWidth

	^(self inARow: {
		self
			buildFakeSlider: #valueForMouseOverHaloWidth
			selector: #adjustTargetMouseOverHaloSize:
			help: 'Drag in here to change the halo width' translated
	}) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:16'!
paneForRepeatingInterval

	^(self 
		inAColumn: {
			self
				buildFakeSlider: #valueForRepeatingInterval
				selector: #adjustTargetRepeatingInterval:
				help: 'Drag in here to change how often the button repeats while the mouse is down'
		}
		 named: #paneForRepeatingInterval
	) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34405047!
paneForRepeatingInterval

	^(self 
		inAColumn: {
			self
				buildFakeSlider: #valueForRepeatingInterval
				selector: #adjustTargetRepeatingInterval:
				help: 'Drag in here to change how often the button repeats while the mouse is down' translated
		}
		 named: #paneForRepeatingInterval
	) hResizing: #shrinkWrap
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:19'!
paneForWantsFiringWhileDownToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetRepeatingWhileDown
			setter: #toggleTargetRepeatingWhileDown
			help: 'Turn repeating while mouse is held down on or off'.
		self lockedString: ' Mouse-down repeating '.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34405869!
paneForWantsFiringWhileDownToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetRepeatingWhileDown
			setter: #toggleTargetRepeatingWhileDown
			help: 'Turn repeating while mouse is held down on or off' translated.
		self lockedString: ' Mouse-down repeating ' translated.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:26'!
paneForWantsRolloverToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetWantsRollover
			setter: #toggleTargetWantsRollover
			help: 'Turn mouse-over highlighting on or off'.
		self lockedString: ' Mouse-over highlighting'.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34406656!
paneForWantsRolloverToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetWantsRollover
			setter: #toggleTargetWantsRollover
			help: 'Turn mouse-over highlighting on or off' translated.
		self lockedString: ' Mouse-over highlighting' translated.
	}
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 12:51'!
rebuild

	| buttonColor |

	myTarget ensuredButtonProperties.
	"self targetProperties unlockAnyText."	"makes styling the text easier"

	self removeAllMorphs.
	self addAColumn: {
		self lockedString: 'Button Properties for ',myTarget name.
	}.
	self addAColumn: {
		self paneForButtonTargetReport.
	}.
	self addAColumn: {
		self paneForButtonSelectorReport.
	}.

	self addAColumn: {
		(self inARow: {
			self paneForActsOnMouseDownToggle.
			self paneForActsOnMouseUpToggle.
		})  hResizing: #shrinkWrap.
	}.

	self addAColumn: {
		self inARow: {
			(self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap.
			self paneForRepeatingInterval.
		}.
	}.

	self addAColumn: {
		(self inAColumn: {
			self paneForWantsRolloverToggle.
		}) hResizing: #shrinkWrap.
	}.
	self addARow: {
		self paneForMouseOverColorPicker.
		self paneForMouseDownColorPicker.
	}.
	self addARow: {
		self paneForChangeMouseEnterLook.
		self paneForChangeMouseDownLook.
	}.

	buttonColor _ color lighter.
	self addARow: {
		self inAColumn: {
			self addARow: {
				self 
					buttonNamed: 'Add label' action: #addTextToTarget color: buttonColor
					help: 'add some text to the button'.
				self 
					buttonNamed: 'Remove label' action: #removeTextFromTarget color: buttonColor
					help: 'remove text from the button'.
			}.
			self addARow: {
				self 
					buttonNamed: 'Accept' action: #doAccept color: buttonColor
					help: 'keep changes made and close panel'.
				self 
					buttonNamed: 'Cancel' action: #doCancel color: buttonColor
					help: 'cancel changes made and close panel'.
				self transparentSpacerOfSize: 10@3.
				self 
					buttonNamed: 'Main' action: #doMainProperties color: color lighter 
					help: 'open a main properties panel for the morph'.
				self 
					buttonNamed: 'Remove' action: #doRemoveProperties color: color lighter 
					help: 'remove the button properties of this morph'.
			}.
		}.
		self inAColumn: {
			self paneForChangeVisibleMorph
		}.
	}.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:03' prior: 34407392!
rebuild

	| buttonColor |

	myTarget ensuredButtonProperties.
	"self targetProperties unlockAnyText."	"makes styling the text easier"

	self removeAllMorphs.
	self addAColumn: {
		self lockedString: ('Button Properties for {1}' translated format: {myTarget name}).
	}.
	self addAColumn: {
		self paneForButtonTargetReport.
	}.
	self addAColumn: {
		self paneForButtonSelectorReport.
	}.

	self addAColumn: {
		(self inARow: {
			self paneForActsOnMouseDownToggle.
			self paneForActsOnMouseUpToggle.
		})  hResizing: #shrinkWrap.
	}.

	self addAColumn: {
		self inARow: {
			(self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap.
			self paneForRepeatingInterval.
		}.
	}.

	self addAColumn: {
		(self inAColumn: {
			self paneForWantsRolloverToggle.
		}) hResizing: #shrinkWrap.
	}.
	self addARow: {
		self paneForMouseOverColorPicker.
		self paneForMouseDownColorPicker.
	}.
	self addARow: {
		self paneForChangeMouseEnterLook.
		self paneForChangeMouseDownLook.
	}.

	buttonColor _ color lighter.
	self addARow: {
		self inAColumn: {
			self addARow: {
				self 
					buttonNamed: 'Add label' translated action: #addTextToTarget color: buttonColor
					help: 'add some text to the button' translated.
				self 
					buttonNamed: 'Remove label' translated action: #removeTextFromTarget color: buttonColor
					help: 'remove text from the button' translated.
			}.
			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.
				self transparentSpacerOfSize: 10@3.
				self 
					buttonNamed: 'Main' translated action: #doMainProperties color: color lighter 
					help: 'open a main properties panel for the morph' translated.
				self 
					buttonNamed: 'Remove' translated action: #doRemoveProperties color: color lighter 
					help: 'remove the button properties of this morph' translated.
			}.
		}.
		self inAColumn: {
			self paneForChangeVisibleMorph
		}.
	}.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:36'!
removeTextFromTarget

	self targetProperties addTextToButton: nil.
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'!
targetActsOnMouseDown

	^self targetProperties actWhen == #mouseDown! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'!
targetActsOnMouseUp

	^self targetProperties actWhen == #mouseUp! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:05'!
targetProperties

	^myTarget ensuredButtonProperties! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:01'!
targetRepeatingWhileDown

	^self targetProperties delayBetweenFirings notNil! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'!
targetWantsRollover

	^self targetProperties wantsRolloverIndicator! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:51'!
toggleTargetActsOnMouseDown

	| prop |

	prop _ self targetProperties.
	prop actWhen: (prop actWhen == #mouseDown ifTrue: [nil] ifFalse: [#mouseDown])! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:50'!
toggleTargetActsOnMouseUp

	| prop |

	prop _ self targetProperties.
	prop actWhen: (prop actWhen == #mouseUp ifTrue: [nil] ifFalse: [#mouseUp])! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:02'!
toggleTargetRepeatingWhileDown

	| prop |

	prop _ self targetProperties.
	prop delayBetweenFirings: (prop delayBetweenFirings ifNil: [1024] ifNotNil: [nil])
	! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'!
toggleTargetWantsRollover

	self targetProperties wantsRolloverIndicator: self targetProperties wantsRolloverIndicator not! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'!
valueForMouseDownHaloWidth

	^'mouse-down halo width: ',self targetProperties mouseDownHaloWidth printString
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:09'!
valueForMouseOverHaloWidth

	^'mouse-over halo width: ',self targetProperties mouseOverHaloWidth printString
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:41'!
valueForRepeatingInterval

	| n s |

	n _ self targetProperties delayBetweenFirings.

	s _ n ifNil: [
		'*none*'
	] ifNotNil: [
		n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs']
	].
	^'interval: ',s
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:04' prior: 34413967!
valueForRepeatingInterval

	| n s |

	n _ self targetProperties delayBetweenFirings.

	s _ n ifNil: [
		'*none*'
	] ifNotNil: [
		n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs']
	].
	^'interval: ' translated, s
! !

!ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:31'!
wantsDroppedMorph: aMorph event: evt in: aSubmorph

	| why |

	why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
	^why notNil

" toValue: #changeTargetMorph.

	^true"! !

!ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'!
defaultBorderColor
"answer the default border color/fill style for the receiver"
	^ self defaultColor darker! !

!ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.935
		g: 0.839
		b: 0.452! !

!ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'RAA 3/15/2001 11:53'!
initialize

	super initialize.
	myTarget ifNil: [myTarget _ RectangleMorph new openInWorld].
	self color: (Color r: 0.935 g: 0.839 b: 0.452).
	self borderColor: self color darker.
	thingsToRevert at: #buttonProperties: put: myTarget buttonProperties.
	self rebuild.
! !

!ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17' prior: 34415293!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	myTarget
		ifNil: [myTarget _ RectangleMorph new openInWorld].

	thingsToRevert at: #buttonProperties: put: myTarget buttonProperties.
	self rebuild! !

!ButtonPropertiesMorph commentStamp: '<historical>' prior: 0!
ButtonPropertiesMorph basicNew
		targetMorph: self;
		initialize;
		openNearTarget!
!ByteArray methodsFor: 'accessing' stamp: 'yo 10/23/2002 23:35'!
asMultiString

	^ MultiString fromByteArray: self.
! !

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

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29' prior: 18670736!
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: 'comparing' stamp: 'SqR 8/13/2002 10:52' prior: 18675394!
hash
	"#hash is implemented, because #= is implemented"

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

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

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

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

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 5/22/2003 17:11'!
initialize

	literals _ LiteralList new.
	"The following dicts are keyed by sequence id given by client in label: (and gotos)."
	seqOrder _ IdentityDictionary new.  "seqId -> seq order num"
	seqBytes _ IdentityDictionary new.  "seqId -> seq bytecodes"
	jumps _ IdentityDictionary new.  "seqId -> last jump instr"
	instrMaps _ IdentityDictionary new.  "seqId -> (clientInstr -> bytecode pos)"
	stacks _ IdentityDictionary new.  "seqId -> stackCount"
	maxTemp _ 0.
	primNum _ 0.
	numArgs _ 0.
	currentSeqNum _ 0.
	orderSeq _ OrderedCollection new.  "reverse map of seqOrder"

	"starting label in case one is not provided by client"
	self label: self newDummySeqId.
! !

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 5/22/2003 17:11' prior: 34418839!
initialize

	literals _ LiteralList new.
	"The following dicts are keyed by sequence id given by client in label: (and gotos)."
	seqOrder _ IdentityDictionary new.  "seqId -> seq order num"
	seqBytes _ IdentityDictionary new.  "seqId -> seq bytecodes"
	jumps _ IdentityDictionary new.  "seqId -> last jump instr"
	instrMaps _ IdentityDictionary new.  "seqId -> (clientInstr -> bytecode pos)"
	stacks _ IdentityDictionary new.  "seqId -> stackCount"
	maxTemp _ 0.
	primNum _ 0.
	numArgs _ 0.
	currentSeqNum _ 0.
	orderSeq _ OrderedCollection new.  "reverse map of seqOrder"

	"starting label in case one is not provided by client"
	self label: self newDummySeqId.
! !

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21'!
numArgs: n

	numArgs _ n! !

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21' prior: 34420339!
numArgs: n

	numArgs _ n! !

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21'!
primitiveNode: aPrimitiveNode

	literals isEmpty ifFalse: [self error: 'init prim before adding instructions'].
	aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec].
	primNum _ aPrimitiveNode num.
! !

!BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21' prior: 34420561!
primitiveNode: aPrimitiveNode

	literals isEmpty ifFalse: [self error: 'init prim before adding instructions'].
	aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec].
	primNum _ aPrimitiveNode num.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:22'!
goto: seqId

	stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).

	self saveLastJump: (Message
		selector: #from:goto:
		arguments: {currentSeqId. seqId}).
	self from: currentSeqId goto: seqId.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:22' prior: 34421159!
goto: seqId

	stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).

	self saveLastJump: (Message
		selector: #from:goto:
		arguments: {currentSeqId. seqId}).
	self from: currentSeqId goto: seqId.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 13:26'!
if: bool goto: seqId

	| otherwiseSeqId |
	otherwiseSeqId _ self newDummySeqId.
	self if: bool goto: seqId otherwise: otherwiseSeqId.
	self label: otherwiseSeqId.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 13:26' prior: 34421777!
if: bool goto: seqId

	| otherwiseSeqId |
	otherwiseSeqId _ self newDummySeqId.
	self if: bool goto: seqId otherwise: otherwiseSeqId.
	self label: otherwiseSeqId.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:26'!
if: bool goto: seqId1 otherwise: seqId2

	stack pop.
	stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])).
	stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])).

	self saveLastJump: (Message
		selector: #from:if:goto:otherwise:
		arguments: {currentSeqId. bool. seqId1. seqId2}).
	self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:26' prior: 34422281!
if: bool goto: seqId1 otherwise: seqId2

	stack pop.
	stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])).
	stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])).

	self saveLastJump: (Message
		selector: #from:if:goto:otherwise:
		arguments: {currentSeqId. bool. seqId1. seqId2}).
	self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:16'!
label: seqId

	(currentSeqId notNil and: [(jumps at: currentSeqId) isNil]) ifTrue: [
		"make previous implicit goto explicit"
		self goto: seqId.
	].

	lastSpecialReturn _ nil.
	currentSeqId _ seqId.
	currentSeqNum _ currentSeqNum + 1.
	seqOrder at: seqId put: currentSeqNum.
	orderSeq at: currentSeqNum ifAbsentPut: [seqId].
	bytes _ seqBytes at: seqId ifAbsentPut: [OrderedCollection new].
	jumps at: seqId ifAbsentPut: [nil].
	instrMap _ instrMaps at: seqId ifAbsentPut: [OrderedCollection new].
	stack _ stacks at: seqId ifAbsentPut: [StackCount new].
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:16' prior: 34423255!
label: seqId

	(currentSeqId notNil and: [(jumps at: currentSeqId) isNil]) ifTrue: [
		"make previous implicit goto explicit"
		self goto: seqId.
	].

	lastSpecialReturn _ nil.
	currentSeqId _ seqId.
	currentSeqNum _ currentSeqNum + 1.
	seqOrder at: seqId put: currentSeqNum.
	orderSeq at: currentSeqNum ifAbsentPut: [seqId].
	bytes _ seqBytes at: seqId ifAbsentPut: [OrderedCollection new].
	jumps at: seqId ifAbsentPut: [nil].
	instrMap _ instrMaps at: seqId ifAbsentPut: [OrderedCollection new].
	stack _ stacks at: seqId ifAbsentPut: [StackCount new].
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48'!
popTop

	stack pop.

	self nextPut: (Bytecodes at: #popStackBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48' prior: 34424545!
popTop

	stack pop.

	self nextPut: (Bytecodes at: #popStackBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48'!
pushDup

	stack push.

	self nextPut: (Bytecodes at: #duplicateTopBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48' prior: 34424865!
pushDup

	stack push.

	self nextPut: (Bytecodes at: #duplicateTopBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:49'!
pushInstVar: instVarIndex

	| interval |
	stack push.

	interval _ Bytecodes at: #pushReceiverVariableBytecode.
	instVarIndex <= interval size ifTrue: [
		^ self nextPut: (interval at: instVarIndex).
	].
	instVarIndex <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedPushBytecode).
		^ self nextPut: (0 "instVar" << 6) + instVarIndex - 1.
	].
	instVarIndex <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 2 "pushInstVar" << 5.
	self nextPut: instVarIndex - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:49' prior: 34425197!
pushInstVar: instVarIndex

	| interval |
	stack push.

	interval _ Bytecodes at: #pushReceiverVariableBytecode.
	instVarIndex <= interval size ifTrue: [
		^ self nextPut: (interval at: instVarIndex).
	].
	instVarIndex <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedPushBytecode).
		^ self nextPut: (0 "instVar" << 6) + instVarIndex - 1.
	].
	instVarIndex <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 2 "pushInstVar" << 5.
	self nextPut: instVarIndex - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50'!
pushLiteral: object

	| index interval |
	stack push.

	(index _ SpecialConstants identityIndexOf: object) > 0 ifTrue: [
		^ self nextPut: (Bytecodes at: #pushConstantTrueBytecode) + index - 1].

	index _ self addLiteral: object.
	interval _ Bytecodes at: #pushLiteralConstantBytecode.
	(index <= interval size) ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedPushBytecode).
		^ self nextPut: 2 "lit constant" << 6 + index - 1
	].
	index > 256 ifTrue: [self error: 'too many literals (>256)'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 3 "lit constant" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50' prior: 34426523!
pushLiteral: object

	| index interval |
	stack push.

	(index _ SpecialConstants identityIndexOf: object) > 0 ifTrue: [
		^ self nextPut: (Bytecodes at: #pushConstantTrueBytecode) + index - 1].

	index _ self addLiteral: object.
	interval _ Bytecodes at: #pushLiteralConstantBytecode.
	(index <= interval size) ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedPushBytecode).
		^ self nextPut: 2 "lit constant" << 6 + index - 1
	].
	index > 256 ifTrue: [self error: 'too many literals (>256)'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 3 "lit constant" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50'!
pushReceiver

	stack push.

	self nextPut: (Bytecodes at: #pushReceiverBytecode)! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50' prior: 34428085!
pushReceiver

	stack push.

	self nextPut: (Bytecodes at: #pushReceiverBytecode)! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51'!
pushTemp: index

	| interval |
	stack push.
	maxTemp _ index max: maxTemp.

	interval _ Bytecodes at: #pushTemporaryVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index).
	].
	index <= 64 ifFalse: [self error: 'too many temp vars (>64)'].
	self nextPut: (Bytecodes at: #extendedPushBytecode).
	self nextPut: (1 "temp" << 6) + index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51' prior: 34428423!
pushTemp: index

	| interval |
	stack push.
	maxTemp _ index max: maxTemp.

	interval _ Bytecodes at: #pushTemporaryVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index).
	].
	index <= 64 ifFalse: [self error: 'too many temp vars (>64)'].
	self nextPut: (Bytecodes at: #extendedPushBytecode).
	self nextPut: (1 "temp" << 6) + index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51'!
pushThisContext

	stack push.

	self nextPut: (Bytecodes at: #pushActiveContextBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51' prior: 34429349!
pushThisContext

	stack push.

	self nextPut: (Bytecodes at: #pushActiveContextBytecode).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:01'!
remoteReturn

	self saveLastJump: #return.

	self send: #remoteReturnTo:.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:01' prior: 34429707!
remoteReturn

	self saveLastJump: #return.

	self send: #remoteReturnTo:.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'!
returnConstant: obj

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnConstant: argument: obj].

	obj caseOf: {
		[true] -> [self nextPut: (Bytecodes at: #returnTrue)].
		[false] -> [self nextPut: (Bytecodes at: #returnFalse)].
		[nil] -> [self nextPut: (Bytecodes at: #returnNil)]
	} otherwise: [
		self pushLiteral: obj.
		self returnTop.
	]
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34430033!
returnConstant: obj

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnConstant: argument: obj].

	obj caseOf: {
		[true] -> [self nextPut: (Bytecodes at: #returnTrue)].
		[false] -> [self nextPut: (Bytecodes at: #returnFalse)].
		[nil] -> [self nextPut: (Bytecodes at: #returnNil)]
	} otherwise: [
		self pushLiteral: obj.
		self returnTop.
	]
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'!
returnInstVar: index

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnInstVar: argument: index].

	self pushInstVar: index.
	self returnTop.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34431007!
returnInstVar: index

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnInstVar: argument: index].

	self pushInstVar: index.
	self returnTop.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'!
returnReceiver

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnReceiver].

	self nextPut: (Bytecodes at: #returnReceiver).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34431577!
returnReceiver

	self saveLastJump: #return.

	bytes size = 0 ifTrue: [
		lastSpecialReturn _ Message selector: #returnReceiver].

	self nextPut: (Bytecodes at: #returnReceiver).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'!
returnTop

	self saveLastJump: #return.

	self nextPut: (Bytecodes at: #returnTopFromMethod).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34432113!
returnTop

	self saveLastJump: #return.

	self nextPut: (Bytecodes at: #returnTopFromMethod).
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43'!
send: selector

	| index nArgs |
	nArgs _ selector numArgs.
	stack pop: nArgs.

	SpecialSelectors at: selector ifPresent: [:i |
		^ self nextPut: (Bytecodes at: #bytecodePrimAdd) + i].

	index _ self addLiteral: selector.
	(index <= 16 and: [nArgs <= 2]) ifTrue: [
		"short send"
		^ self nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + index - 1
	].
	(index <= 32 and: [nArgs <= 7]) ifTrue: [
		"extended (2-byte) send"
		self nextPut: (Bytecodes at: #singleExtendedSendBytecode).
		^ self nextPut: nArgs * 32 + index - 1
	].
	(index <= 64 and: [nArgs <= 3]) ifTrue: [
		"new extended (2-byte)"
		self nextPut: (Bytecodes at: #secondExtendedSendBytecode).
		^ self nextPut: nArgs * 64 + index - 1
	].
	"long (3-byte) send"
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: nArgs.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43' prior: 34432479!
send: selector

	| index nArgs |
	nArgs _ selector numArgs.
	stack pop: nArgs.

	SpecialSelectors at: selector ifPresent: [:i |
		^ self nextPut: (Bytecodes at: #bytecodePrimAdd) + i].

	index _ self addLiteral: selector.
	(index <= 16 and: [nArgs <= 2]) ifTrue: [
		"short send"
		^ self nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + index - 1
	].
	(index <= 32 and: [nArgs <= 7]) ifTrue: [
		"extended (2-byte) send"
		self nextPut: (Bytecodes at: #singleExtendedSendBytecode).
		^ self nextPut: nArgs * 32 + index - 1
	].
	(index <= 64 and: [nArgs <= 3]) ifTrue: [
		"new extended (2-byte)"
		self nextPut: (Bytecodes at: #secondExtendedSendBytecode).
		^ self nextPut: nArgs * 64 + index - 1
	].
	"long (3-byte) send"
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: nArgs.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43'!
send: selector toSuperOf: behavior

	| index nArgs |
	nArgs _ selector numArgs.
	stack pop: nArgs.

	self addLastLiteral: behavior holder.
	index _ self addLiteral: selector.
	(index <= 32 and: [nArgs <= 7]) ifTrue: [
		"extended (2-byte) send"
		self nextPut: (Bytecodes at: #singleExtendedSuperBytecode).
		^ self nextPut: nArgs * 32 + index - 1
	].
	"long (3-byte) send"
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 1 << 5 "super" + nArgs.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43' prior: 34434391!
send: selector toSuperOf: behavior

	| index nArgs |
	nArgs _ selector numArgs.
	stack pop: nArgs.

	self addLastLiteral: behavior holder.
	index _ self addLiteral: selector.
	(index <= 32 and: [nArgs <= 7]) ifTrue: [
		"extended (2-byte) send"
		self nextPut: (Bytecodes at: #singleExtendedSuperBytecode).
		^ self nextPut: nArgs * 32 + index - 1
	].
	"long (3-byte) send"
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 1 << 5 "super" + nArgs.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 20:36'!
storeInstVar: index

	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreBytecode).
		^ self nextPut: (0 "instVar" << 6) + index - 1.
	].
	index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 5 "storeInstVar" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 20:36' prior: 34435578!
storeInstVar: index

	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreBytecode).
		^ self nextPut: (0 "instVar" << 6) + index - 1.
	].
	index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 5 "storeInstVar" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:00'!
storePopInstVar: index

	| interval |
	stack pop.

	interval _ Bytecodes at: #storeAndPopReceiverVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode).
		^ self nextPut: (0 "instVar" << 6) + index - 1.
	].
	index <= 256 ifFalse: [
		self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 6 "storePopInstVar" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:00' prior: 34436485!
storePopInstVar: index

	| interval |
	stack pop.

	interval _ Bytecodes at: #storeAndPopReceiverVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode).
		^ self nextPut: (0 "instVar" << 6) + index - 1.
	].
	index <= 256 ifFalse: [
		self error: 'can''t reference more than 256 inst vars'].
	self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode).
	self nextPut: 6 "storePopInstVar" << 5.
	self nextPut: index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01'!
storePopTemp: index

	| interval |
	stack pop.
	maxTemp _ index max: maxTemp.

	interval _ Bytecodes at: #storeAndPopTemporaryVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode).
		^ self nextPut: (1 "temp" << 6) + index - 1.
	].
	self error: 'too many temps (>64)'! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01' prior: 34437759!
storePopTemp: index

	| interval |
	stack pop.
	maxTemp _ index max: maxTemp.

	interval _ Bytecodes at: #storeAndPopTemporaryVariableBytecode.
	index <= interval size ifTrue: [
		^ self nextPut: (interval at: index)
	].
	index <= 64 ifTrue: [
		self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode).
		^ self nextPut: (1 "temp" << 6) + index - 1.
	].
	self error: 'too many temps (>64)'! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01'!
storeTemp: index

	maxTemp _ index max: maxTemp.

	index <= 64 ifFalse: [self error: 'too many temps (>64)'].
	self nextPut: (Bytecodes at: #extendedStoreBytecode).
	self nextPut: (1 "temp" << 6) + index - 1.
! !

!BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01' prior: 34438721!
storeTemp: index

	maxTemp _ index max: maxTemp.

	index <= 64 ifFalse: [self error: 'too many temps (>64)'].
	self nextPut: (Bytecodes at: #extendedStoreBytecode).
	self nextPut: (1 "temp" << 6) + index - 1.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/6/2003 22:48'!
addLastLiteral: object

	lastLiteral ifNil: [^ lastLiteral _ object].
	(lastLiteral literalEqual: object)
		ifFalse: [self error: 'there can only be one last literal'].! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/6/2003 22:48' prior: 34439311!
addLastLiteral: object

	lastLiteral ifNil: [^ lastLiteral _ object].
	(lastLiteral literalEqual: object)
		ifFalse: [self error: 'there can only be one last literal'].! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/8/2003 20:56'!
addLiteral: object

	literals add: object.
	^ literals indexOf: object! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/8/2003 20:56' prior: 34439813!
addLiteral: object

	literals add: object.
	^ literals indexOf: object! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:00'!
from: fromSeqId goto: toSeqId

	| distance from to |
	from _ seqOrder at: fromSeqId.
	to _ seqOrder at: toSeqId ifAbsent: [^ self].
	from + 1 = to ifTrue: [^ self].  "fall through, no jump needed"

	from < to ifTrue: [ "jump forward"
		distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | 
				size + (seqBytes at: (orderSeq at: i)) size].
		self jumpForward: distance.
	] ifFalse: [ "jump backward"
		distance _ ((to to: from - 1) inject: 0 into: [:size :i |
				size + (seqBytes at: (orderSeq at: i)) size])
			+ bytes size.
		self jumpBackward: distance.
	].
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:00' prior: 34440120!
from: fromSeqId goto: toSeqId

	| distance from to |
	from _ seqOrder at: fromSeqId.
	to _ seqOrder at: toSeqId ifAbsent: [^ self].
	from + 1 = to ifTrue: [^ self].  "fall through, no jump needed"

	from < to ifTrue: [ "jump forward"
		distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | 
				size + (seqBytes at: (orderSeq at: i)) size].
		self jumpForward: distance.
	] ifFalse: [ "jump backward"
		distance _ ((to to: from - 1) inject: 0 into: [:size :i |
				size + (seqBytes at: (orderSeq at: i)) size])
			+ bytes size.
		self jumpBackward: distance.
	].
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:22'!
from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId

	| distance from to otherwise |
	from _ seqOrder at: fromSeqId.
	to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	from < to ifFalse: [self errorConditionalJumpBackwards].
	from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext].
	distance _ (from + 1 to: to - 1)
		inject: 0
		into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size].
	self jump: distance if: bool.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:22' prior: 34441428!
from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId

	| distance from to otherwise |
	from _ seqOrder at: fromSeqId.
	to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"
	from < to ifFalse: [self errorConditionalJumpBackwards].
	from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext].
	distance _ (from + 1 to: to - 1)
		inject: 0
		into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size].
	self jump: distance if: bool.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:48'!
jump: distance if: condition

	| hi |
	distance = 0 ifTrue: [
		"jumps to fall through, no-op"
		^ self nextPut: (Bytecodes at: #popStackBytecode)].
	condition ifTrue: [
		hi _ distance // 256.
		hi < 8 ifFalse: [self error: 'true jump too big'].
		self nextPut: (Bytecodes at: #longJumpIfTrue) first + hi.
		self nextPut: distance \\ 256.
	] ifFalse: [
		distance <= 8 ifTrue: [
			self nextPut: (Bytecodes at: #shortConditionalJump) first + distance - 1.
		] ifFalse: [
			hi _ distance // 256.
			hi < 8 ifFalse: [self error: 'false jump too big'].
			self nextPut: (Bytecodes at: #longJumpIfFalse) first + hi.
			self nextPut: distance \\ 256.
		].
	]	
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:48' prior: 34442748!
jump: distance if: condition

	| hi |
	distance = 0 ifTrue: [
		"jumps to fall through, no-op"
		^ self nextPut: (Bytecodes at: #popStackBytecode)].
	condition ifTrue: [
		hi _ distance // 256.
		hi < 8 ifFalse: [self error: 'true jump too big'].
		self nextPut: (Bytecodes at: #longJumpIfTrue) first + hi.
		self nextPut: distance \\ 256.
	] ifFalse: [
		distance <= 8 ifTrue: [
			self nextPut: (Bytecodes at: #shortConditionalJump) first + distance - 1.
		] ifFalse: [
			hi _ distance // 256.
			hi < 8 ifFalse: [self error: 'false jump too big'].
			self nextPut: (Bytecodes at: #longJumpIfFalse) first + hi.
			self nextPut: distance \\ 256.
		].
	]	
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46'!
jumpBackward: distance

	| dist |
	distance = 0 ifTrue: [^ self].  "no-op"
	dist _ 1024 - distance - 2.
	dist < 0 ifTrue: [self error: 'back jump to big'].
	self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256).
	self nextPut: dist \\ 256.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46' prior: 34444230!
jumpBackward: distance

	| dist |
	distance = 0 ifTrue: [^ self].  "no-op"
	dist _ 1024 - distance - 2.
	dist < 0 ifTrue: [self error: 'back jump to big'].
	self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256).
	self nextPut: dist \\ 256.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46'!
jumpForward: distance

	distance = 0 ifTrue: [^ self].  "no-op"
	distance <= 8 ifTrue: [
		self nextPut: (Bytecodes at: #shortUnconditionalJump) first + distance - 1.
	] ifFalse: [
		distance > 1023 ifTrue: [self error: 'forward jump too big'].
		self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4.
		self nextPut: distance \\ 256.
	].
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46' prior: 34444920!
jumpForward: distance

	distance = 0 ifTrue: [^ self].  "no-op"
	distance <= 8 ifTrue: [
		self nextPut: (Bytecodes at: #shortUnconditionalJump) first + distance - 1.
	] ifFalse: [
		distance > 1023 ifTrue: [self error: 'forward jump too big'].
		self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4.
		self nextPut: distance \\ 256.
	].
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:28'!
newDummySeqId

	^ Object new! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:28' prior: 34445824!
newDummySeqId

	^ Object new! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/13/2003 13:00'!
nextPut: byte

	bytes add: byte! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/13/2003 13:00' prior: 34446048!
nextPut: byte

	bytes add: byte! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 12:23'!
saveLastJump: message

	jumps at: currentSeqId put: {bytes size. message}.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 12:23' prior: 34446278!
saveLastJump: message

	jumps at: currentSeqId put: {bytes size. message}.
! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 6/22/2003 14:41'!
updateJump: seqId
	"Recalculate final jump bytecodes.  Return true if jump bytecodes SIZE has changed, otherwise return false"

	| pair s1 |
	pair _ jumps at: seqId.
	pair last == #return ifTrue: [^ false].  "no jump, a return"
	bytes _ seqBytes at: seqId.
	s1 _ bytes size.
	bytes removeLast: (bytes size - pair first).
	pair last sendTo: self.
	^ s1 ~= bytes size! !

!BytecodeGenerator methodsFor: 'private' stamp: 'ajh 6/22/2003 14:41' prior: 34446596!
updateJump: seqId
	"Recalculate final jump bytecodes.  Return true if jump bytecodes SIZE has changed, otherwise return false"

	| pair s1 |
	pair _ jumps at: seqId.
	pair last == #return ifTrue: [^ false].  "no jump, a return"
	bytes _ seqBytes at: seqId.
	s1 _ bytes size.
	bytes removeLast: (bytes size - pair first).
	pair last sendTo: self.
	^ s1 ~= bytes size! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/22/2003 13:06'!
bytecodes

	| stream |
	[ orderSeq
		inject: false
		into: [:changed :seqId | (self updateJump: seqId) | changed]
	] whileTrue.

	stream _ (ByteArray new: 100) writeStream.
	orderSeq do: [:seqId |
		(instrMaps at: seqId) do: [:assoc |
			assoc key "instr" bytecodeIndex: stream position + assoc value.
		].
		stream nextPutAll: (seqBytes at: seqId).
	].
	^ stream contents! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/22/2003 13:06' prior: 34447494!
bytecodes

	| stream |
	[ orderSeq
		inject: false
		into: [:changed :seqId | (self updateJump: seqId) | changed]
	] whileTrue.

	stream _ (ByteArray new: 100) writeStream.
	orderSeq do: [:seqId |
		(instrMaps at: seqId) do: [:assoc |
			assoc key "instr" bytecodeIndex: stream position + assoc value.
		].
		stream nextPutAll: (seqBytes at: seqId).
	].
	^ stream contents! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/23/2003 10:48'!
compiledMethod

	^ self compiledMethodWith: #(0)! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/23/2003 10:48' prior: 34448406!
compiledMethod

	^ self compiledMethodWith: #(0)! !

!BytecodeGenerator methodsFor: 'results' stamp: 'md 11/14/2003 19:43'!
compiledMethodWith: trailer

	^ (CompiledMethod
		primitive: (self primNum > 0
			ifTrue: [self primNum]
			ifFalse: [self quickMethodPrim])
		numArgs: self numArgs
		numTemps: (self numTemps max: self numArgs)
		stackSize: self stackSize
		literals: self literals
		bytecodes: self bytecodes
		trailer: trailer)! !

!BytecodeGenerator methodsFor: 'results' stamp: 'md 11/14/2003 19:43' prior: 34448670!
compiledMethodWith: trailer

	^ (CompiledMethod
		primitive: (self primNum > 0
			ifTrue: [self primNum]
			ifFalse: [self quickMethodPrim])
		numArgs: self numArgs
		numTemps: (self numTemps max: self numArgs)
		stackSize: self stackSize
		literals: self literals
		bytecodes: self bytecodes
		trailer: trailer)! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/16/2003 13:57'!
literals

	^ lastLiteral
		ifNil: [literals]
		ifNotNil: [literals asArray copyWith: lastLiteral]! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/16/2003 13:57' prior: 34449462!
literals

	^ lastLiteral
		ifNil: [literals]
		ifNotNil: [literals asArray copyWith: lastLiteral]! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27'!
numArgs

	^ numArgs! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27' prior: 34449824!
numArgs

	^ numArgs! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03'!
numTemps

	^ maxTemp! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03' prior: 34450030!
numTemps

	^ maxTemp! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27'!
primNum

	^ primNum! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27' prior: 34450238!
primNum

	^ primNum! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28'!
quickMethodPrim

	| i |
	self numArgs = 0 ifFalse: [^ 0].
	lastSpecialReturn ifNil: [^ 0].
	seqBytes size = 1 ifFalse: [^ 0].
	^ lastSpecialReturn selector caseOf: {
		[#returnReceiver] -> [256].
		[#returnConstant:] -> [
			(i _ SpecialConstants indexOf: lastSpecialReturn argument) > 0
				ifTrue: [256 + i] ifFalse: [0]].
		[#returnInstVar:] -> [263 + lastSpecialReturn argument]
	  }! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28' prior: 34450444!
quickMethodPrim

	| i |
	self numArgs = 0 ifFalse: [^ 0].
	lastSpecialReturn ifNil: [^ 0].
	seqBytes size = 1 ifFalse: [^ 0].
	^ lastSpecialReturn selector caseOf: {
		[#returnReceiver] -> [256].
		[#returnConstant:] -> [
			(i _ SpecialConstants indexOf: lastSpecialReturn argument) > 0
				ifTrue: [256 + i] ifFalse: [0]].
		[#returnInstVar:] -> [263 + lastSpecialReturn argument]
	  }! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03'!
stackSize

	^ (stacks collect: [:s | s length]) max! !

!BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03' prior: 34451386!
stackSize

	^ (stacks collect: [:s | s length]) max! !

!BytecodeGenerator methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:00'!
mapBytesTo: instr
	"Associate next byte with instr"

	instrMap add: instr -> (bytes size + 1)! !

!BytecodeGenerator methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:00' prior: 34451656!
mapBytesTo: instr
	"Associate next byte with instr"

	instrMap add: instr -> (bytes size + 1)! !

!BytecodeGenerator commentStamp: 'ajh 5/23/2003 10:59' prior: 0!
I generate bytecodes in response to 'instructions' messages being sent to me.  I rewrite jumps at the end so their jump offsets are correct (see #bytecodes).  For example, to create a compiled method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in IRBuilder), do:

	BytecodeGenerator new
		numArgs: 1;
		pushInstVar: 1;
		pushTemp: 1;
		send: #>;
		if: false goto: #else;
		pushLiteral: 'yes';
		returnTop;
		label: #else;
		pushLiteral: 'no';
		returnTop;
		compiledMethod

You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree.
!
!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:44'!
bytecodeTableFrom: specArray
	"SpecArray is an array of either
	(index selector) or
	(index1 index2 selector)."

	| contiguous |
	Bytecodes _ IdentityDictionary new: 256.
	BytecodeTable _ Array new: 256.
	contiguous _ 0.
	specArray do: [ :spec |
		(spec at: 1) = contiguous ifFalse: [self error: 'Non-contiguous table entry'].
		spec size = 2 ifTrue: [
			Bytecodes at: (spec at: 2) put: (spec at: 1).
			BytecodeTable at: (spec at: 1) + 1 put: (spec at: 2).
			contiguous _ contiguous + 1.
		] ifFalse: [
			spec size = 3 ifFalse: [self error: 'bad spec size'].
			Bytecodes at: (spec at: 3) put: ((spec at: 1) to: (spec at: 2)).
			(spec at: 1) to: (spec at: 2) do: [ :i |
				BytecodeTable at: i + 1 put: (spec at: 3).
			].
			contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1.
		].
	].
	^ BytecodeTable! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:44' prior: 34452739!
bytecodeTableFrom: specArray
	"SpecArray is an array of either
	(index selector) or
	(index1 index2 selector)."

	| contiguous |
	Bytecodes _ IdentityDictionary new: 256.
	BytecodeTable _ Array new: 256.
	contiguous _ 0.
	specArray do: [ :spec |
		(spec at: 1) = contiguous ifFalse: [self error: 'Non-contiguous table entry'].
		spec size = 2 ifTrue: [
			Bytecodes at: (spec at: 2) put: (spec at: 1).
			BytecodeTable at: (spec at: 1) + 1 put: (spec at: 2).
			contiguous _ contiguous + 1.
		] ifFalse: [
			spec size = 3 ifFalse: [self error: 'bad spec size'].
			Bytecodes at: (spec at: 3) put: ((spec at: 1) to: (spec at: 2)).
			(spec at: 1) to: (spec at: 2) do: [ :i |
				BytecodeTable at: i + 1 put: (spec at: 3).
			].
			contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1.
		].
	].
	^ BytecodeTable! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'!
initialize

	self initializeBytecodeTable.
	self initializeSpecialSelectors.
	self initializeSpecialConstants.
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40' prior: 34454557!
initialize

	self initializeBytecodeTable.
	self initializeSpecialSelectors.
	self initializeSpecialConstants.
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:42'!
initializeBytecodeTable
	"BytecodeWriteStream initialize"
	"Defines all the bytecode instructions for the Compiler and the Interpreter.
	The following bytecode tuple format is:

	#(bytecode bytecodeSelector)

	bytecodeSelector is the method in the Interpreter that gets executed for the given bytecode.
	Common Send selector position within the specialSelectorsArray is hard code in the Interpreter, see senders of Interpreter specialSelector:."

	^ self bytecodeTableFrom:
	#(
		(  0  15 pushReceiverVariableBytecode)
		( 16  31 pushTemporaryVariableBytecode)
		( 32  63 pushLiteralConstantBytecode)
		( 64  95 pushLiteralVariableBytecode)
		( 96 103 storeAndPopReceiverVariableBytecode)
		(104 111 storeAndPopTemporaryVariableBytecode)
		(112 pushReceiverBytecode)
		(113 pushConstantTrueBytecode)
		(114 pushConstantFalseBytecode)
		(115 pushConstantNilBytecode)
		(116 pushConstantMinusOneBytecode)
		(117 pushConstantZeroBytecode)
		(118 pushConstantOneBytecode)
		(119 pushConstantTwoBytecode)
		(120 returnReceiver)
		(121 returnTrue)
		(122 returnFalse)
		(123 returnNil)
		(124 returnTopFromMethod)
		(125 returnTopFromBlock)
		(126 unknownBytecode)
		(127 unknownBytecode)
		(128 extendedPushBytecode)
		(129 extendedStoreBytecode)
		(130 extendedStoreAndPopBytecode)
		(131 singleExtendedSendBytecode)
		(132 doubleExtendedDoAnythingBytecode)
		(133 singleExtendedSuperBytecode)
		(134 secondExtendedSendBytecode)
		(135 popStackBytecode)
		(136 duplicateTopBytecode)
		(137 pushActiveContextBytecode)
		(138 143 experimentalBytecode)
		(144 151 shortUnconditionalJump)
		(152 159 shortConditionalJump)
		(160 167 longUnconditionalJump)
		(168 171 longJumpIfTrue)
		(172 175 longJumpIfFalse)

		"176-191 were sendArithmeticSelectorBytecode"
		(176 bytecodePrimAdd)
		(177 bytecodePrimSubtract)
		(178 bytecodePrimLessThan)
		(179 bytecodePrimGreaterThan)
		(180 bytecodePrimLessOrEqual)
		(181 bytecodePrimGreaterOrEqual)
		(182 bytecodePrimEqual)
		(183 bytecodePrimNotEqual)
		(184 bytecodePrimMultiply)
		(185 bytecodePrimDivide)
		(186 bytecodePrimMod)
		(187 bytecodePrimMakePoint)
		(188 bytecodePrimBitShift)
		(189 bytecodePrimDiv)
		(190 bytecodePrimBitAnd)
		(191 bytecodePrimBitOr)	

		"192-207 were sendCommonSelectorBytecode"
		(192 bytecodePrimAt)
		(193 bytecodePrimAtPut)
		(194 bytecodePrimSize)
		(195 bytecodePrimNext)
		(196 bytecodePrimNextPut)
		(197 bytecodePrimAtEnd)
		(198 bytecodePrimEquivalent)
		(199 bytecodePrimClass)
		(200 bytecodePrimBlockCopy)
		(201 bytecodePrimValue)
		(202 bytecodePrimValueWithArg)
		(203 bytecodePrimDo)
		(204 bytecodePrimNew)
		(205 bytecodePrimNewWithArg)
		(206 bytecodePrimPointX)
		(207 bytecodePrimPointY)

		(208 255 sendLiteralSelectorBytecode)
	)
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:42' prior: 34454963!
initializeBytecodeTable
	"BytecodeWriteStream initialize"
	"Defines all the bytecode instructions for the Compiler and the Interpreter.
	The following bytecode tuple format is:

	#(bytecode bytecodeSelector)

	bytecodeSelector is the method in the Interpreter that gets executed for the given bytecode.
	Common Send selector position within the specialSelectorsArray is hard code in the Interpreter, see senders of Interpreter specialSelector:."

	^ self bytecodeTableFrom:
	#(
		(  0  15 pushReceiverVariableBytecode)
		( 16  31 pushTemporaryVariableBytecode)
		( 32  63 pushLiteralConstantBytecode)
		( 64  95 pushLiteralVariableBytecode)
		( 96 103 storeAndPopReceiverVariableBytecode)
		(104 111 storeAndPopTemporaryVariableBytecode)
		(112 pushReceiverBytecode)
		(113 pushConstantTrueBytecode)
		(114 pushConstantFalseBytecode)
		(115 pushConstantNilBytecode)
		(116 pushConstantMinusOneBytecode)
		(117 pushConstantZeroBytecode)
		(118 pushConstantOneBytecode)
		(119 pushConstantTwoBytecode)
		(120 returnReceiver)
		(121 returnTrue)
		(122 returnFalse)
		(123 returnNil)
		(124 returnTopFromMethod)
		(125 returnTopFromBlock)
		(126 unknownBytecode)
		(127 unknownBytecode)
		(128 extendedPushBytecode)
		(129 extendedStoreBytecode)
		(130 extendedStoreAndPopBytecode)
		(131 singleExtendedSendBytecode)
		(132 doubleExtendedDoAnythingBytecode)
		(133 singleExtendedSuperBytecode)
		(134 secondExtendedSendBytecode)
		(135 popStackBytecode)
		(136 duplicateTopBytecode)
		(137 pushActiveContextBytecode)
		(138 143 experimentalBytecode)
		(144 151 shortUnconditionalJump)
		(152 159 shortConditionalJump)
		(160 167 longUnconditionalJump)
		(168 171 longJumpIfTrue)
		(172 175 longJumpIfFalse)

		"176-191 were sendArithmeticSelectorBytecode"
		(176 bytecodePrimAdd)
		(177 bytecodePrimSubtract)
		(178 bytecodePrimLessThan)
		(179 bytecodePrimGreaterThan)
		(180 bytecodePrimLessOrEqual)
		(181 bytecodePrimGreaterOrEqual)
		(182 bytecodePrimEqual)
		(183 bytecodePrimNotEqual)
		(184 bytecodePrimMultiply)
		(185 bytecodePrimDivide)
		(186 bytecodePrimMod)
		(187 bytecodePrimMakePoint)
		(188 bytecodePrimBitShift)
		(189 bytecodePrimDiv)
		(190 bytecodePrimBitAnd)
		(191 bytecodePrimBitOr)	

		"192-207 were sendCommonSelectorBytecode"
		(192 bytecodePrimAt)
		(193 bytecodePrimAtPut)
		(194 bytecodePrimSize)
		(195 bytecodePrimNext)
		(196 bytecodePrimNextPut)
		(197 bytecodePrimAtEnd)
		(198 bytecodePrimEquivalent)
		(199 bytecodePrimClass)
		(200 bytecodePrimBlockCopy)
		(201 bytecodePrimValue)
		(202 bytecodePrimValueWithArg)
		(203 bytecodePrimDo)
		(204 bytecodePrimNew)
		(205 bytecodePrimNewWithArg)
		(206 bytecodePrimPointX)
		(207 bytecodePrimPointY)

		(208 255 sendLiteralSelectorBytecode)
	)
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45'!
initializeSpecialConstants

	SpecialConstants _ {true. false. nil. -1. 0. 1. 2}! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45' prior: 34460597!
initializeSpecialConstants

	SpecialConstants _ {true. false. nil. -1. 0. 1. 2}! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'!
initializeSpecialSelectors
	"Create a map from specialSelector -> bytecode offset from sendAdd (the first one)"

	| array |
	SpecialSelectors _ IdentityDictionary new.
	array _ self specialSelectorsArray.  "Smalltalk specialObjectsArray at: 24"
	1 to: array size by: 2 "skip numArgs" do: [:i |
		SpecialSelectors at: (array at: i) put: i - 1 / 2].
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40' prior: 34460939!
initializeSpecialSelectors
	"Create a map from specialSelector -> bytecode offset from sendAdd (the first one)"

	| array |
	SpecialSelectors _ IdentityDictionary new.
	array _ self specialSelectorsArray.  "Smalltalk specialObjectsArray at: 24"
	1 to: array size by: 2 "skip numArgs" do: [:i |
		SpecialSelectors at: (array at: i) put: i - 1 / 2].
! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/15/2003 15:43'!
specialConstants

	^ SpecialConstants! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/15/2003 15:43' prior: 34461820!
specialConstants

	^ SpecialConstants! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45'!
specialSelectorsArray

	^ #(#+ 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)! !

!BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45' prior: 34462079!
specialSelectorsArray

	^ #(#+ 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)! !

!CNGBTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'!
leadingChar

	^ GB2312 leadingChar
! !

!CNGBTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 15:38'!
unicodeClass

	^ UnicodeTraditionalChinese.
! !

!CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'!
encodingNames 

	^ #('gb2312' ) copy
! !

!CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'!
example1
	"CNGBTextConverter example1"

	| fileStream |
	fileStream _ FileStream newFileNamed: 'test.gb'.
	fileStream converter: CNGBTextConverter new.
	fileStream nextPut: (MultiCharacter value: 33559461).
	fileStream nextPut: (MultiCharacter value: 33556777).
	fileStream close
! !

!CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:43'!
example2
	"CNGBTextConverter example2"

	| writeStream fileStream |
	writeStream _ WriteStream on: String new.
	fileStream _ FileStream fileNamed: 'test.gb'.
	fileStream converter: CNGBTextConverter new.
	[fileStream atEnd] whileFalse: [writeStream nextPut: fileStream next].
	fileStream close.
	^ writeStream contents
! !

!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:13'!
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: 'porcine capture' stamp: 'nk 3/8/2001 20:47'!
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: 'nk 3/8/2001 16:05'!
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: 'nk 3/8/2001 17:23'!
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: 'startup-shutdown' stamp: 'nk 3/14/2001 08:39'!
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: 'nk 3/8/2001 16:24'!
stopMonitoring
	watcher ifNotNil: [
		ProcessBrowser terminateProcess: watcher.
		watcher _ nil.
	]! !

!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: 'nk 3/8/2001 18:38'!
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 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 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: 'nk 3/14/2001 08:16'!
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: 'nk 3/14/2001 08:05'!
stopMonitoring
	"CPUWatcher stopMonitoring"

	CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ].
	CurrentCPUWatcher _ nil.
! !

!CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'!
isResumable
	^true! !

!CachingCodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40' prior: 18764503!
httpRequestClass
	^CachedHTTPDownloadRequest
! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03' prior: 18766208!
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: '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: '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' prior: 18765573!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	damageRecorder _ DamageRecorder new! !

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

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

!Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41' prior: 18771328!
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-general' stamp: 'ar 12/30/2001 15:23'!
drawMorph: aMorph
	self draw: aMorph! !

!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/10/2004 17:19' prior: 18784976!
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-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-support' stamp: 'gm 2/22/2003 14:53' prior: 18776484!
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-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: 'testing' stamp: 'nk 1/1/2004 21:09'!
isPostscriptCanvas
	^false! !

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

!CanvasCharacterScanner methodsFor: 'scanning' stamp: 'ar 12/31/2001 02:35'!
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! !

!CanvasCharacterScanner methodsFor: 'scanning' stamp: 'aoy 2/15/2003 21:24' prior: 34479556!
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: '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])! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:44' prior: 34482424!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (textStyle 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: 'RAA 3/3/2001 19:42'!
setFont
	foregroundColor ifNil: [foregroundColor _ Color black].
	super setFont.
	destY _ lineY + line baseline - font ascent! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'yo 6/8/2003 21:29' prior: 34483807!
setFont

	foregroundColor _ defaultTextColor.
	super setFont.
	destY _ lineY + line baseline - font ascent! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40' prior: 34484027!
setFont
	foregroundColor _ self defaultTextColor.
	super setFont.
	destY _ lineY + line baseline - font ascent! !

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

!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: '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' prior: 18795663!
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' prior: 18796202!
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: 'dgd 2/22/2003 18:43' prior: 18796839!
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: 
					[CachedForms ifNil: [CachedForms := Array new: 100].
					cacheNew 
						ifTrue: [CachedForms at: cacheID put: image]
						ifFalse: 
							[previousImage := CachedForms at: cacheID.
							image ifNil: [image := previousImage]
								ifNotNil: 
									[(previousImage notNil and: [image depth > 8]) 
										ifTrue: [image := previousImage addDeltasFrom: image].
									CachedForms at: cacheID put: image]]]].
	self drawCommand: 
			[:c | 
			c 
				image: image
				at: point
				sourceRect: sourceRect
				rule: rule]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:24' prior: 34486468!
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' prior: 18797943!
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: 'dgd 2/22/2003 13:18' prior: 18798312!
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: 'yo 10/23/2002 23:37'!
drawMultiText: command

	| boundsEnc colorEnc  text bounds color fontIndexEnc fontIndex |

	text := MultiString 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: 'dgd 2/22/2003 13:19' prior: 18798839!
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' prior: 18799479!
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: 'dgd 2/22/2003 13:19' prior: 18800195!
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' prior: 18800879!
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: 'ar 12/31/2001 02:33'!
drawText: command
	| boundsEnc colorEnc  text bounds color fontIndexEnc fontIndex |

	text := command at: 2.
	boundsEnc := command at: 3.
	fontIndexEnc := command at: 4.
	colorEnc := command at: 5.


	bounds _ self class decodeRectangle: boundsEnc.
	fontIndex := self class decodeInteger: fontIndexEnc.
	color _ self class decodeColor: colorEnc.

	self drawCommand: [ :c |
		c drawString: text in: bounds font: (fonts at: fontIndex) color: color ]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 34493079!
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' prior: 18802033!
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: 'RAA 3/3/2001 18:27'!
processCommand: command  onForceDo: forceBlock
	| verb verbCode |
	command isEmpty ifTrue: [ ^self ].

	verb _ command first.
	verbCode := verb at: 1.

	verbCode = CanvasEncoder codeClip ifTrue: [ ^self setClip: command ].
	verbCode = CanvasEncoder codeTransform ifTrue: [ ^self setTransform: command ].
	verbCode = CanvasEncoder codeText ifTrue: [ ^self drawText: command ].
	verbCode = CanvasEncoder codeLine ifTrue: [ ^self drawLine: command ].
	verbCode = CanvasEncoder codeRect ifTrue: [ ^self drawRect: command ].
	verbCode = CanvasEncoder codeBalloonRect ifTrue: [ ^self drawBalloonRect: command ].
	verbCode = CanvasEncoder codeBalloonOval ifTrue: [ ^self drawBalloonOval: command ].
	verbCode = CanvasEncoder codeInfiniteFill ifTrue: [ ^self drawInfiniteFill: command ].

	verbCode = CanvasEncoder codeOval ifTrue: [ ^self drawOval: command ].
	verbCode = CanvasEncoder codeImage ifTrue: [ ^self drawImage: command ].
	verbCode = CanvasEncoder codeReleaseCache ifTrue: [ ^self releaseImage: command ].
	verbCode = CanvasEncoder codePoly ifTrue: [ ^self drawPoly: command ].
	verbCode = CanvasEncoder codeStencil ifTrue: [ ^self drawStencil: command ].
	verbCode = CanvasEncoder codeForce ifTrue: [ ^self forceToScreen: command withBlock: forceBlock ].
	verbCode = CanvasEncoder codeFont ifTrue: [ ^self addFontToCache: command ].
	verbCode = CanvasEncoder codeExtentDepth ifTrue: [ ^self extentDepth: command ].
	verbCode = CanvasEncoder codeShadowColor ifTrue: [ ^self shadowColor: command ].

self error: 'unknown command: ', command first.! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:20' prior: 34494446!
processCommand: command onForceDo: forceBlock 
	| verb verbCode |
	command isEmpty
		ifTrue: [^ self].
	verb _ command first.
	verbCode _ verb first.
""
	verbCode = CanvasEncoder codeClip
		ifTrue: [^ self setClip: command].
	verbCode = CanvasEncoder codeTransform
		ifTrue: [^ self setTransform: command].
	verbCode = CanvasEncoder codeText
		ifTrue: [^ self drawText: command].
	verbCode = CanvasEncoder codeLine
		ifTrue: [^ self drawLine: command].
	verbCode = CanvasEncoder codeRect
		ifTrue: [^ self drawRect: command].
	verbCode = CanvasEncoder codeBalloonRect
		ifTrue: [^ self drawBalloonRect: command].
	verbCode = CanvasEncoder codeBalloonOval
		ifTrue: [^ self drawBalloonOval: command].
	verbCode = CanvasEncoder codeInfiniteFill
		ifTrue: [^ self drawInfiniteFill: command].
	verbCode = CanvasEncoder codeOval
		ifTrue: [^ self drawOval: command].
	verbCode = CanvasEncoder codeImage
		ifTrue: [^ self drawImage: command].
	verbCode = CanvasEncoder codeReleaseCache
		ifTrue: [^ self releaseImage: command].
	verbCode = CanvasEncoder codePoly
		ifTrue: [^ self drawPoly: command].
	verbCode = CanvasEncoder codeStencil
		ifTrue: [^ self drawStencil: command].
	verbCode = CanvasEncoder codeForce
		ifTrue: [^ self forceToScreen: command withBlock: forceBlock].
	verbCode = CanvasEncoder codeFont
		ifTrue: [^ self addFontToCache: command].
	verbCode = CanvasEncoder codeExtentDepth
		ifTrue: [^ self extentDepth: command].
	verbCode = CanvasEncoder codeShadowColor
		ifTrue: [^ self shadowColor: command].
""
	self error: 'unknown command: ' , command first! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:42' prior: 34496086!
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' prior: 18804064!
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' prior: 18804290!
setClip: command 
	| clipRectEnc |
	clipRectEnc := command second.
	clipRect := self class decodeRectangle: clipRectEnc! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:45' prior: 18804477!
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 class methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:39'!
decodeFontSet: fontString

	^ StrikeFontSet fontNamed: fontString
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 6/23/2003 20:12'!
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: '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: 'class initialization' stamp: 'nk 6/25/2003 12:45'!
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:)
	(codeTTCFont addTTCFontToCache:)
	(codeExtentDepth extentDepth:)
	(codeShadowColor shadowColor:))
		do: [ :arr |
			DecodeTable
				at: ((CanvasEncoder perform: arr first) asciiValue + 1)
				put: arr second
		].
! !

!CanvasDecoder class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 12:46'!
reinitialize
	"CanvasDecoder reinitialize"
	"Set up my cache and decode table, removing old contents."
	CachedForms _ nil.
	DecodeTable _ nil.
	self initialize.
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:36'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	| fontIndex |
	fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]).
	self sendCommand: {
		String with: CanvasEncoder codeText.
		s asString copyFrom: firstIndex to: lastIndex.
		self class encodeRectangle: boundsRect.
		self class encodeInteger: fontIndex.
		self class encodeColor: c
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'yo 10/23/2002 23:40' prior: 34501712!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	| fontIndex str |
	fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]).
	str _ s asString.
	str class = MultiString ifTrue: [
		self sendCommand: {
			String with: CanvasEncoder codeMultiText.
			(str copyFrom: firstIndex to: lastIndex) asByteArray asString.
			self class encodeRectangle: boundsRect.
			self class encodeInteger: fontIndex.
			self class encodeColor: c
		}
	] ifFalse: [
		self sendCommand: {
			String with: CanvasEncoder codeText.
			s asString copyFrom: firstIndex to: lastIndex.
			self class encodeRectangle: boundsRect.
			self class encodeInteger: fontIndex.
			self class encodeColor: c
		}
	].
! !

!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: 'dgd 2/22/2003 19:01' prior: 18818021!
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: 'fonts' stamp: 'nk 6/25/2003 12:58' prior: 18821234!
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: 'private' stamp: 'dgd 2/22/2003 14:41' prior: 18819742!
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 methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 18826041!
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 3/3/2001 18:25'!
nameForCode: aStringOrChar

	| ch |
	ch _ (aStringOrChar isKindOf: String) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar].
	ch == self codeBalloonOval ifTrue: [^'balloon oval'].
	ch == self codeBalloonRect ifTrue: [^'balloon rectangle'].
	ch == self codeClip ifTrue: [^'clip'].
	ch == self codeExtentDepth ifTrue: [^'codeExtentDepth'].
	ch == self codeFont ifTrue: [^'codeFont'].
	ch == self codeForce ifTrue: [^'codeForce'].
	ch == self codeImage ifTrue: [^'codeImage'].
	ch == self codeLine ifTrue: [^'codeLine'].
	ch == self codeOval ifTrue: [^'codeOval'].
	ch == self codePoly ifTrue: [^'codePoly'].
	ch == self codeRect ifTrue: [^'codeRect'].
	ch == self codeReleaseCache ifTrue: [^'codeReleaseCache'].
	ch == self codeStencil ifTrue: [^'codeStencil'].
	ch == self codeText ifTrue: [^'codeText'].
	ch == self codeTransform ifTrue: [^'codeTransform'].
	ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill'].
	ch == self codeShadowColor ifTrue: [^'shadowColor'].
	^'????'
! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'yo 3/21/2003 23:01' prior: 34505941!
nameForCode: aStringOrChar

	| ch |
	ch _ (aStringOrChar isKindOf: String) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar].
	ch == self codeBalloonOval ifTrue: [^'balloon oval'].
	ch == self codeBalloonRect ifTrue: [^'balloon rectangle'].
	ch == self codeClip ifTrue: [^'clip'].
	ch == self codeExtentDepth ifTrue: [^'codeExtentDepth'].
	ch == self codeFont ifTrue: [^'codeFont'].
	ch == self 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: 'nb 6/17/2003 12:25' prior: 18828220!
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: 'codes' stamp: 'yo 10/23/2002 23:41'!
codeFontSet

	^ $S
! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:42'!
codeMultiText

	^ $c
! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 3/3/2001 18:24'!
codeShadowColor

	^$s! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'yo 3/21/2003 23:00'!
codeTTCFont

	^ $T.
! !

!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: 'tk 5/28/2001 14:54'!
allStringsAfter: aText
	| list ok instVarValue string |
	"return an OrderedCollection of strings of text in my instance vars.  If aText is non-nil, begin with that object."

	list _ OrderedCollection new.
	ok _ aText == nil.
	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: 'dgd 2/22/2003 14:43' prior: 34510964!
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: '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 5/7/2001 15:51'!
url
	"For now, don't know we could be on a server"

	^ nil! !

!CardPlayer methodsFor: 'misc' stamp: 'tk 9/28/2001 13:00'!
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."

	| aTile  tile |
	Preferences universalTiles ifTrue:
		[tile _ SyntaxMorph new parseNode: 
			(VariableNode new name: 'self' key: 'self' code: 112).
		tile layoutInset: 1; addMorph: (tile addString: 'self' special: false).
			"translate to wordy variant here..."
		tile color: (SyntaxMorph translateColor: #variable).
		tile extent: tile firstSubmorph extent + (2@2).
		^ tile].

	aTile _ TileMorph new setToReferTo: self.
	^ aTile! !

!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 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 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: 'slots' stamp: 'sw 2/18/2001 17:02'!
compileAccessorsFor: varName
	"Compile instance-variable accessor methods for the given variable name"

	| nameString |
	nameString _ varName asString capitalized.
	self compileInobtrusively: ('get', nameString, '
	^ ', varName)
		classified: 'access'.
	self compileInobtrusively: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access'! !

!CardPlayer class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41' prior: 34517131!
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' prior: 18834410!
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: '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].
! !

!CascadeNode methodsFor: 'tiles' stamp: 'RAA 2/22/2001 13:56'!
asMorphicSyntaxIn: parent

	^parent
		cascadeNode: self 
		receiver: receiver 
		messages: messages
! !

!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: 'NS 4/7/2004 10:36'!
changeFromCategorySpecs: categorySpecs 
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| oldElements newElements newCategories newStops currentStop temp ii cc catSpec |
	oldElements _ elementArray asSet.
	newCategories _ Array new: categorySpecs size.
	newStops _ Array new: categorySpecs size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: categorySpecs size do: 
		[:i | 
		catSpec _ categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		catSpec allButFirst asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
				[newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect:
		[:elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	(cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element"
		temp _ categoryArray asOrderedCollection.
		temp removeAll: categoryArray asSet asOrderedCollection.
		temp do: [:dup | 
			ii _ categoryArray indexOf: dup.
			[dup _ (dup,' #2') asSymbol.  cc includes: dup] whileTrue.
			cc add: dup.
			categoryArray at: ii put: dup]].
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first].! !

!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: 'NS 4/5/2004 17:54'!
classify: element under: heading suppressIfDefault: aBoolean
	"Store the argument, element, in the category named heading.   If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein"

	| catName catIndex elemIndex realHeading |
	((heading = NullCategory) or: [heading == nil])
		ifTrue: [realHeading _ Default]
		ifFalse: [realHeading _ heading asSymbol].
	(catName _ self categoryOfElement: element) = realHeading
		ifTrue: [^ self].  "done if already under that category"

	catName ~~ nil ifTrue: 
		[(aBoolean and: [realHeading = Default])
				ifTrue: [^ self].	  "return if non-Default category already assigned in memory"
		self removeElement: element].	"remove if in another category"

	(categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].

	catIndex _ categoryArray indexOf: realHeading.
	elemIndex _ 
		catIndex > 1
			ifTrue: [categoryStops at: catIndex - 1]
			ifFalse: [0].
	[(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) 
		and: [element >= (elementArray at: elemIndex)]] whileTrue.

	"elemIndex is now the index for inserting the element. Do the insertion before it."
	elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1
						with: (Array with: element).

	"add one to stops for this and later categories"
	catIndex to: categoryArray size do: 
		[:i | categoryStops at: i put: (categoryStops at: i) + 1].

	(self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! !

!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/5/2004 17:44'!
removeElement: element 
	"Remove the selector, element, from all categories."
	| categoryIndex elementIndex nextStop newElements |
	categoryIndex _ 1.
	elementIndex _ 0.
	nextStop _ 0.
	"nextStop keeps track of the stops in the new element array"
	newElements _ WriteStream on: (Array new: elementArray size).
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			[[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: 
					[categoryStops at: categoryIndex put: nextStop.
					categoryIndex _ categoryIndex + 1].
			(elementArray at: elementIndex) = element
				ifFalse: 
					[nextStop _ nextStop + 1.
					newElements nextPut: (elementArray at: elementIndex)]].
	[categoryIndex <= categoryStops size]
		whileTrue: 
			[categoryStops at: categoryIndex put: nextStop.
			categoryIndex _ categoryIndex + 1].
	elementArray _ newElements contents! !

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

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

!CategoryViewer methodsFor: 'categories' stamp: 'sw 11/11/2001 21:07'!
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 orOf: TilePadMorph)
			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 11/16/2001 14:15'!
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: #'instance variables'].
	aMenu _ CustomMenu labels: aList lines: lineList selections: aList.
	reply _ aMenu startUpWithCaption: 'category'.
	reply ifNil: [^ self].
	self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol
! !

!CategoryViewer methodsFor: 'categories' stamp: 'dgd 2/22/2003 14:25' prior: 34538758!
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 isEmpty ifTrue: [aList add: #'instance variables'].
	aMenu := CustomMenu 
				labels: aList
				lines: lineList
				selections: aList.
	reply := aMenu startUpWithCaption: 'category'.
	reply ifNil: [^self].
	self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol! !

!CategoryViewer methodsFor: 'categories' stamp: 'dgd 10/8/2003 18:50' prior: 34539552!
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 isEmpty ifTrue: [aList add: #'instance variables'].
	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 3/2/2004 23:53' prior: 34540365!
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 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: 'sw 9/6/2002 10:55'!
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].

	chosen _ (SelectionMenu selections: hits) startUp.
	chosen isEmptyOrNil ifFalse:
		[self outerViewer addCategoryViewerFor: chosen atEnd: true]

	! !

!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: '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: 'sw 9/27/2001 21:44'!
setNaturalLanguageTo: aLanguage
	"Set the natural language symbol as indicated"

	chosenCategorySymbol ifNil: [^ self delete].
	self updateCategoryNameTo: ((self currentVocabulary ifNil: [Vocabulary eToyVocabulary]) categoryWordingAt: chosenCategorySymbol)! !

!CategoryViewer methodsFor: 'editing pane' stamp: 'nb 6/17/2003 12:25' prior: 18850677!
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: 'md 11/14/2003 16:21' prior: 18852556!
addIsOverColorDetailTo: aRow
	| clrTile readout aTile |
	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
	aRow addMorphBack: (clrTile _ Color blue newTileMorphRepresentative).
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"
	readout _ UpdatingStringMorphWithArgument new
			target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
			argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
	readout useDefaultFormat.
	aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
	aTile addMorphBack: readout.
	aRow addMorphBack: aTile.
	aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 9/6/2002 11:54'!
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:20' prior: 34548099!
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' prior: 18853358!
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: 'sw 5/29/2001 11:44'!
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'.
	^ aButton! !

!CategoryViewer methodsFor: 'entries' stamp: 'dgd 9/1/2003 13:50' prior: 34549664!
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: 'md 11/14/2003 16:20' prior: 34550603!
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: 'sw 8/22/2002 14:24'!
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 documentationOrNil.
	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.
				aPhrase setOperator: cmd
					type: resultType
					rcvrType: #Player
					argType: argType.
				argTile _ ScriptingSystem tileForArgType: argType.
				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) documentationOrNil].
			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'].

	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.
	(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: 'dgd 9/1/2003 15:01' prior: 34552487!
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 documentationOrNil.
	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.
				aPhrase setOperator: cmd
					type: resultType
					rcvrType: #Player
					argType: argType.
				argTile _ ScriptingSystem tileForArgType: argType.
				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) documentationOrNil].
			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.
	(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: 'sw 3/4/2004 13:25' prior: 34555782!
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 documentationOrNil.
	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.
				aPhrase setOperator: cmd
					type: resultType
					rcvrType: #Player
					argType: argType.
				argTile _ ScriptingSystem tileForArgType: argType.
				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) documentationOrNil].
			aDocString ifNil:
				[balloonTextSelector _ #userScript]].

	tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. 
	aDocString
		ifNotNil:
			[tileBearingHelp setBalloonText: aDocString translated]
		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: 'sw 9/6/2002 11:50'!
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 |

	aRow _ ViewerLine newRow
		color: self color;
		beSticky;
		elementSymbol: (slotName _ aMethodInterface selector);
		wrapCentering: #center;
		cellPositioning: #leftCenter.

	(universal _ scriptedPlayer isUniversalTiles) ifFalse:
		[aRow addMorphBack: (Morph new color: self color;
		extent: 11 @ 22; yourself)].  "spacer"

	aRow addMorphBack: (self infoButtonFor: slotName).
	aRow addMorphBack: (Morph new color: self color; extent: 0@10).  " 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:
			[aRow addMorphBack: self tileForSelf bePossessive.
			aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
			getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType].

	aRow addMorphBack: getterButton.
	(doc _ aMethodInterface documentationOrNil) ifNotNil:
		[getterButton setBalloonText: doc].

	universal ifFalse:
		[(slotName == #seesColor:) ifTrue:
			[self addIsOverColorDetailTo: aRow.
			^ aRow].
		(slotName == #touchesA:) ifTrue:
			[self addTouchesADetailTo: aRow.
			^ aRow].
		(slotName == #overlaps:) 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)].
		aRow addMorphBack: anArrow].
	(#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse:
 		[(universal and: [slotName == #seesColor:]) ifFalse:
			[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: 'nk 7/12/2003 06:58' prior: 34562674!
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 buttonFont |
	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: '!!') + 6) @ (buttonFont height + 6));
					 yourself)].
	"spacer"
	aRow
		addMorphBack: (self infoButtonFor: slotName).
	aRow addMorphBack: (Morph new color: self color;
			 extent: 0 @ 10).
	"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: [aRow addMorphBack: self tileForSelf bePossessive.
			aRow addMorphBack: (Morph new color: self color;
					 extent: 2 @ 10).
			"spacer"
			getterButton := self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType].
	aRow addMorphBack: getterButton.
	(doc := aMethodInterface documentationOrNil)
		ifNotNil: [getterButton setBalloonText: doc].
	universal
		ifFalse: [slotName == #seesColor:
				ifTrue: [self addIsOverColorDetailTo: aRow.
					^ aRow].
			slotName == #touchesA:
				ifTrue: [self addTouchesADetailTo: aRow.
					^ aRow].
			slotName == #overlaps:
				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)].
			aRow addMorphBack: anArrow].
	(#(#color:sees: #playerSeeingColor #copy #touchesA: #overlaps: ) includes: slotName)
		ifFalse: [(universal
					and: [slotName == #seesColor:])
				ifFalse: [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 3/4/2004 13:29' prior: 34565673!
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 |

	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: '!!') + 6) @ (buttonFont height + 6));
					 yourself)].  "spacer"

	aRow addMorphBack: (self infoButtonFor: slotName).
	aRow addMorphBack: (Morph new color: self color; extent: 0@10).  " 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 documentationOrNil) ifNotNil:
		[getterButton setBalloonText: doc translated].

	universal ifFalse:
		[(slotName == #seesColor:) ifTrue:
			[self addIsOverColorDetailTo: aRow.
			^ aRow].
		(slotName == #touchesA:) ifTrue:
			[self addTouchesADetailTo: aRow.
			^ aRow].
		(slotName == #overlaps:) 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:) 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: 'nk 7/12/2004 22:55' prior: 34568926!
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 |

	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).  " 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 documentationOrNil) ifNotNil:
		[getterButton setBalloonText: doc translated].

	universal ifFalse:
		[(slotName == #seesColor:) ifTrue:
			[self addIsOverColorDetailTo: aRow.
			^ aRow].
		(slotName == #touchesA:) ifTrue:
			[self addTouchesADetailTo: aRow.
			^ aRow].
		(slotName == #overlaps:) 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:) 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: 'nk 7/12/2004 22:55' prior: 34573494!
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 |

	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).  " 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 documentationOrNil) ifNotNil:
		[getterButton setBalloonText: doc translated].

	universal ifFalse:
		[(slotName == #seesColor:) ifTrue:
			[self addIsOverColorDetailTo: aRow.
			^ aRow].
		(slotName == #touchesA:) ifTrue:
			[self addTouchesADetailTo: aRow.
			^ aRow].
		(slotName == #overlaps:) 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:) 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 11/29/2001 13:15'!
readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector
	"Answer a readout morph for the given part"

	| readout |
	readout _ (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector.
	"The below is a regrettable temporary expedient"
	(#(getScaleFactor "etc.") includes: getSelector) ifTrue:
		[readout setProperty: #arrowDelta toValue: 0.1.
		(readout findA: UpdatingStringMorph) floatPrecision: 0.1].
	readout step.
	^ readout! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 9/6/2002 11:31'!
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:) includes: aSymbol]) ifTrue: [^ false].
	^ true! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51' prior: 18858662!
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: 'ar 3/17/2001 14:19'!
arrowSetterButtonFor: partName type: partType

	| m |
	m _ RectangleMorph new
		color: (ScriptingSystem colorForType: #command);
		extent: 24@TileMorph defaultH;
		borderWidth: 0.
	m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')).
	m setBalloonText: 'drag from here to obtain an assignment phrase.'.
	m on: #mouseDown send: #makeSetter:event:from:
		to: self
		withValue: (Array with: partName with: partType).
	^ m
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51' prior: 34584163!
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: 'sw 9/6/2002 11:57'!
getterTilesFor: getterSelector type: aType
	"Answer classic getter for the given name/type"

	|  selfTile selector  aPhrase |
	"aPhrase _ nil, assumed"
	(#(color:sees: colorSees) includes: getterSelector) ifTrue: [aPhrase _ self colorSeesPhrase].
	(#(seesColor: isOverColor) includes: getterSelector) ifTrue: [aPhrase _ self seesColorPhrase].
	(#(overlaps: overlaps) includes: getterSelector) ifTrue: [aPhrase _ self overlapsPhrase].
	(#(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 at: 2.
	(Vocabulary vocabularyNamed: aType capitalized)
		ifNotNilDo:
			[:aVocab | aVocab wantsSuffixArrow ifTrue:
				[selector addSuffixArrow]].
	selector updateLiteralLabel.
	aPhrase enforceTileColorPolicy.
	^ aPhrase! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 2/22/2003 19:00' prior: 34585973!
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].
	(#(#seesColor: #isOverColor) includes: getterSelector) 
		ifTrue: [aPhrase := self seesColorPhrase].
	(#(#overlaps: #overlaps) includes: getterSelector) 
		ifTrue: [aPhrase := self overlapsPhrase].
	(#(#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.
	(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: 'sw 9/14/2002 12:27'!
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 |
	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 isKindOf: Number])
				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: 'gm 2/22/2003 13:12' prior: 34588892!
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 |
	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 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: 'sw 9/6/2002 11:30'!
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)].
	aMethodInterface selector == #touchesA: ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Player.
		ms arguments: (Array with: argTile actualObject)].
	aMethodInterface selector == #overlaps: 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 12/11/2001 19:08'!
addHeaderMorph
	"Add the header at the top of the viewer, with a control for choosing the category, etc."

	| header aFont aButton |
	header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
	aFont _ Preferences standardButtonFont.
	header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont).
	aButton target: self;
			color:  Color tan;
			actionSelector: #delete;
			setBalloonText: 'remove this pane from the screen
don''t worry -- nothing will be lost!!.'.
	self maybeAddArrowsTo: header.
	header beSticky.
	self addMorph: header.
	self addNamePaneTo: header.
	chosenCategorySymbol _ #basic! !

!CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 15:02' prior: 34597139!
addHeaderMorph
	"Add the header at the top of the viewer, with a control for choosing the category, etc."

	| header aFont aButton |
	header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
	aFont _ Preferences standardButtonFont.
	header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont).
	aButton target: self;
			color:  Color tan;
			actionSelector: #delete;
			setBalloonText: 'remove this pane from the screen
don''t worry -- nothing will be lost!!.' translated.
	self maybeAddArrowsTo: header.
	header beSticky.
	self addMorph: header.
	self addNamePaneTo: header.
	chosenCategorySymbol _ #basic! !

!CategoryViewer methodsFor: 'header pane' stamp: 'sw 12/11/2001 15:37'!
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: (StrikeFont familyName: #NewYork size: 12)) color: Color black.
	aButton target: self; arguments: Array new; actionSelector: #chooseCategory.
	aButton actWhen: #buttonDown.
	namePane addMorph: aButton.
	aButton position: namePane position.
	namePane align: namePane topLeft with: (bounds topLeft + (50 @ 0)).
	namePane setBalloonText: 'category (click here to choose a different one)'.

	header addMorphBack: namePane.
	(namePane isKindOf: RectangleMorph) ifTrue:
		[namePane addDropShadow.
		namePane shadowColor: Color gray]! !

!CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:46' prior: 34598631!
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 standardEToysFont)
				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 11/16/2003 10:38' prior: 34599533!
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: (StrikeFont familyName: #NewYork size: 12))
				color: Color black.
	aButton target: self;
		 arguments: Array new;
		 actionSelector: #chooseCategory.
	aButton actWhen: #buttonDown.
	namePane addMorph: aButton.
	aButton position: namePane position.
	namePane align: namePane topLeft with: bounds topLeft + (50 @ 0).
	namePane setBalloonText: 'category (click here to choose a different one)' translated.
	header addMorphBack: namePane.
	(namePane isKindOf: RectangleMorph)
		ifTrue: [namePane addDropShadow.
			namePane shadowColor: Color gray]! !

!CategoryViewer methodsFor: 'header pane' stamp: 'dgd 11/26/2003 15:04' prior: 34600455!
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 standardEToysFont)
				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: 'nk 7/12/2004 23:15' prior: 34601390!
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: 'nk 7/12/2004 23:15' prior: 34602310!
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: 'sw 12/11/2001 19:12'!
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'.	
	wrpr submorphs first  setBalloonText: 'next category'! !

!CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:47' prior: 34604139!
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 8/17/2002 01:54'!
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 chosenCategorySymbol: 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: '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: 'sw 9/27/2001 16:39'!
booleanPhraseFromPhrase: phrase
	"Answer, if possible, a boolean-valued phrase derived from the phrase provided"

	|  retrieverOp retrieverTile |
	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: 
			[^ 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 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 5/4/2001 05:32'!
tileForSelf
	"Return a tile representing the receiver's viewee"

	^ scriptedPlayer tileToRefer
! !

!CautiousModel methodsFor: 'updating' stamp: 'nb 6/17/2003 12:25' prior: 18867849!
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"! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 9/5/2001 13:53'!
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: 'tpr 10/4/2001 21:58'!
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: 'sw 11/13/2001 08:50'!
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: 'nk 1/7/2004 11:08'!
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: 'RAA 5/28/2001 11:37'!
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: 'nk 1/7/2004 10:23'!
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: 'sw 12/3/2002 22:33'!
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 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: 'nk 1/7/2004 11:11' prior: 34614140!
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: 'sw 5/20/2001 21:18'!
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: 'sw 8/15/2002 22:35'!
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: 5@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;
				useRoundedCorners;
				label: triplet first asString;
				askBeforeChanging: true;
				onColor: Color transparent offColor: Color transparent.

			aRow addMorphBack: aButton.
			aButton setBalloonText: triplet third].
	aRow addMorphBack: self regularDiffButton.
	self wantsPrettyDiffOption ifTrue:
		[aRow addMorphBack: self prettyDiffButton].
	^ aRow! !

!ChangeList methodsFor: 'menu actions' stamp: 'ar 2/24/2001 18:29'!
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: 'sw 6/6/2001 12:54'!
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 5/23/2003 14:24' prior: 18976609!
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: 'di 4/6/2001 09:03'!
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 _ (PopUpMenu labels: aStream contents) startUp.
	index > 0 ifTrue: [
		self selectConflicts: (all at: index)].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 12/3/2002 22:27'!
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: 'nk 1/7/2004 09:16' prior: 18979759!
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: 'viewing access' stamp: 'sw 6/18/2001 10:44'!
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: 'sw 5/19/2001 10:59'!
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: 'sw 6/7/2001 23:54'!
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' stamp: 'NS 1/28/2004 11:18' prior: 18982885!
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 1/7/2004 09:50'!
selectedClass
	^self selectedClassOrMetaClass theNonMetaClass ! !

!ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50' prior: 34629185!
selectedClass
	^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! !

!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: 'HK 4/18/2002 15:02'!
browseRecent: 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.
	self
		open: changeList
		name: 'Recent changes'
		multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'HK 4/24/2002 16:55'!
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: Smalltalk lastQuitLogPosition! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:10' prior: 34630262!
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: 'sw 7/4/2002 19:05'!
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: '----SNAPSHOT----' startingAt: 1)
								= 1
							or: [(chunk indexOfSubCollection: '----QUIT----' startingAt: 1)
									= 1])
						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: 'nk 7/8/2003 13:56' prior: 34630913!
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: 'sw 1/2/2003 21:39'!
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.
	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: 'sw 7/4/2002 18:54'!
browseRecentLogOnPath: fullName 
	"figure out where the last snapshot or quit was, then browse the recent  entries."

	fullName
		ifNotNil:
			[self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)]
		ifNil:
			[self beep]
	! !

!ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25' prior: 34634472!
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/16/2003 14:11' prior: 18988048!
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: 'instance creation' stamp: 'tpr 10/8/2001 21:02'!
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: '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: 'initialize-release' stamp: 'hg 8/3/2000 18:14'!
initialize

	FileList registerFileReader: self! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'hg 8/3/2000 18:12'!
browseChangesFile: fullName
	"Browse the selected file in fileIn format."

	fullName
		ifNotNil:
			[ChangeList browseStream: (FileStream oldFileNamed: fullName)]
		ifNil:
			[self beep]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'asm 5/3/2003 10:57' prior: 34639186!
browseChangesFile: fullName
	"Browse the selected file in fileIn format."

	fullName
		ifNotNil:
			[ChangeList browseStream: (FileStream readOnlyFileNamed:  fullName)]
		ifNil:
			[self beep]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'md 10/22/2003 16:13' prior: 34639465!
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: 'nk 12/13/2002 11:58'!
browseCompressedChangesFile: fullName
	"Browse the selected file in fileIn format."
	| zipped unzipped |
	fullName ifNil: [ ^self beep ].
	zipped _ GZipReadStream on: (FileStream readOnlyFileNamed: fullName).
	unzipped _ ReadStream on: zipped contents asString.
	ChangeList browseStream: unzipped! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 18:56'!
fileReaderServicesForFile: fullName suffix: suffix

	^ (FileStream isSourceFileSuffix: suffix)
		ifTrue:
			[Array with: self serviceBrowseChangeFile]
		ifFalse:
			[suffix = 'changes'
				ifTrue:
					[Array with: self serviceBrowseDotChangesFile]
				ifFalse:
					[#()]]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:05' prior: 34640395!
fileReaderServicesForFile: fullName suffix: suffix 
	(FileStream isSourceFileSuffix: suffix)
		ifTrue: [^ Array with: self serviceBrowseChangeFile].
	suffix = 'changes'
		ifTrue: [^ Array with: self serviceBrowseDotChangesFile].
	(fullName asLowercase endsWith: '.cs.gz')
		ifTrue: [^ Array with: self serviceBrowseCompressedChangeFile].
	^ #()! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:48' prior: 34640762!
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: 'sw 2/17/2002 00:13'!
serviceBrowseChangeFile
	"Answer a service for opening a changelist browser on a file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'changelist browser'
		selector: #browseChangesFile:
		description: 'open a changelist tool on this file'
		buttonLabel: 'changes'! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 7/24/2003 17:15' prior: 34641731!
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 directory readOnlyFileNamed: fileList fileName ]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35' prior: 34642092!
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: 'sw 7/4/2002 19:05'!
services
	"Answer potential file services associated with this class"

	^ Array with: self serviceBrowseChangeFile with: self serviceBrowseDotChangesFile! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:04' prior: 34643706!
services
	"Answer potential file services associated with this class"

	^ { self serviceBrowseChangeFile. 
		self serviceBrowseDotChangesFile.
		self serviceBrowseCompressedChangeFile }! !

!ChangeList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!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: 'sw 5/19/2001 11:06'!
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]! !

!ChangeListForProjects commentStamp: '<historical>' prior: 0!
A ChangeList that looks at the changes in a revokable project.  This class has no users at present.!
!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: 'dew 9/7/2001 00:27'!
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 _ ChangeSorter 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: '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: '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 ]]! !

!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: 'change logging' stamp: 'tk 6/11/2001 17:53'!
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 1/19/2004 18:30' prior: 34650104!
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 1/27/2004 15:55'!
event: anEvent
	"Hook for SystemChangeNotifier"

	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) 
		ifTrue: [self noteRemovalOf: anEvent item].
	(anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier classKind]) 
		ifTrue: [self addClass: anEvent item].
	(anEvent isModified and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]].
	(anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self commentClass: anEvent item].
	(anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil].
	(anEvent isModified and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem].
	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}].
	(anEvent isRenamed and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self renameClass: anEvent item as: anEvent newName].
	(anEvent isReorganized and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self reorganizeClass: anEvent item].! !

!ChangeSet methodsFor: 'change logging' stamp: 'NS 4/12/2004 22:44' prior: 34652016!
event: anEvent
	"Hook for SystemChangeNotifier"

	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) 
		ifTrue: [self noteRemovalOf: anEvent item].
	(anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier classKind]) 
		ifTrue: [self addClass: anEvent item].
	(anEvent isModified and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]].
	(anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self commentClass: anEvent item].
	(anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil].
	(anEvent isModified and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem].
	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}].
	(anEvent isRenamed and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self renameClass: anEvent item as: anEvent newName].
	(anEvent isReorganized and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self reorganizeClass: anEvent item].
	(anEvent isRecategorized and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [self reorganizeClass: anEvent itemClass].! !

!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: '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: 'gm 2/16/2003 20:39' prior: 19006728!
editPostscript
	"edit the receiver's postscript, in a separate window.  "

	| deps found |
	self assurePostscriptExists.
	deps := postscript dependents 
				select: [:m | (m isSystemWindow) or: [m isKindOf: StandardSystemView]].
	deps size > 0 
		ifTrue: 
			[Smalltalk isMorphic 
				ifTrue: 
					[found := deps 
								detect: [:obj | obj isSystemWindow and: [obj world == self currentWorld]]
								ifNone: [nil].
					found ifNotNil: [^found activate]]
				ifFalse: 
					[found := deps detect: 
									[:obj | 
									(obj isKindOf: StandardSystemView) 
										and: [ScheduledControllers scheduledControllers includes: obj controller]]
								ifNone: [nil].
					found 
						ifNotNil: [^ScheduledControllers activateController: found controller]].
			self 
				inform: 'Caution -- there' , (deps size isOrAreStringWith: 'other window') 
						, '
already open on this postscript elsewhere'].
	postscript openLabel: 'Postscript for ChangeSet named ' , name! !

!ChangeSet methodsFor: '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: 'sw 3/29/2001 14:32'!
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: (Smalltalk changes methodsWithoutClassifications) name: 'unclassified methods'"! !

!ChangeSet methodsFor: 'testing' stamp: 'nk 7/2/2003 10:47' prior: 34658141!
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: 'sd 5/23/2003 14:24' prior: 19010261!
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: 'method changes' stamp: 'RAA 5/28/2001 13:43'!
browseMessagesWithPriorVersions
	"Open a message list browser on the new and changed methods in the receiver which have at least one prior version.  6/28/96 sw"

	| aList |

	aList _ self 
		messageListForChangesWhich: [ :aClass :aSelector |
			(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1
		]
		ifNone: [^self inform: 'None!!'].
	Smalltalk 
		browseMessageList: aList 
		name: self name, ' methods that have prior versions'! !

!ChangeSet methodsFor: 'method changes' stamp: 'sd 4/16/2003 09:15' prior: 34660249!
browseMessagesWithPriorVersions
	"Open a message list browser on the new and changed methods in the receiver which have at least one prior version.  6/28/96 sw"

	| aList |

	aList _ self 
		messageListForChangesWhich: [ :aClass :aSelector |
			(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1
		]
		ifNone: [^self inform: 'None!!'].
	self systemNavigation 
		browseMessageList: aList 
		name: self name, ' methods that have prior versions'! !

!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: '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: 'class changes' stamp: 'NS 1/26/2004 09:46' prior: 19016848!
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: 'NS 1/19/2004 17:49' prior: 19020173!
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: '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' prior: 19025601!
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: 'sw 6/6/2001 13:37'!
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: (Smalltalk changes methodsWithoutComments) name: 'methods lacking comments'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47' prior: 34665436!
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: 'yo 8/30/2002 13:59' prior: 19027440!
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: 'fileIn/Out' stamp: 'tk 6/8/2001 20:28'!
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 _ PopUpMenu withCaption: '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.'
		chooseFrom: pairList, #('all of these need a non-nil value'
						'all of these are OK with a nil 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: 'tk 6/8/2001 20:29'!
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 _ PopUpMenu withCaption: '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.'
		chooseFrom: pairList, #('all of these need a conversion method'
						'all of these have old values that can be erased').
	(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: 'tk 6/8/2001 11:12'!
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 _ PopUpMenu withCaption: 'You renamed class ', rec priorName, 
				' to be ', rec thisName,
				'.\Could an instance of ', rec priorName, 
				' be in a project on someone''s disk?'
			chooseFrom: #('Yes, write code to convert those instances'
				'No, no instances are in projects').
			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: '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' prior: 19028808!
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: 'nk 3/30/2002 09:03'!
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:
			[Smalltalk browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', initials, '"']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34673447!
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: 'tk 6/8/2001 11:48'!
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 _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["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 _ Smalltalk changes) == self ifFalse: [
		Smalltalk 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: [Smalltalk newChanges: restore].
	msgSet messageList isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	MessageSet open: msgSet name: 'Conversion methods for ', self name.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 15:14' prior: 34674965!
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 _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["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 current newChanges: restore].
	msgSet messageList isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	MessageSet open: msgSet name: 'Conversion methods for ', self name.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 09:01' prior: 34678203!
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 _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["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 messageList isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	MessageSet open: msgSet name: 'Conversion methods for ', self name.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 09:01' prior: 34681452!
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 _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["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 messageList isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	MessageSet open: msgSet name: 'Conversion methods for ', self name.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/29/2001 14:30'!
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:
			[Smalltalk browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34687919!
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: 'sw 7/19/2002 20:21'!
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:
			[ClassListBrowser new initForClassesNamed: 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' prior: 19032920!
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: 'RAA 5/28/2001 11:46'!
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 _ Smalltalk allUnSentMessagesIn: allChangedSelectors.
	unsent size = 0 ifTrue: [
		^self inform: 'There are no unsent 
messages in change set
', nameLine
	].

	Smalltalk 
		browseMessageList: (augList select: [ :each | unsent includes: each methodSymbol]) 
		name: 'Unsent messages in ', nameLine! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34690062!
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 _ Smalltalk 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: 'sd 4/29/2003 20:19' prior: 34690830!
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: 'FBS 1/6/2004 16:59' prior: 19034324!
chooseSubjectPrefixForEmail

	| subjectIndex |

	subjectIndex _
		(PopUpMenu labels: 'Bug fix [FIX]\Enhancement [ENH]\Goodie [GOODIE]\Test suite [TEST]\None of the above (will not be archived)' withCRs)
			startUpWithCaption: 'What type of change set\are you submitting to the list?' withCRs.

	^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[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: 'tpr 10/9/2001 16:58'!
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'"

	| file slips nameToUse |
	self checkForConversionMethods.
	nameToUse _ Preferences changeSetVersionNumbers
		ifTrue:
			[FileDirectory default nextNameFor: self name extension: 'cs']
		ifFalse:
			[(self name, FileDirectory dot, Utilities dateTimeSuffix, 
				FileDirectory dot, 'cs') asFileName].

	nameToUse size > 31 ifTrue: [nameToUse _ FillInTheBlank request:  (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo:30).
		nameToUse = '' ifTrue:[^self]].

	Cursor write showWhile:
		[[file _ FileStream newFileNamed: nameToUse.
		file header; timeStamp.
		self fileOutPreambleOn: file.
		self fileOutOn: file.
		self fileOutPostscriptOn: file.
		file trailer] ensure: [file close]].

	Preferences checkForSlips ifFalse: [^ self].

	slips _ self checkForSlips.
	(slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2])
		ifTrue: [Smalltalk browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34692987!
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'"

	| file slips nameToUse |
	self checkForConversionMethods.
	nameToUse _ Preferences changeSetVersionNumbers
		ifTrue:
			[FileDirectory default nextNameFor: self name extension: 'cs']
		ifFalse:
			[(self name, FileDirectory dot, Utilities dateTimeSuffix, 
				FileDirectory dot, 'cs') asFileName].

	(Preferences warningForMacOSFileNameLength and: [nameToUse size > 31])
		ifTrue: [
			nameToUse _ FillInTheBlank request:  (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo:30).
			nameToUse = '' ifTrue:[^self]].

	Cursor write showWhile:
		[[file _ FileStream newFileNamed: nameToUse.
		file header; timeStamp.
		self fileOutPreambleOn: file.
		self fileOutOn: file.
		self fileOutPostscriptOn: file.
		file trailer] ensure: [file close]].

	Preferences checkForSlips ifFalse: [^ self].

	slips _ self checkForSlips.
	(slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2])
		ifTrue: [self systemNavigation  browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 1/4/2004 17:07' prior: 34694458!
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'"
	| file slips nameToUse |
	self checkForConversionMethods.
	ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
	nameToUse := Preferences changeSetVersionNumbers
				ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: 'cs']
				ifFalse: [(self name , FileDirectory dot , Utilities dateTimeSuffix , FileDirectory dot , 'cs') asFileName].
	(Preferences warningForMacOSFileNameLength
			and: [nameToUse size > 31])
		ifTrue: [nameToUse := FillInTheBlank
						request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs
						initialAnswer: (nameToUse contractTo: 30).
			nameToUse = ''
				ifTrue: [^ self]].
	Cursor write
		showWhile: [[file := self defaultChangeSetDirectory newFileNamed: nameToUse.
			file header; timeStamp.
			self fileOutPreambleOn: file.
			self fileOutOn: file.
			self fileOutPostscriptOn: file.
			file trailer]
				ensure: [file close]].
	Preferences checkForSlips
		ifFalse: [^ self].
	slips := self checkForSlips.
	(slips size > 0
			and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?' chooseFrom: 'Ignore\Browse slips')
					= 2])
		ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/23/2001 13:29'!
fileOutOn: stream 
	"Write out all the changes the receiver knows about"

	| classList |
	(self isEmpty and: [stream isKindOf: FileStream])
		ifTrue: [self inform: 'Warning: no changes to file out'].
	classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection.

	"First put out rename, max classDef and comment changes."
	classList do: [:aClass | self fileOutClassDefinition: aClass on: stream].

	"Then put out all the method changes"
	classList do: [:aClass | self fileOutChangesFor: aClass on: stream].

	"Finally put out removals, final class defs and reorganization if any"
	classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream].

	self classRemoves asSortedCollection do:
		[:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 19038919!
lookForSlips
	"Scan the receiver for changes that the user may regard as slips to be remedied"

	| slips nameLine msg |
	nameLine _ '
"', self name, '"
'.
	(slips _ self checkForSlips) size == 0 ifTrue:
		[^ self inform: 'No slips detected in change set', nameLine].

	msg _ slips size == 1
		ifTrue:
			[ 'One method in change set', nameLine, 
'has a halt, reference to the Transcript,
and/or some other ''slip'' in it.
Would you like to browse it? ?']
		ifFalse:
			[ slips size printString,
' methods in change set', nameLine, 'have halts or references to the
Transcript or other ''slips'' in them.
Would you like to browse them?'].

	(PopUpMenu withCaption: msg chooseFrom: 'Ignore\Browse slips') = 2
		ifTrue: [self systemNavigation  browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'dew 9/25/2001 23:39'!
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.)"

	| usingCeleste userName server message slips |

	usingCeleste _ (Smalltalk includesKey: #Celeste) and: [Celeste isSmtpServerSet].
	usingCeleste
		ifTrue: [server _ Celeste smtpServer.
				userName _ Celeste userName.]
		ifFalse: [server _  FillInTheBlank request: 'What is your mail server for outgoing mail?'.
				userName _ FillInTheBlank request: 'What is your email address?'].

	self checkForConversionMethods.
	Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName].

	usingCeleste ifTrue:
			[CelesteComposition
				openForCeleste: Celeste current 
				initialText: message text]
		ifFalse:
			[AdHocComposition 
				openForCeleste: server
				initialText: message text].

	Preferences suppressCheckForSlips ifTrue: [^ self].
	slips _ self checkForSlips.
	(slips size > 0 and: [self confirm: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?'])
		ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name]
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'dvf 5/11/2002 00:45' prior: 34699408!
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: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name]
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34700711!
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: 'md 11/14/2003 16:22' prior: 19041953!
objectForDataStream: refStrm
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	refStrm projectChangeSet == self ifTrue: [^ self].

	"try to write reference for me"
	^ DiskProxy 
		global: #ChangeSorter
		selector: #existingOrNewChangeSetNamed: 
		args: (Array with: self name)
"===
	refStrm replace: self with: nil.
	^ nil
==="
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 10:47' prior: 19043241!
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: 'sw 3/30/2001 13:47'!
setPreambleToSay: aString
	"Make aString become the preamble of this change set"

	preamble _ StringHolder new contents: aString! !

!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: 'private' stamp: 'yo 8/30/2002 13:59' prior: 19046551!
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 class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 19:59'!
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.'].
	ChangedMessageSet openFor: 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: 'sd 5/22/2003 22:24'!
currentChangeSetString
	"ChangeSet current currentChangeSetString"

	^ 'Current Change Set: ', self current name! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'!
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"

	current isolationSet: nil.
	current _ aChangeSet.
	Smalltalk currentProjectDo:
		[:proj |
		proj setChangeSet: aChangeSet.
		aChangeSet isolationSet: proj isolationSet]! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49' prior: 34706384!
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 1/4/2004 16:10'!
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 := FileDirectory default directoryNamed: directoryName.
	dir exists
		ifTrue: [^ dir].
	^ FileDirectory default! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13' prior: 34707856!
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 7/18/2004 16:13' prior: 34708339!
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 10/15/2003 10:06'!
defaultChangeSetDirectory: dirOrName
	"Set the Preference for storing change sets to the given directory or name (possibly relative).
	If dirOrName is an empty string, use the default directory."
	"ChangeSet defaultChangeSetDirectory: 'changeSets'"
	| dirName |
	dirName _ dirOrName isString ifTrue: [ FileDirectory default fullNameFor: dirOrName ] ifFalse: [ dirOrName fullName ].
	(dirName beginsWith: FileDirectory default fullName)
		ifTrue: [ dirName _ dirName copyFrom: FileDirectory default fullName size + 2 to: dirName size ].
	Preferences setParameter: #defaultChangeSetDirectoryName to: dirName.
! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nk 3/24/2004 15:52' prior: 34709446!
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: 'di 4/5/2001 21:33'!
defaultName

	^ self uniqueNameLike: 'Unnamed'! !

!ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56' prior: 34711027!
defaultName
	^ self uniqueNameLike: 'Unnamed' translated! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nk 1/4/2004 16:47'!
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 := FileList2 modalFolderSelector.
					directoryName := dir
					ifNil: [ '' ]
						ifNotNil: [dir pathName ]]].
		self defaultChangeSetDirectory: directoryName.
		^dir! !

!ChangeSet class methodsFor: 'defaults' stamp: 'di 4/5/2001 21:31'!
uniqueNameLike: aString

	| try |
	1 to: 999999 do:
		[:i | try _ aString , i printString.
		(ChangeSorter changeSetNamed: try) ifNil: [^ try]]! !

!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: 'di 4/6/2001 10:02'!
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."

	^ ChangeSorter basicNewChangeSet: ChangeSet defaultName! !

!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 7/27/2001 20:38'!
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: 'sw 3/29/2001 23:38'!
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! !

!ChangeSetBrowser commentStamp: '<historical>' prior: 0!
A tool allowing you to browse the methods of a single change set.!
!ChangeSetCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 12:35'!
membershipSelector: aSelector
	"Set the membershipSelector"

	membershipSelector _ aSelector! !

!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: 'sw 3/30/2001 14:39'!
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: 'sw 3/30/2001 14:41'!
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: 
		[Utilities fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! !

!ChangeSetCategory methodsFor: 'services' stamp: 'sd 1/16/2004 21:37' prior: 34721429!
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: 'sw 3/30/2001 13:55'!
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 methodsFor: 'miscellaneous' stamp: 'sw 3/29/2001 11:47'!
defaultChangeSetToShow
	"Answer the name of a change-set to show"

	^ Smalltalk changes! !

!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 5/23/2003 14:25' prior: 34723786!
defaultChangeSetToShow
	"Answer the name of a change-set to show"

	^ ChangeSet current! !

!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'di 4/6/2001 10:37'!
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 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.!
!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: 'nk 6/26/2002 12:04'!
parameters: anArray
	parameters _ anArray! !

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:16'!
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]! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 5/23/2003 14:25' prior: 19050523!
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 5/23/2003 14:26' prior: 19050843!
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 2/26/2001 12:00'!
openAsMorphIn: window rect: rect
	"Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0."

	| csListHeight msgListHeight csMsgListHeight |
	contents _ ''.
	csListHeight _ 0.25.
	msgListHeight _ 0.25.
	csMsgListHeight _ csListHeight + msgListHeight.
	self addDependent: window.		"so it will get changed: #relabel"

	window addMorph: ((PluggableListMorphByItem on: self
				list: #changeSetList
				selected: #currentCngSet
				changeSelected: #showChangeSetNamed:
				menu: #changeSetMenu:shifted:
				keystroke: #changeSetListKey:from:)
			autoDeselect: false)
		frame: (((0@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #classList
				selected: #currentClassName
				changeSelected: #currentClassName:
				menu: #classListMenu:shifted:
				keystroke: #classListKey:from:)
		frame: (((0.5@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #messageList
				selected: #currentSelector
				changeSelected: #currentSelector:
				menu: #messageMenu:shifted:
				keystroke: #messageListKey:from:)
		frame: (((0@csListHeight extent: 1@msgListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	 self addLowerPanesTo: window
		at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin)
		with: nil.! !

!ChangeSorter methodsFor: 'creation' stamp: 'sps 4/3/2004 20:15' prior: 34727375!
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: 'sw 2/26/2001 12:00'!
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: 'sw 3/29/2001 14:46'!
setDefaultChangeSetCategory
	"Set a default ChangeSetCategory for the receiver, and answer it"

	^ changeSetCategory _ self class changeSetCategoryNamed: #All! !

!ChangeSorter methodsFor: 'creation' stamp: 'sw 3/29/2001 13:01'!
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: '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 3/29/2001 22:53'!
labelString
	"The label for my entire window.  The large button that displays my name is gotten via mainButtonName"

	^ String streamContents:
		[:aStream |
			aStream nextPutAll: (Smalltalk changes == myChangeSet
				ifTrue: ['Changes go to "', myChangeSet name, '"']
				ifFalse: ['ChangeSet: ', myChangeSet name]).
		(self changeSetCategory categoryName ~~ #All)
			ifTrue:
				[aStream nextPutAll:  ' - ', self parenthesizedCategoryName]]! !

!ChangeSorter methodsFor: 'access' stamp: 'sd 5/23/2003 14:25' prior: 34734644!
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: 'sw 3/29/2001 22:51'!
parenthesizedCategoryName
	"Answer my category name in parentheses"

	^ ' (', self changeSetCategory categoryName, ')'! !

!ChangeSorter methodsFor: 'access' stamp: 'di 4/5/2001 21:20'!
showChangeSetNamed: aName

	self showChangeSet: (ChangeSorter changeSetNamed: aName) ! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:30'!
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: 'RAA 5/28/2001 12:06'!
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: '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: 'di 4/5/2001 17:56'!
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: 'sw 3/30/2001 13:24'!
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: 'di 4/5/2001 17:56'!
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: 'nk 1/4/2004 17:07' prior: 19065575!
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: '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: 'RAA 5/2/2001 13:22'!
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 _ FillInTheBlank request: 'ChangeSet name or fragment?'.
	pattern isEmpty ifTrue: [^ self].
	nameList _ self changeSetList asSet.
	candidates _ AllChangeSets select:
			[:c | (nameList includes: c name) and: 
				[c name includesSubstring: pattern caseSensitive: false]].
	candidates size = 0 ifTrue: [^ self beep].
	candidates size = 1 ifTrue:
		[^ self showChangeSet: candidates first].
	index _ (PopUpMenu labels: 
		(candidates collect: [:each | each name]) asStringWithCr) startUp.
	index = 0 ifFalse: [self showChangeSet: (candidates at: index)].
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'nb 6/17/2003 12:25' prior: 34747559!
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 _ FillInTheBlank request: 'ChangeSet name or fragment?'.
	pattern isEmpty ifTrue: [^ self].
	nameList _ self changeSetList asSet.
	candidates _ 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: 'sw 4/11/2001 16:43'!
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 _ FillInTheBlank 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: 'nk 6/26/2002 12: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 _ FillInTheBlank 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: 'RAA 5/28/2001 12:07'!
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: 'RAA 5/28/2001 12:07'!
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: 'sw 10/5/2001 08:52'!
newCurrent
	"make my change set be the current one that changes go into"

	Smalltalk newChanges: myChangeSet.
	self update.  "Because list of changes in a category may thus have changed"
	self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 15:15' prior: 34752703!
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: 'sw 4/11/2001 16: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' prior: 19070283!
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: 'sw 4/11/2001 20:03'!
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: 'MU 7/1/2002 18:38'!
removeContainedInClassCategories
	| matchExpression |
	myChangeSet removePreamble.
	matchExpression :=  FillInTheBlank request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. 
	(SystemOrganization categories
		select: [:each | matchExpression match: each])
		do: [:eachCat | 
			| classNames | 
			classNames := SystemOrganization listAtCategoryNamed: eachCat.
			classNames
				do: [:eachClassName | 
					myChangeSet removeClassChanges: eachClassName.
					myChangeSet removeClassChanges: eachClassName , ' class'].
			self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:31'!
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 4/16/2002 00:18'!
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: Smalltalk changes.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 14:26' prior: 34756670!
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: 'sw 1/16/2002 22:36'!
rename
	"Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

	| newName |
	newName _ FillInTheBlank request: 'New name for this change set'
						initialAnswer: myChangeSet name.
	(newName = myChangeSet name or: [newName size == 0]) ifTrue:
			[^ self 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: 'nb 6/17/2003 12:25' prior: 34759372!
rename
	"Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

	| newName |
	newName _ FillInTheBlank request: 'New name for this change set'
						initialAnswer: myChangeSet name.
	(newName = myChangeSet name or: [newName size == 0]) ifTrue:
			[^ 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: 'sw 4/11/2001 18:18'!
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 _ FillInTheBlank 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: 'sw 3/30/2001 13:37'!
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 ', self class 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: 'sw 7/27/2002 16:24'!
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: '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: 'mu 12/11/2003 20:05' prior: 34762245!
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: 'sw 8/11/2002 01:11'!
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: 'sw 3/30/2001 13:27'!
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: 'di 4/5/2001 21:22'!
submergeIntoOtherSide
	"Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
	| other message nextToView i |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ self].
	other _ (parent other: self) changeSet.
	other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!'].
	myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy.  To remove,
simply choose "remove".'].

	myChangeSet okayToRemove ifFalse: [^ self].
	message _ 'Please confirm:  copy all changes
in "', myChangeSet name, '" into "', other name, '"
and then destroy the change set
named "', myChangeSet name, '"?'.
 
	(self confirm: message) ifFalse: [^ self].

	(myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue:
		[(self confirm: 
'Caution!!  This change set has a preamble or
a postscript or both.  If you submerge it into
the other side, these will be lost.
Do you really want to go ahead with this?') ifFalse: [^ self]].

	other assimilateAllChangesFoundIn: myChangeSet.

	nextToView _ ((AllChangeSets includes: myChangeSet)
		and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size])
		ifTrue: [AllChangeSets at: i+1]
		ifFalse: [other].

	self removePrompting: false.
	self showChangeSet: nextToView.
	parent modelWakeUp.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/20/2001 09:37'!
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: 'nb 6/17/2003 12:25' prior: 19082416!
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: '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: 'sw 10/1/2001 10:43'!
moveClassToOther
	"Place class changes in the other changeSet and remove them from this one"

	self checkThatSidesDiffer: [^ self].
	(self okToChange and: [currentClassName notNil]) ifFalse: [^ self beep].

	self copyClassToOther.
	self forgetClass! !

!ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25' prior: 34779543!
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: '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: 'nb 6/17/2003 12:25' prior: 19088794!
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: [^ self beep].
		cls _ self selectedClassOrMetaClass.
		sel _ currentSelector asSymbol.
		other absorbMethod: sel class: cls from: myChangeSet.
	
		(parent other: self) showChangeSet: other.
		self forget "removes the method from this side"]
! !

!ChangeSorter methodsFor: 'message list' prior: 19089662!
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 _ SystemNavigation new  confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass.
			confirmation == 3
				ifTrue: [^ self].
			self selectedClassOrMetaClass removeSelector: sel.
			self update.
			confirmation == 2
				ifTrue: [Smalltalk browseAllCallsOn: sel]]! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 4/15/2003 16:13' prior: 34782241!
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: [Smalltalk browseAllCallsOn: sel]]! !

!ChangeSorter methodsFor: 'message list' stamp: 'nk 6/26/2003 21:42' prior: 34782830!
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: 'sd 5/11/2003 18:38' prior: 34783421!
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: 'code pane' stamp: 'sw 11/13/2001 07:35'!
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 altSyntax) includes: contentsSymbol) ifTrue:
				[contents _ class compilerClass new
					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: '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 class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:33'!
allChangeSetNames
	^ self allChangeSets collect: [:c | c name]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:27'!
allChangeSets
	"Return the list of all current ChangeSets"

	^ 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: 'nk 6/26/2002 12:39'!
changeSet: aChangeSet containsClass: aClass
	| theClass |
	theClass _ Smalltalk classNamed: aClass.
	theClass ifNil: [^ false].
	^ aChangeSet containsClass: theClass! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'!
changeSetNamed: 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]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'!
changeSetsNamedSuchThat: nameBlock
	"(ChangeSorter changeSetsNamedSuchThat:
		[:name | name first isDigit and: [name initialInteger >= 373]])
		do: [:cs | AllChangeSets remove: cs wither]"

	^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/6/2001 09:49'!
existingOrNewChangeSetNamed: aName

	| newSet |

	^(self changeSetNamed: aName) ifNil: [
		newSet _ ChangeSet basicNewNamed: aName.
		AllChangeSets add: newSet.
		newSet
	]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:37'!
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: 'di 4/5/2001 20:03'!
promoteToTop: aChangeSet
	"make aChangeSet the first in the list from now on"
	AllChangeSets remove: aChangeSet ifAbsent: [^ self].
	AllChangeSets add: aChangeSet.
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 12/13/2003 18:22' prior: 34789460!
promoteToTop: aChangeSet
	"Make aChangeSet the first in the list from now on"

	AllChangeSets remove: aChangeSet ifAbsent: [^ self].
	AllChangeSets add: aChangeSet! !

!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: 'sw 3/30/2001 12:44'!
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: 'sw 4/16/2002 00:47'!
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: 'LEG 10/24/2001 21:21'!
initialize
	"Initialize the class variables"

	AllChangeSets == nil ifTrue:
		[AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.
	ChangeSetCategories ifNil:
		[self initializeChangeSetCategories].
	RecentUpdateMarker _ 0.

	"ChangeSorter initialize"

	FileList registerFileReader: self
! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:41' prior: 34793057!
initialize
	"Initialize the class variables"

	AllChangeSets == nil ifTrue:
		[AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.
	ChangeSetCategories ifNil:
		[self initializeChangeSetCategories].
	RecentUpdateMarker _ 0.

	"ChangeSorter initialize"

	FileList registerFileReader: self.

	self registerInFlapsRegistry.
! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 13:30'!
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: 'sw 4/16/2002 00:47'!
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: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32' prior: 34797041!
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: 'adding' stamp: 'di 4/6/2001 09:46'!
basicNewChangeSet: newName
	| newSet |
	newName ifNil: [^ nil].
	(self changeSetNamed: newName) ifNotNil:
		[self inform: 'Sorry that name is already used'.
		^ nil].
	newSet _ ChangeSet basicNewNamed: newName.
	AllChangeSets add: newSet.
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sw 12/18/2001 23:27'!
newChangeSet
	"Prompt the user for a name, and establish a new change set of
	that name (if ok), making it the current changeset.  Return nil
	of not ok, else return the actual changeset."

	| newName newSet |
	newName _ FillInTheBlank
		request: 'Please name the new change set:'
		initialAnswer: ChangeSet defaultName.
	newName isEmptyOrNil ifTrue:
		[^ nil].
	newSet _ self basicNewChangeSet: newName.
	newSet ifNotNil:
		[Smalltalk newChanges: newSet].
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sd 5/23/2003 15:15' prior: 34797813!
newChangeSet
	"Prompt the user for a name, and establish a new change set of
	that name (if ok), making it the current changeset.  Return nil
	of not ok, else return the actual changeset."

	| newName newSet |
	newName _ FillInTheBlank
		request: 'Please name the new change set:'
		initialAnswer: ChangeSet defaultName.
	newName isEmptyOrNil ifTrue:
		[^ nil].
	newSet _ self basicNewChangeSet: newName.
	newSet ifNotNil:
		[ChangeSet  newChanges: newSet].
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'tk 12/14/2001 11:14'!
newChangesFromStream: aStream named: aName
	"File in the code from the stream into a new change set whose
	name is derived from aName. Leave the 'current change set'
	unchanged. Return the new change set or nil on failure."

	| oldChanges newName newSet |
	oldChanges _ Smalltalk changes.
	PreviousSet _ oldChanges name. 		"so a Bumper update can find it"
	newName _ aName sansPeriodSuffix.
	newSet _ self basicNewChangeSet: newName.
	[newSet ifNotNil:
		[Smalltalk newChanges: newSet.
		aStream fileInAnnouncing: 'Loading ', newName, '...'.
		Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName].
	aStream close] ensure: [
			Smalltalk newChanges: oldChanges].
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sd 5/23/2003 15:15' prior: 34798913!
newChangesFromStream: aStream named: aName
	"File in the code from the stream into a new change set whose
	name is derived from aName. Leave the 'current change set'
	unchanged. Return the new change set or nil on failure."

	| oldChanges newName newSet |
	oldChanges _ ChangeSet current.
	PreviousSet _ oldChanges name. 		"so a Bumper update can find it"
	newName _ aName sansPeriodSuffix.
	newSet _ self basicNewChangeSet: newName.
	[newSet ifNotNil:
		[ChangeSet  newChanges: newSet.
		aStream fileInAnnouncing: 'Loading ', newName, '...'.
		Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName].
	aStream close] ensure: [
			ChangeSet  newChanges: oldChanges].
	^ newSet! !

!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: 'di 4/5/2001 21:13'!
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: 'sw 3/30/2001 13:43'!
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: 'sw 5/23/2001 13:30'!
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:	[(PopUpMenu labelArray: (hits collect: [:cs | cs name])
					lines: #()) startUp].
	index = 0 ifTrue: [^ self].
	(ChangeSorter new myChangeSet: (hits at: index)) open.
! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:31'!
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:	[(PopUpMenu labelArray: (hits collect: [:cs | cs name])
					lines: #()) startUp].
	index = 0 ifTrue: [^ self].
	(ChangeSetBrowser new myChangeSet: (hits at: index)) open

"ChangeSorter browseChangeSetsWithSelector: #clearPenTrails"
! !

!ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:36'!
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: 'sw 3/30/2001 00:30'!
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: 'sw 3/30/2001 00:30'!
recentUpdateMarker: aNumber
	"Set the recent update marker as indicated"

	^ RecentUpdateMarker _ aNumber! !

!ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:14'!
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.
	AllChangeSets do:
		[:aChangeSet |
			(self belongsInProjectsInRelease: aChangeSet)
				ifTrue:
					[newHead add: aChangeSet]
				ifFalse:
					[(self belongsInNumbered: aChangeSet)
						ifTrue:
							[newMid add: aChangeSet]
						ifFalse:
							[newTail add: aChangeSet]]].
	AllChangeSets _ newHead, newMid, newTail.
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! !

!ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:15'!
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 == Smalltalk changes
		ifTrue: 	[^ AllChangeSets at: (AllChangeSets size - 1)]
		ifFalse:	[^ AllChangeSets last]! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 5/23/2003 14:27' prior: 34806042!
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]! !

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

!ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sw 2/16/2002 01:31'!
fileIntoNewChangeSet: fullName
	"File in all of the contents of the currently selected file, if any, into a new change set." 

	| fn ff |
	fullName ifNil: [^ self beep].
	ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName).
	((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! !

!ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'nb 6/17/2003 12:25' prior: 34807175!
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).
	((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! !

!ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:29'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'st') | (suffix = 'cs') | (suffix = '*')
		ifTrue: [ self services]
		ifFalse: [#()]! !

!ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 01:36'!
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'! !

!ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:47'!
services

	^ Array with: self serviceFileIntoNewChangeSet

	! !

!ChangeSorter class methodsFor: 'utilities' stamp: 'sd 1/16/2004 21:36'!
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! !

!ChangedMessageSet methodsFor: 'acceptance' stamp: 'sw 6/26/2001 11: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 _ Parser 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: '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 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 class methodsFor: 'as yet unclassified' stamp: 'RAA 5/29/2001 10:19'!
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: 'RAA 5/28/2001 11:42'!
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)]! !

!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' prior: 19122253!
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: 'yo 8/27/2002 15:16' prior: 19122766!
= aCharacter 
	"Primitive. Answer true if the receiver and the argument are the same
	object (have the same object pointer) and false otherwise. Optional. See
	Object documentation whatIsAPrimitive."

	"<primitive: 110>"
	^ self == aCharacter
		or: [aCharacter class == MultiCharacter
				and: [aCharacter asciiValue = self asciiValue]].
! !

!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' stamp: 'yo 8/28/2002 13:42'!
isCharacter

	^ true.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 19123452!
isDigit

	^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self.
! !

!Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:50' prior: 19123575!
isLetter
	"Answer whether the receiver is a letter."

	^ (ClassificationTable at: value + 1)
		anyMask: LetterBits! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34814302!
isLetter

	^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self.
! !

!Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:51' prior: 19123753!
isLowercase
	"Answer whether the receiver is a lowercase letter.
	(The old implementation answered whether the receiver is not an uppercase letter.)"

	^ ((ClassificationTable at: value + 1)
		bitAnd: LowercaseBit)
		= LowercaseBit! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34814656!
isLowercase

	^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'!
isOctetCharacter

	^ value < 256.
! !

!Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:52' prior: 19124009!
isSafeForHTTP
	"whether a character is 'safe', or needs to be escaped when used, eg, in a URL"
	^ value < 128
		and: [self isAlphaNumeric
				or: ['.~-_' includes: self]]! !

!Character methodsFor: 'testing' stamp: 'yo 12/30/2002 15:55'!
isUnicode

	^ false.
! !

!Character methodsFor: 'testing' stamp: 'yo 12/30/2002 16:14'!
isUnicodeCJK

	^ self isUnicode and: [Unicode isCJK: self charCode].
! !

!Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:52' prior: 19124727!
isUppercase
	"Answer whether the receiver is an uppercase letter.
	(The old implementation answered whether the receiver is not a lowercase letter.)"

	^ ((ClassificationTable at: value + 1)
		bitAnd: UppercaseBit)
		= UppercaseBit! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34815714!
isUppercase

	^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self.
! !

!Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'!
clone
	"Answer with the receiver, because Characters are unique."! !

!Character methodsFor: 'converting' stamp: 'dgd 8/24/2003 14:53' prior: 19126781!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	
	^ Character
		value: ((ClassificationTable at: value + 1)
				bitAnd: 255)! !

!Character methodsFor: 'converting' stamp: 'yo 10/4/2003 15:00' prior: 34816326!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	
	(8r101 <= value and: [value <= 8r132])  "self isUppercase"
		ifTrue: [^ Character value: value + 8r40]
		ifFalse: [^ self]! !

!Character methodsFor: 'converting' stamp: '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: 'yo 12/30/2002 11:36'!
asUnicode

	^ value
! !

!Character methodsFor: 'converting' stamp: 'dgd 8/24/2003 14:53' prior: 19127412!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	
	^ Character
		value: (((ClassificationTable at: value + 1)
				bitShift: -8)
				bitAnd: 255)! !

!Character methodsFor: 'converting' stamp: 'yo 10/4/2003 15:00' prior: 34817143!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	
	(8r141 <= value and: [value <= 8r172])  "self isLowercase"
		ifTrue: [^ Character value: value - 8r40]
		ifFalse: [^ self]! !

!Character methodsFor: 'converting' stamp: '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: 'yo 8/18/2003 19:25' prior: 19127694!
isoToSqueak 
	"Convert receiver from iso8895-1 (actually CP1252) to mac encoding.
	Does not do lf/cr conversion!!

	To make the round-trip conversion possible, each undefined code point is mapped to a unique value.

	For each c in Character, c squeakToIso isoToSqueak = c, and c isoToSqueak squeakToIso = c is true.  Also, for each array literals in squeakToIso and isoToSqueak, self size = self asSet size is true.  Finally, the table is compabie with the 'keymap' table in the Windows VM.
"

	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' stamp: 'yo 8/18/2003 17:02' prior: 19128636!
squeakToIso
	| 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: '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: '*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: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15' prior: 34820944!
escapeEntities
	#($< '&lt;' $> '&gt;' $& '&amp;') pairsDo:
		[:k :v |
		self = k ifTrue: [^ v]].
	^ String with: self! !

!Character class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 14:47' prior: 19129854!
initialize
	"Create the table of unique Characters."
	self initializeClassificationTable! !

!Character class methodsFor: 'class initialization' stamp: 'yo 10/4/2003 16:03' prior: 34821378!
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: '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' stamp: 'yo 8/27/2002 15:15' prior: 19130853!
value: anInteger 
	"Answer the Character whose value is anInteger."

	anInteger > 255 ifTrue: [^ MultiCharacter value: anInteger].
	^ CharacterTable at: anInteger + 1.
! !

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

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

!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: 'ar 12/15/2001 23:28'!
endOfRun
	"Before arriving at the cursor location, the selection has encountered an 
	end of run. Answer false if the selection continues, true otherwise. Set 
	up indexes for building the appropriate CharacterBlock."

	| runLength lineStop |
	((characterIndex ~~ nil and:
		[runStopIndex < characterIndex and: [runStopIndex < text size]])
			or:	[characterIndex == nil and: [lastIndex < line last]])
		ifTrue:	["We're really at the end of a real run."
				runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
				characterIndex ~~ nil
					ifTrue:	[lineStop _ characterIndex	"scanning for index"]
					ifFalse:	[lineStop _ line last			"scanning for point"].
				(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
					ifTrue: 	[runStopIndex _ lineStop].
				self setStopConditions.
				^false].

	lastCharacter _ text at: lastIndex.
	characterPoint _ destX @ destY.
	((lastCharacter = Space and: [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: 'yo 11/18/2002 13:16' prior: 34828970!
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 12/15/2001 23:28'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	alignment = Justified ifTrue:[
		"Make a local copy of stop conditions so we don't modify the default"
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:44' prior: 34833429!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (textStyle 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: 'ar 12/19/2001 11:24'!
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]]]! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 18:14'!
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 == nil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint _ line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex ~~ nil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
					textLine: line].
	destX _ leftMargin _ line leftMarginForAlignment: alignment.
	destY _ line top.
	runLength _ text runLengthFor: line first.
	characterIndex ~~ nil
		ifTrue:	[lineStop _ characterIndex  "scanning for index"]
		ifFalse:	[lineStop _ line last  "scanning for point"].
	runStopIndex _ lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0.

	done  _ false.
	[done] whileFalse:
		[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth == nil
			ifTrue: [font widthOf: (text at: lastIndex)]
			ifFalse: [specialWidth]).
		(self perform: stopCondition) ifTrue:
			[characterIndex == nil
				ifTrue: ["Result for characterBlockAtPoint: "
						^ (CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifFalse: ["Result for characterBlockForIndex: "
						^ (CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern) - kern @ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: '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 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.!
!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: '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 12/31/2001 00:52'!
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.
	map _ aFont characterToGlyphMap.
	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 12/17/2001 02:08'!
scanCharactersFrom: 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: 'yo 12/27/2002 04:32' prior: 34844898!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| startEncoding selector |
	(sourceString isKindOf: String) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.].

	(sourceString isKindOf: MultiString) 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: '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 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 class methodsFor: 'class initialization' stamp: 'ar 12/17/2001 02:17'!
initialize
	"CharacterScanner initialize"
	"NewCharacterScanner initialize"
	| stopConditions |
	stopConditions _ Array new: 258.
	stopConditions atAllPut: nil.
	stopConditions at: 1+1 put: #embeddedObject.
	stopConditions at: Space asciiValue + 1 put: nil.
	stopConditions at: Tab asciiValue + 1 put: #tab.
	stopConditions at: CR asciiValue + 1 put: #cr.
	stopConditions at: EndOfRun put: #endOfRun.
	stopConditions at: CrossedX put: #crossedX.
	DefaultStopConditions _ stopConditions.! !

!CharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09' prior: 34850984!
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.
! !

!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'!
= anObject
	^self species == anObject species and: [
		self byteArrayMap = anObject byteArrayMap ]! !

!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:57'!
species
	^CharacterSet! !

!CharacterTest methodsFor: 'testing - Class Methods' stamp: 'md 4/18/2003 09:59'!
testNew
	self should: [Character new] raise: Error.! !

!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!
!ChatButtonMorph methodsFor: 'event handling' stamp: 'ar 6/4/2001 00:40'!
mouseDown: evt

	oldColor _ self fillStyle.
	self label: labelDown.
	self doButtonDownAction.

! !

!ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40' prior: 19162787!
doButtonDownAction
	(target notNil and: [actionDownSelector notNil]) 
		ifTrue: [Cursor normal showWhile: [target perform: actionDownSelector]]! !

!ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40' prior: 19163009!
doButtonUpAction
	(target notNil and: [actionUpSelector notNil]) 
		ifTrue: [Cursor normal showWhile: [target perform: actionUpSelector]]! !

!ChatNotes methodsFor: 'initialization' stamp: 'mir 11/27/2001 12:01'!
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: 'file i/o' stamp: 'mir 11/27/2001 12:04'!
audioDirectory

	(FileDirectory default directoryExists: 'audio')
		ifFalse: [FileDirectory default createDirectory: 'audio'].
	^FileDirectory default directoryNamed: 'audio'! !

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

!Class methodsFor: 'initialize-release' stamp: 'hg 10/30/2001 13:38'!
deactivate
	"A remnant from the 3.3a modules work, retained . Does nothing, but may be overridden in Metaclasses."! !

!Class methodsFor: 'initialize-release' stamp: 'ar 5/17/2003 14:14' prior: 19209575!
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 isLowercase
			ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool == nil 
		ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 
					[:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self 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: 'yo 7/15/2003 20:58' prior: 34855257!
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: 'ar 3/1/2001 22:28'!
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: 'sw 11/2/2002 22:46'!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	
	"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].
	Smalltalk removeClassFromSystem: self logged: logged.
	self obsolete! !

!Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:24' prior: 34857556!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	
	"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 removeClassFromSystem: self logged: logged.
	self obsolete! !

!Class methodsFor: 'initialize-release' stamp: 'dtl 9/16/2003 22:08' prior: 34858130!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	
	"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: 'NS 1/16/2004 15:16' prior: 34858712!
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: 'ar 3/1/2001 22:29'!
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: 'sd 3/28/2003 16:09' prior: 19211742!
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: 'NS 4/6/2004 15:32' prior: 19212580!
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: 'hg 12/12/2001 12:00'!
unload
	"Sent when a the class is removed.  Does nothing, but may be overridden by (class-side) subclasses."
! !

!Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'!
classPoolFrom: aClass
	"share the classPool with aClass."

	classPool := aClass classPool! !

!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: 'sw 5/23/2001 13:32'!
rename: aString
	"The new name of the receiver is the argument, aString."

	| newName |
	(newName _ aString asSymbol) ~= self name
		ifTrue:
			[(Smalltalk includesKey: newName)
				ifTrue: [^self error: newName , ' already exists'].
			(Undeclared includesKey: newName)
				ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
			Smalltalk renameClass: self as: newName.
			name _ newName]! !

!Class methodsFor: 'class name' stamp: 'sd 3/28/2003 15:25' prior: 34862453!
rename: aString
	"The new name of the receiver is the argument, aString."

	| newName |
	(newName _ aString asSymbol) ~= self name
		ifTrue:
			[(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 name' stamp: 'rw 8/23/2003 15:45' prior: 34862998!
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! !

!Class methodsFor: 'class name' stamp: 'NS 1/15/2004 15:41' prior: 34863557!
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: 'instance variables' stamp: 'sw 12/26/2003 19:30' prior: 19215776!
addInstVarName: aString
	"Add the argument, aString, as one of the receiver's instance variables."
	^(ClassBuilder new)
		name: self name
		inEnvironment: self environment
		subclassOf: superclass
		type: self typeOfClass
		instanceVariableNames: self instanceVariablesString, ' ', aString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
! !

!Class methodsFor: 'class variables' stamp: 'sd 3/28/2003 15:24' prior: 19216988!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		subclass scopeHas: symbol
			ifTrue: [:temp | 
					^ self error: aString 
						, ' is already used as a variable name in class ' 
						, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		self environment changes changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'class variables' stamp: 'sd 5/23/2003 14:29' prior: 34865159!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		subclass scopeHas: symbol
			ifTrue: [:temp | 
					^ self error: aString 
						, ' is already used as a variable name in class ' 
						, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		ChangeSet current changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'class variables' stamp: 'ar 5/17/2003 14:12' prior: 34866078!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		(subclass 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"
		ChangeSet current changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'class variables' stamp: 'NS 1/27/2004 14:19' prior: 34866990!
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 isLowercase
		ifTrue: [^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: 'yo 7/15/2003 20:55' prior: 34867889!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first 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"
		Smalltalk changes changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04' prior: 19219729!
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' prior: 19220173!
allSharedPools
	"Answer a Set of the pools the receiver shares, including those defined  
	in the superclasses of the receiver."
	| aSet | 
	^ superclass == nil
		ifTrue: [self sharedPools copy]
		ifFalse: [aSet _ superclass allSharedPools.
			aSet addAll: self sharedPools.
			aSet]! !

!Class methodsFor: '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' prior: 19222394!
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: 'sd 3/28/2003 15:24' prior: 19223643!
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: 'subclass creation' stamp: 'sd 3/28/2003 15:24' prior: 19225285!
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: 'fileIn/Out' stamp: 'tk 3/7/2001 13:57'!
fileOutAsHtml: useHtml
	"File a description of the receiver onto a new file whose base name is the name of the receiver."

	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml]
		ifFalse: [FileStream newFileNamed: self name, FileDirectory dot, 'st'].
	fileStream header; timeStamp.
	self sharedPools size > 0 ifTrue: [
		self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: fileStream]].
	self fileOutOn: fileStream moveSource: false toFile: 0.
	fileStream trailer; close.

	"DeepCopier new checkVariables."
! !

!Class methodsFor: 'fileIn/Out' stamp: 'yo 8/30/2002 14:00' prior: 34873064!
fileOutAsHtml: useHtml
	"File a description of the receiver onto a new file whose base name is the name of the receiver."

	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml]
		ifFalse: [FileStream newFileNamed: (self name, FileDirectory dot, 'st') asFileName].
	fileStream header; timeStamp.
	self sharedPools size > 0 ifTrue: [
		self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: fileStream]].
	self fileOutOn: fileStream moveSource: false toFile: 0.
	fileStream trailer; close.

	"DeepCopier new checkVariables."
! !

!Class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:24' prior: 19230421!
fileOutPool: aPool onFileStream: aFileStream 
	| aPoolName aValue |
	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: 'tpr 5/30/2003 13:01' prior: 34874411!
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: 'sd 3/28/2003 15:24' prior: 19231190!
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: 'sd 3/28/2003 15:24' prior: 19232499!
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:"

	self environment changes removeClassAndMetaClassChanges: self! !

!Class methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:33' prior: 34876546!
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: 'private' stamp: 'sd 2/1/2004 15:18'!
spaceUsed

	"Object spaceUsed"
	^ super spaceUsed + self class spaceUsed! !

!Class methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'!
sunitName
 
        ^self name! !

!Class methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57' prior: 34877311!
sunitName
 
        ^self name! !

!Class class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:25' prior: 19236523!
fileOutPool: aString
	"file out the global pool named aString"
	| f |
	f _ FileStream newFileNamed: aString, '.st'.
	self new fileOutPool: (self environment at: aString asSymbol) onFileStream: f. 	f close.
	! !

!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: 'class definition' stamp: 'ar 9/22/2002 02:57'!
class: oldClass instanceVariableNames: instVarString unsafe: unsafe
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	| instVars newClass needNew |
	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"
	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.
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:20' prior: 34878071!
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 9/22/2002 03:00'!
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 |
	environ _ env.
	instVars _ Scanner new scanFieldNames: instVarString.
	classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass _ env at: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:"

	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"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 ..."
	organization _ environ ifNotNil:[environ organization].
	organization classify: newClass name under: category asSymbol.
	newClass environment: environ.

	"... recompile ..."
	newClass _ self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[
		[environ at: newClass name put: newClass]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		Smalltalk flushClassNameCache.
	].

	self doneCompiling: newClass.

	^newClass
! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/20/2004 19:46' prior: 34880678!
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:"
	copyOfOldClass _ oldClass copy.

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

	self doneCompiling: newClass.
	
	"... notify interested clients ..."
	oldClass isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
		^ newClass].
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
	newCategory ~= oldCategory 
		ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category].
	^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: 'ar 9/22/2002 03:16'!
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 newSubclassOf: 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].
		self recordClass: oldClass replacedBy: newClass.
	].

	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/27/2003 22:56' prior: 34888086!
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].
		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: 'ar 9/22/2002 03:12'!
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 has an empty method dictionary
		so we don't need to recompile"
		Smalltalk changes addClass: newClass.
		newClass superclass addSubclass: newClass.
		^newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		"No recompilation necessary but we might have added
		class vars or class pools so record the change"
		Smalltalk changes changeClass: newClass from: oldClass.
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		Smalltalk changes changeClass: newClass from: oldClass.
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		Smalltalk changes changeClass: newClass from: oldClass.
		self mutate: oldClass to: newClass.
	].
	^oldClass "now mutated to newClass"! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/27/2003 22:24' prior: 34890265!
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 has an empty method dictionary
		so we don't need to recompile"
		Smalltalk changes addClass: newClass.
		^newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		"No recompilation necessary but we might have added
		class vars or class pools so record the change"
		Smalltalk changes changeClass: newClass from: oldClass.
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		Smalltalk changes changeClass: newClass from: oldClass.
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		Smalltalk changes changeClass: newClass from: oldClass.
		self mutate: oldClass to: newClass.
	].
	^oldClass "now mutated to newClass"! !

!ClassBuilder methodsFor: 'class definition' stamp: 'sd 5/23/2003 14:51' prior: 34891815!
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 has an empty method dictionary
		so we don't need to recompile"
		ChangeSet current addClass: newClass.
		^newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		"No recompilation necessary but we might have added
		class vars or class pools so record the change"
		ChangeSet current changeClass: newClass from: oldClass.
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		ChangeSet current changeClass: newClass from: oldClass.
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		ChangeSet current changeClass: newClass from: oldClass.
		self mutate: oldClass to: newClass.
	].
	^oldClass "now mutated to newClass"! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:53' prior: 34893320!
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: 'ar 5/16/2003 00:48' prior: 19248726!
silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName
	"Move the instvar from srcClass to dstClass.
	Do not perform any checks."
	| srcVars dstVars dstIndex newClass |
	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.! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:21' prior: 34895934!
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: 'validation' stamp: 'yo 11/11/2002 10:22' prior: 19253789!
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: 'ajh 10/17/2002 11:10' prior: 19255642!
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' prior: 19257052!
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: '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: 'ar 3/2/2001 01:05'!
recordClass: oldClass replacedBy: newClass
	"Keep the changes up to date when we're moving instVars around"
	(instVarMap includesKey: oldClass name) ifTrue:[
		Smalltalk changes changeClass: newClass from: oldClass.
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'sd 5/23/2003 14:33' prior: 34904645!
recordClass: oldClass replacedBy: newClass
	"Keep the changes up to date when we're moving instVars around"
	(instVarMap includesKey: oldClass name) ifTrue:[
		ChangeSet current changeClass: newClass from: oldClass.
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21' prior: 34904950!
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: '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: 'class mutation' stamp: 'ar 9/22/2002 03:11'!
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 oldSuper newSuper |
	self showProgressFor: oldClass.
	oldSuper _ oldClass superclass.
	newSuper _ newClass superclass.
	oldSuper isObsolete 
		ifTrue:[oldSuper removeObsoleteSubclass: oldClass]
		ifFalse:[oldSuper removeSubclass: oldClass].
	"Convert the subclasses"
	oldClass subclasses do:[:oldSubclass|
		oldClass removeSubclass: oldSubclass.
		newSubclass _ self mutate: oldSubclass toSuper: newClass.
		newClass addSubclass: newSubclass.
	].
	"And any obsolete ones"
	oldClass obsoleteSubclasses do:[:oldSubclass|
		oldSubclass ifNotNil:[
			oldClass removeObsoleteSubclass: oldSubclass.
			newSubclass _ self mutate: oldSubclass toSuper: newClass.
			newClass addObsoleteSubclass: newSubclass.
		].
	].

	self update: oldClass to: newClass.

	newSuper isObsolete
		ifTrue:[newSuper addObsoleteSubclass: newClass]
		ifFalse:[newSuper addSubclass: newClass].! !

!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 22:44' prior: 34906026!
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 9/21/2002 15:34'!
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 since we can rely on two assumptions (those 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. 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."
	[
		"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.

	] valueUnpreemptively.
! !

!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42' prior: 34908702!
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 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 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].! !

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

!ClassBuilderChangeClassTypeTest methodsFor: 'testing' stamp: 'BG 1/6/2004 00:04'!
testClassCreationAndChange

    |  success |

  [baseClass := Object subclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
  self assert: baseClass isPointers.
  self deny: baseClass isVariable.
  success := true.
     [Object variableSubclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.]
      on: Error
      do: [:exception |  success := false].
  self assert: (success and: [baseClass isVariable]).
 ] 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! !

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

!ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'!
theClass

	^ class! !

!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: 'rename' stamp: 'tk 6/8/2001 09:11'!
thisName

	^ thisName! !

!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: []]! !

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

!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:33'!
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: 'asm 8/13/2002 23:37'!
openSingleMessageBrowser
	| mr |
	"Create and schedule a message list browser populated only by the currently selected message"

	mr _ MethodReference new
				setStandardClass: self selectedClass
				methodSymbol: #Comment.

	Smalltalk 
		browseMessageList: (Array with: mr)
		name: mr asStringOrText
		autoSelect: nil! !

!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 4/16/2003 08:52' prior: 34939567!
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: 'basic function' stamp: 'asm 8/13/2002 22: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: 'asm 8/13/2002 21:28'!
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: 'asm 1/3/2003 16:06'!
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: 'asm 8/13/2002 21:33'!
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: '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: 'asm 8/13/2002 22:14'!
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 commentStamp: 'asm 8/13/2002 23:20' prior: 0!
A class-comment-versions-browser tool!
!ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'asm 8/12/2002 22:46'!
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: 'asm 8/13/2002 22:09'!
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: 'asm 8/13/2002 20:54'!
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.'! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:32' prior: 19292817!
obsolete
	"Make the receiver obsolete."
	superclass removeSubclass: self.
	self organization: nil.
	super obsolete.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:31' prior: 19293013!
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: 'accessing' stamp: 'sd 6/27/2003 23:57' prior: 19295975!
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: 'sw 11/5/2001 00:53'!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.
	Smalltalk changes commentClass: self.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'sd 3/28/2003 15:32' prior: 34952535!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.
	self environment changes commentClass: self.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'sd 5/23/2003 14:34' prior: 34952878!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.
	ChangeSet current commentClass: self.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54' prior: 34953228!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.! !

!ClassDescription methodsFor: 'accessing' stamp: 'sw 11/5/2001 00:55'!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.
	Smalltalk changes commentClass: self theNonMetaClass.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'sd 3/28/2003 15:32' prior: 34953786!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.
	self environment changes commentClass: self theNonMetaClass.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'sd 5/23/2003 14:34' prior: 34954173!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.
	ChangeSet current commentClass: self theNonMetaClass.
	Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54' prior: 34954567!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.! !

!ClassDescription methodsFor: 'accessing' stamp: 'ls 10/28/2003 12:32'!
hasComment
	"return whether this class truly has a comment other than the default"
	| org |
	org := self theNonMetaClass organization.
	^org classComment notNil and: [
		org classComment isEmpty not ].
! !

!ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:50'!
theMetaClass
	"Sent to a class or metaclass, always return the metaclass"

	^self class! !

!ClassDescription methodsFor: 'copying' stamp: 'NS 4/6/2004 15:31' prior: 19300462!
copyMethodDictionaryFrom: donorClass
	"Copy the method dictionary of the donor class over to the receiver"

	methodDict _ donorClass copyOfMethodDictionary.
	self organization: donorClass organization deepCopy.! !

!ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:21' prior: 19300715!
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: 'lr 11/24/2003 17:20' prior: 19301039!
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: 'lr 11/24/2003 17:24' prior: 19301535!
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: 'instance variables' stamp: 'sw 3/20/2001 20:38'!
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: [^1 beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ nil].
	^ allVars at: index! !

!ClassDescription methodsFor: 'instance variables' stamp: 'nb 6/17/2003 12:25' prior: 34956995!
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 _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ nil].
	^ allVars at: index! !

!ClassDescription methodsFor: 'instance variables' stamp: 'sw 3/20/2001 20:51'!
classThatDefinesClassVariable: classVarName
	"Answer the class that defines the given class variable"

	(self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. 
	^ superclass ifNotNil: [superclass classThatDefinesClassVariable: classVarName]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'NS 1/27/2004 11:49' prior: 19308671!
renameSilentlyInstVar: old to: new
	| i oldName newName |
	oldName _ old asString.
	newName _ new asString.
	(i _ instanceVariables indexOf: oldName) = 0 ifTrue:
		[self error: oldName , ' is not defined in ', self name].
	self allSuperclasses , self withAllSubclasses asOrderedCollection do:
		[:cls | (cls instVarNames includes: newName) ifTrue:
			[self error: newName , ' is already used in ', cls name]].

	instanceVariables replaceFrom: i to: i with: (Array with: newName).
	self replaceSilently: oldName to: newName.	"replace in text body of all methods"! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:12'!
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].! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:10'!
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].! !

!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: 'sw 12/12/2000 12: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: 'sd 4/18/2003 10:26' prior: 34961770!
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: 'sw 12/11/2000 14:00'!
isUniClass
	"Answer whether the receiver is a uniclass."

	^ self name endsWithDigit! !

!ClassDescription methodsFor: '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: '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: 'di 3/7/2001 16:16'!
recoverFromMDFaultWithTrace
	"This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)."
	self recoverFromMDFault.
	Smalltalk 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: 'sd 3/28/2003 15:32' prior: 34963762!
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: 'sd 3/28/2003 15:32' prior: 19311634!
removeSelector: selector 
	| priorMethod | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	self environment changes removeSelector: selector class: self
		priorMethod: priorMethod
		lastMethodInfo: {priorMethod sourcePointer.
						(self whichCategoryIncludesSelector: selector)}.
	super removeSelector: selector.
	self organization removeElement: selector.
	self acceptsLoggingOfCompilation ifTrue:
		[self environment logChange: self name , ' removeSelector: #' , selector]! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 5/23/2003 14:34' prior: 34965427!
removeSelector: selector 
	| priorMethod | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	ChangeSet current removeSelector: selector class: self
		priorMethod: priorMethod
		lastMethodInfo: {priorMethod sourcePointer.
						(self whichCategoryIncludesSelector: selector)}.
	super removeSelector: selector.
	self organization removeElement: selector.
	self acceptsLoggingOfCompilation ifTrue:
		[self environment logChange: self name , ' removeSelector: #' , selector]! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/16/2004 15:41' prior: 34966204!
removeSelector: selector 
	| priorMethod priorProtocol | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	priorProtocol := self whichCategoryIncludesSelector: selector.
	ChangeSet current removeSelector: selector class: self
		priorMethod: priorMethod
		lastMethodInfo: {priorMethod sourcePointer.
						priorProtocol}.
	super removeSelector: selector.
	self organization removeElement: selector.
	self acceptsLoggingOfCompilation ifTrue:
		[SmalltalkImage current logChange: self name , ' removeSelector: #' , selector].
	SystemChangeNotifier uniqueInstance 
			methodRemoved: selector inProtocol: priorProtocol fromClass: self! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:11' prior: 34966974!
removeSelector: selector 
	| priorMethod priorProtocol | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	priorProtocol := self whichCategoryIncludesSelector: selector.
	super removeSelector: selector.
	self organization removeElement: selector.
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:26' prior: 34967903!
removeSelector: selector 
	| priorMethod priorProtocol | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil].
	priorProtocol _ self whichCategoryIncludesSelector: selector.
	super removeSelector: selector.
	self organization removeElement: selector.
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 4/7/2004 13:33' prior: 34968574!
removeSelector: selector 
	| priorMethod priorProtocol | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil].
	priorProtocol _ self whichCategoryIncludesSelector: selector.
	SystemChangeNotifier uniqueInstance doSilently: [
		self organization removeElement: selector].
	super removeSelector: selector.
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !

!ClassDescription methodsFor: 'organization' stamp: 'rw 8/2/2003 11:05' prior: 19313338!
category: cat 
	"Categorize the receiver under the system category, cat, removing it from 
	any previous categorization."

	| oldCat |
	oldCat := self category.
	(cat isKindOf: String)
		ifTrue: [SystemOrganization classify: self name under: cat asSymbol]
		ifFalse: [self errorCategoryName].
	SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCat to: cat asSymbol! !

!ClassDescription methodsFor: 'organization' stamp: 'nk 3/8/2004 13:18'!
forgetDoIts
	"get rid of old DoIt methods and bogus entries in the ClassOrganizer."
	super forgetDoIts.
	self organization
		removeElement: #DoIt;
		removeElement: #DoItIn:.! !

!ClassDescription methodsFor: 'organization' stamp: 'NS 4/7/2004 13:33' prior: 34970332!
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: 'organization' stamp: 'di 3/7/2001 17:05'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil:
		[organization _ ClassOrganizer defaultList: 
						self methodDict keys asSortedCollection asArray].
	(organization isMemberOf: Array) ifTrue:
		[self recoverFromMDFaultWithTrace].
	^ organization! !

!ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:46' prior: 34970908!
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/6/2004 15:26' prior: 19314082!
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' stamp: 'NS 4/6/2004 15:30' prior: 19314922!
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 isMeta ifFalse: [self class zapOrganization]! !

!ClassDescription methodsFor: 'compiling' stamp: 'di 5/4/2001 11:35'!
compile: text classified: category withStamp: changeStamp notifying: requestor
	^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 9/25/2001 02:08'!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	| selector priorMethod method methodNode newText |
	method _ self
		compile: text asString
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel.
			priorMethod _ self methodDict at: selector ifAbsent: [nil].
			methodNode _ node].
	logSource ifTrue:
		[newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
						and: [Preferences confirmFirstUseOfStyle])
			ifTrue: [text askIfAddStyle: priorMethod req: requestor]
			ifFalse: [text].
		 method putSource: newText
				fromParseNode: methodNode
				class: self category: category withStamp: changeStamp 
				inFile: 2 priorMethod: priorMethod].
	self organization classify: selector under: category.
	self theNonMetaClass noteCompilationOf: selector meta: self isMeta.
	^ selector! !

!ClassDescription methodsFor: 'compiling' stamp: 'NS 1/26/2004 13:33' prior: 34972873!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	| selector priorMethodOrNil method methodNode newText |
	SystemChangeNotifier uniqueInstance doSilently: [method _ self
		compile: text asString
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel.
			priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil].
			methodNode _ node]].
	logSource ifTrue:
		[newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
						and: [Preferences confirmFirstUseOfStyle])
			ifTrue: [text askIfAddStyle: priorMethodOrNil req: requestor]
			ifFalse: [text].
		 method putSource: newText
				fromParseNode: methodNode
				class: self category: category withStamp: changeStamp 
				inFile: 2 priorMethod: priorMethodOrNil].
	SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category].
	self theNonMetaClass noteCompilationOf: selector meta: self isMeta.
	priorMethodOrNil isNil
		ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: method selector: selector inProtocol: category class: self requestor: requestor]
		ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: method selector: selector inClass: self requestor: requestor].
	^ selector! !

!ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:25' prior: 34973882!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	| methodAndNode |
	methodAndNode _ self basicCompile: text asString 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 theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta.
	^ methodAndNode selector! !

!ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'!
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.! !

!ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'!
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].! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 9/25/2001 02:11'!
noteCompilationOf: aSelector meta: isMeta
	"A hook allowing some classes to react to recompilation of certain selectors"! !

!ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:48' prior: 19320026!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.  7/12/96 sw"

	^ true! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/8/1998 14:44'!
classComment: aString
	"Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing.  Empty string gets stored only if had a non-empty one before."
	^ self classComment: aString stamp: '<historical>'! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 8/1/2002 14:23'!
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:
		[Smalltalk changes commentClass: self.
		^ self organization classComment: aString stamp: aStamp].

	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil:
		[file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	Smalltalk changes commentClass: self.
	organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:32' prior: 34977782!
classComment: aString stamp: aStamp
	"Store the comment, aString or Text or RemoteString, associated with the class we are organizing.  Empty string gets stored only if had a non-empty one before."

	| ptr header file oldCommentRemoteStr |
	(aString isKindOf: RemoteString) ifTrue:
		[self environment changes commentClass: self.
		^ self organization classComment: aString stamp: aStamp].

	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil:
		[file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	self environment changes commentClass: self.
	organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:51' prior: 34979099!
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:
		[ChangeSet current commentClass: self.
		^ self organization classComment: aString stamp: aStamp].

	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil:
		[file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	ChangeSet current commentClass: self.
	organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 1/27/2004 14:54' prior: 34980430!
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: [^ 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]].
	SystemChangeNotifier uniqueInstance classCommented: self.
	organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'nk 3/8/2004 17:28' prior: 34981747!
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: [^ 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]].
	organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp.
	SystemChangeNotifier uniqueInstance classCommented: self.
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:35' prior: 34983103!
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.
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'!
definitionST80
	"Answer a String that defines the receiver."

	| aStream path |
	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'ProtoObject']
		ifFalse: [path _ ''.
				self environment scopeFor: superclass name from: nil
						envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.

	superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'!
definitionST80: isST80
	"Answer a String that defines the receiver."

	| aStream path |
	isST80 ifTrue: [^ self definitionST80].

	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'ProtoObject']
		ifFalse: [path _ ''.
				self environment scopeFor: superclass name from: nil
						envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutKeyword: self kindOfSubclass
			withArg: self name.
	aStream cr; tab; nextPutKeyword: 'instanceVariableNames: '
			withArg: self instanceVariablesString.
	aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString.
	aStream cr; tab; nextPutKeyword: 'poolDictionaries: '
			withArg: self sharedPoolsString.
	aStream cr; tab; nextPutKeyword: 'category: '
			withArg: (SystemOrganization categoryOfElement: self name) asString.

	superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self name.
		aStream space; nextPutAll: 'superclass (nil)'. ].

	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 8/30/2002 14:00' prior: 19325012!
fileOutCategory: catName asHtml: useHtml
	"FileOut the named category, possibly in Html format."
	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: self name , '-' , catName , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: (self name , '-' , catName , '.st') asFileName].
	fileStream header; timeStamp.
	self fileOutCategory: catName on: fileStream moveSource: false toFile: 0.
	fileStream trailer; close! !

!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: 'sw 8/1/2002 14:39'!
fileOutMethod: selector asHtml: useHtml
	"Write source code of a single method on a file in .st or .html format"

	| fileStream nameBody |
	(selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.'].
	(self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found'].
	nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: '').
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: nameBody , '.st'].
	fileStream header; timeStamp.
	self printMethodChunk: selector withPreamble: true
		on: fileStream moveSource: false toFile: 0.
	fileStream close! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 7/15/2003 20:51' prior: 34989390!
fileOutMethod: selector asHtml: useHtml
	"Write source code of a single method on a file in .st or .html format"

	| fileStream nameBody |
	(selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.'].
	(self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found'].
	nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: '').
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: (nameBody , '.st') asFileName].
	fileStream header; timeStamp.
	self printMethodChunk: selector withPreamble: true
		on: fileStream moveSource: false toFile: 0.
	fileStream close! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/2/2003 21:50'!
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 methodDict at: sel) fileIndex > 1].
	self fileOutChangedMessages: changes
		on: newFile
		moveSource: true
		toFile: 2! !

!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: 'yo 10/15/2003 17:10' prior: 19333524!
printMethodChunk: selector withPreamble: doPreamble on: outStream
		moveSource: moveSource toFile: fileIndex
	"Copy the source code for the method associated with selector onto the fileStream.  If moveSource true, then also set the source code pointer of the method."
	| preamble method oldPos newPos sourceFile endPos |
	doPreamble 
		ifTrue: [preamble _ self name , ' methodsFor: ' ,
					(self organization categoryOfElement: selector) asString printString]
		ifFalse: [preamble _ ''].
	method _ self methodDict at: selector.
	((method fileIndex = 0
		or: [(SourceFiles at: method fileIndex) == nil])
		or: [(oldPos _ method filePosition) = 0])
		ifTrue:
		["The source code is not accessible.  We must decompile..."
		preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr].
		outStream nextChunkPut: (self decompilerClass new decompile: selector
											in: self method: method) decompileString]
		ifFalse:
		[sourceFile _ SourceFiles at: method fileIndex.
		preamble size > 0 ifTrue:    "Copy the preamble"
			[outStream copyPreamble: preamble from: sourceFile at: 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! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 17:10'!
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: (
			self decompilerClass new 
				decompile: selector in: self method: method) decompileString.
		outStream nextChunkPut: ' '; cr]
	ifFalse: [
		changeList _ (VersionsBrowser new 
			scanVersionsOf: method 
			class: self 
			meta: self isMeta
			category: category 
			selector: selector) changeList.
		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: 'fileIn/Out' stamp: 'sw 1/14/2003 15:36'!
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.
	organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:32' prior: 34995847!
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! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:32' prior: 19335935!
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 environment changes reorganizeClass: self.
	^self organization!
]style[(10 156 22 87)f1b,f1,f1LReadWriteStream fileIn;,f1! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:35' prior: 34998227!
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:"

	ChangeSet current reorganizeClass: self.
	^self organization!
]style[(10 156 22 80)f1b,f1,f1LReadWriteStream fileIn;,f1! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 1/27/2004 14:55' prior: 34998656!
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:"

	SystemChangeNotifier uniqueInstance classReorganized: self.
	^self organization!
]style[(10 156 22 20 59 20)f1b,f1,f1LReadWriteStream fileIn;,f1,f2,f1! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 23:01' prior: 34999078!
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!
]style[(10 156 22 38)f1b,f1,f1LReadWriteStream fileIn;,f1! !

!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: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:32' prior: 19341520!
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: 'deprecated' stamp: 'sw 10/29/2001 17:41'!
categoryFromUserWithPrompt: aPrompt
	"SystemDictionary categoryFromUserWithPrompt: 'testing'"

	|  labels myCategories reject lines cats newName menuIndex |
	labels _ OrderedCollection with: 'new...'.
	labels addAll: (myCategories _ self 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).

	self 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 _ (PopUpMenu labelArray: labels lines: lines)
		startUpWithCaption: aPrompt.
		menuIndex = 0 ifTrue: [^ nil].
		menuIndex = 1])
			ifTrue:
				[FillInTheBlank request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: 
				[labels at: menuIndex].
	^ newName ifNotNil: [newName asSymbol]! !

!ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 17:59' prior: 35001234!
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: 'deprecated' stamp: 'sw 2/18/2001 21:14'!
compileInobtrusively: 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."

	| methodNode newMethod |
	methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil].
	self addSelector: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)).
	self organization classify: methodNode selector under: category.
	^ newMethod! !

!ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:42' prior: 35002929!
compileInobtrusively: 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."

	| methodNode newMethod |
	self deprecated: 'Use compileSilently:classified: instead.'.
	
	methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil].
	self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)).
	SystemChangeNotifier doSilently: [self organization classify: methodNode selector under: category].
	^ newMethod! !

!ClassDescription methodsFor: 'deprecated' stamp: 'avi 2/17/2004 01:59' prior: 35003624!
compileInobtrusively: 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."

	| methodNode newMethod |
	self deprecated: 'Use compileSilently:classified: instead.'.
	
	methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil].
	self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)).
	SystemChangeNotifier uniqueInstance doSilently: [self organization classify: methodNode selector under: category].
	^ newMethod! !

!ClassDescription methodsFor: 'deprecated' stamp: 'sw 2/18/2001 16:59'!
compileProgrammatically: code classified: cat 
	"compile the given code programmatically.  In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set"

	^ self compileInobtrusively: code classified: cat

"
	| oldInitials |
	oldInitials _ Utilities authorInitialsPerSe.
	Utilities setAuthorInitials: 'programmatic'.
	self compile: code classified: cat.
	Utilities setAuthorInitials: oldInitials.
"! !

!ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:43' prior: 35005228!
compileProgrammatically: code classified: cat 
	"compile the given code programmatically.  In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set"

	self deprecated: 'Use compileSilently:classified: instead.'.
	^ self compileSilently: code classified: cat

"
	| oldInitials |
	oldInitials _ Utilities authorInitialsPerSe.
	Utilities setAuthorInitials: 'programmatic'.
	self compile: code classified: cat.
	Utilities setAuthorInitials: oldInitials.
"! !

!ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:47' prior: 19319132!
compileUnlogged: text classified: category notifying: requestor 

	self deprecated: 'Use compileSilently:classified:notifying: instead.'.
	^ self compileSilently: text classified: category notifying: requestor.

"
	| selector  |
	self compile: text asString
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^ nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel].
	self organization classify: selector under: category.
	^ selector
"! !

!ClassDescription methodsFor: 'deprecated' stamp: 'sw 10/29/2001 06:58'!
letUserReclassify: anElement
	"Put up a list of categories and solicit one from the user.  Answer true if user indeed made a change, else false"
	"ClassOrganizer organization letUserReclassify: #letUserReclassify:"

	| currentCat newCat |
	currentCat _ self organization categoryOfElement: anElement.
	newCat _ self categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")'.
	(newCat ~~ nil and: [newCat ~= currentCat])
		ifTrue:
			[self organization classify: anElement under: newCat suppressIfDefault: false.
			^ true]
		ifFalse:
			[^ false]! !

!ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 18:01' prior: 35006909!
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: 'deprecated' stamp: 'NS 1/30/2004 13:14' prior: 19312371!
removeSelectorUnlogged: aSymbol 
	"Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise.  Do not log the action either to the current change set or to the changes log"

	self deprecated: 'Use removeSelectorSilently: instead'.
	(self methodDict includesKey: aSymbol) ifFalse: [^ nil].
	super removeSelector: aSymbol.
	self organization removeElement: aSymbol! !

!ClassDescription methodsFor: 'deprecated' stamp: 'NS 4/7/2004 13:33' prior: 35007939!
removeSelectorUnlogged: aSymbol 
	"Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise.  Do not log the action either to the current change set or to the changes log"

	self deprecated: 'Use removeSelectorSilently: instead'.
	(self methodDict includesKey: aSymbol) ifFalse: [^ nil].
	SystemChangeNotifier uniqueInstance doSilently: [
		self organization removeElement: aSymbol].
	super removeSelector: aSymbol.! !

!ClassDescription methodsFor: '*system-support' stamp: 'sw 9/26/2001 01:51'!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	|  aList |
	aList _ OrderedCollection new.
	self withAllSuperclasses reverseDo:
		[:aClass |
		aClass classVarNames do:
			[:var |
				(Smalltalk allCallsOn: (aClass classPool associationAt: var))
					size == 0 ifTrue:
						[aList add: var]]].
	^ aList! !

!ClassDescription methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:31' prior: 35009027!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	|  aList |
	aList _ OrderedCollection new.
	self withAllSuperclasses reverseDo:
		[:aClass |
		aClass classVarNames do:
			[:var |
				(self environment allCallsOn: (aClass classPool associationAt: var))
					size == 0 ifTrue:
						[aList add: var]]].
	^ aList! !

!ClassDescription methodsFor: '*system-support' stamp: 'sd 4/29/2003 13:10' prior: 35009528!
allUnreferencedClassVariables
	self flag: #deprecated.
	self error: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'! !

!ClassDescription methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:19' prior: 35010036!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	|  aList |
	self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'.
	aList _ OrderedCollection new.
	self withAllSuperclasses reverseDo:
		[:aClass |
		aClass classVarNames do:
			[:var |
				(self environment allCallsOn: (aClass classPool associationAt: var))
					size == 0 ifTrue:
						[aList add: var]]].
	^ aList! !

!ClassDescription methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:45' prior: 35010285!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	^ self systemNavigation allUnreferencedClassVariablesOf: self! !

!ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'!
setUp
	"I am the method in which your test is initialized. 
If you have ressources to build, put them here."! !

!ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !

!ClassDescriptionTest methodsFor: 'testing' stamp: 'md 3/26/2003 17:37'!
testOrganization

	| aClassOrganizer |

	aClassOrganizer := ClassDescription organization.
	self should: [aClassOrganizer isKindOf: ClassOrganizer].! !

!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!
!ClassDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:49' prior: 19343229!
printPatchSequence: ps on: aStream 
	| type line |
	ps do: [:assoc | 
			type := assoc key.
			line := assoc value.
			aStream
				withAttributes: (self attributesOf: type)
				do: [aStream nextPutAll: line]]! !

!ClassListBrowser methodsFor: 'initialization' stamp: 'sw 7/18/2002 22:43'!
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: 'sw 7/18/2002 22:42'!
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 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 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: 'sw 7/27/2002 14:34'!
example2
	"Put up a ClassListBrowser that shows all classes whose names start with the letter S"

	self new initForClassesNamed: (Smalltalk allClasses collect: [:c | c name] thenSelect: [:aName | aName first == $S]) title: 'All classes starting with S'

"ClassListBrowser example2"
	! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21' prior: 35014326!
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: 'sw 7/27/2002 14:28'!
browseClassesSatisfying: classBlock title: aTitle
	"Put up a ClassListBrowser showing all classes that satisfy the classBlock."

	self new
		initForClassesNamed:
			(Smalltalk allClasses select:
					[:c | (classBlock value: c) == true]
				thenCollect:
					[:c | c name])
		title:
			aTitle! !

!ClassListBrowser class methodsFor: 'instance creation' stamp: 'sd 4/17/2003 21:21' prior: 35016379!
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! !

!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/7/2004 22:52'!
notifyOfChangedSelector: element from: oldCategory to: newCategory
	(self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [
		SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self subject
	].! !

!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: '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 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!!!
!ClassRenameFixTest methodsFor: 'Private' stamp: 'rw 8/23/2003 16:04'!
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: 'rw 8/23/2003 16:17'!
removeEverythingInSetFromSystem: aChangeSet 

	aChangeSet changedMessageList
		do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol].
	aChangeSet changedClasses
		do: [:each | each isMeta
				ifFalse: [each removeFromSystemUnlogged]]! !

!ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:46'!
renameClassUsing: aBlock

	| originalName createdClass newClassName 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: 'rw 8/23/2003 16:45'!
testRenameClassUsingClass
	"self run: #testRenameClassUsingClass"

	self renameClassUsing: [:class :newName | class rename: newName].! !

!ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:45'!
testRenameClassUsingSystemDictionary
	"self run: #testRenameClassUsingSystemDictionary"

	self renameClassUsing: [:class :newName | Smalltalk renameClass: class as: newName].! !

!ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:16'!
setUp

	previousChangeSet := ChangeSet current.
	testsChangeSet := ChangeSet new.
	ChangeSet newChanges: testsChangeSet.
	super setUp! !

!ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:17'!
tearDown

	self removeEverythingInSetFromSystem: testsChangeSet.
	ChangeSet newChanges: previousChangeSet.
	ChangeSorter removeChangeSet: testsChangeSet.
	previousChangeSet := nil.
	testsChangeSet := nil.
	super tearDown.! !

!ClassTest methodsFor: 'setup' stamp: 'md 1/5/2004 14:59'!
setUp

	Smalltalk removeClassNamed: #TUTU.
	Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Tests-Kernel-Classes'! !

!ClassTest methodsFor: 'setup' stamp: 'sd 12/28/2003 10:53'!
tearDown

	Smalltalk removeClassNamed: #TUTU.
	! !

!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 - compiling' stamp: 'md 4/16/2003 14:54'!
testCompileAll
	self shouldnt: [ClassTest compileAll] raise: Error.! !

!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:32' prior: 35026720!
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: 'private' stamp: 'md 1/28/2004 11:28' prior: 35027156!
targetClass
  |className|

  className := self class name asText copyFrom: 0 to: self class name size - 4.
  ^ Smalltalk at: (className asString asSymbol).
! !

!ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:39'!
testClassComment
	self shouldnt: [self targetClass organization hasNoComment].! !

!ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:39' prior: 35027626!
testClassComment
	self shouldnt: [self targetClass organization hasNoComment].! !

!ClassTestCase methodsFor: 'testing' stamp: 'md 3/25/2003 23:07'!
testNew
	self shouldnt: [self targetClass new] raise: Error.! !

!ClassTestCase methodsFor: 'testing' stamp: 'md 3/25/2003 23:07' prior: 35027940!
testNew
	self shouldnt: [self targetClass new] raise: Error.! !

!ClassTestCase methodsFor: 'testing' 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: 'testing' stamp: 'md 3/26/2003 17:24' prior: 35028218!
testUnCategorizedMethods
	| categories slips  |
	categories := self categoriesForClass: self targetClass.
	slips := categories select: [:each | each = #'as yet unclassified'].
	self should: [slips isEmpty].	! !

!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: 'Private' stamp: 'brp 8/6/2003 19:24'!
resumeFromDeprecatedMethods: autoResume
	"If true, make the default action for all Deprecation warnings to resume"

	| da |
	autoResume
		ifTrue: [Deprecation compiledMethodAt: #defaultAction ifAbsent: 
					[ Deprecation 
						addSelector: #defaultAction 
						withMethod: (Notification >> #defaultAction) ] ]
		ifFalse: [da _ Deprecation compiledMethodAt: #defaultAction ifAbsent: [].
				da == (Notification >> #defaultAction) 
					ifTrue: [ Deprecation removeSelectorSimply: #defaultAction] ]
				


! !

!ClassTestCase methodsFor: 'Private' stamp: 'rhi 5/27/2004 14:04' prior: 35029070!
resumeFromDeprecatedMethods: autoResume
	"If true, make the default action for all Deprecation warnings to resume"

	| da |
	autoResume
		ifTrue: [Deprecation compiledMethodAt: #defaultAction ifAbsent: 
					[ Deprecation 
						addSelector: #defaultAction 
						withMethod: (Notification >> #defaultAction) ] ]
		ifFalse: [da _ Deprecation compiledMethodAt: #defaultAction ifAbsent: [].
				da == (Notification >> #defaultAction) 
					ifTrue: [ Deprecation basicRemoveSelector: #defaultAction] ]! !

!ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:25'!
setUp

	self resumeFromDeprecatedMethods: true.! !

!ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:26'!
tearDown

	self resumeFromDeprecatedMethods: false.! !

!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:36'!
selectorsTested
	| literals |
	literals _ Set new.
	self class
		selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test')
			ifTrue: [ literals addAll: (m literals select: [ :l | l isSymbol and: [l first isLowercase]]) ] ].
	^ literals! !

!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 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 class methodsFor: 'Testing' stamp: 'md 1/28/2004 11:50'!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self sunitName = #ClassTestCase
			! !

!ClassTestCase class methodsFor: 'Testing' stamp: 'brp 7/27/2003 12:53' prior: 35031807!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self sunitName = #ClassTestCase
			! !

!ClassTestCase class methodsFor: 'Testing' stamp: 'brp 12/14/2003 15:50'!
mustTestCoverage

	^ false! !

!CleanKernelTest methodsFor: 'utility'!
classesCreated
	classesCreated ifNil: [ classesCreated := OrderedCollection new].
	^ classesCreated! !

!CleanKernelTest methodsFor: 'utility'!
createClassNamed: aClassname 
	^ self createClassNamed: aClassname superClass: Object! !

!CleanKernelTest methodsFor: 'utility' stamp: 'rw 5/12/2003 12:33'!
createClassNamed: aClassname superClass: aClass 

	^self createClassNamed: aClassname superClass: aClass instanceVariables: ''! !

!CleanKernelTest methodsFor: 'utility' stamp: 'md 10/30/2003 09:49'!
createClassNamed: aClassname superClass: aClass instanceVariables: instvarString

	| r |
	r := aClass
		subclass: aClassname
		instanceVariableNames: instvarString
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Tests-KCP'.
	self classesCreated add: r.
	^ r! !

!CleanKernelTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:45'!
isSelector: aSymbol definedInClass: aClassSymbol 
	| cls |
	cls := Smalltalk
				at: aClassSymbol
				ifAbsent: [^ false].
	^ cls selectors includes: aSymbol! !

!CleanKernelTest methodsFor: 'utility' stamp: 'sd 4/29/2003 21:43'!
isSelector: aSymbol definedInClassOrMetaClass: aClass	
	
	^ (aClass selectors includes: aSymbol)! !

!CleanKernelTest methodsFor: 'utility' stamp: 'rw 5/13/2003 16:19'!
isSelector: aSymbol deprecatedInClass: aClassSymbol 

	| cls |
	cls _ Smalltalk
				at: aClassSymbol
				ifAbsent: [^ false].
	^ (cls >> aSymbol) literals includesAllOf: #(deprecatedExplanation:)! !

!CleanKernelTest methodsFor: 'utility'!
removeClassNamedIfExists: aClassname
	Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem].
	Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! !

!CleanKernelTest methodsFor: 'Running' stamp: 'rw 5/12/2003 12:52'!
setUp

	| classBuilderTestClass classBuilderTestSubClass |
	self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var1 var2'.
	classBuilderTestClass := (Smalltalk at: #ClassBuilderTestClass).
	classBuilderTestClass compile: 'var1	^var1'.
	classBuilderTestClass compile: 'var1: object	var1 := object'.
	classBuilderTestClass compile: 'var2	^var2'.
	classBuilderTestClass compile: 'var2: object	var2 := object'.

	self createClassNamed: #ClassBuilderTestSubClass superClass: classBuilderTestClass instanceVariables: 'var3 var4'.
	classBuilderTestSubClass := (Smalltalk at: #ClassBuilderTestSubClass).
	classBuilderTestSubClass compile: 'var3	^var3'.
	classBuilderTestSubClass compile: 'var3: object	var3 := object'.
	classBuilderTestSubClass compile: 'var4	^var4'.
	classBuilderTestSubClass compile: 'var4: object	var4 := object'.! !

!CleanKernelTest methodsFor: 'Running' stamp: 'sd 5/23/2003 14:52'!
tearDown

	| name |
	self classesCreated
		do: [:cls | 
			name _ cls name.
			self removeClassNamedIfExists: name.
			ChangeSet current removeClassChanges: name].
	classesCreated _ nil! !

!CleanKernelTest methodsFor: 'behavior'!
testAccessingClassHierarchy
	"self run: #testAccessingClassHierarchy"
	| clsRoot clsA clsB clsC1 clsC2 |
	clsRoot _ self createClassNamed: #Root.
	clsA _ self createClassNamed: #A superClass: clsRoot.
	clsB _ self createClassNamed: #B superClass: clsA.
	clsC1 _ self createClassNamed: #C1 superClass: clsB.
	clsC2 _ self createClassNamed: #C2 superClass: clsB.
	"--------"
	self assert: clsRoot subclasses size = 1.
	self
		assert: (clsRoot subclasses includes: clsA).
	self assert: clsB subclasses size = 2.
	self
		assert: (clsB subclasses
				includesAllOf: (Array with: clsC1 with: clsC2)).
	self assert: clsC1 subclasses isEmpty.
	"--------"
	self assert: clsRoot allSubclasses size = 4.
	self
		assert: (clsRoot allSubclasses
				includesAllOf: (Array
						with: clsA
						with: clsB
						with: clsC1
						with: clsC2)).
	"--------"
	self assert: clsRoot withAllSubclasses size = 5.	
	self
		assert: (clsRoot withAllSubclasses
				includesAllOf: (Array
						with: clsA
						with: clsB
						with: clsC1
						with: clsC2
						with: clsRoot)).
! !

!CleanKernelTest methodsFor: 'behavior'!
testAccessingClassHierarchySuperclasses
	"self run: #testAccessingClassHierarchySuperclasses"
	| clsRoot clsA clsB clsC1 clsC2 |
	clsRoot _ self createClassNamed: #Root.
	clsA _ self createClassNamed: #A superClass: clsRoot.
	clsB _ self createClassNamed: #B superClass: clsA.
	clsC1 _ self createClassNamed: #C1 superClass: clsB.
	clsC2 _ self createClassNamed: #C2 superClass: clsB.
	"--------"
	self assert: clsC2 superclass == clsB.
	self
		assert: (clsC2 allSuperclasses includes: clsA).
	self assert: clsC2 allSuperclasses size = 5.
	self
		assert: (clsC2 allSuperclasses
				includesAllOf: (Array
						with: clsB
						with: clsA
						with: clsRoot
						with: Object
						with: ProtoObject)).
	"--------"
	self assert: clsC1 superclass == clsB.
	self
		assert: (clsC1 allSuperclasses includes: clsA).
	self assert: clsC1 allSuperclasses size = 5.
	self
		assert: (clsC1 allSuperclasses
				includesAllOf: (Array
						with: clsB
						with: clsA
						with: clsRoot
						with: Object
						with: ProtoObject)).
	"--------"
	self assert: clsC2 withAllSuperclasses size = (clsC2 allSuperclasses size + 1).
	self
		assert: (clsC2 withAllSuperclasses includesAllOf: clsC2 allSuperclasses).
	self
		assert: (clsC2 withAllSuperclasses includes: clsC2).
	"--------"
	self assert: clsC1 withAllSuperclasses size = (clsC1 allSuperclasses size + 1).
	self
		assert: (clsC1 withAllSuperclasses includesAllOf: clsC1 allSuperclasses).
	self
		assert: (clsC1 withAllSuperclasses includes: clsC1)! !

!CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:15'!
testAllCallsOn
	"self run: #testAllCallsOn"
	self class forgetDoIts.
	self assert: (SystemNavigation new allCallsOn: #zoulouSymbol) size = 7.
	self assert: (SystemNavigation new allCallsOn: #callingAnotherMethod) size = 2! !

!CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:17'!
testAllCallsOnAnd
	"self run: #testAllCallsOnAnd"
	self class forgetDoIts.
	self assert: (SystemNavigation new allCallsOn: #zoulouSymbol and: #callingAThirdMethod) size = 2.
	self assert: (SystemNavigation new allCallsOn: #callingAThirdMethod and: #inform:) size = 1! !

!CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 20:43'!
testAllMethodsSelect
	"self run: #testAllMethodsSelect"
	| res |
	res _ SystemNavigation new
				allMethodsSelect: [:each | each messages includes: #zoulouSymbol].
	self assert: res size = 1.
	self assert: (res at: 1) methodSymbol = #callingAThirdMethod! !

!CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'!
testIsThereAnImplementorOf
	"self run: #testIsThereAnImplementorOf"

	self deny: (SystemNavigation new isThereAnImplementorOf: #nobodyImplementsThis) .
	self assert: (SystemNavigation new isThereAnImplementorOf: #zoulouSymbol).! !

!CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:41'!
testNumberOfImplementors
	"self run: #testNumberOfImplementors"

	self assert: (SystemNavigation new numberOfImplementorsOf: #nobodyImplementsThis) isZero.
	self assert: (SystemNavigation new numberOfImplementorsOf: #zoulouSymbol) = 2.! !

!CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'!
testBehaviorDefineIsMeta
	self deny: Behavior new isMeta! !

!CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'!
testMetaclassDefineIsMeta
	self assert: Metaclass new isMeta! !

!CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:37'!
testMovePowerManagementToPwerManagement
	self
		assert: (self isSelector: #disablePowerManager definedInClassOrMetaClass: PowerManagement class).
	self
		assert: (self isSelector: #enablePowerManager definedInClassOrMetaClass: PowerManagement class).
	self
		assert: (self isSelector: #disablePowerManager: definedInClassOrMetaClass: PowerManagement class).
	self
		assert: (self isSelector: #itsyVoltage definedInClassOrMetaClass: PowerManagement class)! !

!CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:45'!
testMoveSortAllCategoriesToClassOrganizer

	self
	 assert: (self isSelector: #sortAllCategories definedInClassOrMetaClass: ClassOrganizer class).

! !

!CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'!
testPullUpIsMeta
	self
		deny: (self isSelector: #isMeta definedInClass: #ClassDescription).
	self
		deny: (self isSelector: #isMeta definedInClass: #Class).
	self
		assert: (self isSelector: #isMeta definedInClass: #Behavior)! !

!CleanKernelTest methodsFor: 'isMeta'!
testPullUpIsWithAllSubclasses
	"self run: #testPullUpIsWithAllSubclasses" 
	self
		deny: (self isSelector: #withAllSubclasses definedInClass: #ClassDescription).
	self
		assert: (self isSelector: #withAllSubclasses definedInClass: #Behavior)! !

!CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:08'!
testMetaclassClassClassDescriptionDoesNotReferToSmalltalk
	"self run: #testMetaclassClassClassDescriptionDoesNotReferToSmalltalk"

	self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk).
	self deny: ((Analyzer externalReferenceOf: (Array with: ClassDescription)) includes: #Smalltalk). 
	self deny: ((Analyzer externalReferenceOf: (Array with: Class)) includes: #Smalltalk).! !

!CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:06'!
testMetaclassDoesNotReferToSmalltalk
	"self run: #testMetaclassDoesNotReferToSmalltalk"

	self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk).! !

!CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 15:16'!
testNilEnvironment
	"self run: #testNilEnvironment"

	self assert: nil environment == Smalltalk! !

!CleanKernelTest methodsFor: 'allSubclasses' stamp: 'md 10/30/2003 09:30'!
testPullUpAllSubclasses
	self
		deny: (self isSelector: #allSubclasses definedInClass: #ClassDescription).
	self
		assert: (self isSelector: #allSubclasses definedInClass: #Behavior)! !

!CleanKernelTest methodsFor: 'browing' stamp: 'sd 3/28/2003 17:00'!
testRemoveBroweMethod
	self
		deny: (self isSelector: #browse definedInClass: #Behavior)! !

!CleanKernelTest methodsFor: 'module reference' stamp: 'md 10/29/2003 23:44'!
testRemoveSubclassModuleMethod
	self 
		deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:module: definedInClass: #Class)! !

!CleanKernelTest methodsFor: 'module reference' stamp: 'sd 3/28/2003 18:15'!
testRemoveSubclassModuleMethodInClass
	self
		deny: (self isSelector: #existingCategoryFor:orConvert:   definedInClass: #Class).
	self
		deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:module:  definedInClass: #Class).
self
		deny: (self isSelector: #variableByteSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class).
self
		deny: (self isSelector: #variableSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class).
self
		deny: (self isSelector: #variableWordSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class).
self
		deny: (self isSelector: #weakSubclass:instanceVariableNames:classVariableNames:module:  definedInClass: #Class).
! !

!CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:48'!
testReshapeClass
	"see if reshaping classes works"
	"self run: #testReshapeClass"

	| testInstance testClass testMeta newClass newMeta |
	testClass _ Smalltalk at: #ClassBuilderTestClass.
	testMeta _ testClass class.
	testInstance _ testClass new.
	testInstance var1: 42.
	testInstance var2: 'hello'.
	newClass _ self
				createClassNamed: #ClassBuilderTestClass
				superClass: Object
				instanceVariables: 'foo var1 bar var2 mumble'.
	newMeta _ newClass class.
	"test transparency of mapping"
	self assert: testInstance var1 = 42.
	self assert: testInstance var2 = 'hello'.
	self assert: (testInstance instVarAt: 1) isNil.
	self assert: (testInstance instVarAt: 2)
			= 42.
	self assert: (testInstance instVarAt: 3) isNil.
	self assert: (testInstance instVarAt: 4)
			= 'hello'.
	self assert: (testInstance instVarAt: 5) isNil.
	"test transparency of reshapes"
	self assert: testInstance class == newClass.
	self assert: testClass == newClass.
	self assert: testMeta == newMeta! !

!CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:49'!
testReshapeClassWithJugglingInstVars
	"see if reshapes of classes juggle their instVars correctly"

	| testInstance testClass testMeta newClass newMeta |
	testClass _ Smalltalk at: #ClassBuilderTestClass.
	testMeta _ testClass class.
	testInstance _ testClass new.
	testInstance var1: 42.
	testInstance var2: 'hello'.
	newClass _ self
				createClassNamed: #ClassBuilderTestClass
				superClass: Object
				instanceVariables: 'var2 foo bar mumble var1'.
	newMeta _ newClass class.
	"test transparency of mapping"
	self assert: testInstance var1 = 42.
	self assert: testInstance var2 = 'hello'.
	self assert: (testInstance instVarAt: 1)
			= 'hello'.
	self assert: (testInstance instVarAt: 2) isNil.
	self assert: (testInstance instVarAt: 3) isNil.
	self assert: (testInstance instVarAt: 4) isNil.
	self assert: (testInstance instVarAt: 5)
			= 42.
	"test transparency of reshapes"
	self assert: testInstance class == newClass.
	self assert: testClass == newClass.
	self assert: testMeta == newMeta! !

!CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:55'!
testReshapeSubClass
	"self run: #testReshapeSubClass"
	"self debug: #testReshapeSubClass"

	| testInstance testClass testMeta |

	testClass _ Smalltalk at: #ClassBuilderTestSubClass.
	testMeta _ testClass class.
	testInstance _ testClass new.
	testInstance var1: 42.
	testInstance var2: 'hello'.
	testInstance var3: 'foo'.
	testInstance var4: #bar.
	self
		createClassNamed: #ClassBuilderTestClass
		superClass: Object
		instanceVariables: 'var1 foo var2 bar mumble '.
	self assert: testInstance var1 = 42.
	self assert: testInstance var2 = 'hello'.
	self assert: testInstance var3 = 'foo'.
	self assert: testInstance var4 = #bar.
	self assert: (testInstance instVarAt: 1)
			= 42.
	self assert: (testInstance instVarAt: 2) isNil.
	self assert: (testInstance instVarAt: 3)
			= 'hello'.
	self assert: (testInstance instVarAt: 4) isNil.
	self assert: (testInstance instVarAt: 5) isNil.
	self assert: (testInstance instVarAt: 6)
			= 'foo'.
	self assert: (testInstance instVarAt: 7)
			= #bar.
	self assert: testInstance class == (Smalltalk at: #ClassBuilderTestSubClass).
	self assert: testClass == (Smalltalk at: #ClassBuilderTestSubClass).
	self assert: testMeta == (Smalltalk at: #ClassBuilderTestSubClass) class! !

!CleanKernelTest methodsFor: 'classBuilder' stamp: 'sd 5/23/2003 14:52'!
testValidateSubclassFormatFix
	"Recompiling Array"
	self
		shouldnt: [ArrayedCollection
				variableSubclass: #Array
				instanceVariableNames: ''
				classVariableNames: ''
				poolDictionaries: ''
				category: 'Collections-Arrayed']
		raise: Error.
	ChangeSet current removeClassChanges: #Array! !

!CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:09'!
testTheMetaClass
	"self run: #testTheMetaClass"

	self assert: Class class theMetaClass == Class class.
	self assert: Class theMetaClass == Class class.! !

!CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:10'!
testTheNonMetaClass
	"self run: #testTheNonMetaClass"

	self assert: Class class theNonMetaClass == Class.
	self assert: Class theNonMetaClass == Class.! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:07'!
clearInterpreter

	interpreter _ nil.
! !

!Clipboard methodsFor: 'accessing' stamp: 'RAA 2/6/2001 11:18'!
clipboardText
	"Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard."

	| s |
	s _ self primitiveClipboardText.
	(s isEmpty or: [s = contents asString])
		ifTrue: [^ contents]
		ifFalse: [^ s asText]! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:04' prior: 35047868!
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: 'RAA 2/6/2001 11:21'!
clipboardText: text
	"Set text currently on the clipboard.  Also export to OS"
	contents _ text.
	self noteRecentClipping: text asText.
	self primitiveClipboardText: text asString! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:12' prior: 35049095!
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: 'yo 9/26/2003 11:51'!
setInterpreter

	interpreter _ Smalltalk systemLanguage defaultClipboardInterpreter.
	interpreter ifNil: [interpreter _ NoConversionClipboardInterpreter new].
! !

!Clipboard class methodsFor: 'class initialization' stamp: 'yo 8/11/2003 22:43'!
clearInterpreters

	self allInstances do: [:each | each clearInterpreter].
! !

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

!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: 'sw 7/30/2001 23:31'!
initializeToStandAlone
	super initializeToStandAlone.
	self initialize.
	color _ Color blue.
	self borderWidth: 6; borderColor: (Color r: 1.0 g: 0.355 b: 0.452).
	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: 'parts bin' stamp: 'dgd 2/14/2003 22:09' prior: 35050994!
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 commentStamp: '<historical>' prior: 0!
A morph that always displays the current contents of the text clipboard.!
!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'! !

!ClockMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 19372485!
initialize
"initialize the state of the receiver"
	super initialize.
""
	showSeconds _ true.
	self step! !

!ClockMorph methodsFor: 'initialization' stamp: 'fc 2/8/2004 11:33' prior: 35052595!
initialize
"initialize the state of the receiver"
	super initialize.
""
	showSeconds _ true.
	show24hr _ false.
	self step! !

!ClockMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 17:41'!
initializeToStandAlone
	super initializeToStandAlone.
	showSeconds _ true.
	self step! !

!ClockMorph methodsFor: 'stepping and presenter' stamp: 'fc 2/8/2004 11:40' prior: 19372751!
step
	| time |
	super step.
	time _ String streamContents:
		[:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm].

	self contents: time			! !

!ClockMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17' prior: 19372018!
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
! !

!ClockMorph methodsFor: 'menu' stamp: 'fc 2/8/2004 11:57' prior: 35053424!
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: '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 class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:22'!
descriptionForPartsBin
	^ self partName:	'Clock'
		categories:		#('Useful')
		documentation:	'A digital clock'! !

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

!CodeHolder methodsFor: 'annotation' stamp: 'jcg 9/22/2001 00:41'!
addOptionalAnnotationsTo: window at: fractions plus: verticalOffset
	"Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any"

	| aTextMorph divider delta |
	self wantsAnnotationPane ifFalse: [^ verticalOffset].
	aTextMorph _ PluggableTextMorph 
		on: self
		text: #annotation 
		accept: nil
		readSelection: nil
		menu: #annotationPaneMenu:shifted:.
	aTextMorph
		askBeforeDiscardingEdits: false;
		borderWidth: 0;
		hideScrollBarIndefinitely.
	divider _ BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:[
		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 - 1))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'annotation' stamp: 'nk 4/28/2004 10:16' prior: 35055769!
addOptionalAnnotationsTo: window at: fractions plus: verticalOffset
	"Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any"

	| aTextMorph divider delta |
	self wantsAnnotationPane ifFalse: [^ verticalOffset].
	aTextMorph _ PluggableTextMorph 
		on: self
		text: #annotation 
		accept: nil
		readSelection: nil
		menu: #annotationPaneMenu:shifted:.
	aTextMorph
		askBeforeDiscardingEdits: false;
		borderWidth: 0;
		hideScrollBarsIndefinitely.
	divider _ BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:[
		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 - 1))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:00'!
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: 'sw 9/11/2002 21:30'!
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: 'sw 8/26/2002 10:15'!
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 _ (Smalltalk allCallsOn: aSelector) size.
			sendersCount _ sendersCount == 1
				ifTrue:
					['1 sender']
				ifFalse:
					[sendersCount printString, ' senders'].
			aStream nextPutAll: sendersCount, separator].

		aRequest == #implementorsCount ifTrue:
			[implementorsCount _ Smalltalk 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: 'sd 4/29/2003 11:54' prior: 35059834!
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: '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 2/1/2004 17:56'!
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 _ (PopUpMenu labelArray: labels lines: lines)
		startUpWithCaption: aPrompt.
		menuIndex = 0 ifTrue: [^ nil].
		menuIndex = 1])
			ifTrue:
				[FillInTheBlank request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: 
				[labels at: menuIndex].
	^ newName ifNotNil: [newName asSymbol]! !

!CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:55' prior: 19377943!
categoryOfCurrentMethod
	"Answer the category that owns the current method.  If unable to determine a category, answer nil."

	| aClass aSelector |
	^ (aClass _ self selectedClassOrMetaClass) 
		ifNotNil: [(aSelector _ self selectedMessageName) 
			            ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 10/29/2001 06:58'!
changeCategory
	"Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message"

	| aClass aSelector |
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[(aSelector _ self selectedMessageName) ifNotNil:
			[(aClass letUserReclassify: aSelector) ifTrue:
				["Smalltalk changes reorganizeClass: aClass."
				"Decided on further review that the above, when present, could cause more
                    unexpected harm than good"
				self methodCategoryChanged]]]! !

!CodeHolder methodsFor: 'categories' stamp: 'nk 7/2/2003 10:47' prior: 35069048!
changeCategory
	"Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message"

	| aClass aSelector |
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[(aSelector _ self selectedMessageName) ifNotNil:
			[(aClass letUserReclassify: aSelector) 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 2/1/2004 17:55' prior: 35069668!
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 2/1/2004 17:54'!
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: '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: 'sw 5/20/2001 10:21'!
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 printAlternateSyntax
			ifTrue:
				[#altSyntax]
			ifFalse:
				[Preferences browseWithPrettyPrint
					ifTrue:
						[Preferences colorWhenPrettyPrinting
							ifTrue:	[#colorPrint]
							ifFalse:	[#prettyPrint]]
					ifFalse:
						[#source]]]! !

!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' prior: 19383134!
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: 'sw 2/27/2001 07:26'!
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: 
		[Smalltalk browseAllImplementorsOf: aMessageName]! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 4/16/2003 09:33' prior: 35073562!
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: 'sw 3/19/2001 06:08'!
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: Smalltalk! !

!CodeHolder methodsFor: 'commands' stamp: 'nk 6/26/2003 21:43' prior: 35074308!
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: 'sw 3/20/2001 15:33'!
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:	[^ self beep].

	allClasses _ Utilities hierarchyOfClassesSurrounding: aClass.
	implementors _ Utilities 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: 'nb 6/17/2003 12:25' prior: 35074930!
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 _ Utilities hierarchyOfClassesSurrounding: aClass.
	implementors _ Utilities 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: 'sd 1/16/2004 21:05' prior: 35076422!
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: 'sw 11/15/2002 13:16'!
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: [self 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: 'nb 6/17/2003 12:25' prior: 35080015!
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: 'sw 9/27/2001 00:11'!
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) ifNil: [^ self].
	aList _ cls allUnreferencedClassVariables.
	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: 'commands' stamp: 'sd 4/29/2003 13:09' prior: 35081968!
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)
		ifNil: [^ 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: 'commands' stamp: 'sw 9/26/2001 01:55'!
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) ifNil: [^ self].
	aList _ cls allUnreferencedInstanceVariables.
	aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced
instance variables in
', cls name].
	aReport _ String streamContents:
		[:aStream |
			aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr.
			aList do: [:el | aStream tab; nextPutAll: el; cr]].
	Transcript cr; show: aReport.
	(SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced
instance variables in 
', cls name! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 2/22/2001 06:38'!
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: 'sw 11/12/2002 13:41'!
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].
	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: 'commands' stamp: 'sw 3/20/2001 15:10'!
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: 'nk 11/9/2003 08:06' prior: 19393697!
buildMorphicCodePaneWith: editString
	"Construct the pane that shows the code.
	Respect the Preference for standardCodeFont."

	| codePane |
	codePane := PluggableTextMorph
				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: 'controls' stamp: 'ar 8/19/2001 16:15'!
addOptionalButtonsTo: window at: fractions plus: verticalOffset
	"If the receiver wishes it, add a button pane to the window, and answer the verticalOffset plus the height added"

	| delta buttons divider |
	self wantsOptionalButtons ifFalse: [^verticalOffset].
	delta _ self defaultButtonPaneHeight.
	buttons _ self optionalButtonRow 
		color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]);
		borderWidth: 0.
	Preferences alternativeWindowLook ifTrue:[
		buttons color: Color transparent.
		buttons submorphsDo:[:m| m borderWidth: 2; borderColor: #raised].
	].
	divider _ BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:[
		divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	].
	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: 'controls' stamp: 'gm 2/16/2003 20:37' prior: 19394087!
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: 'ar 8/19/2001 16:28'!
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 beTransparent.
	aButton borderColor: Color black.
	^aButton! !

!CodeHolder methodsFor: 'controls' stamp: 'sw 5/19/2001 01:12'!
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: 'sw 11/13/2001 07:48'!
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') 
(altSyntax		toggleAltSyntax				showingAltSyntaxString		'altSyntax'			'alternative syntax')
-
(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: 'sw 7/31/2002 13:12'!
decorateForInheritance
	"Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to."

	| aColor aButton |
	(aButton _ self inheritanceButton) ifNil: [^ self].

	aColor _ (((currentCompiledMethod isKindOf: CompiledMethod) not) or: [Preferences decorateBrowserButtons not])
		ifTrue:
			[Color transparent]
		ifFalse:
			[currentCompiledMethod sendsToSuper
				ifTrue:
					[self isThereAnOverride
						ifTrue:
							[Color blue muchLighter]
						ifFalse:
							[Color green muchLighter ]]
				ifFalse:
					[self isThereAnOverride
						ifTrue:
							[Color tan lighter]
						ifFalse:
							[Color transparent]]].
	aButton offColor: aColor! !

!CodeHolder methodsFor: 'controls' stamp: 'nk 7/6/2003 08:29' prior: 35093574!
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 10/2/2001 00:22'!
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' )}]
		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: 'nk 7/7/2003 11:39' prior: 35095580!
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: 'tk 9/8/2001 22:40'!
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: 3.
	Preferences menuButtonInToolPane
		ifTrue:
			[aRow addMorphFront: self menuButton].

	self optionalButtonPairs  do:
		[:tuple |
			aButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: tuple second.
			aButton 
				useRoundedCorners;
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				onColor: Color transparent offColor: Color transparent.
			aLabel _ Preferences abbreviatedBrowserButtons 
				ifTrue: [self abbreviatedWordingFor: tuple second]
				ifFalse: [nil].
			aButton label: (aLabel ifNil: [tuple first asString])
				" font: (StrikeFont familyName: 'Atlanta' size: 9)".
			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: 'sw 11/13/2001 09:09'!
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: 'sw 5/20/2001 21:14'!
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: 'sw 6/8/2001 00:37'!
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: 'sw 11/13/2001 07:37'!
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: 'sw 5/18/2001 19:54'!
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: 'sw 9/5/2001 13:36'!
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: 'sw 5/22/2001 18:25'!
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: 'sw 11/13/2001 07:50'!
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: 'sw 5/18/2001 23:50'!
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 11/13/2001 07:30'!
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: 'sw 5/18/2001 19:57'!
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: 'sw 5/19/2001 00:02'!
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: 'sw 5/18/2001 19:54'!
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: 'sw 11/13/2001 07:27'!
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: '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: 'nk 4/10/2001 07:53'!
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 _ FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'.
		^ 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: 'RAA 5/28/2001 11:42'!
isThereAnOverride
	"Answer whether any subclass of my selected class implements my selected selector"

	| aName aClass |

	aName _ self selectedMessageName ifNil: [^ false].
	aClass _ self selectedClassOrMetaClass.
	(Smalltalk allImplementorsOf: aName) do: [ :each |
		(each actualClass inheritsFrom: aClass) ifTrue: [^ true]
	].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 4/19/2003 12:12' prior: 35110116!
isThereAnOverride
	"Answer whether any subclass of my selected class implements my 
	selected selector"
	| aName aClass |
	aName _ self selectedMessageName
				ifNil: [^ false].
	aClass _ self selectedClassOrMetaClass.
	(self systemNavigation allImplementorsOf: aName)
		do: [:each | (each actualClass inheritsFrom: aClass)
				ifTrue: [^ true]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:49' prior: 35110535!
isThereAnOverride
	"Answer whether any subclass of my selected class implements my 
	selected selector"
	| aName aClass |
	aName _ self selectedMessageName
				ifNil: [^ false].
	aClass _ self selectedClassOrMetaClass.
	aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:52'!
isThisAnOverride
	"Answer whether any superclass of my selected class implements my selected selector"
	| aName aClass |
	aName _ self selectedMessageName
				ifNil: [^ false].
	aClass _ self selectedClassOrMetaClass.
	aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 8/1/2001 11:08'!
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: '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: 'sw 5/22/2001 16:47'!
refusesToAcceptCode
	"Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to"

	^ (#(byteCodes documentation altSyntax tiles) includes: self contentsSymbol)! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 3/19/2001 06:06'!
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 _FillInTheBlank 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: '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: 'sw 3/20/2001 09:26'!
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 _FillInTheBlank 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: 'sw 7/31/2002 13:11'!
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].

	aSelector == #Comment 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 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: 'what to show' stamp: 'sw 5/18/2001 23:35'!
addContentsTogglesTo: aMenu
	"Add updating menu toggles governing contents to aMenu."

	self contentsSymbolQuints do:
		[:aQuint |
			aQuint == #-
				ifTrue:
					[aMenu addLine]
				ifFalse:
					[aMenu addUpdating: aQuint third target: self action: aQuint second.
					aMenu balloonTextForLastItem: aQuint fifth]]! !

!CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:59' prior: 35116886!
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: 'sw 5/24/2001 14:14'!
offerWhatToShowMenu
	"Offer a menu governing what to show"

	 | aMenu  |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'What to show'.
	aMenu addStayUpItem.
	self addContentsTogglesTo: aMenu.
	aMenu popUpInWorld 
! !

!CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:29' prior: 35118182!
offerWhatToShowMenu
	"Offer a menu governing what to show"
	| aMenu |
	Smalltalk isMorphic
		ifTrue: [aMenu := MenuMorph new defaultTarget: self.
			aMenu addTitle: 'What to show'.
			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: 'sw 2/14/2001 15:25'!
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: 'sw 5/20/2001 09:26'!
showAltSyntax: aBoolean
	"Set the decompile toggle as indicated"

	self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#altSyntax])! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 21:13'!
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 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 5/20/2001 09:27'!
showingAltSyntax
	"Answer whether the receiver should show alt syntax rather than, say, source code"

	^ self contentsSymbol == #altSyntax
! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:37'!
showingAltSyntaxString
	"Answer a string characerizing whether altSyntax is showing"

	^ (self showingAltSyntax
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'altSyntax'! !

!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 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 5/20/2001 09:28'!
toggleAltSyntax
	"Toggle the setting of the showingAltSyntax flag, unless there are unsubmitted edits that the user declines to discard"

	| wasShowing |
	self okToChange ifTrue:
		[wasShowing _ self showingAltSyntax.
		self restoreTextualCodingPane.
		self showAltSyntax: wasShowing not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:48'!
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: 'sw 5/18/2001 20:15'!
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: 'tiles' stamp: 'sw 7/27/2001 19:01'!
addModelItemsToWindowMenu: aMenu
	"Add model-related item to the window menu"

	super addModelItemsToWindowMenu: aMenu. 
	Smalltalk isMorphic ifTrue:
		[aMenu addLine.
		aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu]! !

!CodeHolder methodsFor: 'tiles' stamp: 'RAA 5/20/2001 10: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: 'tiles' stamp: 'sw 8/16/2002 23:39'!
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 classThatUnderstands:  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: [nil].
	codePane ifNotNil: [codePane hideScrollBar].
	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: 'tiles' prior: 35125586!
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 hideScrollBar].
	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: 'tiles' stamp: 'nk 4/28/2004 10:14' prior: 35126951!
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: '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: 'tiles' stamp: 'sw 2/3/2001 00:10'!
showingTiles
	"Answer whether the receiver is currently showing tiles"

	^ contentsSymbol == #tiles
! !

!CodeHolder methodsFor: '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: '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: 'categories & search pane' stamp: 'sw 3/7/2001 12:17'!
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: 'sw 12/1/2000 20:44'!
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: 'sw 3/7/2001 12:21'!
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: 'message list' stamp: 'sw 5/20/2001 06:57'!
decompiledSourceIntoContents
	"Obtain a source string by decompiling the method's code, and place that source string into my contents.  Get temps from source file"

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

	tempNames _ (class compilerClass new
					parse: method getSourceFromFile asString in: class notifying: nil)
					tempNames.
	contents _ ((class decompilerClass new withTempNames: tempNames)
			decompile: selector in: class method: method) decompileString.
	contents _ contents asText makeSelectorBoldIn: class.
	^ contents copy! !

!CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:50' prior: 35132904!
decompiledSourceIntoContents
	"For backwards compatibility."

	^self  decompiledSourceIntoContentsWithTempNames: (Sensor leftShiftDown not) 
! !

!CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:41'!
decompiledSourceIntoContentsWithTempNames: showTempNames 
	"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 showTempNames is true."

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

	currentCompiledMethod := method.
	(showTempNames not
			or: [method fileIndex > 0
					and: [(SourceFiles at: method fileIndex) isNil]])
		ifTrue: [
			"Emergency or no source file -- decompile without temp names "
			contents := (class decompilerClass new
						decompile: selector
						in: class
						method: method) decompileString]
		ifFalse: [tempNames := (class compilerClass new
						parse: method getSourceFromFile asString
						in: class
						notifying: nil) tempNames.
			contents := ((class decompilerClass new withTempNames: tempNames)
						decompile: selector
						in: class
						method: method) decompileString].
	contents := contents asText makeSelectorBoldIn: class.
	^ contents copy! !

!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: 'sw 6/4/2001 17:31'!
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 tempNames |
	contents == nil ifFalse: [^ 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.

	(Sensor controlKeyPressed
		or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])
		ifTrue:
		["Emergency or no source file -- decompile without temp names"
		contents _ (class decompilerClass new decompile: selector in: class method: method)
			decompileString.
		contents _ contents asText makeSelectorBoldIn: class.
		^ contents copy].

	Sensor leftShiftDown ifTrue:
		["Special request to decompile -- get temps from source file"
		tempNames _ (class compilerClass new
						parse: method getSourceFromFile asString in: class notifying: nil)
						tempNames.
		contents _ ((class decompilerClass new withTempNames: tempNames)
				decompile: selector in: class method: method) decompileString.
		contents _ contents asText makeSelectorBoldIn: class.
		^ contents copy].

	self showComment
		ifFalse:
			[contents _ self sourceStringPrettifiedAndDiffed]
		ifTrue:
			[contents _ self commentContents].
	^ contents _ contents copy asText makeSelectorBoldIn: class! !

!CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:46' prior: 35135487!
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 decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

	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: 'sw 7/23/2002 13:05'!
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 altSyntax) includes: contentsSymbol) ifTrue:
		[sourceString _ class compilerClass new
			format: sourceString in: class notifying: nil contentsSymbol: contentsSymbol].
	self showingAnyKindOfDiffs ifTrue:
		[sourceString _ self diffFromPriorSourceFor: sourceString].

	^ sourceString! !

!CodeHolder methodsFor: 'message list' stamp: 'sw 8/19/2001 12:57'!
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: Smalltalk 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' stamp: 'sd 9/30/2003 14:01' prior: 35139218!
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: 'sw 8/5/2002 16:56'!
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: Smalltalk].
	aChar == $n ifTrue: 
		[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk].

	"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 == $C and: [self canShowMultipleMessageCategories])
			ifTrue: [^ self showHomeCategory]].

	^ self arrowKey: aChar from: view! !

!CodeHolder methodsFor: 'message list menu' stamp: 'sd 4/16/2003 09:33' prior: 35142179!
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 == $C and: [self canShowMultipleMessageCategories])
			ifTrue: [^ self showHomeCategory]].

	^ self arrowKey: aChar from: view! !

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

!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: 'bf 3/2/2001 16:18'!
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 respondsTo: #close) ifTrue:[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: 'sd 1/30/2004 15:16' prior: 35145814!
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: 'bf 3/2/2001 16:18'!
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 respondsTo: #close) ifTrue:[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: 'sd 1/30/2004 15:16' prior: 35147371!
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: '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' prior: 19404634!
httpRequestClass
	^HTTPDownloadRequest! !

!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: 'ar 2/6/2001 19:22'!
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 splitName: destFile to:[:path :file|
		SecurityManager default signFile: file directory: (FileDirectory on: path).
	].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'asm 12/6/2002 08:11' prior: 35149258!
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: 'ads 7/31/2003 14:00' prior: 19412289!
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.

! !

!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' prior: 19418210!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self codecClassName: 'MuLawCodec'! !

!CodecDemoMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17' prior: 19417603!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'select codec' translated action: #selectCodec.
! !

!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' prior: 19419589!
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: 'queries' stamp: 'sw 4/9/2001 12:53'!
isMyUncollapsedMorph: aMorph
	"Answer whether my uncollapsed morph is aMorph"

	^ uncollapsedMorph == aMorph! !

!CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ false! !

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

!Collection methodsFor: 'accessing' stamp: 'tk 4/9/2001 15:26'!
atRandom
	"Answer a random element of the receiver.  Uses a shared random 
	number generator owned by class Collection.  If you use this a lot, 
	define your own instance of Random and use #atRandom:.  Causes 
	an error if self has no elements."

	^ self atRandom: Collection randomForPicking

"Examples:
	#('one' 'or' 'the' 'other') atRandom
	(1 to: 10) atRandom
	'Just pick one of these letters at random' atRandom
	#(3 7 4 9 21) asSet atRandom		(just to show it also works for Sets)
"! !

!Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05' prior: 35154318!
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: 'arithmetic' stamp: 'raok 10/22/2002 00:17'!
raisedTo: arg

	^ arg adaptToCollection: self andSend: #raisedTo:! !

!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: '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' 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: '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: '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: '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: '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: 'raok 10/22/2002 00:21'!
ln
	^self collect: [:each | each ln]! !

!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: 'raok 10/22/2002 00:22'!
tan
	^self collect: [:each | each tan]! !

!Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14' prior: 19441276!
errorNotKeyed

	self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name})
! !

!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: 'jf 12/1/2003 15:39'!
ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"

	^ self isEmpty ifTrue: emptyBlock ifFalse: notEmptyBlock! !

!Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:11' prior: 35159270!
ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"

	^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgs: {self}]! !

!Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'!
ifNotEmpty: aBlock
	"Evaluate the block unless I'm empty"

	^ self isEmpty ifFalse: aBlock! !

!Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:08' prior: 35159784!
ifNotEmpty: aBlock
	"Evaluate the block unless I'm empty"

	^self isEmpty ifFalse: [aBlock valueWithPossibleArgs: {self}].
! !

!Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:47'!
ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"

	^ self isEmpty ifFalse: notEmptyBlock ifTrue: emptyBlock! !

!Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:11' prior: 35160149!
ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"

	^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgs: {self}] ifTrue: emptyBlock! !

!Collection methodsFor: 'testing' stamp: 'dgd 4/4/2004 12:14'!
isZero
	"Answer whether the receiver is zero"
	^ false! !

!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: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26' prior: 35160795!
gather: aBlock
	^ Array streamContents:
		[:stream |
		self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! !

!Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26' prior: 35161002!
gather: aBlock
	^ Array streamContents:
		[:stream |
		self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! !

!Collection methodsFor: '*connectors-truncation and round-off' stamp: 'nk 12/30/2003 15:47'!
roundTo: quantum
	^self collect: [ :ea | ea roundTo: quantum ]! !

!Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07' prior: 19448850!
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! !

!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 4/20/2001 04:33'!
isOpaque
	^true! !

!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: '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: 'dew 1/19/2002 01:29'!
muchDarker

	^ self alphaMixed: 0.5 with: Color black
! !

!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: 'dew 3/23/2002 01:38'!
whiter

	^ self alphaMixed: 0.8333 with: Color white
! !

!Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'!
raisedColor
	^ self! !

!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: 'Morphic menu' stamp: 'dgd 10/17/2003 12:10' prior: 19485797!
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 class methodsFor: 'instance creation' stamp: 'sw 2/26/2002 10:46'!
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 isKindOf: Symbol) ifTrue: [^ self perform: 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: 'dew 3/19/2002 23:49'!
h: h s: s v: v alpha: alpha

	^ (self h: h s: s v: v) alpha: alpha! !

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

!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: '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: '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: '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: 'copying' stamp: 'di 11/12/2001 15:37'!
blankCopyOf: aRectangle scaledBy: scale

        | newForm |
        newForm _ super blankCopyOf: aRectangle scaledBy: scale.
        colors ifNotNil: [newForm colors: colors copy].
        ^ newForm! !

!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: '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: '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: '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: '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 class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44' prior: 19538090!
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
! !

!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 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: '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 class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'!
masks: maskArray shifts: shiftArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!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-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 8/8/2001 14:14'!
on: aCanvas
	myCanvas _ aCanvas.! !

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

!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: 'ar 8/25/2001 20: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 isKindOf: Color)
		ifTrue: [colorOrSymbol]
		ifFalse: [Color lightGreen].
	originalForm fill: RevertBox fillColor: originalColor.
	selectedColor _ originalColor.
	self locationIndicator center: self topLeft + (self positionOfColor: originalColor).! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'gm 2/22/2003 13:12' prior: 35180946!
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 locationIndicator 
		center: self topLeft + (self positionOfColor: originalColor)! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:24' prior: 19559531!
target: anObject 
	target := anObject.
	selectedColor := (target respondsTo: #color)  
				ifTrue: [target color]
				ifFalse: [Color white]! !

!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: '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: 'RAA 2/19/2001 13:18'!
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').
	self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'shows selected color').
	self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'adjust translucency').

	self buildChartForm.
	
	selectedColor ifNil: [selectedColor _ Color white].
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	updateContinuously _ true.
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17' prior: 19566670!
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: 'tk 2/21/2001 17:54'!
pickUpColorFor: aMorph
	"Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle"

      | aHand localPt |
	aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand].
	aHand ifNil: [aHand _ self currentHand].
	self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds.
	self owner ifNil: [^ self].

	aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) 
			hotSpotOffset: 6 negated @ 4 negated.    "<<<< the form was changed a bit??"

	self updateContinuously: false.
	[Sensor anyButtonPressed]
		whileFalse: 
			 [self trackColorUnderMouse].
	self deleteAllBalloons.

	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].
	aHand newMouseFocus: nil;
		showTemporaryCursor: nil;
		flushEvents.
	self delete.
		 
 ! !

!ColorPickerMorph methodsFor: 'other' stamp: 'dgd 8/26/2003 21:44' prior: 19570025!
delete
	"The moment of departure has come.  If the receiver has an affiliated command, finalize it and have the system remember it.  In any case, delete the receiver"

	self rememberCommand: 
		(Command new
			cmdWording: 'color change' translated;
			undoTarget: target selector: selector arguments: (self argumentsWith: originalColor);
			redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)).
	super delete! !

!ColorPickerMorph methodsFor: 'private' stamp: 'ar 7/19/2003 20:40' prior: 19561530!
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: 'dgd 2/21/2003 22:59' prior: 19561995!
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: 'ar 8/25/2001 20:43'!
pickColorAt: aGlobalPoint 

	| alpha selfRelativePoint pickedColor |
	clickedTranslucency ifNil: [clickedTranslucency _ false].
	selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft.
	(FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
	(RevertBox containsPoint: selfRelativePoint)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].

	"check for transparent color and update using appropriate feedback color "
	(TransparentBox containsPoint: selfRelativePoint) ifTrue:
		[clickedTranslucency ifFalse: [^ self].  "Can't wander into translucency control"
		alpha _ (selfRelativePoint x - TransparentBox left - 10) asFloat /
							(TransparentBox width - 20)
							min: 1.0 max: 0.0.
					"(alpha roundTo: 0.01) printString , '   ' displayAt: 0@0." " -- debug"
		self 
			updateColor: (selectedColor alpha: alpha)
			feedbackColor: (selectedColor alpha: alpha).
		^ self].

	"pick up color, either inside or outside this world"
	clickedTranslucency ifTrue: [^ self].  "Can't wander out of translucency control"
	self locationIndicator visible: false. self refreshWorld.
	pickedColor _ Display colorAt: aGlobalPoint.
	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: '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' prior: 19565884!
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' prior: 19566348!
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 commentStamp: 'kfr 10/27/2003 16:16' prior: 0!
A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.!
!ColorSeerTile methodsFor: 'code generation' stamp: 'dgd 2/22/2003 14:25' prior: 19575372!
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: 'sw 10/10/2001 21:23'!
initialize

	| 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: []) elementWording.
	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: 'dgd 3/7/2003 15:45' prior: 35192117!
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: []) elementWording.
	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: 'bf 10/8/2001 14:59'!
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 documentation.! !

!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: 'sw 3/23/2001 12:13'!
readFromTarget
	"Obtain a value from the target and set it into my lastValue"

	| v |
	((target == nil) or: [getSelector == nil]) ifTrue: [^ contents].
	v _ target perform: getSelector with: argument.
	lastValue _ v.
	^ v ! !

!ColorSwatch methodsFor: 'target access' stamp: 'dgd 2/22/2003 13:32' prior: 35194606!
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! !

!ColorTileMorph methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:27'!
resultType
	"Answer the result type of the receiver"

	^ #Color! !

!ColorTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44' prior: 19577440!
initialize
"initialize the state of the receiver"
	super initialize.
""
	type _ #literal.
	self addColorSwatch! !

!ColorType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ Color blue newTileMorphRepresentative! !

!ColorType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:08'!
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.
	(setter isNil or: [#(unused none nil) includes: setter]) ifFalse:
		[readout putSelector: setter].
	^ readout
! !

!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: '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)	! !

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 18:57'!
add: unicode

	| dict elem |
	codes ifNil: [codes _ Array with: unicode. combined _ unicode. ^ true].

	dict _ Compositions at: combined ifAbsent: [^ false].

	elem _ dict at: unicode ifAbsent: [^ false].

	codes _ codes copyWith: unicode.
	combined _ elem.
	^ true.
! !

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 1/1/2003 10:42'!
base

	^ Unicode value: codes first.
! !

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 21:43'!
combined

	^ Unicode value: combined.
! !

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

!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.!
]style[(25 108 10 103)f1b,f1,f1LDeepCopier Comment;,f1! !

!Command methodsFor: 'private' stamp: 'dgd 8/26/2003 21:43' prior: 19590565!
cmdWording
	"Answer the wording to be used to refer to the command in a menu"

	^ cmdWording ifNil: ['last command' translated]! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'aoy 2/15/2003 21:14' prior: 19598632!
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: 'nb 6/17/2003 12:25' prior: 19600082!
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' prior: 19600571!
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' prior: 19601101!
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: 'sw 3/28/2001 10:03'!
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: [^ self 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: 'called from the ui' stamp: 'nb 6/17/2003 12:25' prior: 35202124!
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: 'menu' stamp: 'sw 3/28/2001 09:50'!
redoMenuWording
	"Answer the wording to be used in a menu offering the current Redo command"

	| nextCommand |
	((nextCommand _ self nextCommand) == nil or: [Preferences useUndo not]) ifTrue:  [^ 'can''t redo'].
	^ String streamContents:
		[:aStream | 
			aStream nextPutAll: 'redo "'.
			aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done ifFalse:
				[aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40' prior: 35203624!
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'].
	^String streamContents: 
			[:aStream | 
			aStream nextPutAll: 'redo "'.
			aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done ifFalse: [aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'sw 3/26/2001 23:13'!
undoMenuWording
	"Answer the wording to be used in an 'undo' menu item"

	(((lastCommand == nil or: [Preferences useUndo not]) or:
		[Preferences infiniteUndo not and: [lastCommand phase == #undone]])  or: 
			[self nextCommandToUndo == nil]) ifTrue: [^ 'can''t undo'].

	^ String streamContents:
		[:aStream | 
			aStream nextPutAll: 'undo "'.
			aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done ifTrue:
				[aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40' prior: 35204691!
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'].
	^String streamContents: 
			[:aStream | 
			aStream nextPutAll: 'undo "'.
			aStream 
				nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done ifTrue: [aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'sw 3/28/2001 09:52'!
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 |
	lastCommand ifNil: [^ 'can''t undo'].
	pre _ lastCommand phase == #done
		ifTrue:		['undo']
		ifFalse:		['redo'].
	^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! !

!CommandHistory methodsFor: 'menu' stamp: 'dgd 8/26/2003 21:42' prior: 35205896!
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 |
	lastCommand ifNil: [^ 'can''t undo' translated].
	pre _ lastCommand phase == #done
		ifTrue: ['undo' translated]
		ifFalse: ['redo' translated].
	^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! !

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

!CommandLineLauncherExample methodsFor: 'running' stamp: 'sd 3/28/2003 16:24' prior: 19603667!
startUp
	| className |
	className _ self parameterAt: 'class'.
	Browser newOnClass: (Smalltalk at: className asSymbol ifAbsent: [Object])! !

!CommentedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:37'!
isCommented

	^true! !

!CommentedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:37'!
printEventKindOn: aStream

	aStream nextPutAll: 'Commented'! !

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

!CompiledMethod methodsFor: 'accessing' stamp: 'rw 5/12/2003 11:12'!
defaultSelector 
	"Invent and answer an appropriate message selector (a 
	Symbol) for me, that is, one that will parse with the correct number of 
	arguments."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	aStream nextPutAll: 'DoIt'.
	1 to: self numArgs do: [:i | aStream nextPutAll: 'with:'].
	^aStream contents asSymbol! !

!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: 'nk 3/15/2004 11:29'!
methodReference
	| who |
	who _ self who.
	who = #(unknown unknown) ifTrue: [ ^nil ].
	^MethodReference new setStandardClass: who first methodSymbol: who second.
	! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35' prior: 19616910!
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: '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: 'comparing' stamp: 'ar 8/16/2001 13:24'!
= method
	| myLits otherLits |
	"Answer whether the receiver implements the same code as the 
	argument, method."
	(method isKindOf: CompiledMethod) ifFalse: [^false].
	self size = method size ifFalse: [^false].
	self header = method header ifFalse: [^false].
	self initialPC to: self endPC do:
		[:i | (self at: i) = (method at: i) ifFalse: [^false]].
	(myLits _ self literals) = (otherLits _ method literals) ifFalse:
		[myLits size = otherLits size ifFalse: [^ false].
		"Dont bother checking FFI and named primitives"
		(#(117 120) includes: self primitive) ifTrue: [^ true].
		myLits with: otherLits do:
			[:lit1 :lit2 | lit1 = lit2 ifFalse:
			[(lit1 isVariableBinding)
			ifTrue:
				["Associations match if value is equal, since associations
				used for super may have key = nil or name of class."
				lit1 value == lit2 value ifFalse: [^ false]]
			ifFalse:
				[(lit1 isMemberOf: Float)
				ifTrue:
					["Floats match if values are close, due to roundoff error."
					(lit1 closeTo: lit2) ifFalse: [^ false]]
				ifFalse:
					["any other discrepancy is a failure"
					^ false]]]]].
	^ true! !

!CompiledMethod methodsFor: 'testing' stamp: 'sw 5/3/2001 15:06'!
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) do:
		[:aLit | (self hasLiteral: aLit) ifTrue: [^ true]].

	#(Transcript AA BB CC DD EE) do:
		[:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil:
			[(self hasLiteral: assoc) ifTrue: [^ true]]].

	^ false! !

!CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'!
isCompiledMethod

	^ true! !

!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: 'ajh 2/9/2003 14:17' prior: 35212593!
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: 'ajh 2/9/2003 14:20' prior: 35213023!
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 tabs: 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 tabs: tabs.
		self printPrimitiveOn: aStream.
	].
	(InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream.
! !

!CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08' prior: 35213675!
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: 'ajh 6/27/2003 22:21' prior: 19623134!
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: 'ajh 3/20/2001 11:41' prior: 35214982!
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: 'sw 7/29/2002 02:21'!
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"

	| position file preamble stamp tokens tokenCount |
	self fileIndex == 0 ifTrue: [^ String new].  "no source pointer for this method"
	position _ self filePosition.
	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].
	file position: (0 max: position - 150).  "Skip back to before the preamble"
		[file position < (position - 1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].
		stamp _ String new.
		tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [Scanner new scanTokens: preamble]
			ifFalse: [Array new  "ie cant be back ref"].
		(((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount - 3) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
							stamp _ tokens at: tokenCount - 2]].
		((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount  - 1) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokenCount]].
	file close.
	^ stamp
! !

!CompiledMethod methodsFor: 'printing' stamp: 'sd 4/17/2003 20:45' prior: 19623737!
who 
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."

	| sel |
	SystemNavigation new allBehaviorsDo:
		[:class |
		(sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil])
			ifNotNil: [^Array with: class with: sel]].
	^ Array with: #unknown with: #unknown
! !

!CompiledMethod methodsFor: 'printing' stamp: 'dvf 8/23/2003 11:50' prior: 35217240!
who
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."

	| sel |
	self systemNavigation allBehaviorsDo: 
			[:class | 
			(sel := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) 
				ifNotNil: [^Array with: class with: sel]].
	^Array with: #unknown with: #unknown! !

!CompiledMethod methodsFor: 'literals' stamp: 'ajh 2/9/2003 13:15'!
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 nextPut: $"; cr.
	^ s contents! !

!CompiledMethod methodsFor: 'literals' stamp: 'ar 8/16/2001 13:24'!
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 isMemberOf: Symbol)
				ifTrue: [litStrs addAll: lit keywords]
				ifFalse: [litStrs addLast: lit printString]]].
	^ litStrs! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32' prior: 19632214!
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: '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: 'RAA 5/29/2001 08:49'!
putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock
	"Store the source code for the receiver on an external file.
	If no sources are available, i.e., SourceFile is nil, then store
	temp names for decompilation at the end of the method.
	If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,
	in each case, storing a 4-byte source code pointer at the method end."

	| file remoteString  st80str |
	(SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:
		[^ self become: (self copyWithTempNames: methodNode tempNames)].

	Smalltalk assureStartupStampLogged.
	file setToEnd.

	preambleBlock value: file.  "Write the preamble"
	(methodNode isKindOf: DialectMethodNode)
		ifTrue:
		["This source was parsed from an alternate syntax.
		We must convert to ST80 before logging it."
		st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm])
						asString.
		remoteString _ RemoteString newString: st80str
						onFileNumber: fileIndex toFile: file]
		ifFalse:
		[remoteString _ RemoteString newString: sourceStr
						onFileNumber: fileIndex toFile: file].

	file nextChunkPut: ' '.
	InMidstOfFileinNotification signal ifFalse: [file flush].
	self checkOKToAdd: sourceStr size at: remoteString position.
	self setSourcePosition: remoteString position inFile: fileIndex! !

!CompiledMethod methodsFor: 'source code management' stamp: 'NS 1/16/2004 15:39' prior: 35220166!
putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock
	"Store the source code for the receiver on an external file.
	If no sources are available, i.e., SourceFile is nil, then store
	temp names for decompilation at the end of the method.
	If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,
	in each case, storing a 4-byte source code pointer at the method end."

	| file remoteString  st80str |
	(SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:
		[^ self become: (self copyWithTempNames: methodNode tempNames)].

	SmalltalkImage current assureStartupStampLogged.
	file setToEnd.

	preambleBlock value: file.  "Write the preamble"
	(methodNode isKindOf: DialectMethodNode)
		ifTrue:
		["This source was parsed from an alternate syntax.
		We must convert to ST80 before logging it."
		st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm])
						asString.
		remoteString _ RemoteString newString: st80str
						onFileNumber: fileIndex toFile: file]
		ifFalse:
		[remoteString _ RemoteString newString: sourceStr
						onFileNumber: fileIndex toFile: file].

	file nextChunkPut: ' '.
	InMidstOfFileinNotification signal ifFalse: [file flush].
	self checkOKToAdd: sourceStr size at: remoteString position.
	self setSourcePosition: remoteString position inFile: fileIndex! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32'!
qCompress: str 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 |
	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' stamp: 'yo 3/16/2004 12:48' prior: 35223120!
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' 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: 'ajh 8/13/2002 18:28'!
sourceSelector
	"Answer my selector extracted from my source.  If no source answer nil"

	| sourceString |
	sourceString _ self getSourceFromFile ifNil: [^ nil].
	^ Compiler parserClass new parseSelector: sourceString! !

!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29' prior: 19639919!
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: '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: 'evaluating' stamp: 'ajh 1/28/2003 12:33' prior: 19641553!
valueWithReceiver: aReceiver arguments: anArray 

	^ aReceiver withArgs: anArray executeMethod: self! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/3/2003 21:18'!
blockNode

	BlockNodeCache key == self ifTrue: [^ BlockNodeCache value].
	^ self blockNodeIn: nil! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 5/28/2003 01:10'!
blockNodeIn: homeMethodNode
	"Return the block node for self"

	homeMethodNode ifNil: [
		^ self decompilerClass new decompileBlock: self].

	homeMethodNode ir compiledMethod.  "generate method"
	homeMethodNode nodesDo: [:node |
		(node isBlock and:
		 [node scope isInlined not and:
		  [node ir compiledMethod = self]])
			ifTrue: [
				BlockNodeCache _ self -> node.
				^ node]
	].
	self errorNodeNotFound! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:45'!
decompile
	"Return the decompiled parse tree that represents self"

	^ self decompileClass: nil selector: nil! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:44'!
decompileClass: aClass selector: selector
	"Return the decompiled parse tree that represents self"

	^ self decompilerClass new decompile: selector in: aClass method: self! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'!
decompilerClass
	^Decompiler
! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 13:11'!
isClosureCompiled
	"Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true).  Return false if it was compiled with the old compiler."

	^ self header < 0! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 13:11' prior: 35230383!
isClosureCompiled
	"Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true).  Return false if it was compiled with the old compiler."

	^ self header < 0! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 00:22'!
methodNode
	"Return the parse tree that represents self"

	^ self methodNodeDecompileClass: nil selector: nil! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 3/3/2003 12:02'!
methodNodeDecompileClass: aClass selector: selector
	"Return the parse tree that represents self"

	| source |
	^ (source _ self getSourceFromFile)
		ifNil: [self decompileClass: aClass selector: selector]
		ifNotNil: [self parserClass new parse: source class: (self sourceClass ifNil: [aClass])]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 12/13/2003 18:30' prior: 35231210!
methodNodeDecompileClass: aClass selector: selector
	"Return the parse tree that represents self"

	| source |
	^ (source _ self getSourceFromFile)
		ifNil: [self decompileClass: aClass selector: selector]
		ifNotNil: [self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:59'!
methodNodeFormattedAndDecorated: decorate
	"Return the parse tree that represents self"

	^ self methodNodeFormattedDecompileClass: nil selector: nil decorate: decorate! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:58'!
methodNodeFormattedDecompileClass: aClass selector: selector  decorate: decorated
	"Return the parse tree that represents self, using pretty-printed source text if possible."
	| source sClass node |
	source := self getSourceFromFile.
	sClass _ aClass ifNil: [self sourceClass].
	source ifNil: [ ^self decompileClass: sClass selector: selector].
	source _ sClass compilerClass new
						format: source
						in: sClass
						notifying: nil
						decorated: decorated.
	node _ sClass parserClass new
				parse: source
				class: sClass.
	node sourceText: source.
	^node! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'!
parserClass
	^Parser! !

!CompiledMethod methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:22'!
hasBreakpoint
	^BreakpointManager methodHasBreakpoint: self! !

!CompiledMethod methodsFor: 'user interface' stamp: 'ajh 2/3/2003 19:18'!
inspectorClass

	^ CompiledMethodInspector! !

!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 class methodsFor: 'class initialization' stamp: 'ajh 2/3/2003 21:16' prior: 19642162!
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: 'instance creation' stamp: 'ls 7/5/2003 13:49'!
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 > 64 ifTrue:
		[^ self error: 'Cannot compile -- too many temporary 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' stamp: 'ajh 3/9/2003 15:09'!
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! !

!CompiledMethodInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2003 13:47'!
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: 'ajh 1/18/2003 13:56'!
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! !

!CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:26'!
returnPlusOne: anInteger
	^anInteger + 1.! !

!CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:25'!
returnTrue
	^true! !

!CompiledMethodTest methodsFor: 'testing - 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: 'testing - 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 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!
!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 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 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.! !

!Compiler methodsFor: 'error handling' stamp: 'LC 1/6/2002 13:53' prior: 19647558!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	requestor == nil
		ifTrue: [^SyntaxErrorNotification
					inClass: class
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)
					doitFlag: false]
		ifFalse: [^requestor
					notify: aString
					at: location
					in: sourceStream]! !

!Compiler methodsFor: 'public access' 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: 'RAA 5/28/2001 17:09'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock
	"Compiles the sourceStream into a parse tree, then generates code into a 
	method. This method is then installed in the receiver's class so that it 
	can be invoked. In other words, if receiver is not nil, then the text can 
	refer to instance variables of that receiver (the Inspector uses this). If 
	aContext is not nil, the text can refer to temporaries in that context (the 
	Debugger uses this). If aRequestor is not nil, then it will receive a 
	notify:at: message before the attempt to evaluate is aborted. Finally, the 
	compiled method is invoked from here as DoIt or (in the case of 
	evaluation in aContext) DoItIn:. The method is subsequently removed 
	from the class, but this will not get done if the invocation causes an 
	error which is terminated. Such garbage can be removed by executing: 
	Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 
	#DoItIn:]."

	| methodNode method value |
	class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode _ self translate: sourceStream noPattern: true ifFail:
		[^failBlock value].
	method _ methodNode generate: #(0 0 0 0).
	self interactive ifTrue:
		[method _ method copyWithTempNames: methodNode tempNames].
	context == nil
		ifTrue: [class addSelector: #DoIt withMethod: method.
				value _ receiver DoIt.
				InMidstOfFileinNotification signal ifFalse: [
					class removeSelectorSimply: #DoIt.
				].
				^value]
		ifFalse: [class addSelector: #DoItIn: withMethod: method.
				value _ receiver DoItIn: context.
				InMidstOfFileinNotification signal ifFalse: [
					class removeSelectorSimply: #DoItIn:.
				].
				^value]! !

!Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05' prior: 35241860!
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: 'NS 1/19/2004 10:00'!
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. This method is then installed in the receiver's class so that it 
	can be invoked. In other words, if receiver is not nil, then the text can 
	refer to instance variables of that receiver (the Inspector uses this). If 
	aContext is not nil, the text can refer to temporaries in that context (the 
	Debugger uses this). If aRequestor is not nil, then it will receive a 
	notify:at: message before the attempt to evaluate is aborted. Finally, the 
	compiled method is invoked from here as DoIt or (in the case of 
	evaluation in aContext) DoItIn:. The method is subsequently removed 
	from the class, but this will not get done if the invocation causes an 
	error which is terminated. Such garbage can be removed by executing: 
	Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 
	#DoItIn:]."

	| methodNode method value selector |
	class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode _ self translate: sourceStream noPattern: true ifFail:
		[^failBlock value].
	method _ methodNode generate: #(0 0 0 0).
	self interactive ifTrue:
		[method _ method copyWithTempNames: methodNode tempNames].
	
	selector _ context isNil
		ifTrue: [#DoIt]
		ifFalse: [#DoItIn:].
	SystemChangeNotifier uniqueInstance doSilently: [class addSelector: selector withMethod: method].
	value _ context isNil
		ifTrue: [receiver DoIt]
		ifFalse: [receiver DoItIn: context].
	InMidstOfFileinNotification signal 
		ifFalse: [SystemChangeNotifier uniqueInstance doSilently: [class removeSelectorSimply: selector]].
	logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext].
	^ value.! !

!Compiler methodsFor: 'public access' stamp: 'NS 1/28/2004 11:19' prior: 35244036!
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. This method is then installed in the receiver's class so that it 
	can be invoked. In other words, if receiver is not nil, then the text can 
	refer to instance variables of that receiver (the Inspector uses this). If 
	aContext is not nil, the text can refer to temporaries in that context (the 
	Debugger uses this). If aRequestor is not nil, then it will receive a 
	notify:at: message before the attempt to evaluate is aborted. Finally, the 
	compiled method is invoked from here as DoIt or (in the case of 
	evaluation in aContext) DoItIn:. The method is subsequently removed 
	from the class, but this will not get done if the invocation causes an 
	error which is terminated. Such garbage can be removed by executing: 
	Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 
	#DoItIn:]."

	| methodNode method value selector |
	class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode _ self translate: sourceStream noPattern: true ifFail:
		[^failBlock value].
	method _ methodNode generate: #(0 0 0 0).
	self interactive ifTrue:
		[method _ method copyWithTempNames: methodNode tempNames].
	
	selector _ context isNil
		ifTrue: [#DoIt]
		ifFalse: [#DoItIn:].
	class addSelectorSilently: selector withMethod: method.
	value _ context isNil
		ifTrue: [receiver DoIt]
		ifFalse: [receiver DoItIn: context].
	InMidstOfFileinNotification signal 
		ifFalse: [class basicRemoveSelector: selector].
	logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext].
	^ value.! !

!Compiler methodsFor: 'public access' stamp: 'sw 5/20/2001 10:01'!
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 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].

	aSymbol == #colorPrint
		ifTrue: [^ aNode asColorizedSmalltalk80Text].

	aSymbol == #altSyntax  "Alan's current explorations for alternate syntax - 2000/2001"
		ifTrue:
			[^ aNode asAltSyntaxText].

	^ aNode decompileString! !

!Compiler methodsFor: 'public access' stamp: 'ajh 9/14/2002 18:47' prior: 19651410!
parse: textOrStream in: aClass notifying: req dialect: useDialect
        "Compile the argument, textOrStream, with respect to the class, aClass, 
        and answer the MethodNode that is the root of the resulting parse tree. 
        Notify the argument, req, if an error occurs. The failBlock is defaulted to 
        an empty block."

        self from: textOrStream class: aClass context: nil notifying: req.
        ^ ((useDialect and: [RequestAlternateSyntaxSetting signal])
                ifTrue: [self dialectParserClass]
                ifFalse: [self parserClass]) new
                        parse: sourceStream
                        class: class
                        noPattern: false
                        context: context
                        notifying: requestor
                        ifFail: []! !

!Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:19'!
cacheDoItNode: boolean

	cacheDoItNode _ boolean! !

!Compiler methodsFor: 'private' stamp: 'ar 6/28/2003 00:05'!
dialectParserClass
	^DialectParser! !

!Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44' prior: 19652280!
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: 'ajh 1/21/2003 12:44'!
parserClass

	^ parserClass! !

!Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:20'!
parserClass: aParserClass

	parserClass _ aParserClass.
	cacheDoItNode _ true.
! !

!Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:45' prior: 19652900!
translate: 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 class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:39'!
new

	^ super new parserClass: self parserClass! !

!Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:42'!
old

	^ self new parserClass: Parser! !

!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07' prior: 19653425!
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' stamp: 'NS 1/16/2004 15:41' prior: 19654126!
evaluate: textOrString for: anObject notifying: aController logged: logFlag
	"Compile and execute the argument, textOrString with respect to the class 
	of anObject. If a compilation error occurs, notify aController. If both 
	compilation and execution are successful then, if logFlag is true, log 
	(write) the text onto a system changes file so that it can be replayed if 
	necessary."

	| val |
	val _ self new
				evaluate: textOrString
				in: nil
				to: anObject
				notifying: aController
				ifFail: [^nil].
	logFlag ifTrue: [Smalltalk logChange: textOrString].
	^val! !

!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50' prior: 35251402!
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.! !

!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: 'ar 8/26/2001 19:31'!
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.
	length > 1.0e-10 ifTrue:[dir _ delta / length] ifFalse:[dir _ 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: 'aoy 2/17/2003 01:08' prior: 35253286!
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: 'ar 8/25/2001 16:15'!
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"
		(direction x > 0 or:[direction y < 0]) ifTrue:["up->right"
			colorArray _ cc copyFrom: 1 to: width.
		] ifFalse:["down->left"
			"colors are stored in reverse direction when following a line"
			colorArray _ (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: 'aoy 2/17/2003 01:02' prior: 35264146!
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: 'ar 8/25/2001 16:16'!
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|
		false
			ifTrue:[param _ 0.5 + (hw * i)]
			ifFalse:[param _ 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:03' prior: 35267131!
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: 'ar 8/25/2001 16:16'!
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|
		false 
			ifTrue:[param _ 0.5 + (hw * i)]
			ifFalse:[param _ 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: 'aoy 2/17/2003 01:05' prior: 35268492!
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: 'ar 8/25/2001 16:16'!
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|
		true
			ifTrue:[param _ 0.5 + (hw * i)]
			ifFalse:[param _ 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:06' prior: 35271090!
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: 'ar 8/25/2001 16:16'!
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|
		true 
			ifTrue:[param _ 0.5 + (hw * i)]
			ifFalse:[param _ 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: 'aoy 2/17/2003 01:07' prior: 35272390!
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 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 class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'!
style: aSymbol
	^self new style: aSymbol! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 3/2/2001 20:31'!
addProgressDecoration: extraParam
	| f m |
	targetMorph ifNil:[^self].
	(extraParam isKindOf: Form) ifTrue:[
		targetMorph submorphsDo:[:mm| (mm isKindOf: SketchMorph) 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 isMemberOf: String) ifTrue:[
		targetMorph submorphsDo:[:mm| (mm isKindOf: StringMorph) ifTrue:[mm delete]].
		m _ StringMorph contents: extraParam.
		m align: m fullBounds bottomCenter + (0@8) with: targetMorph bounds bottomCenter.
		targetMorph addMorph: m.
		^self].! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'gm 2/22/2003 14:46' prior: 35277784!
addProgressDecoration: extraParam 
	| f m |
	targetMorph ifNil: [^self].
	(extraParam isForm) 
		ifTrue: 
			[targetMorph 
				submorphsDo: [:mm | (mm isKindOf: SketchMorph) 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 isMemberOf: String) 
		ifTrue: 
			[targetMorph 
				submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]].
			m := StringMorph contents: extraParam.
			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' prior: 19656054!
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: 'ar 3/2/2001 20:25'!
withProgressDo: aBlock

	| safetyFactor totals trialRect delta stageCompletedString |

	Smalltalk isMorphic ifFalse: [^aBlock value].
	formerProject _ Project current.
	formerWorld _ World.
	formerProcess _ Processor activeProcess.
	targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal].
	targetMorph ifNil: [
		trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80.
		delta _ trialRect amountToTranslateWithin: formerWorld bounds.
		trialRect _ trialRect translateBy: delta.
		translucentMorph _ TranslucentProgessMorph new
			opaqueBackgroundColor: Color white;
			bounds: trialRect;
			openInWorld: formerWorld.
	] ifNotNil: [
		translucentMorph _ TranslucentProgessMorph new
			setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
			bounds: targetMorph boundsInWorld;
			openInWorld: targetMorph world.
	].
	stageCompleted _ 0.
	safetyFactor _ 1.1.	"better to guess high than low"
	translucentMorph setProperty: #progressStageNumber toValue: 1.
	totals _ self loadingHistoryDataForKey: 'total'.
	newRatio _ 1.0.
	estimate _ totals size < 2 ifTrue: [
		15000		"be a pessimist"
	] ifFalse: [
		(totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor.
	].
	start _ Time millisecondClockValue.
	self forkProgressWatcher.

	[
		aBlock 
			on: ProgressInitiationException
			do: [ :ex | 
				ex sendNotificationsTo: [ :min :max :curr |
					"ignore this as it is inaccurate"
				].
			].
	] on: ProgressNotification do: [ :note |
		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 methodsFor: 'as yet unclassified' stamp: 'mir 1/5/2004 11:45' prior: 35281446!
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.
		targetOwner := targetMorph owner].
	targetMorph ifNil: [
		trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80.
		delta _ trialRect amountToTranslateWithin: formerWorld bounds.
		trialRect _ trialRect translateBy: delta.
		translucentMorph _ TranslucentProgessMorph new
			opaqueBackgroundColor: Color white;
			bounds: trialRect;
			openInWorld: formerWorld.
	] ifNotNil: [
		translucentMorph _ TranslucentProgessMorph new
			setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
			bounds: targetMorph boundsInWorld;
			openInWorld: targetMorph world.
	].
	stageCompleted _ 0.
	safetyFactor _ 1.1.	"better to guess high than low"
	translucentMorph setProperty: #progressStageNumber toValue: 1.
	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 methodsFor: 'as yet unclassified' stamp: 'mir 3/9/2004 16:27' prior: 35283745!
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 methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 19661273!
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'! !

!Component methodsFor: 'variables' stamp: 'gm 3/2/2003 18:35' prior: 19664378!
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! !

!ComponentLayout methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17' prior: 19673053!
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' prior: 19673508!
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' prior: 19673314!
allKnownNames
	^super allKnownNames 
		, (self submorphs collect: [:m | m knownName] thenSelect: [:m | m notNil])! !

!ComponentLikeModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:01' prior: 19674728!
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: 'gm 2/22/2003 13:14' prior: 19675876!
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: 
			[(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! !

!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: '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 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/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
! !

!CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/18/2003 17:50'!
emitSequenceToResetStateIfNeededOn: aStream

	Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state.
! !

!CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/13/2003 11:34'!
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: [^ MultiCharacter leadingChar: leadingChar code: character asciiValue]
	].
	size = 2 ifTrue: [
		character2 _ aStream basicNext.
		character2 ifNil: [self errorMalformedInput].
		character _ character asciiValue - offset.
		character2 _ character2 asciiValue - offset.
		result _ MultiCharacter leadingChar: leadingChar code: character * 94 + character2.
		^ self toUnicode: result
	].
	self error: 'unsupported encoding'.
! !

!CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/18/2003 17:52'!
nextPut: aCharacter toStream: aStream

	| ascii leadingChar |
	aStream isBinary ifTrue: [
		aCharacter class == Character ifTrue: [
			^ aStream basicNextPut: aCharacter.
		].
		aCharacter class == MultiCharacter ifTrue: [
			"this shouldn't happen?"
			^ aStream nextInt32Put: aCharacter value.
		].
	].

	aCharacter isUnicode ifTrue: [
		ascii _ (JISX0208 charFromUnicode: aCharacter asUnicode) charCode.
		leadingChar _ JISX0208 leadingChar.
	] ifFalse: [
		ascii _ aCharacter charCode.
		leadingChar _ aCharacter leadingChar.
	].

	self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar.
! !

!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 11/4/2002 14:47'!
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 = #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 methodsFor: 'private' stamp: 'yo 11/4/2002 12:33'!
restoreStateOf: aStream with: aConverterState

	state _ aConverterState copy.
	aStream position: state streamPosition.
! !

!CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 13:52'!
saveStateOf: aStream

	| inst |
	inst _  state clone.
	inst streamPosition: aStream position.
	^ inst.
! !

!CompoundTextConverter methodsFor: 'private' stamp: 'yo 8/4/2003 12:02'!
toUnicode: aChar

	^ MultiCharacter leadingChar: UnicodeJapanese leadingChar code: aChar asUnicode.
! !

!CompoundTextConverter methodsFor: 'accessing' stamp: 'yo 8/23/2002 22:39'!
accepts: aSymbol

	^ acceptingEncodings includes: aSymbol.
! !

!CompoundTextConverter methodsFor: 'accessing' stamp: 'yo 9/16/2002 21:41'!
currentCharSize

	^ state charSize.
! !

!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: 'as yet unclassified' stamp: 'yo 8/19/2002 16:47'!
errorMalformedInput

	^ self error: 'malformed input'.
! !

!CompoundTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/19/2002 16:48'!
errorUnsupported

	^ self error: 'unsupported encoding'.
! !

!CompoundTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/24/2002 14:16'!
encodingNames

	^ #('iso-2022-jp' 'x-ctext') copy
! !

!CompoundTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 22:56'!
new

	^ (super new) initialize; yourself.

! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'!
charSize

	^ charSize
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'!
charSize: s

	charSize _ s.
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'!
g0Leading

	^ g0Leading
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'!
g0Leading: l

	g0Leading _ l.
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'!
g0Size

	^ g0Size
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'!
g0Size: s

	g0Size _ s.
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'!
g1Leading

	^ g1Leading
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'!
g1Leading: l

	g1Leading _ l.
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'!
g1Size

	^ g1Size
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'!
g1Size: s

	g1Size _ s.
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'!
streamPosition

	^ streamPosition
! !

!CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:40'!
streamPosition: pos

	streamPosition _ pos.
! !

!CompoundTextConverterState class methodsFor: 'as yet unclassified' 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.
! !

!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: 'e-toy support' stamp: 'ar 2/7/2001 17:57'!
isTileEditor
	"Yes I am"
	^true! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:22'!
handlesMouseDown: 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: '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 1/16/2002 20:03'!
initialize

	| r |
	super initialize.
	self color: Color orange muchLighter.
	self borderWidth: 1.
	self layoutInset: 2.
	self listDirection: #topToBottom.
	self hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200@14).

	r _ AlignmentMorph newRow color: color; layoutInset: 0.
	r setProperty: #demandsBoolean toValue: true.
	r addMorphBack: (Morph new color: color; extent: 2@5).  "spacer"
	r addMorphBack: (StringMorph new contents: 'Test').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1).
	testPart color: Color transparent.
	testPart hResizing: #spaceFill.
	self addMorphBack: r.

	r _ AlignmentMorph newRow color: color; layoutInset: 0.
	r addMorphBack: (Morph new color: color; extent: 30@5).  "spacer"
	r addMorphBack: (StringMorph new contents: 'Yes').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2).
	yesPart 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"
	r addMorphBack: (StringMorph new contents: 'No').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2).
	noPart hResizing: #spaceFill.
	noPart color: Color transparent.
	self addMorphBack: r.
	self bounds: self fullBounds! !

!CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:22' prior: 35306971!
initialize
	"initialize the state of the receiver"
	| r |
	super initialize.
	""

	self layoutInset: 2.
	self listDirection: #topToBottom.
	self hResizing: #spaceFill;
		 vResizing: #shrinkWrap;
		 cellInset: 0 @ 1;
		 minCellSize: 200 @ 14.
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r setProperty: #demandsBoolean toValue: true.
	r addMorphBack: (Morph new color: color;
			 extent: 2 @ 5).
	"spacer"
	r
		addMorphBack: (StringMorph new contents: 'Test').
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0;
					 layoutInset: 1).
	testPart color: Color transparent.
	testPart hResizing: #spaceFill.
	self addMorphBack: r.
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r addMorphBack: (Morph new color: color;
			 extent: 30 @ 5).
	"spacer"
	r
		addMorphBack: (StringMorph new contents: 'Yes').
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0;
					 layoutInset: 2).
	yesPart 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"
	r
		addMorphBack: (StringMorph new contents: 'No').
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0;
					 layoutInset: 2).
	noPart hResizing: #spaceFill.
	noPart color: Color transparent.
	self addMorphBack: r.
	self bounds: self fullBounds! !

!CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 10/8/2003 18:51' prior: 35308646!
initialize
	"initialize the state of the receiver"
	| r |
	super initialize.
	""

	self layoutInset: 2.
	self listDirection: #topToBottom.
	self hResizing: #spaceFill;
		 vResizing: #shrinkWrap;
		 cellInset: 0 @ 1;
		 minCellSize: 200 @ 14.
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r setProperty: #demandsBoolean toValue: true.
	r addMorphBack: (Morph new color: color;
			 extent: 2 @ 5).
	"spacer"
	r
		addMorphBack: (StringMorph new contents: 'Test' translated).
	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"
	r
		addMorphBack: (StringMorph new contents: 'Yes' translated).
	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"
	r
		addMorphBack: (StringMorph new contents: 'No' translated).
	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! !

!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: '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: 'testing' stamp: 'yo 11/4/2002 20:33'!
isTileScriptingElement

	^ true
! !

!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: 'di 11/3/2003 17:54'!
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: 'di 11/5/2003 22:41'!
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: '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: 'di 11/1/2003 22:48'!
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: 'di 11/20/2003 12:03'!
next
	<primitive: 65>
	position >= readLimit
		ifTrue: [^ (self next: 1) at: 1]
		ifFalse: [^ collection at: (position _ position + 1)]! !

!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:45'!
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: 'di 11/2/2003 12:06'!
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: 'di 11/2/2003 22:24'!
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: '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: 'di 11/5/2003 22:41'!
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: 'di 11/5/2003 22:42'!
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 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 class methodsFor: 'as yet unclassified' stamp: 'di 11/1/2003 22:58'!
on: aFile
	^ self basicNew openOn: aFile! !

!ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0!
Signals a prematurely closed connection.
!
!ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:27' prior: 19724582!
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
				ifNotNil: [accessSema critical: [connections addLast: newConnection]].
		self pruneStaleConnections]. ! !

!ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28' prior: 19726259!
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].
! !

!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 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 class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'!
host: addressOrHostName port: portNumber
	^ self new host: addressOrHostName port: portNumber! !

!ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0!
Signals that a connection attempt timed out.
!
!ContextPart methodsFor: 'accessing' stamp: 'ajh 2/9/2003 00:21'!
methodNode

	| selector methodClass |
	selector _ self receiver class
		selectorAtMethod: self method
		setClass: [:mclass | methodClass _ mclass].
	^ self method methodNodeDecompileClass: methodClass selector: selector! !

!ContextPart methodsFor: 'accessing' stamp: 'nk 2/20/2004 16:50'!
methodNodeFormattedAndDecorated: decorate
	"Answer a method node made from pretty-printed (and colorized, if decorate is true) source text."

	| selector methodClass |
	selector _ self receiver class
		selectorAtMethod: self method
		setClass: [:mclass | methodClass _ mclass].
	^ self method methodNodeFormattedDecompileClass: methodClass selector: selector decorate: decorate! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/30/2001 20:40'!
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: #mustBeBoolean
			to: bool
			with: #()
			super: false].
	(bool eqv: condition) ifTrue: [self jump: distance]! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38' prior: 35328071!
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' prior: 19731397!
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' prior: 19731666!
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' prior: 19731900!
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' stamp: 'ajh 1/24/2003 23:17'!
return: value from: aContext
	"Return value to aContext's sender.  If aContext is not self then do remote return by calling return: from self and resuming until the return is complete.  This is done so unwind blocks will be executed in context of self's thread (not thisContext thread which is simulating it)."

	| topContext here error ctxt |
	self == aContext ifTrue: [
		"Do local return"
		topContext _ self sender.
		self singleRelease.
		topContext ifNotNil: [topContext push: value].
		^ topContext
	].

	"Activate a remote #return: context"
	topContext _ self activateReturn: aContext value: value.

	"Insert ensure: and on:do: under aContext that will halt when reached"
	here _ thisContext.
	error _ false.
	ctxt _ aContext insertSender: (ContextPart
		contextOn: UnhandledError do: [:ex | error
			ifTrue: [ex pass]
			ifFalse: [error _ true. topContext _ thisContext. here jump]]).
	ctxt _ ctxt insertSender: (ContextPart
		contextEnsure: [error ifFalse: [topContext _ thisContext. here jump]]).

	"Execute remote return"
	topContext jumpTop.  "do not add return value when jumping to it"

	"'here jump' resumes here"
	topContext push: nil.  "since we jump out of the topContext in the blocks above before pushing a block return value"

	"If no unhandled error was raised, remove ensure: context and step down to sender"
	error ifFalse: [
		topContext _ topContext stepToCallee.
		topContext == ctxt ifTrue: [^ topContext stepToCallee].  "pop ensure: & return"
		"topContext must be ContextPart>>#return:, step until it returns"
		ctxt _ topContext.
		[ctxt isDead] whileFalse: [topContext _ topContext step].
	].
	^ topContext! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44' prior: 35329877!
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: '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' stamp: 'sw 7/19/2002 13:04'!
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: Smalltalk platformName asString;
		nextPutAll: ' - ';
		nextPutAll: Smalltalk vmVersion asString;
		cr.
	strm nextPutAll: 'Image: ';
		nextPutAll: Smalltalk version asString;
		nextPutAll: ' [';
		nextPutAll: Smalltalk lastUpdateString asString;
		nextPutAll: ']';
		cr.
	strm cr.

	"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
	cnt _ 0.  startPos _ strm position.
	aContext _ self.
	[aContext == nil] whileFalse:
		[[(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: 'ajh 8/4/2003 13:20' prior: 35333454!
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: Smalltalk platformName asString;
		nextPutAll: ' - ';
		nextPutAll: Smalltalk vmVersion asString;
		cr.
	strm nextPutAll: 'Image: ';
		nextPutAll: Smalltalk version asString;
		nextPutAll: ' [';
		nextPutAll: Smalltalk lastUpdateString asString;
		nextPutAll: ']';
		cr.
	strm cr.

	"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
	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: 'md 10/28/2003 10:34' prior: 35335093!
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: Smalltalk platformName asString;
		nextPutAll: ' - ';
		nextPutAll: Smalltalk vmVersion asString;
		cr.
	strm nextPutAll: 'Image: ';
		nextPutAll:  SystemVersion current version asString;
		nextPutAll: ' [';
		nextPutAll: Smalltalk lastUpdateString asString;
		nextPutAll: ']';
		cr.
	strm cr.

	"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
	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: 'md 12/12/2003 17:13' prior: 35336715!
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: Smalltalk lastUpdateString asString;
		nextPutAll: ']';
		cr.
	strm cr.

	"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
	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: 'sw 3/4/2004 00:27' prior: 35338350!
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: Smalltalk 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: 'ajh 9/7/2002 21:15'!
methodSelector
	"Answer the selector of the method that created the receiver."

	^self receiver class 
		selectorAtMethod: self method 
		setClass: [:ignored]! !

!ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03' prior: 19738034!
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: 'ajh 2/9/2003 12:25' prior: 19739954!
tempNames
	"Answer an OrderedCollection of the names of the receiver's temporary 
	variables, which are strings."

	^ self methodNode tempNames! !

!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: 'controlling' stamp: 'ajh 1/24/2003 01:41'!
jump
	"Abandon thisContext thread and execute self instead.  You probably should save thisContext's sender before calling this so you can jump back to it."

	thisContext privSender: self.
	^ nil! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07' prior: 35343009!
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: '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 2/1/2003 12:39'!
restart
	"Roll back thisContext to self and resume from beginning.  Execute unwind blocks when rolling back.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	self isDead ifTrue: [self cannotReturn: nil to: self].
	self privRefresh.
	[	ctxt _ thisContext findNextUnwindContextUpTo: self.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		thisContext terminateTo: ctxt sender.
		unwindBlock value.
	].
	thisContext terminateTo: self.
	self jumpTop.
! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32' prior: 35345634!
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 6/27/2003 22:16'!
resume: value
	"Roll back thisContext to self and resume with value as result of last send.  Execute unwind blocks when rolling back.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	self isDead ifTrue: [self cannotReturn: value to: self].
	[	ctxt _ thisContext findNextUnwindContextUpTo: self.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		thisContext terminateTo: ctxt sender.
		unwindBlock value.
	].
	thisContext terminateTo: self.
	^ value
! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32' prior: 35347036!
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 2/1/2003 12:38'!
return: value
	"Roll back thisContext to self and return value to self's sender.  Execute any unwind blocks on the way.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	(sender isNil or: [sender isDead]) ifTrue: [self cannotReturn: value to: sender].
	[	ctxt _ thisContext findNextUnwindContextUpTo: self.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		thisContext terminateTo: ctxt sender.
		unwindBlock value.
	].
	thisContext terminateTo: self sender.
	^ value! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 3/5/2004 02:37' prior: 35348362!
return: value
	"Roll back thisContext to self and return value to self's sender.  Execute any unwind blocks on the way.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	(sender isNil or: [sender isDead]) ifTrue: [self cannotReturn: value to: sender].
	[	ctxt _ thisContext findNextUnwindContextUpTo: self sender.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		thisContext terminateTo: ctxt sender.
		unwindBlock value.
	].
	thisContext terminateTo: self sender.
	^ value! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27' prior: 35348948!
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' prior: 19742282!
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 3/5/2004 02:00'!
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 jumpTop.  "Control jumps to self"

	"Control resumes here once above ensure block or exception handler is executed"
	topContext push: nil.  "top context needs return value"
	error ifNil: [
		"No error was raised, remove ensure context and step down to sender"
		topContext _ topContext stepToCallee.  "pop ensure block context"
		topContext == ctxt ifTrue: [^ {topContext stepToCallee. nil}]. "pop ensure context & return"
		"ensure block must have been executed as a result of remote returning past it, so topContext must be ContextPart>>#return:"
		topContext method == ContextPart theReturnMethod ifFalse: [
			topContext halt: 'Error in control assumptions'.
			^ {topContext.nil}].
		"Allow remote return to complete by running until the home context returns"
		^ topContext runUntilErrorOrReturnFrom: topContext receiver
	] 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: 'ajh 5/20/2004 17:20' prior: 35350080!
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: 'ajh 1/24/2003 00:56' prior: 19743558!
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: '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: 'ajh 3/17/2003 09:25' prior: 19744328!
printOn: aStream 
	| selector class mclass |
	self method == nil ifTrue: [^ super printOn: aStream].
	selector _ 
		(class _ self receiver class) 
			selectorAtMethod: self method 
			setClass: [:c | mclass _ c].
	selector == #?
		ifTrue: 
			[aStream nextPut: $?; print: self method who.
			^self].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector.
	selector = #doesNotUnderstand: ifTrue: [
		aStream space.
		(self tempAt: 1) selector printOn: aStream.
	].
! !

!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 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: 'system simulation' stamp: 'ajh 7/6/2003 17:59' prior: 35357246!
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 or: [self willReturn or: [self willStore or: [self willJumpIfTrue or: [self willJumpIfFalse]]]]]
		whileFalse: [
			ctxt _ self step.
			ctxt == self ifFalse: [self halt. 
				"Caused by mustBeBoolean handling"
				^ctxt]]! !

!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48' prior: 35357700!
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 1/24/2003 16:17'!
activateReturn: aContext value: value
	"Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"

	| meth |
	meth _ aContext class lookupSelector: #return:.
	meth primitive = 0 ifFalse: [^ self error: '#return: must not be a primitive'].
	^ self
		activateMethod: meth
		withArgs: {value}
		receiver: aContext
		class: aContext class! !

!ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27' prior: 35358645!
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: 'hg 10/2/2001 20:44'!
doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments 
	"Simulate a primitive method whose index is primitiveIndex.  The
	simulated receiver and arguments are given as arguments to this message."

	| value |
	<primitive: 19> "Simulation guard"
	"If successful, push result and return resuming context,
		else ^ PrimitiveFailToken"
	(primitiveIndex = 19) ifTrue:[
		Debugger 
			openContext: self
			label:'Code simulation error'
			contents: 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].
	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 1/24/2003 23:17'!
insertSender: aContext
	"Insert aContext and its sender chain between me and my sender.  Return new callee of my original sender."

	| ctxt |
	ctxt _ aContext bottom.
	ctxt privSender: self sender.
	self privSender: aContext.
	^ ctxt! !

!ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59' prior: 35362264!
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-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: 'tpr 2/24/2001 21:39'!
unwindTo: aContext

	| ctx returnValue unwindBlock |
	ctx := self.

	[(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [
		unwindBlock := ctx tempAt: 1.
		unwindBlock == nil
			ifFalse: [returnValue := unwindBlock value]].

	^returnValue! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 1/21/2003 17:59' prior: 35365419!
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: '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: '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: '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 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 3/5/2004 20:50'!
theReturnMethod

	| meth |
	meth _ self lookupSelector: #return:.
	meth primitive = 0 ifFalse: [^ self error: '#return: must not be a primitive'].
	^ meth! !

!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 5/20/2004 16:25' prior: 35368780!
theReturnMethod

	| meth |
	meth _ self lookupSelector: #return:.
	meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive'].
	^ meth! !

!ContextVariablesInspector methodsFor: 'accessing' stamp: 'ajh 1/31/2003 15:45'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''! !

!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: 'scheduling' stamp: 'ajh 12/31/2001 15:15'!
spawnNewProcess

	self activeController: self screenController! !

!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: 'ar 1/5/2002 17:22'!
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: shadowColor]].
	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:[
				"Paint over with border if any"
				aCanvas stencil: (cornerOverlays at: i) at: corner + offset
						color: (fourColors at: i)]]].
	aCanvas shadowColor: shadowColor. "restore shadow color"
! !

!CornerRounder methodsFor: 'all' stamp: 'kfr 8/4/2003 23:28' prior: 35370750!
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 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! !

!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!
!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'sw 5/4/2001 23:22'!
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 xxxCurrent showSharedFlaps! !

!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'sw 8/11/2001 23:13'!
suppressFlapsString
	"Answer a string characterizing whether flaps are suppressed at the moment or not"

	^ self currentFlapsSuppressed
		ifFalse: ['<yes>show shared tabs (F)']
		ifTrue: ['<no>show shared tabs (F)']! !

!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dgd 8/31/2003 18:06' prior: 35377024!
suppressFlapsString
	"Answer a string characterizing whether flaps are suppressed 
	at the moment or not"
	^ (self currentFlapsSuppressed
		ifTrue: ['<no>']
		ifFalse: ['<yes>']), 'show shared tabs (F)' translated! !

!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 methodsFor: 'displaying' stamp: 'ls 6/17/2002 11:56'!
show
	"Make the hardware's mouse cursor look like the receiver"

	Sensor currentCursor: self! !

!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 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' stamp: 'kfr 7/12/2003 21:02' prior: 19826070!
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' 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' prior: 19827701!
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' stamp: 'kfr 7/12/2003 22:55' prior: 19830005!
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: 'JMM 10/21/2003 18:57'!
initResizeLeft

	ResizeLeftCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000101010010000
		2r0001101010011000
		2r0011101010011100
		2r0111111011111110
		2r0011101010011100
		2r0001101010011000
		2r0000101010010000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000000000000000 )
	offset: -7@-7 ) withMask
! !

!Cursor class methodsFor: 'class initialization' stamp: 'dew 2/14/2004 01:24' prior: 35381453!
initResizeLeft

	ResizeLeftCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000001001000000
		2r0000001001000000
		2r0000001001000000
		2r0000101001010000
		2r0001101001011000
		2r0011101001011100
		2r0111111001111110
		2r0011101001011100
		2r0001101001011000
		2r0000101001010000
		2r0000001001000000
		2r0000001001000000
		2r0000001001000000
		2r0000001001000000
		2r0000000000000000 )
	offset: -7@-7 ) withMask
! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:59'!
initResizeTop

	ResizeTopCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000000100000000
		2r0000001110000000
		2r0000011111000000
		2r0000111111100000
		2r0000000100000000
		2r0111111111111110
		2r0000000000000000
		2r0111111111111110
		2r0000000100000000
		2r0000000100000000
		2r0000111111100000
		2r0000011111000000
		2r0000001110000000
		2r0000000100000000
		2r0000000000000000)
	offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 4/3/2004 11:46' prior: 35382516!
initResizeTop
     "Cursor initResizeTop"
	ResizeTopCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r000000100000000
		2r000001110000000
		2r000011111000000
		2r000111111100000
		2r000000100000000
		2r111111111111100
		2r000000000000000
		2r000000000000000
		2r111111111111100
		2r000000100000000
		2r000111111100000
		2r000011111000000
		2r000001110000000
		2r000000100000000
		2r000000000000000)
	offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:59'!
initResizeTopLeft

	ResizeTopLeftCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0111110000010000
		2r0111100000100000
		2r0111000001000100
		2r0110100010001000
		2r0100010100010000
		2r0000001000100000
		2r0000010001000000
		2r0000100010000000
		2r0001000100100010
		2r0010001000010110
		2r0000010000001110
		2r0000100000011110
		2r0000000000111110
		2r0000000000000000
		2r0000000000000000)
	offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:00'!
initResizeTopRight

	ResizeTopRightCursor _ 
		(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000100000111110
		2r0000010000011110
		2r0010001000001110
		2r0001000100010110
		2r0000100010100010
		2r0000010001000000
		2r0000001000100000
		2r0000000100010000
		2r0100010010001000
		2r0110100001000100
		2r0111000000100000
		2r0111100000010000
		2r0111110000000000
		2r0000000000000000
		2r0000000000000000)
	offset: -7@-7) withMask.! !

!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' stamp: 'kfr 7/12/2003 21:27' prior: 19831397!
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' prior: 19831877!
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' stamp: 'JMM 10/21/2003 19:04' prior: 19832849!
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: '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 class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13' prior: 19835080!
bottomLeft
	"Cursor bottomLeft showWhile: [Sensor waitButton]"
	^BottomLeftCursor
! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13' prior: 19835585!
bottomRight
	"Cursor bottomRight showWhile: [Sensor waitButton]"
	^BottomRightCursor
! !

!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: 'ar 8/16/2001 14:50'!
resizeLeft
	"Cursor resizeLeft showWhile: [Sensor waitButton]"
	^(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000101010010000
		2r0001101010011000
		2r0011101010011100
		2r0111111011111110
		2r0011101010011100
		2r0001101010011000
		2r0000101010010000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000001010000000
		2r0000000000000000 )
	offset: -7@-7 ) withMask
! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58' prior: 35388418!
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: 'ar 8/16/2001 14:49'!
resizeTop
	"Cursor resizeTop showWhile: [Sensor waitButton]"
 	^(Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000000100000000
		2r0000001110000000
		2r0000011111000000
		2r0000111111100000
		2r0000000100000000
		2r0111111111111110
		2r0000000000000000
		2r0111111111111110
		2r0000000100000000
		2r0000000100000000
		2r0000111111100000
		2r0000011111000000
		2r0000001110000000
		2r0000000100000000
		2r0000000000000000)
	offset: -7@-7) withMask! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19' prior: 35389280!
resizeTop
	"Cursor resizeTop showWhile: [Sensor waitButton]"
	^ResizeTopCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 15:58'!
resizeTopLeft
	"Cursor resizeTopLeft showWhile: [Sensor waitButton]"
	^  (Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0111110000010000
		2r0111100000100000
		2r0111000001000100
		2r0110100010001000
		2r0100010100010000
		2r0000001000100000
		2r0000010001000000
		2r0000100010000000
		2r0001000100100010
		2r0010001000010110
		2r0000010000001110
		2r0000100000011110
		2r0000000000111110
		2r0000000000000000
		2r0000000000000000)
	offset: -7@-7) withMask! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00' prior: 35389981!
resizeTopLeft
	"Cursor resizeTopLeft showWhile: [Sensor waitButton]"
	^ ResizeTopLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 16:00'!
resizeTopRight
	"Cursor resizeTopRight showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16 fromArray: #(
		2r0000000000000000
		2r0000100000111110
		2r0000010000011110
		2r0010001000001110
		2r0001000100010110
		2r0000100010100010
		2r0000010001000000
		2r0000001000100000
		2r0000000100010000
		2r0100010010001000
		2r0110100001000100
		2r0111000000100000
		2r0111100000010000
		2r0111110000000000
		2r0000000000000000
		2r0000000000000000)
	offset: -7@-7) withMask.! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00' prior: 35390704!
resizeTopRight
	"Cursor resizeTopRight showWhile: [Sensor waitButton]"
	^ResizeTopRightCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01' prior: 19837773!
topLeft
	"Cursor topLeft showWhile: [Sensor waitButton]"
	^ TopLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02' prior: 19838270!
topRight
	"Cursor topRight showWhile: [Sensor waitButton]"
	^ TopRightCursor! !

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

!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!
!CurveMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'!
initializeToStandAlone

	super initializeToStandAlone.
	self beSmoothCurve.
! !

!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: 'tk 11/16/2001 12:17'!
descriptionForPartsBin
	^ self partName:	'Curve'
		categories:		#('Graphics' ' Basic 1 ')
		documentation:	'A smooth wiggly curve, or a curved solid.  Shift-click to get handles and move the points.'! !

!CurveMorph class methodsFor: 'parts bin' stamp: 'tk 11/16/2001 12:17'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'Curvy Arrow'
		categoryList: #(' Basic 1 ' 'Graphics')
		documentation: 'A curved line with an arrowhead.  Shift-click to get handles and move the points.'
		globalReceiverSymbol: #CurveMorph
		nativitySelector: #arrowPrototype}
! !

!CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:15'!
initialize

	self registerInFlapsRegistry.	! !

!CurveMorph class methodsFor: '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: '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] ! !

!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: '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: 'yo 8/28/2002 22:34' prior: 19848662!
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: '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: '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: '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: 'sumim 2/10/2002 01:21'!
addService: aService for: serviceUser
	"Append a menu item with the given service. If the item is selected, it will perform the given service."

	self add: aService label target: aService selector: aService requestSelector argument: serviceUser
! !

!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:19' prior: 35399857!
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: 'sumim 2/10/2002 01:19'!
addServices2: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		self 
			add: service label 
			target: service 
			selector: service requestSelector 
			argument: (service getArgumentsFrom: served).
		(linesArray includes: i) | service useLineAfter ifTrue: [self addLine]
	]! !

!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:02' prior: 35400464!
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]! !

!DSCPostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53' prior: 19888430!
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: 'RAA 2/22/2001 07:47'!
writePSIdentifierRotated: rotateFlag
	| morphExtent pageExtent scaledBox |

	target	print:'%!!PS-Adobe-2.0'; cr; 
			print:'%%Pages: (atend)'; cr.

	"Define initialScale so that the morph will fit the page rotated or not"
	savedMorphExtent _ morphExtent _ rotateFlag ifTrue: [psBounds extent transposed]
							ifFalse: [psBounds extent].

	pageExtent _ self defaultImageableArea extent asFloatPoint.
	initialScale _ (printSpecs isNil or: [printSpecs scaleToFitPage]) ifTrue: [
		pageExtent x/morphExtent x min: pageExtent y/morphExtent y
	] ifFalse: [
		1.0
	].
	target print:'% initialScale: '; write:initialScale; cr.
	scaledBox _ self pageBBox rounded.
	target print: '%%BoundingBox: '; write: scaledBox rounded; cr.
	rotateFlag ifTrue: [
		target
			print: '90 rotate'; cr;
			write: self defaultMargin * initialScale;
			space;
			write: (self defaultMargin + scaledBox height * initialScale) negated;
			print: ' translate'; cr
	] ifFalse: [
		target
			write: self defaultMargin * initialScale;
			space;
			write: (self defaultMargin * initialScale);
			print: ' translate'; cr
	].
	target print: '%%EndComments'; cr.

! !

!DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 15:36' prior: 35402228!
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: 'tk 12/12/2001 15:51'!
fullDrawBookMorph: aBookMorph
	" draw all the pages in a book morph, but only if it is the top-level morph "

	| currentPage |
	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."
	currentPage _ 0.
	(aBookMorph isKindOf: StackMorph) 
		ifTrue: [
			aBookMorph cards do: [:aCard |
				aBookMorph goToCard: aCard.	"cause card-specific morphs to be installed"
				currentPage _ currentPage + 1.
				target print: '%%Page: '; write: currentPage; space; write: currentPage; cr.
				self drawPage: aBookMorph currentPage]]
		ifFalse: [
			aBookMorph pages do: [:aPage |
				currentPage _ currentPage + 1.
				target print: '%%Page: '; write: currentPage; space; write: currentPage; cr.
				self drawPage: aPage]].
	target print: '%%EOF'; cr.
! !

!DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:18' prior: 35404905!
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 pages]]
		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 6/10/2004 13:19' prior: 35405891!
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' prior: 19889710!
setupGStateForMorph: aMorph 
	"position the morph on the page "
	morphLevel
			== (topLevelMorph pagesHandledAutomatically
					ifTrue: [2]
					ifFalse: [1])
		ifTrue:  [ self writePageSetupFor: aMorph ]! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'aoy 2/15/2003 21:46' prior: 19889000!
pageBBox
	| pageSize offset bbox trueExtent |
	trueExtent := EPSCanvas bobsPostScriptHacks 
		ifTrue: [savedMorphExtent	"this one has been rotated"]
		ifFalse: [psBounds extent].
	pageSize := self defaultImageableArea.
	offset := ((pageSize extent - trueExtent) / 2 max: 0 @ 0) 
				+ self defaultMargin.
	bbox := offset extent: psBounds extent.
	^bbox! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 19:56' prior: 35408048!
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' prior: 19889452!
pageOffset
	^self pageBBox origin.
! !

!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: 'RAA 2/22/2001 07:41'!
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 methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 17:39' prior: 35409227!
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 methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:40'!
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:' 
				initialAnswer: 'xxx',Time millisecondClockValue printString,'.eps'. 
			newFileName isEmptyOrNil ifFalse: [
				stream _ FileStream fileNamed: newFileName.
				stream ifNotNil: [ex resume: stream].
			].
		].

! !

!DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 16:58' prior: 35409943!
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: 'testing' stamp: 'RAA 2/22/2001 07:41'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset

	^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil
! !

!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' prior: 19895198!
updateIsNeeded
	"Return true if the display needs to be updated."

	^totalRepaint or: [invalidRects notEmpty]! !

!DataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'!
contents
	^byteStream contents! !

!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 class methodsFor: 'as yet unclassified' stamp: 'tk 3/7/2001 17:57'!
initialize
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.  
	Classes named here have special formats in the file.  If such a class has a subclass, it will use type 9 and write correctly.  It will just be slow.  (Later write the class name in the special format, then subclasses can use the type also.)
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
	"DataStream initialize"

	| refTypes t |
	refTypes _ OrderedCollection new.
	t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing"

	t at: UndefinedObject put: 1.   refTypes add: 0.
	t at: True put: 2.   refTypes add: 0.
	t at: False put: 3.   refTypes add: 0.
	t at: SmallInteger put: 4.	 refTypes add: 0.
	t at: String put: 5.   refTypes add: 1.
	t at: Symbol put: 6.   refTypes add: 1.
	t at: ByteArray put: 7.   refTypes add: 1.
	t at: Array put: 8.   refTypes add: 1.
	"(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)"
		refTypes add: 1.
	"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
		refTypes add: 0.
	t at: Bitmap put: 11.   refTypes add: 1.
	t at: Metaclass put: 12.   refTypes add: 0.
	"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
		refTypes add: 1.
	t at: Float put: 14.  refTypes add: 1.
	t at: Rectangle put: 15.  refTypes add: 1.	"Allow compact Rects."
	"type ID 16 is an instance with short header.  See beginInstance:size:"
		refTypes add: 1.
	t at: String put: 17.   refTypes add: 1.	"new String format, 1 or 4 bytes of length"
	t at: WordArray put: 18.  refTypes add: 1.	"bitmap-like"
	t at: WordArrayForSegment put: 19.  refTypes add: 1.		"bitmap-like"
	t at: SoundBuffer put: 20.  refTypes add: 1.	"And all other word arrays, 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]]]]].! !

!DataType methodsFor: '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: '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: 'tiles' stamp: 'sw 9/6/2002 11:32'!
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"

	(#(colorSees copy newClone getNewClone color:sees: touchesA: overlaps:) includes: aGetter) ifFalse:
		[aMenu add: 'simple watcher' selector: #tearOffWatcherFor: argument: aGetter]! !

!DataType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:29' prior: 35416982!
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"

	(#(colorSees copy newClone getNewClone color:sees: touchesA: overlaps:) includes: aGetter) ifFalse:
		[aMenu add: 'simple watcher' translated selector: #tearOffWatcherFor: argument: aGetter]! !

!DataType methodsFor: '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: '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: 'tiles' stamp: 'sw 9/27/2001 13:15'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ 'arg' newTileMorphRepresentative typeColor: self typeColor! !

!DataType methodsFor: '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: 'tiles' stamp: 'sw 9/25/2001 21:18'!
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: '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: '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: '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! !

!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: '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: 'color' stamp: 'sw 9/27/2001 17:32'!
subduedColorFromTriplet: anRGBTriplet
	"Answer a subdued color derived from the rgb-triplet to use as a tile color.  Don't pay too much attention to this whole branch, for it relates to an aspect whose use is basically in abeyance"

	^ (Color fromRgbTriplet: anRGBTriplet) mixed: ScriptingSystem colorFudge with: ScriptingSystem uniformTileInteriorColor! !

!DataType methodsFor: 'queries' stamp: 'sw 9/27/2001 03:25'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ (self class == DataType) not  "i.e. subclasses yes, myself no"! !

!DataType commentStamp: 'sw 8/22/2002 15:01' prior: 0!
A Vocabulary representing typed data.!
!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: 'deprecated' stamp: 'brp 8/5/2003 18:36'!
asGregorian
	"Return an array of integers #(dd mm yyyy)"

	^ self
		deprecated: 'Use #dayMonthYearDo:';
		dayMonthYearDo: [ :d :m :y | { d. m. y } ] 
! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:32'!
asJulianDayNumber

	^ self 
		deprecated: 'Use #julianDayNumber';
		julianDayNumber! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:36'!
day: dayInteger year: yearInteger

	^ self
		deprecated: 'Obsolete'
! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:39'!
daylightSavingsInEffect
	"Return true if DST is observed at or after 2am on this day"

	self deprecated: 'Deprecated'.

	self dayMonthYearDo: 
		[ :day :month :year |
		(month < 4 or: [month > 10]) ifTrue: [^ false].  "False November through March"
		(month > 4 and: [month < 10]) ifTrue: [^ true].  "True May through September"
		month = 4
		ifTrue:	["It's April -- true on first Sunday or later"
				day >= 7 ifTrue: [^ true].  "Must be after"
				^ day > (self weekdayIndex \\ 7)]
		ifFalse: ["It's October -- false on last Sunday or later".
				day <= 24 ifTrue: [^ true].  "Must be before"
				^ day <= (24 + (self weekdayIndex \\ 7))]]! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:39'!
daylightSavingsInEffectAtStandardHour: hour
	"Return true if DST is observed at this very hour (standard time)"
	"Note: this *should* be the kernel method, and daylightSavingsInEffect
		should simply be self daylightSavingsInEffectAtHour: 3"

	self deprecated: 'Deprecated'.

	self daylightSavingsInEffect
		ifTrue: [^ (self addDays: -1) daylightSavingsInEffect or: [hour >= 2]]
		ifFalse: [^ (self addDays: -1) daylightSavingsInEffect and: [hour < 1]]! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:37'!
firstDayOfMonthIndex: monthIndex 

	^ self
		deprecated: 'Obsolete'
! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:41'!
julianDayNumber: anInteger
	"Set the number of days elapsed since midnight GMT on January 1st, 4713 B.C."

	self deprecated: 'Obsolete'.

! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:34'!
mmddyy
	"Please use mmddyyyy instead, so dates in 2000 will be unambiguous"

	^ self 
		deprecated: 'Use #mmddyyyy';
		printFormat: #(2 1 3 $/ 1 2)
! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:46'!
uniqueDateStringBetween: aStart and: anEnd
	"Return a String, with just enough information to distinguish it from other dates in the range."

	"later, be more sophisticated"
	self deprecated: 'Deprecated'.

	aStart year + 1 >= anEnd year ifFalse: [^ self printFormat: #(1 2 3 $  3 1)].	"full"
	aStart week next >= anEnd week ifFalse: [^ self printFormat: #(2 1 9 $  3 1)]. "May 6"
	^ self weekday
! !

!Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:31'!
week

	^ self 
		deprecated: 'Use #asWeek';
		asWeek! !

!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 class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:48'!
dateAndTimeNow
	"Answer an Array whose with Date today and Time now."

	^ self timeClass dateAndTimeNow! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00' prior: 35429415!
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: 'deprecated' stamp: 'brp 8/4/2003 22:13'!
absoluteDaysToYear: gregorianYear

	self deprecated: 'Deprecated'! !

!Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:14'!
fromJulianDayNumber: aJulianDayNumber

	self 
		deprecated: 'Deprecated';
		julianDayNumber: aJulianDayNumber! !

!Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:15'!
yearAndDaysFromDays: days into: aTwoArgBlock

	self deprecated: 'Deprecated'! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:03'!
fromString: aString
	"Answer an instance of created from a string with format dd.mm.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! !

!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: 'brp 8/23/2003 15:49'!
< comparand
	"comparand conforms to protocol DataAndTime"

	| lticks rticks |

	lticks _ self asUTC ticks.
	rticks _ comparand asDateAndTime asUTC ticks. 	^ (lticks first < rticks first)
		ifTrue: [ true ]
	
		ifFalse:
			[ (lticks first > rticks first)
				ifTrue: [ false ]
				ifFalse:
					[ (lticks second < rticks second
)
						ifTrue: [ true ]
						ifFalse: 
							[ (lticks second > rticks second)
								ifTrue: [ false ]
								ifFalse:
									[ lticks third < rticks third ]]]]
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 09:09' prior: 35435349!
< 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 8/23/2003 15:49'!
= comparand
	"comparand conforms to protocol DateAndTime"

	^ self == comparand
	
		ifTrue: [true]
		ifFalse:
 [ [self asUTC ticks = comparand asDateAndTime asUTC ticks ]
					on: MessageNotUnderstood do: [false] ].! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 08:49' prior: 35436688!
= 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 ticks = comparandAsDateAndTime ticks]
		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: 'brp 8/23/2003 13:12'!
asUTC


	^ 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 5/13/2003 07:29'!
dayOfYear


	^ jdn - (Year year: self year) start julianDayNumber + 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: 'brp 8/23/2003 11:21'!
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." 	| h |
	h _ (self hour24 abs + 1).
	^ h > 12 ifTrue: [h - 12] ifFalse: [h].
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:46' prior: 35438805!
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: 'squeak protocol' stamp: 'brp 8/23/2003 23:56'!
asDate


	^ Date starting: self
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:56' prior: 35441207!
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/23/2003 22:37' prior: 35442024!
asTime


	^ self timeClass seconds: seconds nanoSeconds: nanos! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:00' prior: 35442170!
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 8/24/2003 00:02' prior: 35442456!
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: 'brp 9/25/2003 13:23'!
printOn: aStream 
	"Print as per ISO 8601 sections 5.3.3 and 5.4.1. 
	-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z "
	| year month day |
	self dayMonthYearDo: [ :d :m :y | year _ y. month _ m. day _ d ].
	aStream
		nextPut: (year negative ifTrue: [$-] ifFalse: [ Character space ]);
		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);
		nextPut: $T;
		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).
	self nanoSecond ~= 0 ifTrue:
		[ | z ps |
		ps _ self nanoSecond 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 ] ].
	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:38' prior: 35444868!
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: 'nk 3/12/2004 10:37'!
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 ].
		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: '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: '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: 'brp 1/14/2004 09:08'!
ticks: ticks offset: utcOffset
	"ticks is {julianDayNumber. secondCount. nanoSeconds}"
	| normalize |

	normalize _ [ :i :base | | tick quo rem |
		tick _ ticks at: i.
		quo _ tick abs // base.
		rem _ tick abs \\ base.
		(tick negative and: [rem ~= 0]) ifTrue: [ quo _ (quo+1) negated. 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 methodsFor: 'private' stamp: 'nk 3/30/2004 09:38' prior: 35451532!
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 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 class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:32'!
clockPrecision
	"One nanosecond precision"

	^ Duration nanoSeconds: 1
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 9/25/2003 10:59'!
now
	| ticks millis |
	LastTickSemaphore critical:
		[millis _ self millisecondClockValue - FirstMilliSecondValue.
		ticks _ (self totalSeconds * NanosInSecond) + (millis * NanosInMillisecond).
		LastTick _ (LastTick >= ticks ifTrue: [LastTick + 1] ifFalse: [ticks]).
		^ self basicNew 
			ticks: (Duration 
					days: SqueakEpoch 
					hours: 0 
					minutes: 0 
					seconds: 0 
					nanoSeconds: LastTick) ticks
			offset: self localOffset;
			yourself]
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 19:03' prior: 35453499!
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: '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: 'brp 9/4/2003 06:40'!
localTimeZone: aTimeZone
	"Set the local time zone"

	LocalTimeZone _ aTimeZone

! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'nk 3/30/2004 09:53' prior: 35456914!
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: 'brp 1/7/2004 15:39'!
year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset
	"Return a DateAndTime"

	| monthIndex p q r s julianDayNumber since |

	monthIndex _ month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month].
	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
! !

!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:00' prior: 35462143!
millisecondClockValue

	^ Time millisecondClockValue! !

!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01'!
totalSeconds

	^ Time totalSeconds! !

!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01' prior: 35462425!
totalSeconds

	^ Time totalSeconds! !

!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 1/4/2004 14:02'!
testHash
	self assert: aDateAndTime hash =    DateAndTime new hash.
	self assert: aDateAndTime hash =    199296261
! !

!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: 'tlk 1/1/2004 16:57'!
testHour12
	self assert: aDateAndTime hour12  =    DateAndTime new hour12.
	self assert: aDateAndTime hour12  =    1
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:21' prior: 35468021!
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: 'tlk 1/4/2004 10:37'!
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: 'nk 3/12/2004 10:16' prior: 35471797!
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: 'tlk 1/2/2004 11:12'!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Grenwich Mean Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'GMT'

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26' prior: 35476508!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'UTC'

! !

!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 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. !
!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 1/4/2004 13:58'!
testHash
	self assert: aDateAndTime hash =     29855404
! !

!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: 'tlk 1/4/2004 13:57'!
testHour12
	self assert: aDateAndTime hour12  =    2.
	self deny: aDateAndTime hour12  =    1
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:19' prior: 35482723!
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: 'tlk 1/4/2004 13:42'!
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(GMT)'.
	rw _ ReadWriteStream on: ''.
     aTimeZone printOn:  rw.
     self assert: rw contents = cs contents	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:27' prior: 35485142!
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: 'tlk 1/2/2004 21:30'!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Grenwich Mean Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'GMT'

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26' prior: 35487405!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'UTC'

! !

!DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:54'!
setUp
     localTimeZoneToRestore := DateAndTime localTimeZone.
     "so how do I set local time zone?"
	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: 'nk 3/12/2004 11:00' prior: 35487841!
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 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) !
!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: '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: 'brp 9/25/2003 09:47'!
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).
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'nk 3/12/2004 11:06' prior: 35489992!
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: '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: '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
! !

!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: 'Private' stamp: 'brp 8/24/2003 00:10'!
dateClass

	^ Date! !

!DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'!
classToBeTested

	^ self dateClass! !

!DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 14:05'!
selectorsToBeIgnored

	 | deprecated private special |
	deprecated := #(
		#fromJulianDayNumber:
		#uniqueDateStringBetween:and:
		#daylightSavingsInEffectAtStandardHour:
		#daylightSavingsInEffect
		#asGregorian
		#asJulianDayNumber
		#day:year:
		#firstDayOfMonthIndex:
		#mmddyy
		#absoluteDaysToYear:
		#yearAndDaysFromDays:into:
		#week
		#month ).

	private := #( #julianDayNumber: ).

	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: '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: '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 commentStamp: 'brp 7/26/2003 16:58' prior: 0!
This is the unit test for the class Date. !
!Debugger methodsFor: 'initialize' stamp: 'sw 1/16/2002 20:03'!
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: 'hmm 7/30/2001 17:25'!
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: 'ar 8/16/2001 11:27'!
buttonRowForPreDebugWindow: aDebugWindow
	| aRow aButton |
	aRow _ AlignmentMorph newRow hResizing: #spaceFill.
	aRow beSticky.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	self preDebugButtonQuads do:
			[:quad |
				aButton _ SimpleButtonMorph new target: aDebugWindow.
				aButton color: Color transparent; borderWidth: 1.
				aButton actionSelector: quad second.
				aButton label: quad first.
				aButton submorphs first color: (Color colorFrom: quad third).
				aButton setBalloonText: quad fourth.
				Preferences alternativeWindowLook 
					ifTrue:[aButton borderWidth: 2; borderColor: #raised].
				aRow addMorphBack: aButton.
				aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'nk 2/12/2003 22:56' prior: 35505649!
buttonRowForPreDebugWindow: aDebugWindow
	| aRow aButton quads |
	aRow _ AlignmentMorph newRow hResizing: #spaceFill.
	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 transparent; borderWidth: 1.
				aButton actionSelector: quad second.
				aButton label: quad first.
				aButton submorphs first color: (Color colorFrom: quad third).
				aButton setBalloonText: quad fourth.
				Preferences alternativeWindowLook 
					ifTrue:[aButton borderWidth: 2; borderColor: #raised].
				aRow addMorphBack: aButton.
				aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'sw 8/21/2002 18:40'!
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;
				useRoundedCorners;
				onColor: Color transparent offColor: Color transparent.
			(#(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].
			Preferences alternativeWindowLook 
				ifTrue:[aButton borderWidth: 2; borderColor: #raised].
			aRow addMorphBack: aButton.
			aRow addTransparentSpacerOfSize: (3 @ 0)].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'sw 8/21/2002 18:41'!
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.')
		('Send'			send				'step into message sends')
		('Step'			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: 'ab 2/25/2004 18:59' prior: 35508934!
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: 'ajh 7/20/2003 23:41'!
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 10/29/2001 20:01'!
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.3).

	self addLowerPanesTo: window at: (0@0.3 corner: 1@0.7) with: nil.

	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self receiverInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:)
		frame: (0@0.7 corner: 0.2@1).
	window addMorph: (PluggableTextMorph on: self receiverInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.2@0.7 corner: 0.5@1).
	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self contextVariablesInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:)
		frame: (0.5@0.7 corner: 0.7@1).
	window addMorph: (PluggableTextMorph on: self contextVariablesInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.7@0.7 corner: 1@1).
	window openInWorld.
	self toggleContextStackIndex: oldContextStackIndex.
	^ window ! !

!Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:07' prior: 35511029!
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:)
		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: 'di 10/28/2001 10:59'!
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 _ CurrentProjectRefactoring newProcessIfUI: 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: '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: 'sw 12/14/2001 01:29'!
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;
					useRoundedCorners;
					onColor: Color transparent offColor: Color transparent.
				(#(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].
				Preferences alternativeWindowLook 
					ifTrue:[aButton borderWidth: 2; borderColor: #raised].
				aRow addMorphBack: aButton.
				aRow addTransparentSpacerOfSize: (3 @ 0)].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'mir 11/10/2003 15:13' prior: 19961891!
preDebugButtonQuads

	^Preferences eToyFriendly
		ifTrue: [
	 #(('Store log'		storeLog 	blue 	'write a log of the encountered problem' )
		('Abandon'		abandon 	black 	'abandon this execution by closing this window')
		('Debug'		debug 		red 		'bring up a debugger'))]
		ifFalse: [
	 #(('Proceed'		proceed 	blue 	'continue execution' )
		('Abandon'		abandon 	black 	'abandon this execution by closing this window')
		('Debug'		debug 		red 		'bring up a debugger'))]
! !

!Debugger methodsFor: 'initialize' stamp: 'ajh 7/6/2003 17:10' prior: 19962821!
windowIsClosing
	"My window is being closed; clean up. Restart the low space watcher."

	interruptedProcess == nil ifTrue: [^ self].
	[interruptedProcess terminate] on: Error do: [].
	interruptedProcess _ nil.
	interruptedController _ nil.
	contextStack _ nil.
	contextStackTop _ nil.
	receiverInspector _ nil.
	contextVariablesInspector _ nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
! !

!Debugger methodsFor: 'initialize' stamp: 'ajh 3/5/2004 21:31' prior: 35518799!
windowIsClosing
	"My window is being closed; clean up. Restart the low space watcher."

	interruptedProcess == nil ifTrue: [^ self].
	interruptedProcess terminate.
	interruptedProcess _ nil.
	interruptedController _ nil.
	contextStack _ nil.
	contextStackTop _ nil.
	receiverInspector _ nil.
	contextVariablesInspector _ nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
! !

!Debugger methodsFor: 'accessing' stamp: 'sw 5/23/2001 13: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 method priorMethod parseNode |
	contextStackIndex = 0 ifTrue: [^ false].
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^ false]].
	classOfMethod _ self selectedClass.
	category _ self selectedMessageCategoryName.
	Cursor execute showWhile:
		[method _ classOfMethod
		compile: aText
		notifying: aController
		trailer: #(0 0 0 0)
		ifFail: [^ false]
		elseSetSelectorAndNode: 
			[:sel :methodNode | selector _ sel.
			selector == self selectedMessageName
				ifFalse: [self inform: 'can''t change selector'. ^ false].
			priorMethod _ (classOfMethod includesSelector: selector)
				ifTrue: [classOfMethod compiledMethodAt: selector]
				ifFalse: [nil].
			sourceMap _ methodNode sourceMap.
			tempNames _ methodNode tempNames.
			parseNode _ methodNode].
		method cacheTempNames: tempNames].
	category isNil ifFalse: "Skip this for DoIts"
		[method putSource: aText
				fromParseNode: parseNode
				class: classOfMethod
				category: category
				inFile: 2 priorMethod: priorMethod.
		classOfMethod organization classify: selector under: category].
	contents _ aText copy.
	self selectedContext restartWith: method.
	contextVariablesInspector object: nil.
	self resetContext: self selectedContext.
	^true! !

!Debugger methodsFor: 'accessing' stamp: 'ajh 3/21/2003 00:44' prior: 35519751!
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 |
	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 _ Compiler parserClass new parseSelector: aText.
	selector == self selectedMessageName
		ifFalse: [self inform: 'can''t change selector'. ^ false].

	selector _ classOfMethod
		compile: aText
		classified: category
		notifying: aController.
	selector ifNil: [^ false].  "compile cancelled"

	contents _ aText.
	ctxt _ self selectedContext.
	interruptedProcess
		popTo: ctxt;
		restartTopWith: (classOfMethod compiledMethodAt: selector);
		stepToSendOrReturn.

	contextVariablesInspector object: nil.
	theMethodNode _ ctxt methodNode.
	sourceMap _ theMethodNode sourceMap.
	tempNames _ theMethodNode tempNames.
	self resetContext: ctxt.

	^true! !

!Debugger methodsFor: 'accessing' stamp: 'nk 2/20/2004 16:00' prior: 35521467!
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 |
	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].
	selector := classOfMethod
				compile: aText
				classified: category
				notifying: aController.
	selector
		ifNil: [^ false].
	"compile cancelled"
	contents := aText.
	ctxt := self selectedContext.
	interruptedProcess popTo: ctxt;
		
		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: 'accessing' stamp: 'ajh 3/5/2004 01:20' prior: 35522907!
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 |
	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].
	selector := classOfMethod
				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: 'accessing' stamp: 'hmm 7/16/2001 21:54'!
labelString
	^labelString! !

!Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'!
labelString: aString
	labelString _ aString.
	self changed: #relabel! !

!Debugger methodsFor: 'notifier menu' stamp: 'jcg 3/7/2003 01:47' prior: 19966830!
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: 'context stack (message list)' stamp: 'ajh 9/25/2001 00:14' prior: 19968257!
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)' stamp: 'ajh 3/19/2003 13:40' prior: 19968708!
selectedMessage
	"Answer the source code of the currently selected context."

	contents _ theMethodNode sourceText.
	Preferences browseWithPrettyPrint ifTrue: [
		contents _ self selectedClass compilerClass new
				format: contents
				in: self selectedClass
				notifying: nil
				decorated: Preferences colorWhenPrettyPrinting].
	^ contents _ contents asText makeSelectorBold! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'nk 2/20/2004 15:55' prior: 35528013!
selectedMessage
	"Answer the source code of the currently selected context."
	contents := theMethodNode sourceText.
	^ contents := contents asText makeSelectorBold! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/7/2002 21:15' prior: 19969254!
selectedMessageName
	"Answer the message selector of the currently selected context."

	^self selectedContext methodSelector! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 3/4/2004 20:39'!
askForCategoryIn: aClass default: aString
	| categories index category |
	categories := OrderedCollection with: 'new ...'. 
	categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object).	
	index := PopUpMenu withCaption: 'Please provide a good category for the new method!!' translated
						chooseFrom: categories.
	index = 0 ifTrue: [^ aString].
	category := index = 1 ifTrue: [FillInTheBlank request: 'Enter category name:']
						ifFalse: [categories at: index].
	^ category isEmpty ifTrue: [^ aString] ifFalse: [category]! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 9/14/2001 00:26'!
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: 'hg 10/2/2001 20:22'!
buildMorphicNotifierLabelled: label message: messageString
	| notifyPane window contentTop extentToUse |
	self expandStack.
	window _ (PreDebugWindow labelled: label) model: self.

	contentTop _ 0.2.
	extentToUse _ 450 @ 156. "nice and wide to show plenty of the error msg"
	window addMorph: (self buttonRowForPreDebugWindow: window)
				frame: (0@0 corner: 1 @ contentTop).

	Preferences eToyFriendly | 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: 'context stack menu' stamp: 'hg 9/29/2001 20:24'!
contextStackMenu: aMenu shifted: shifted
	"Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"

	^ shifted ifFalse: [aMenu labels: 
'fullStack (f)
restart (r)
proceed (p)
step (t)
step through (T)
send (e)
where (w)
peel to first like this
senders of... (n)
implementors of... (m)
inheritance (i)
versions (v)
inst var refs...
inst var defs...
class var refs...
class variables
class refs (N)
browse full (b)
file out 
mail out bug report
more...'
	lines: #(8 12 14 17 20)
	selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst
browseSendersOfMessages browseMessages methodHierarchy browseVersions
browseInstVarRefs browseInstVarDefs
browseClassVarRefs browseClassVariables browseClassRefs
browseMethodFull fileOutMessage mailOutBugReport
shiftedYellowButtonActivity)]

	ifTrue: [aMenu labels: 
'browse class hierarchy
browse class
browse method (O)
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
revert to previous version
remove from current change set
revert & remove from changes
more...' 
	lines: #(5 7 10)
	selections: #(classHierarchy browseClass 
		openSingleMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]

! !

!Debugger methodsFor: 'context stack menu' stamp: 'ads 2/17/2003 10:15' prior: 35531223!
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
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 12 14 17 20)
		selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst
browseSendersOfMessages browseMessages methodHierarchy browseVersions
browseInstVarRefs browseInstVarDefs
browseClassVarRefs browseClassVariables browseClassRefs
browseMethodFull fileOutMessage mailOutBugReport
shiftedYellowButtonActivity)]

	ifTrue: [aMenu labels: 
'browse class hierarchy
browse class
browse method (O)
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
revert to previous version
remove from current change set
revert & remove from changes
more...' 
	lines: #(5 7 10)
	selections: #(classHierarchy browseClass 
		openSingleMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]

! !

!Debugger methodsFor: 'context stack menu' stamp: 'emm 5/30/2002 10:14' prior: 35532731!
contextStackMenu: aMenu shifted: shifted
	"Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"

	^ shifted ifFalse: [aMenu labels: 
'fullStack (f)
restart (r)
proceed (p)
step (t)
step through (T)
send (e)
where (w)
peel to first like this
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 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: 'gk 4/26/2004 14:09' prior: 35534545!
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
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 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: 'hmm 7/30/2001 20:49'!
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.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext.
	self contextStackIndex > 1
		ifTrue: 
			[newContext _ currentContext completeCallee: contextStackTop.
			self resetContext: newContext]
		ifFalse: 
			[newContext _ currentContext stepToSendOrReturn.
			newContext == currentContext ifTrue: [newContext _ currentContext quickStep].
			newContext == currentContext
				ifTrue: [
					currentContext stepToSendOrReturn.
					self changed: #contentsSelection.
					self updateInspectors]
				ifFalse: [
					externalInterrupt ifFalse: [newContext push: proceedValue].
					externalInterrupt _ true. "simulation leaves same state as interrupting"
					newContext stepToSendOrReturn.
					self resetContext: newContext]]! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 13:35' prior: 35537934!
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.
	interruptedProcess completeStep: currentContext.
	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: 'ajh 7/6/2003 21:06' prior: 35539087!
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: 'ads 7/21/2003 16:00'!
implement: aMessage inClass: aClass

	aClass compile: aMessage createStubMethod.
	self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
	self resetContext: self selectedContext.
	self contextStackIndex: 1 oldContextWas: nil
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 3/4/2004 20:39' prior: 35540510!
implement: aMessage inClass: aClass
	
	| category |
	category := self askForCategoryIn: aClass default: 'as yet unclassified'.
	aClass compile: aMessage createStubMethod classified: category.
	self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
	self resetContext: self selectedContext.
	self contextStackIndex: 1 oldContextWas: nil
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 10/16/2001 19:00'!
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 |
	(Smalltalk includesKey: #Celeste)
		ifFalse: [^ self inform: 'no mail reader present'].

	Cursor write
		showWhile: 
			["Prepare the message"
			messageStrm _ WriteStream on: (String new: 1500).
			messageStrm nextPutAll: 'From: ';
			 nextPutAll: Celeste 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.

			CelesteComposition
				openForCeleste: Celeste current 
				initialText: messageStrm contents].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'dvf 5/11/2002 00:51' prior: 35541295!
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: 'nb 6/17/2003 12:25' prior: 19978710!
peelToFirst
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| upperGuy meth second |
	contextStackIndex = 0 ifTrue: [^ Beeper beep].
	"self okToChange ifFalse: [^ self]."
	upperGuy _ contextStack at: contextStackIndex.
	meth _ upperGuy method.
	contextStackIndex+1 to: contextStack size do: [:ind |
		(contextStack at: ind) method == meth ifTrue: [
			second _ upperGuy.
			upperGuy _ contextStack at: ind]].
	second ifNil: [second _ upperGuy].
	self resetContext: second.
	interruptedProcess popTo: self selectedContext.! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:10' prior: 35543959!
peelToFirst
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| upperGuy meth second ctxt |
	contextStackIndex = 0 ifTrue: [^ Beeper beep].
	"self okToChange ifFalse: [^ self]."
	upperGuy _ contextStack at: contextStackIndex.
	meth _ upperGuy method.
	contextStackIndex+1 to: contextStack size do: [:ind |
		(contextStack at: ind) method == meth ifTrue: [
			second _ upperGuy.
			upperGuy _ contextStack at: ind]].
	second ifNil: [second _ upperGuy].
	ctxt _ interruptedProcess popTo: self selectedContext.
	ctxt == self selectedContext
		ifTrue: [self resetContext: second]
		ifFalse: [self resetContext: ctxt].  "unwind error"
! !

!Debugger methodsFor: 'context stack menu' stamp: 'ads 2/20/2003 08:46'!
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: 'ajh 1/24/2003 12:29' prior: 19979805!
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: 'hmm 9/7/2001 16:46'!
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"

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^self]].
	self selectedContext restart.
	self resetContext: self selectedContext.
	Preferences restartAlsoProceeds ifTrue: [self proceed]! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:27' prior: 35546414!
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"

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	interruptedProcess
		popTo: self selectedContext;
		restartTop;
		stepToSendOrReturn.
	self resetContext: self selectedContext.
	Preferences restartAlsoProceeds ifTrue: [self proceed]! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:14' prior: 35547185!
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: 'hmm 7/30/2001 18:09'!
send
	"Send the selected message in the accessed method, and take control in 
	the method invoked to allow further step or send."

	| currentContext newContext |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext..
	self contextStackIndex > 1
		ifTrue: 
			[currentContext completeCallee: contextStackTop.
			self resetContext: currentContext]
		ifFalse:
			[newContext _ currentContext stepToSendOrReturn.
			newContext == currentContext ifTrue: [
				newContext _ newContext step stepToSendOrReturn].
			self resetContext: newContext]! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29' prior: 35548474!
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: 'hmm 7/30/2001 17:56'!
stepIntoBlock
	"Send messages until you return to the present method context.
	 Used to step into a block in the method."

	| startContext ctxt |
	startContext _ self selectedContext home.
	self send.

	"check if nothing happend on send, otherwise continue until block"
	ctxt _ contextStackTop.
	[ctxt home ~= startContext and: [ctxt hasSender: startContext]]
		whileTrue: 
			[ctxt _ ctxt step].
	ctxt _ ctxt stepToSendOrReturn.
	self resetContext: ctxt! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:46' prior: 35549678!
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: 'nk 2/6/2001 19:34'!
where
	"Select the expression whose evaluation was interrupted."

	selectingPC _ true.
	self contextStackIndex: contextStackIndex oldContextWas: self selectedContext
! !

!Debugger methodsFor: 'code pane' stamp: 'hmm 7/17/2001 20:46'!
pcRange
	"Answer the indices in the source code for the method corresponding to 
	the selected context's program counter value."

	| i methodNode pc end |
	(selectingPC and: [contextStackIndex ~= 0])
		ifFalse: [^1 to: 0].
	sourceMap == nil ifTrue:
		[methodNode _ self selectedClass compilerClass new
			parse: contents in: self selectedClass
			notifying: nil dialect: true.
		sourceMap _ methodNode sourceMap.
		tempNames _ methodNode tempNames.
		self selectedContext method cacheTempNames: tempNames].
	sourceMap size = 0 ifTrue: [^1 to: 0].
	pc_ self selectedContext pc -
		(("externalInterrupt" 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' stamp: 'ar 6/28/2003 00:03' prior: 35550772!
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 == nil ifTrue:
		[sourceMap _ theMethodNode sourceMap.
		tempNames _ theMethodNode tempNames.
		self selectedContext method cacheTempNames: tempNames].
	sourceMap size = 0 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' stamp: 'nk 7/4/2003 19:56' prior: 35551778!
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 == nil ifTrue:
		[sourceMap _ theMethodNode sourceMap.
		tempNames _ theMethodNode tempNames.
		self selectedContext method cacheTempNames: 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' stamp: 'nk 2/20/2004 15:35' prior: 35552993!
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.
		self selectedContext method cacheTempNames: 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: '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: 'private' stamp: 'ads 2/15/2003 13:34'!
askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock
	| classes chosenClassIndex |
	classes _ aClass withAllSuperclasses.
	chosenClassIndex _ PopUpMenu
		withCaption: 'Define #', aSelector, ' in which class?'
		chooseFrom: (classes collect: [:c | c name]).
	chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
	^ classes at: chosenClassIndex! !

!Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34' prior: 19986524!
checkContextSelection

	contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil].
! !

!Debugger methodsFor: 'private' stamp: 'ajh 1/23/2003 19:34' prior: 19986667!
contextStackIndex: anInteger oldContextWas: oldContext

	| newMethod |
	contextStackIndex _ anInteger.
	anInteger = 0
		ifTrue:
			[theMethodNode _ tempNames _ sourceMap _ contents _ nil.
			self changed: #contextStackIndex.
			self contentsChanged.
			contextVariablesInspector object: nil.
			receiverInspector object: self receiver.
			^self].
	(newMethod _ oldContext == nil or:
		[oldContext method ~~ self selectedContext method])
		ifTrue:
			[tempNames _ sourceMap _ nil.
			theMethodNode _ self selectedContext methodNode.
			contents _ self selectedMessage.
			self contentsChanged.
			self pcRange "will compute tempNamesunless noFrills"].
	self changed: #contextStackIndex.
	tempNames == nil
		ifTrue: [tempNames _ 
					self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil].
	contextVariablesInspector object: self selectedContext.
	receiverInspector object: self receiver.
	newMethod ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private' stamp: 'nk 2/17/2004 21:05' prior: 35556393!
contextStackIndex: anInteger oldContextWas: oldContext

	| newMethod |
	contextStackIndex _ anInteger.
	anInteger = 0
		ifTrue:
			[currentCompiledMethod _ theMethodNode _ tempNames _ sourceMap _ contents _ nil.
			self changed: #contextStackIndex.
			self decorateButtons.
			self contentsChanged.
			contextVariablesInspector object: nil.
			receiverInspector object: self receiver.
			^self].
	(newMethod _ oldContext == nil or:
		[oldContext method ~~ (currentCompiledMethod _ self selectedContext method)])
		ifTrue:
			[tempNames _ sourceMap _ nil.
			theMethodNode _ 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: self selectedContext.
	receiverInspector object: self receiver.
	newMethod ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private' stamp: 'nk 2/20/2004 16:51' prior: 35557452!
contextStackIndex: anInteger oldContextWas: oldContext 
	"Change the context stack index to anInteger, perhaps in response to user selection."

	| newMethod |
	contextStackIndex := anInteger.
	anInteger = 0
		ifTrue: [currentCompiledMethod := theMethodNode := tempNames := sourceMap := contents := nil.
			self changed: #contextStackIndex.
			self decorateButtons.
			self contentsChanged.
			contextVariablesInspector object: nil.
			receiverInspector object: self receiver.
			^ 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: self selectedContext.
	receiverInspector object: self receiver.
	newMethod
		ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private' stamp: 'ads 7/21/2003 17:30'!
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.
	self proceed.! !

!Debugger methodsFor: 'private' stamp: 'sw 7/29/2002 23: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: 'ajh 9/25/2001 00:14' prior: 19993464!
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 changed: #content.! !

!Debugger methodsFor: 'private' stamp: 'ar 3/17/2001 23:54'!
resumeProcess: aTopView 
	Smalltalk isMorphic
		ifFalse: [aTopView erase].
	savedCursor
		ifNotNil: [Sensor currentCursor: savedCursor].
	isolationHead
		ifNotNil: [failedProject enterForEmergencyRecovery.
			isolationHead invoke.
			isolationHead _ nil].
	interruptedProcess suspendedContext method
			== (Process compiledMethodAt: #terminate)
		ifFalse: [contextStackIndex > 1
				ifTrue: [interruptedProcess popTo: self selectedContext]
				ifFalse: [interruptedProcess install: self selectedContext].
			Smalltalk isMorphic
				ifTrue: [errorWasInUIProcess
						ifTrue: [Project resumeProcess: interruptedProcess]
						ifFalse: [interruptedProcess resume]]
				ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]].
	"if old process was terminated, just terminate current one"
	interruptedProcess _ nil.
	"Before delete, so release doesn't terminate it"
	Smalltalk isMorphic
		ifTrue: [aTopView delete.
			World displayWorld]
		ifFalse: [aTopView controller closeAndUnscheduleNoErase].
	Smalltalk installLowSpaceWatcher.
	"restart low space handler"
	errorWasInUIProcess == false
		ifFalse: [Processor terminateActive]! !

!Debugger methodsFor: 'private' stamp: 'ajh 1/24/2003 12:25' prior: 35561794!
resumeProcess: aTopView 
	Smalltalk isMorphic
		ifFalse: [aTopView erase].
	savedCursor
		ifNotNil: [Sensor currentCursor: savedCursor].
	isolationHead
		ifNotNil: [failedProject enterForEmergencyRecovery.
			isolationHead invoke.
			isolationHead _ nil].
	interruptedProcess suspendedContext method
			== (Process compiledMethodAt: #terminate)
		ifFalse: [
			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' stamp: 'ajh 7/21/2003 10:08' prior: 35563062!
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: 'controls' stamp: 'sw 9/3/2002 10:24'!
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 divider 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: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]);
		borderWidth: 0.
	Preferences alternativeWindowLook ifTrue:
		[buttons color: Color transparent.
		buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised]].
	divider _ BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:
		[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! !

!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: 'nk 5/31/2003 07:38'!
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 class methodsFor: 'class initialization' stamp: 'hg 9/29/2001 20:24'!
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: 'hg 10/2/2001 20:44'!
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 _ CurrentProjectRefactoring currentIsolationHead)
			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: 'class initialization' stamp: 'hg 10/2/2001 20:44' prior: 35568241!
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 _ CurrentProjectRefactoring currentIsolationHead)
			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' prior: 19996279!
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: 'hmm 8/3/2001 13:05'!
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: 'hg 10/2/2001 20:45'!
openInterrupt: aString onProcess: interruptedProcess
	"Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
	| debugger |
	<primitive: 19> "Simulation guard"
	debugger _ self new.
	debugger
		process: interruptedProcess
		controller: ((Smalltalk isMorphic not
					and: [ScheduledControllers activeControllerProcess == interruptedProcess])
						ifTrue: [ScheduledControllers activeController])
		context: interruptedProcess suspendedContext.
	debugger externalInterrupt: true.

Preferences logDebuggerStackToFile ifTrue:
	[(aString includesSubString: 'Space') & 
		(aString includesSubString: 'low') ifTrue: [
			Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']].

	^ debugger
		openNotifierContents: nil
		label: aString
! !

!Debugger class methodsFor: 'opening' stamp: 'ajh 9/14/2002 22:22'!
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."

	<primitive: 19> "Simulation guard"
	[	| debugger |
		debugger _ self new
			process: process
			controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == process]) ifTrue: [ScheduledControllers activeController])
			context: context.
		bool ifTrue: [debugger openFullNoSuspendLabel: title]
			ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
		Preferences logDebuggerStackToFile ifTrue: [
			Smalltalk logError: title inContext: context to: 'SqueakDebug.log'].
		process isSuspended ifFalse: [process suspend].
	] on: Error do: [:ex |
		self primitiveError: 
			'Orginal error: ', 
			title asString, '.
Debugger error: ', 
			([ex description] on: Error do: ['a ', ex class printString]), ':'
	]! !

!Debugger class methodsFor: 'opening' stamp: 'ajh 7/20/2003 23:53' prior: 35573035!
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."

	| errorWasInUIProcess |
	errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: process.
	[
		[	| debugger |
			debugger _ self new
				process: process
				controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == process]) ifTrue: [ScheduledControllers activeController])
				context: context.
			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'].
		] on: Error do: [:ex |
			self primitiveError: 
				'Orginal error: ', 
				title asString, '.
	Debugger error: ', 
				([ex description] on: Error do: ['a ', ex class printString]), ':'
		]
	] fork.
	process suspend.
! !

!Debugger class methodsFor: 'opening' stamp: 'ajh 8/6/2003 11:40' prior: 35574156!
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 _ CurrentProjectRefactoring newProcessIfUI: process]
		ifFalse: [controller _ ScheduledControllers activeControllerProcess == process
				ifTrue: [ScheduledControllers activeController]].
	[
		[	| debugger |
			debugger _ self new process: process controller: controller context: context.
			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]), ':'
		]
	] fork.
	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.'! !

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

!Decompiler methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 01:14' prior: 19999275!
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: 'instruction decoding' stamp: 'md 11/14/2003 16:28' prior: 20003481!
case: dist
	"statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"

	| nextCase end thenJump stmtStream elements b node cases otherBlock |
	nextCase _ pc + dist.
	end _ limit.
	"Now add CascadeFlag & keyValueBlock to statements"
	statements addLast: stack removeLast.
	stack addLast: CaseFlag. "set for next pop"
	statements addLast: (self blockForCaseTo: nextCase).
	stack last == CaseFlag
		ifTrue: "Last case"
			["ensure jump is within block (in case thenExpr returns wierdly I guess)"
			stack removeLast. "get rid of CaseFlag"
			thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase].
			stmtStream _ ReadStream on: (self popTo: stack removeLast).
			elements _ OrderedCollection new.
			b _ OrderedCollection new.
			[stmtStream atEnd] whileFalse:
				[(node _ stmtStream next) == CascadeFlag
					ifTrue:
						[elements addLast: (constructor
							codeMessage: (constructor codeBlock: b returns: false)
							selector: (constructor codeSelector: #-> code: #macro)
							arguments: (Array with: stmtStream next)).
						 b _ OrderedCollection new]
					ifFalse: [b addLast: node]].
			b size > 0 ifTrue: [self error: 'Bad cases'].
			cases _ constructor codeBrace: elements.
			otherBlock _ self blockTo: thenJump.
			stack addLast:
				(constructor
					codeMessage: stack removeLast
					selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
					arguments: (Array with: cases with: otherBlock))]! !

!Decompiler methodsFor: 'public access' stamp: 'LC 1/6/2002 15:50'!
decompileBlock: aBlock 
	"Original version timestamp: sn 1/26/98 18:27
	(Don't know who's sn?) "
	"Decompile aBlock, returning the result as a BlockNode.  
	Show temp names from source if available."
	"Decompiler new decompileBlock: [3 + 4]"
	| startpc end homeClass blockNode tempNames home source |
	(home _ aBlock home) ifNil: [^ nil].
	method _ home method.
	(homeClass _ home who first) == #unknown ifTrue: [^ nil].
	constructor _ DecompilerConstructor new.
	method fileIndex ~~ 0
		ifTrue: ["got any source code?"
			source _ [method getSourceFromFile]
						on: Error
						do: [:ex | ^ nil].
			tempNames _ ([homeClass compilerClass new
						parse: source
						in: homeClass
						notifying: nil]
						on: (Smalltalk classNamed: 'SyntaxErrorNotification')
						do: [:ex | ^ nil]) tempNames.
			self withTempNames: tempNames].
	self initSymbols: homeClass.
	startpc _ aBlock startpc.
	end _ (method at: startpc - 2)
				\\ 16 - 4 * 256
				+ (method at: startpc - 1) + startpc - 1.
	stack _ OrderedCollection new: method frameSize.
	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 methodsFor: 'private' stamp: 'ajh 11/15/2003 01:21' prior: 20015345!
decompile: aSelector in: aClass method: aMethod using: aConstructor

	| block |
	constructor _ aConstructor.
	method _ aMethod.
	self initSymbols: aClass.  "create symbol tables"
	method isQuick
		ifTrue: [block _ self quickMethod]
		ifFalse: 
			[stack _ OrderedCollection new: method frameSize.
			statements _ OrderedCollection new: 20.
			super method: method pc: method initialPC.
			block _ self blockTo: method endPC + 1.
			stack isEmpty ifFalse: [self error: 'stack not empty']].
	^constructor
		codeMethod: aSelector
		block: block
		tempVars: tempVars
		primitive: method primitive
		class: aClass! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 7/21/2003 00:53' prior: 20021345!
codeMethod: selector block: block tempVars: vars primitive: primitive class: class

	| node |
	node _ self codeSelector: selector code: nil.
	tempVars _ vars.
	^MethodNode new
		selector: node
		arguments: (tempVars copyFrom: 1 to: nArgs)
		precedence: selector precedence
		temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size)
		block: block
		encoder: (Encoder new initScopeAndLiteralTables
					temps: tempVars
					literals: literalValues
					class: class)
		primitive: primitive! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 11/15/2003 01:20' prior: 35583279!
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! !

!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: 'tk 3/7/2001 13:38'!
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'.
(Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | 
	(mm _ aClass instVarNames size) > 0 ifTrue: [
		(aClass instSize - mm + 1) to: aClass instSize do: [:index |
			((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [
				Transcript cr; show: aClass name; space; 
					show: (aClass allInstVarNames at: index)]]]].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'nb 5/6/2003 16:50' prior: 35586899!
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'.
(SystemNavigation new 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:52' prior: 35587793!
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: 'tk 10/4/2001 13:45'!
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."
	(Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | 
		((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [
			aClass instSize > 0 ifTrue: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(Smalltalk allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | 
		meth _ aClass compiledMethodAt: #veryDeepCopyWith:.
		(meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [
			(meth writesField: aClass instSize) ifFalse: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]].

! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'nb 5/6/2003 16:51' prior: 35589676!
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."
	(SystemNavigation new allClassesImplementing: #veryDeepInner:) do: [:aClass | 
		((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [
			aClass instSize > 0 ifTrue: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(SystemNavigation new 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: 'dvf 8/23/2003 11:53' prior: 35590905!
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: 'tk 3/7/2001 13:44'!
initialize: size

	references _ IdentityDictionary new: size.
	uniClasses _ IdentityDictionary new.	"UniClass -> new UniClass"
	"self isItTimeToCheckVariables ifTrue: [self checkVariables]."
		"no more checking at runtime"
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:40' prior: 35593816!
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 10/4/2001 13:48'!
mapUniClasses
	"For new Uniclasses, map their class vars to the new objects.  And their additional class instance vars.  (scripts slotInfo) and cross references like (player321)."
	"Players also refer to each other using associations in the References dictionary.  Search the methods of our Players for those.  Make new entries in References and point to them."
| pp oldPlayer newKey newAssoc oldSelList newSelList |

"Uniclasses use class vars to hold onto siblings who are referred to in code"
pp _ 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:14' prior: 35594447!
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 3/7/2001 15:46'!
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.
	Browser openMessageBrowserForClass: aClass selector: sel editString: nil.
! !

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

!Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'!
isExpired

	^delaySemaphore isSignaled.
! !

!Delay methodsFor: 'private' stamp: 'ar 7/18/2001 20:28'!
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:[
		ActiveDelay signalWaitingProcess.
		SuspendedDelays isEmpty ifTrue:[
			ActiveDelay _ nil.
			ActiveDelayStartTime _ nil.
		] ifFalse:[SuspendedDelays removeFirst activate].
	] ifFalse:[
		TimingSemaphore initSignals.
		Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime.
	].! !

!Delay commentStamp: 'ls 10/14/2003 11:46' 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: .!
]style[(763 22 2)f1,f1LDelay class testDelayOf:for:rect:;,f1!
!Delay class methodsFor: 'instance creation' stamp: 'brp 9/25/2003 13:43'!
forDuration: aDuration

	^ self forMilliseconds: aDuration asMilliSeconds
! !

!Delay class methodsFor: 'testing'!
nextWakeUpTime
	^ AccessProtect
		critical: [ActiveDelay isNil
				ifTrue: [0]
				ifFalse: [ActiveDelay resumptionTime]]! !

!DependentsArray methodsFor: 'copying' stamp: 'ar 2/24/2001 17:30'!
copyWith: newElement 
	"Re-implemented to not copy any niled out dependents"
	^self class streamContents:[:s|
		self do:[:item| s nextPut: item].
		s nextPut: newElement].! !

!DependentsArray methodsFor: 'copying' stamp: 'nk 3/11/2004 09:34'!
size
	^self inject: 0 into: [ :count :dep | dep ifNotNil: [ count _ count + 1 ]]! !

!DependentsArray methodsFor: 'enumerating' stamp: 'ar 2/11/2001 01:52'!
do: aBlock
	"Refer to the comment in Collection|do:."
	| dep |
	1 to: self size do:[:i|
		(dep _ self at: i) ifNotNil:[aBlock value: dep]].! !

!DependentsArray methodsFor: 'enumerating' stamp: 'nk 3/11/2004 09:34' prior: 35606678!
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 commentStamp: '<historical>' prior: 0!
An array of (weak) dependents of some object.!
!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.'
!
!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: 'sw 10/24/2001 15:29'!
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) imageForm]! !

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

!DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:12'!
messagePart: level repeat: repeat initialKeyword: kwdIfAny

	| start receiver selector args precedence words keywordStart |
	[receiver _ parseNode.
	(self matchKeyword and: [level >= 3])
		ifTrue: 
			[start _ self startOfNextToken.
			selector _ WriteStream on: (String new: 32).
			selector nextPutAll: kwdIfAny.
			args _ OrderedCollection new.
			words _ OrderedCollection new.
			[self matchKeyword]
				whileTrue: 
					[keywordStart _ self startOfNextToken + requestorOffset.
					selector nextPutAll: self advance , ':'.
					words addLast: (keywordStart to: hereEnd + requestorOffset).
					self primaryExpression ifFalse: [^ self expected: 'Argument'].
					args addLast: parseNode].
			(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
				ifFalse: [ selector _ self correctSelector: selector contents
										wordIntervals: words
										exprInterval: (start to: self endOfLastToken)
										ifAbort: [ ^ self fail ] ].
			precedence _ 3]
		ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
				and: [level >= 2])
				ifTrue: 
					[start _ self startOfNextToken.
					selector _ self advance asSymbol.
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 1 repeat: true.
					args _ Array with: parseNode.
					precedence _ 2]
				ifFalse: [(hereType == #word
							and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not])
						ifTrue: 
							[start _ self startOfNextToken.
							selector _ self advance.
							args _ #().
							words _ OrderedCollection with: (start  + requestorOffset to: self endOfLastToken + requestorOffset).
							(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
								ifFalse: [ selector _ self correctSelector: selector
													wordIntervals: words
													exprInterval: (start to: self endOfLastToken)
													ifAbort: [ ^ self fail ] ].
							precedence _ 1]
						ifFalse: [^args notNil]]].
	parseNode _ MessageNode new
				receiver: receiver
				selector: selector
				arguments: args
				precedence: precedence
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	repeat]
		whileTrue: [].
	^true! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:09'!
temporaries
	" [ 'Use' (variable)* '.' ]"
	| vars theActualText |
	(self matchToken: #'Use') ifFalse: 
		["no temps"
		doitFlag ifTrue: [requestor
				ifNil: [tempsMark _ 1]
				ifNotNil: [tempsMark _ requestor selectionInterval first].
			^ #()].
		tempsMark _ prevEnd+1.
		tempsMark > 0 ifTrue:
			[theActualText _ source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark _ tempsMark + 1]].
			^ #()].
	vars _ OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance)].
	(self match: #period) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Period'! !

!DialectParser class methodsFor: 'as yet unclassified' stamp: 'sd 4/16/2003 09:19' prior: 20094316!
test    "DialectParser test"

"PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code.  No changes are actually made to the system.  At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running):

	BalloonEngineSimulation circleCosTable and
	BalloonEngineSimulation circleSinTable.

These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors.

Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on.

NOTE:  Some methods may not compare properly until the system has been recompiled once.  Do this by executing...
		Smalltalk recompileAllFrom: 'AARDVAARK'.
"

	 | newCodeString methodNode oldMethod newMethod badOnes n heading |
	Preferences enable: #printAlternateSyntax.
	badOnes _ OrderedCollection new.
	Transcript clear.
	Smalltalk forgetDoIts.
'Formatting and recompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allClassesDo:  "{MethodNode} do:"  "<- to check one class"
		[:nonMeta |  "Transcript cr; show: nonMeta name."
		{nonMeta. nonMeta class} do:
		[:cls |
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			newCodeString _ (cls compilerClass new)
				format: (cls sourceCodeAt: selector)
				in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
			heading _ cls organization categoryOfElement: selector.
			methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls notifying: (SyntaxError new category: heading)
						ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldMethod _ cls compiledMethodAt: selector.
			"Transcript cr; show: cls name , ' ' , selector."
			oldMethod = newMethod ifFalse:
				[Transcript cr; show: '***' , cls name , ' ' , selector.
				oldMethod size = newMethod size ifFalse:
					[Transcript show: ' difft size'].
				oldMethod header = newMethod header ifFalse:
					[Transcript show: ' difft header'].
				oldMethod literals = newMethod literals ifFalse:
					[Transcript show: ' difft literals'].
				Transcript endEntry.
				badOnes add: cls name , ' ' , selector]]]].
].
	SystemNavigation new browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'.
	Preferences disable: #printAlternateSyntax.
! !

!DialectParser class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:17' prior: 35614981!
test    "DialectParser test"

"PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code.  No changes are actually made to the system.  At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running):

	BalloonEngineSimulation circleCosTable and
	BalloonEngineSimulation circleSinTable.

These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors.

Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on.

NOTE:  Some methods may not compare properly until the system has been recompiled once.  Do this by executing...
		Smalltalk recompileAllFrom: 'AARDVAARK'.
"

	 | newCodeString methodNode oldMethod newMethod badOnes n heading |
	Preferences enable: #printAlternateSyntax.
	badOnes _ OrderedCollection new.
	Transcript clear.
	Smalltalk forgetDoIts.
'Formatting and recompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allClassesDo:  "{MethodNode} do:"  "<- to check one class"
		[:nonMeta |  "Transcript cr; show: nonMeta name."
		{nonMeta. nonMeta class} do:
		[:cls |
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			newCodeString _ (cls compilerClass new)
				format: (cls sourceCodeAt: selector)
				in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
			heading _ cls organization categoryOfElement: selector.
			methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls notifying: (SyntaxError new category: heading)
						ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldMethod _ cls compiledMethodAt: selector.
			"Transcript cr; show: cls name , ' ' , selector."
			oldMethod = newMethod ifFalse:
				[Transcript cr; show: '***' , cls name , ' ' , selector.
				oldMethod size = newMethod size ifFalse:
					[Transcript show: ' difft size'].
				oldMethod header = newMethod header ifFalse:
					[Transcript show: ' difft header'].
				oldMethod literals = newMethod literals ifFalse:
					[Transcript show: ' difft literals'].
				Transcript endEntry.
				badOnes add: cls name , ' ' , selector]]]].
].
	self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'.
	Preferences disable: #printAlternateSyntax.
! !

!DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:20'!
colorTable
	"Answer the table to use to determine colors"

	^ colorTable ifNil:
		[colorTable _ dialect == #SQ00
			ifTrue:
				[Sq00ColorTable]
			ifFalse:
				[ST80ColorTable]]! !

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

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

!DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:27'!
initialize
	"Initialize the color tables"

	self initializeST80ColorTable.
	self initializeSq00ColorTable.

"DialectStream initialize"
! !

!DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 21:09'!
initializeST80ColorTable
	"Initiialize 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	tan normal)
		(keyword darkGray bold)
		(prefixKeyword veryDarkGray bold)
		(setOrReturn black bold)) do:
			[:aTriplet |
				ST80ColorTable at: aTriplet first put: aTriplet allButFirst]

"DialectStream initialize"! !

!DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:25'!
initializeSq00ColorTable
	"Initiialize the colors that characterize the Sq00 dialect"

	Sq00ColorTable _ IdentityDictionary new.
	#(	(temporaryVariable black normal)
		(methodArgument black normal)
		(methodSelector black bold)
		(blockArgument black normal)
		(comment brown normal)
		(variable black normal)
		(literal	 blue normal)
		(keyword darkGray bold)
		(prefixKeyword veryDarkGray bold)
		(setOrReturn black bold)) do:
			[:aTriplet |
				Sq00ColorTable at: aTriplet first put: aTriplet allButFirst]! !

!DialectStream class methodsFor: 'instance creation' stamp: 'sw 5/20/2001 21:07'!
dialect: dialectSymbol contents: blockWithArg 
	"Evaluate blockWithArg on a DialectStream of the given description"

	| stream |
	stream _ self on: (Text new: 400).
	stream setDialect: dialectSymbol.
	blockWithArg value: stream.
	^ stream contents! !

!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' 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: '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: '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: 'removing' stamp: 'RAA 5/28/2001 13:38'!
unreferencedKeys		"TextConstants unreferencedKeys"
	| n |
	^ 'Scanning for references . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
		[:bar | n _ 0.
		self keys select:
			[:key | bar value: (n _ n+1).
			(Smalltalk allCallsOn: (self associationAt: key)) isEmpty]]! !

!Dictionary methodsFor: 'removing' stamp: 'sd 4/29/2003 12:01' prior: 35624056!
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).
					(SystemNavigation new
						allCallsOn: (self associationAt: key)) isEmpty]]! !

!Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51' prior: 35624440!
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: 'enumerating' stamp: 'dtl 2/17/2003 09:48' prior: 20110104!
valuesDo: aBlock 
	"Evaluate aBlock for each of the receiver's values."

	self associationsDo: [:association | aBlock value: association value]! !

!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: '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/17/2003 14:07' prior: 35626118!
bindingOf: varName
	^self associationAt: varName ifAbsent:[nil]! !

!Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33'!
bindingsDo: aBlock
	^self associationsDo: aBlock! !

!Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33' prior: 35626400!
bindingsDo: aBlock
	^self associationsDo: aBlock! !

!Dictionary methodsFor: 'comparing' stamp: 'tk 11/8/2001 15:56'!
= other
	"Equal if it has my keys, is same size, and has the same corresponding value associated with each key."

	self == other ifTrue: [^ true].	"stop recursion"
	(other class = self class) ifFalse: [^ false].
		"Do we want to require that they be of exactly the same class?"
	self size = other size ifFalse: [^ false].
	self keysAndValuesDo: [:aKey :aValue |
		(other at: aKey ifAbsent: [^ false]) = aValue ifFalse: [^ false]].
	^ true! !

!Dictionary methodsFor: 'comparing' stamp: 'raok 6/10/2002 15:29' prior: 35626652!
= 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".

	(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 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.!
!DictionaryInspector methodsFor: 'menu' stamp: 'tk 10/18/2002 16:42'!
dictionaryMenu: aMenu

	^ aMenu labels:
'inspect
copy name
references
objects pointing to this value
refresh view
add key
rename key
remove
basic inspect'
	lines: #( 5 8)
	selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection calculateKeyArray addEntry renameEntry removeSelection inspectBasic)
! !

!DictionaryInspector methodsFor: 'menu' stamp: 'sw 5/16/2003 00:33' prior: 35628004!
dictionaryMenu: aMenu
	"Set up the key-list menu for a dictionary inspector"

	aMenu title: 'Dictionary key'.
	Smalltalk isMorphic ifTrue:
		[aMenu addStayUpItem].
	^ aMenu addList: #(
		('inspect'						inspectSelection)
		('copy name'					copyName)
		('references'					selectionReferences)
		('objects pointing to this value'	objectReferencesToSelection)
		('senders of this key'			sendersOfSelectedKey)
		-
		('refresh view'					calculateKeyArray)
		-
		('add key'						addEntry)
		('rename key'					renameEntry)
		('remove'						removeSelection)
		-
		('basic inspect'					inspectBasic))! !

!DictionaryInspector methodsFor: 'menu' stamp: 'tk 10/18/2002 16:41'!
renameEntry
	| newKey aKey value |

	value _ object at: (keyArray at: selectionIndex).
	newKey _ FillInTheBlank request: 
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'
		 initialAnswer: (keyArray at: selectionIndex) printString.
	aKey _ Compiler evaluate: newKey.
	object removeKey: (keyArray at: selectionIndex).
	object at: aKey put: value.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'menu' stamp: 'nk 6/26/2003 21:43' prior: 20119218!
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)).
! !

!DictionaryInspector methodsFor: 'menu' stamp: 'sw 5/16/2003 00:00'!
sendersOfSelectedKey
	"Create a browser on all senders of the selected key"

	| aKey |
	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	((aKey _ keyArray at: selectionIndex) isKindOf: Symbol) ifFalse: [^ self changed: #flash].
	object class == MethodDictionary ifTrue: [^ self changed: #flash].
	Smalltalk browseAllCallsOn: aKey! !

!DictionaryInspector methodsFor: 'menu' stamp: 'wiz 5/16/2004 13:05' prior: 35630129!
sendersOfSelectedKey
	"Create a browser on all senders of the selected key"
	| aKey |
	self selectionIndex = 0
		ifTrue: [^ self changed: #flash].
	((aKey := keyArray at: selectionIndex) isKindOf: Symbol)
		ifFalse: [^ self changed: #flash].
	object class == MethodDictionary
		ifTrue: [^ self changed: #flash].
	SystemNavigation default browseAllCallsOn: aKey! !

!DictionaryTest methodsFor: 'testing' stamp: 'sd 12/17/2003 20:31'!
testAddAll
	"(self run: #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: 'testing' stamp: 'sd 12/17/2003 20:30'!
testComma
	"(self run: #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.! !

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

!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: '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 class methodsFor: 'public' stamp: 'ads 7/31/2003 14:01' prior: 20137248!
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
! !

!DirectoryEntry methodsFor: 'multilingual system' stamp: 'yo 11/5/2002 14:02'!
convertFromSystemName

	name isString ifTrue: [name _ name convertFromSystemString].
! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 3/8/2001 09:33'!
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]].
	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].
				"args not checked against Renamed"
	^ nil 	"was not in proper form"! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 15:23' prior: 35634351!
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"! !

!DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'!
deferUpdatesIn: aRectangle while: aBlock
	"DisplayScreen overrides with something more involved..."
	^aBlock value! !

!DisplayScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 18:13'!
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].
	^ runStopIndex - lastIndex   "Number of characters remaining in the current run"! !

!DisplayScanner methodsFor: 'scanning' stamp: 'yo 10/7/2002 18:38' prior: 35639498!
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: '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: '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: 'ar 12/15/2001 23:28'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	alignment = Justified ifTrue:[
		"Make a local copy of stop conditions so we don't modify the default"
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:43' prior: 35644685!
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: 'MVC-compatibility' stamp: 'ls 1/19/2002 16:11'!
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].
			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: 'BG 12/15/2003 13:02' prior: 35645713!
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].
			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:
				[kern ~= 0
                           ifTrue: [destX := destX - kern].
				fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits].
			lineY _ lineY + lineHeight]]! !

!DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'BEO 8/7/2002 16:13'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
	bitBlt _ BitBlt current 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 commentStamp: '<historical>' prior: 0!
My instances are used to scan text and display it on the screen or in a hidden form.!
!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/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: '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: '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' 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' 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: '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 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: 'snapshots' stamp: 'ar 2/5/2001 17:24'!
actualScreenDepth
	<primitive: 'primitiveScreenDepth'>
	^ Display depth! !

!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'!
startUp  "DisplayScreen startUp"
	Display setExtent: self actualScreenSize depth: Display nativeDepth.
	Display beDisplay! !

!DisplayText methodsFor: 'displaying' stamp: 'yo 6/23/2003 20:05' prior: 20222011!
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: 'private' stamp: 'nk 6/25/2003 12:51' prior: 20224388!
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 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."! !

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

!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' prior: 20241494!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self useRoundedCorners! !

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

	^true! !

!DoItEvent methodsFor: 'printing' stamp: 'rw 7/14/2003 10:15'!
printEventKindOn: aStream

	aStream nextPutAll: 'DoIt'! !

!DoItEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 11:29'!
context

	^context! !

!DoItEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 11:29'!
context: aContext

	context := aContext! !

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

!DocLibrary methodsFor: 'doc pane' stamp: 'mir 6/26/2001 12:08'!
docObjectAt: classAndMethod
	"Return a morphic object that is the documentation pane for this method.  nil if none can be found.  Look on both the network and the disk."

	| fileNames server aUrl strm local obj |
	methodVersions size = 0 ifTrue: [self updateMethodVersions].	"first time"
	fileNames _ self docNamesAt: classAndMethod.
	self assureCacheFolder.
	self haveNetwork ifTrue: [
		"server _ (ServerDirectory serverInGroupNamed: group) clone."  "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up"
		server _ ServerDirectory serverInGroupNamed: group.
			"later try multiple servers"
		aUrl _ server altUrl, 'docpane/'.
		fileNames do: [:aVersion | 
			strm _ HTTPSocket httpGetNoError: aUrl,aVersion 
				args: nil accept: 'application/octet-stream'.
			strm class == RWBinaryOrTextStream ifTrue: [
				self cache: strm as: aVersion.
				strm reset.
				obj _ strm fileInObjectAndCode asMorph.
				(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
					self inform: 'suspicious object'.
					obj setProperty: #classAndMethod toValue: classAndMethod].
				^ obj].	"The pasteUpMorph itself"
			"If file not there, error 404, just keep going"]].
	local _ ServerDirectory new fullPath: DocsCachePath.
	"check that it is really there -- let user respecify"
	fileNames do: [:aVersion | 
		(local includesKey: aVersion) ifTrue: [
			strm _ local readOnlyFileNamed: aVersion.
			obj _ strm fileInObjectAndCode asMorph.
			(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
				self inform: 'suspicious object'.
				obj setProperty: #classAndMethod toValue: classAndMethod].
			Transcript cr; show: 'local cache: ', aVersion.
			^ obj].	"The pasteUpMorph itself"
		"If file not there, just keep looking"].
	"Never been documented"
	^ nil! !

!DocLibrary methodsFor: 'doc pane' stamp: 'mir 11/14/2002 19:37' prior: 35661872!
docObjectAt: classAndMethod
	"Return a morphic object that is the documentation pane for this method.  nil if none can be found.  Look on both the network and the disk."

	| fileNames server aUrl strm local obj |
	methodVersions size = 0 ifTrue: [self updateMethodVersions].	"first time"
	fileNames _ self docNamesAt: classAndMethod.
	self assureCacheFolder.
	"server _ (ServerDirectory serverInGroupNamed: group) clone."  "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up"
	server _ ServerDirectory serverInGroupNamed: group.
		"later try multiple servers"
	aUrl _ server altUrl, 'docpane/'.
	fileNames do: [:aVersion | 
		strm _ HTTPSocket httpGetNoError: aUrl,aVersion 
			args: nil accept: 'application/octet-stream'.
		strm class == RWBinaryOrTextStream ifTrue: [
			self cache: strm as: aVersion.
			strm reset.
			obj _ strm fileInObjectAndCode asMorph.
			(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
				self inform: 'suspicious object'.
				obj setProperty: #classAndMethod toValue: classAndMethod].
			^ obj].	"The pasteUpMorph itself"
		"If file not there, error 404, just keep going"].
	local _ ServerDirectory new fullPath: DocsCachePath.
	"check that it is really there -- let user respecify"
	fileNames do: [:aVersion | 
		(local includesKey: aVersion) ifTrue: [
			strm _ local readOnlyFileNamed: aVersion.
			obj _ strm fileInObjectAndCode asMorph.
			(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
				self inform: 'suspicious object'.
				obj setProperty: #classAndMethod toValue: classAndMethod].
			Transcript cr; show: 'local cache: ', aVersion.
			^ obj].	"The pasteUpMorph itself"
		"If file not there, just keep looking"].
	"Never been documented"
	^ nil! !

!DocLibrary methodsFor: 'doc pane' stamp: 'di 4/5/2001 21:38'!
saveDocCheck: aMorph
	"Make sure the document gets attached to the version of the code that the user was looking at.  Is there a version of this method in a changeSet beyond the updates we know about?  Works even when the user has internal update numbers and the documentation is for external updates (It always is)."

	| classAndMethod parts selector class lastUp beyond ours docFor unNum ok key verList ext response |
	classAndMethod _ aMorph valueOfProperty: #classAndMethod.
	classAndMethod ifNil: [
		^ self error: 'need to know the class and method'].	"later let user set it"
	parts _ classAndMethod findTokens: ' .'.
	selector _ parts last asSymbol.
	class _ Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph].
	parts size = 3 ifTrue: [class _ class class].
	"Four indexes we are looking for:
		docFor = highest numbered below lastUpdate that has method.
		unNum = a higher unnumbered set that has method.
		lastUp = lastUpdate we know about in methodVersions
		beyond = any set about lastUp that has the method."
	ChangeSorter allChangeSets doWithIndex: [:cs :ind | "youngest first"
		(cs name includesSubString: lastUpdateName) ifTrue: [lastUp _ ind].
		(cs atSelector: selector class: class) ~~ #none ifTrue: [
			lastUp ifNotNil: [beyond _ ind. ours _ cs name]
				ifNil: [cs name first isDigit ifTrue: [docFor _ ind] 
						ifFalse: [unNum _ ind. ours _ cs name]]]].
	"See if version the user sees is the version he is documenting"
	ok _ beyond == nil.
	unNum ifNotNil: [docFor ifNotNil: [ok _ docFor > unNum]
						ifNil: [ok _ false]].  "old changeSets gone"
	ok ifTrue: [^ self saveDoc: aMorph].

	key _ DocLibrary properStemFor: classAndMethod.
	verList _ (methodVersions at: key ifAbsent: [#()]), #(0 0).
	ext _ verList first.	"external update number we will write to"
	response _ (PopUpMenu labels: 'Cancel\Broadcast Page' withCRs)
				startUpWithCaption: 'You are documenting a method in External Update ', ext asString, '.\There is a more recent version of that method in ' withCRs, ours, 
'.\If you are explaining the newer version, please Cancel.\Wait until that version appears in an External Update.' withCRs.
	response = 2 ifTrue: [self saveDoc: aMorph].
! !

!DocLibrary methodsFor: 'database of updates' stamp: 'mir 6/26/2001 12:07'!
absorbAfter: oldVersion from: fileName
	"Read the .ix file and add to the methodVersions database.  See class comment."

	| server aUrl strm newUpdate newName prevFile classAndMethod updateID key verList new |
	server _ ServerDirectory serverInGroupNamed: group.
		"later try multiple servers"
	aUrl _ server altUrl, 'docpane/', fileName.
	strm _ HTTPSocket httpGetNoError: aUrl
		args: nil accept: 'application/octet-stream'.
	strm class == RWBinaryOrTextStream ifFalse: [^ false].

	(strm upTo: $ ) = 'External' ifFalse: [strm close. ^ false].
	newUpdate _ Integer readFrom: strm.
	newUpdate = oldVersion ifTrue: [strm close. ^ false].		"already have it"
 	strm upTo: $'.
	newName _ strm nextDelimited: $'.  strm upTo: Character cr.
	prevFile _ strm upTo: Character cr.
	"does this report on updates just after what I know?"
	oldVersion = (prevFile splitInteger first) ifFalse: [
		strm close. ^ prevFile].	"see earlier sucessor file"
	[strm atEnd] whileFalse: [
		strm upTo: $'.
		classAndMethod _ strm nextDelimited: $'.  strm next.
		updateID _ Integer readFrom: strm.
		key _ DocLibrary properStemFor: classAndMethod.
		verList _ methodVersions at: key ifAbsent: [#()].
		(verList includes: updateID) ifFalse: [
			new _ verList, (Array with: updateID with: -1 "file date seen").
			methodVersions at: key put: new]].
	strm close.
	lastUpdate _ newUpdate.
	lastUpdateName _ newName.
	^ true! !

!DocLibrary methodsFor: 'database of updates' stamp: 'mir 11/14/2002 19:38' prior: 20264292!
updateMethodVersions
	"See if any new updates have occurred, and put their methods into the database."

	| indexFile list result |
	indexFile _ 'latest.ix'.
	list _ OrderedCollection new.
	[result _ self absorbAfter: lastUpdate from: indexFile.
	"boolean if succeeded, or we are up to date, or server not available"
	result class == String] whileTrue: [
		"result is the prev file name"
		list addFirst: indexFile.
		indexFile _ result].
	list do: [:aFile | self absorbAfter: lastUpdate from: aFile].
		"should always work this time"
! !

!DocLibrary methodsFor: 'database of updates' stamp: 'yo 7/16/2003 15:53' prior: 35669384!
updateMethodVersions
	"See if any new updates have occurred, and put their methods into the database."

	| indexFile list result |
	indexFile _ 'latest.ix'.
	list _ OrderedCollection new.
	[result _ self absorbAfter: lastUpdate from: indexFile.
	"boolean if succeeded, or we are up to date, or server not available"
	 result isString] whileTrue: [
		"result is the prev file name"
		list addFirst: indexFile.
		indexFile _ result].
	list do: [:aFile | self absorbAfter: lastUpdate from: aFile].
		"should always work this time"
! !

!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: 'nk 12/13/2002 10:05'!
relativeNameFor: path
	"Return the full name for path, assuming that path is a name relative to me."
	path isEmpty ifTrue:[^pathName].
	(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, self slash, path! !

!DosFileDirectory methodsFor: 'path access' stamp: 'nk 12/13/2002 10:05' prior: 35671306!
relativeNameFor: path
	"Return the full name for path, assuming that path is a name relative to me."
	path isEmpty ifTrue:[^pathName].
	(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, self slash, path! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 03:46' prior: 20268251!
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: 'ar 3/6/2004 04:14' prior: 20268744!
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! !

!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: 'ar 3/6/2004 04:14'!
testFileDirectoryNonExistence
	"Hoping that you have 'C:' of course..."
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	self should: [(FileDirectory basicNew fileOrDirectoryExists: 'C:')] raise: InvalidDirectoryError.! !

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

!DoubleClickExample methodsFor: 'accessing' stamp: 'dgd 8/31/2003 18:37' prior: 20269843!
balloonText
	^ 'Double-click on me to change my color; 
single-click on me to change border color;
hold mouse down within me to grow 
(if I''m red) or shrink (if I''m blue).' translated! !

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

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

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

!DualChangeSorter methodsFor: 'initialization' stamp: 'sd 5/23/2003 14:38' prior: 20285913!
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: 'sd 5/23/2003 14:38' prior: 20286635!
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: 'other' stamp: 'sw 3/30/2001 16:16'!
labelString
	"The window label"

	| leftName rightName changesName |
	leftName _ leftCngSorter changeSetCategory categoryName.
	rightName _ rightCngSorter changeSetCategory categoryName.
	changesName _ 'Changes go to "', Smalltalk changes name,  '"'.
	^ ((leftName ~~ #All) or: [rightName ~~ #All])
		ifTrue:
			['(', leftName, ') - ', changesName, ' - (', rightName, ')']
		ifFalse:
			[changesName]! !

!DualChangeSorter methodsFor: 'other' stamp: 'sd 5/23/2003 14:38' prior: 35681558!
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 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.'! !

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

!DummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:48'!
callingAnotherMethod! !

!DummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:48'!
zoulouSymbol

	self callingAnotherMethod! !

!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 2/23/2004 19:18'!
playSoundNamedOrBeep: soundName
	"There is no sound support, so we make the beep."
	
	^self beep! !

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

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

!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 commentStamp: '<historical>' prior: 0!
I represent a duration of time. I have nanosecond precision
!
!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: 'brp 7/27/2003 15:02'!
seconds: aNumber

	^ self days: 0 hours: 0 minutes: 0 seconds: aNumber nanoSeconds: 0! !

!Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:05' prior: 35694185!
seconds: aNumber

	^ (self basicNew) seconds: aNumber nanoSeconds: 0; yourself.
! !

!Duration class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:03'!
zero

	^ self days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0! !

!Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:06' prior: 35694525!
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
! !

!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: '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: '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).	! !

!Dutch methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:27'!
name
	"answer the receiver's name"
	^ #'Nederlands'! !

!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 12/1/2003 22:21'!
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 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}"
! !

!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 11/30/2003 19:32'!
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 hex 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 7/31/2003 12:16'!
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"
	}.

	^ basics, etc.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 7/31/2003 18:20'!
readCharactersInRanges: ranges storeInto: chars

	| array form code rangeStream currentRange |
	rangeStream _ ReadStream on: ranges.
	currentRange _ rangeStream next.
	[true] whileTrue: [
		array _ self readOneCharacter.
		code _ array at: 2.
		"code = 16r3000 ifTrue: [self halt]."
		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 12/1/2003 23:11'!
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}"
! !

!EPSCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53' prior: 20300653!
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' prior: 20301286!
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 methodsFor: 'configuring' stamp: 'nk 1/1/2004 20:22' prior: 20301896!
baseOffset
	^0@0.! !

!EPSCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'!
defaultExtension
	^'.eps'! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 12/17/2001 02:18'!
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: 'ar 12/17/2001 02:18'!
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: '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: 'dgd 2/14/2003 19:36' prior: 20304606!
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 methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:50'!
descriptionForPartsBin

	^ self partName: 	'Text chat'
		categories:		#('Collaborative')
		documentation:	'A tool for sending messages to other Squeak uers'! !

!EToyCommunicatorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:32' prior: 20315634!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self vResizing: #shrinkWrap;
	 hResizing: #shrinkWrap.
	resultQueue _ SharedQueue new.
	fields _ Dictionary new.
	self useRoundedCorners! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 20321155!
playArrivalSound

	Preferences soundsEnabled ifTrue: [
		SampledSound playSoundNamed: 'chirp'.
	] ifFalse: [
		Beeper beep
	].! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 21:07' prior: 35725222!
playArrivalSound
	"Make a sound that something has arrived."

	SoundService default playSoundNamedOrBeep: 'chirp'! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/25/2001 17:40'!
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: 'nb 6/17/2003 12:25' prior: 20327888!
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: '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: 'dgd 2/17/2003 19:58' prior: 20324029!
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: 'RAA 3/7/2001 22:31'!
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 class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:50'!
descriptionForPartsBin

	^ self partName: 	'Fridge'
		categories:		#('Collaborative')
		documentation:	'A tool for sending objects to other Squeak uers'! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:42'!
acceptableTypes

	^acceptableTypes! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:11'!
dateAndTimeStringFrom: totalSeconds

	| dateAndTime |
	dateAndTime _ Time dateAndTimeFromSeconds: totalSeconds.
	^dateAndTime first printString,' ',dateAndTime second printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:51'!
fullInfoString

	^self latestUserName,
		' at ',
		ipAddress ,
		' attempts: ',
		accessAttempts printString,
		'/',
		attempsDenied printString,
		' last: ',
		(self lastIncomingMessageTimeString)
	 
"acceptableTypes"

 ! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 12:19'!
getChoice: aString

	^acceptableTypes includes: aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:33'!
ipAddress

	^ipAddress! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:18'!
ipAddress: aString

	ipAddress _ aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:37'!
lastIncomingMessageTimeString

	lastRequests isEmpty ifTrue: [^'never'].
	^self dateAndTimeStringFrom: lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:56'!
lastTimeChecked

	^self valueOfProperty: #lastTimeChecked
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:57'!
lastTimeChecked: aDateAndTimeInSeconds

	self setProperty: #lastTimeChecked toValue: aDateAndTimeInSeconds
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:22'!
lastTimeCheckedString

	| statusTime |
	statusTime _ self valueOfProperty: #lastTimeChecked ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime)! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:49'!
latestUserName

	^latestUserName ifNil: ['???']! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:46'!
latestUserName: aString

	latestUserName _ aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:09'!
requestAccessOfType: aString

	| ok |

	accessAttempts _ accessAttempts + 1.
	lastRequests addFirst: {Time totalSeconds. aString}.
	lastRequests size > 10 ifTrue: [
		lastRequests _ lastRequests copyFrom: 1 to: 10.
	].
	ok _ (acceptableTypes includes: aString) or: [acceptableTypes includes: 'all'].
	ok ifFalse: [attempsDenied _ attempsDenied + 1].
	^ok! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:10'!
statusReplyReceived: anArray

	self setProperty: #lastStatusReplyTime toValue: Time totalSeconds.
	self setProperty: #lastStatusReply toValue: anArray.! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 14:16'!
statusReplyReceivedString

	| statusTime |
	statusTime _ self valueOfProperty: #lastStatusReplyTime ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime),' accepts:
', (self valueOfProperty: #lastStatusReply) asArray printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:38'!
timeBetweenLastAccessAnd: currentTime

	lastRequests isEmpty ifTrue: [^0].
	^currentTime - lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:39'!
toggleChoice: aString

	(acceptableTypes includes: aString) ifTrue: [
		acceptableTypes remove: aString ifAbsent: []
	] ifFalse: [
		acceptableTypes add: aString
	].! !

!EToyGateKeeperEntry methodsFor: 'initialization' stamp: 'RAA 8/4/2000 11:49'!
initialize

	self flag: #bob.		"need to decide better initial types"

	super initialize.
	ipAddress _ '???'.
	accessAttempts _ attempsDenied _ 0.
	lastRequests _ OrderedCollection new.
	acceptableTypes _ Set withAll: EToyIncomingMessage allTypes.

 ! !

!EToyGateKeeperEntry class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !

!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' prior: 20335258!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 useRoundedCorners;
		 rebuild ! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 11:57'!
entryForIPAddress: ipAddressString

	| known entry |

	UpdateCounter _ self updateCounter + 1.
	known _ self knownIPAddresses.
	entry _ known at: ipAddressString ifAbsentPut: [
		entry _ EToyGateKeeperEntry new.
		entry ipAddress: ipAddressString.
		entry
	].
	^entry! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/6/2001 14:10'!
genericTextFieldNamed: aString

	| newField |

	newField _ ShowEmptyTextMorph new
		beAllFont: self myFont;
		extent: 300@20;
		contentsWrapped: ''.
	namedFields at: aString put: newField.
	^newField
! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 7/12/2003 12:33' prior: 35734539!
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 7/12/2003 12:29' prior: 20338739!
myFont
	^ Preferences standardEToysFont! !

!EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:54' prior: 20338375!
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! !

!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' prior: 20342700!
initialize
	"initialize the state of the receiver"
	super initialize.
	self useRoundedCorners! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 17:57'!
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' prior: 20353318!
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: 'RAA 5/1/2002 17:58'!
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: 'RAA 5/1/2002 19:28'!
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: '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' prior: 20353056!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 rebuild ! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 19:29'!
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: 'sw 7/3/2001 21:54'!
stopListening
	GlobalListener ifNotNil:
		[GlobalListener stopListening.
		GlobalListener _ nil.
		self bumpUpdateCounter]

	"EToyListenerMorph stopListening"! !

!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: 'RAA 8/20/2001 12:51'!
descriptionForPartsBin

	^ self partName: 	'Listener'
		categories:		#('Collaborative')
		documentation:	'A tool for receiving things from other Squeak uers'! !

!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: 'RAA 8/20/2001 13:00'!
initialize

	| earMorph |
	super initialize.
	color _ Color yellow.
	self layoutInset: 8@8.
	"earMorph _ (EToyListenerMorph makeListeningToggle: true) asMorph."

	earMorph _ TextMorph new
		contents: 'Morphs
welcome
here';
		fontName: #ComicBold size: 18;
		centered;
		lock.
	self addARow: {earMorph}.
	self setBalloonText: 
			'My presence in this world means received morphs may appear automatically'.
! !

!EToyMorphsWelcomeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:27' prior: 35741270!
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: #ComicBold size: 18;
				 centered;
				 lock.
	self addARow: {earMorph}.
	self setBalloonText: 'My presence in this world means received morphs may appear automatically'! !

!EToyMorphsWelcomeMorph methodsFor: 'initialization' stamp: 'nk 7/12/2003 08:58' prior: 35741779!
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 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'! !

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

!EToyPeerToPeer methodsFor: 'sending' stamp: 'mir 5/15/2003 18:29' prior: 20366966!
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: 'receiving' stamp: 'mir 5/15/2003 15:40' prior: 20370801!
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

! !

!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: 'jm 9/2/2003 19:39' prior: 20375674!
rebuild

	| bottomButtons |
	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Please describe this project' translated.
	}.
	self addARow: {
		self lockedString: 'Name:' translated.
		self inAColumnForText: {self fieldForProjectName}
	}.
	self expandedFormat ifTrue: [
		self fieldToDetailsMappings do: [ :each |
			self addARow: {
				self lockedString: each third translated.
				self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
			}.
		].
	].
	bottomButtons _ self expandedFormat ifTrue: [
		{
			self okButton.
			self cancelButton.
		}
	] ifFalse: [
		{
			self okButton.
			self expandButton.
			self cancelButton.
		}
	].
	self addARow: bottomButtons.
	self fillInDetails.! !

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'mir 6/19/2001 10:17'!
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;
		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! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 20380429!
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: 'jcg 7/20/2001 18:08'!
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...'; lock.
		}.
	}.
	r1 on: #mouseUp send: #jumpToProject to: self.

	history do: [ :each |
		(
			self addARow: {
				(self inAColumn: {
					StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock
				}) vResizing: #spaceFill.
				self inAColumn: {
					StringMorph new contents: each first; lock.
					"StringMorph new contents: each third; lock."
				}.
			}
		)
			color: Color paleYellow;
			borderWidth: 1;
			borderColor: #raised;
			vResizing: #spaceFill;
			on: #mouseUp send: #mouseUp:in: to: self;
			on: #mouseDown send: #mouseDown:in: to: self;
			on: #mouseMove send: #mouseMove:in: to: self;
			on: #mouseLeave send: #mouseLeave:in: to: self;
			setProperty: #projectParametersTuple toValue: each;
			setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third])
	].
"---
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
---"! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'dgd 9/20/2003 18:52' prior: 35751273!
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' prior: 20378655!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 useRoundedCorners;
		 rebuild ! !

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

!EToyProjectQueryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self color darker! !

!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 methodsFor: 'as yet unclassified' stamp: 'mir 11/14/2001 16:29'!
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;
		openCenteredInWorld! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/2/2003 19:39' prior: 20384969!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString translated font: self myFont;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString translated.
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!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: 'ar 8/23/2001 21:33'!
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:

 : < > | / \ ? * " .'.
	^tm
	
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'ar 2/23/2001 20:53'!
validateTheProjectName

	| proposed |

	proposed _ (namedFields at: 'projectname') contents string withBlanksTrimmed.
	proposed size = 0 ifTrue: [
		self inform: 'I do need a name for the project'.
		^false
	].
	proposed size > 24 ifTrue: [
		self inform: 'Please make the name 24 characters or less'.
		^false
	].
	(Project isBadNameForStoring: proposed) ifTrue: [
		self inform: 'Please remove any funny characters from the name'.
		^false
	].
	proposed = theProject name ifTrue: [^true].
	(ChangeSorter changeSetNamed: proposed) ifNotNil: [
		Utilities inform: 'Sorry that name is already used'.
		^false
	].
	^true! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:58' prior: 35756941!
validateTheProjectName
	| proposed |
	proposed := (namedFields at: 'projectname') contents string 
				withBlanksTrimmed.
	proposed isEmpty 
		ifTrue: 
			[self inform: 'I do need a name for the project'.
			^false].
	proposed size > 24 
		ifTrue: 
			[self inform: 'Please make the name 24 characters or less'.
			^false].
	(Project isBadNameForStoring: proposed) 
		ifTrue: 
			[self inform: 'Please remove any funny characters from the name'.
			^false].
	proposed = theProject name ifTrue: [^true].
	(ChangeSorter changeSetNamed: proposed) ifNotNil: 
			[Utilities inform: 'Sorry that name is already used'.
			^false].
	^true! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 18:53' prior: 35757669!
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 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ color darker! !

!EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 8! !

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

!EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:54' prior: 20386224!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self vResizing: #shrinkWrap;
	  hResizing: #shrinkWrap;
	  layoutInset: 4;
	  useRoundedCorners;
	  rebuild! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 10:22'!
startAudioChat: toggleMode

	| chat r |

	(self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [
		toggleMode ifFalse: [^self].
		^self killExistingChat
	].
	(self ownerThatIsA: EToyFridgeMorph) isNil ifTrue: [
		chat _ AudioChatGUI new ipAddress: self ipAddress.
		chat
			removeConnectButton;		"we already know the connectee"
			vResizing: #shrinkWrap;
			hResizing: #shrinkWrap;
			borderWidth: 2.
		r _ (self addARow: {chat}) vResizing: #shrinkWrap.
		self world startSteppingSubmorphsOf: chat.
		self setProperty: #embeddedAudioChatHolder toValue: r.
		self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	] ifFalse: [
		chat _ AudioChatGUI new ipAddress: self ipAddress.
		chat openInWorld: self world.
	]
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'aoy 2/15/2003 20:59' prior: 35759970!
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 8/20/2001 13:03'!
userName

	^ (self 
		findDeepSubmorphThat: [ :x | x isKindOf: StringMorph] 
		ifAbsent: [^nil]) contents
! !

!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' prior: 20392010!
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: 'RAA 3/7/2001 22:31'!
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 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)! !

!EToySystem class methodsFor: 'development support' stamp: 'sd 5/11/2003 22:13' prior: 20403308!
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' prior: 20403667!
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:)
		)! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 20411135!
addSibling

	parentWrapper ifNil: [^Beeper beep].
	parentWrapper addNewChildAfter: item.! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 20411622!
delete

	parentWrapper ifNil: [^Beeper beep].
	parentWrapper withoutListWrapper removeChild: item withoutListWrapper.
! !

!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: 'sw 9/25/2001 21:20'!
initialize
	"Initialize the vocabulary"

	super initialize.
	self addFromTable: self eToyVectorTable language: #English.
	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 9/13/2001 17:26'!
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"

	| likelyReply |
	likelyReply _ super allMethodsInCategory: aCategorySymbol forInstance: anObject ofClass: aClass.
	^ ((anObject isKindOf: Player) and:
		[aCategorySymbol == #vector])
			ifFalse:
				[likelyReply]
			ifTrue:
				[anObject costume class vectorAdditions collect:
					[:anAddition | (self methodInterfaceFrom: anAddition) selector]]! !

!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.!
!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 9/13/2001 12:39'!
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 morphClassesDeclaringViewerAdditions.
	classes do:
		[:aMorphClass | categorySymbols addAll: aMorphClass basicNew categoriesForViewer].
	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: #deffered.
						"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].

	#(scripts #'instance variables') do: [:sym | self addCategoryNamed: sym].
	self setCategoryDocumentationStrings.

	self addToTranslationTableFrom: #(
(:						'_'						'assign value')
(Incr:					'increase by'			'increase value by')
(Decr:					'decrease by'			'decrease value by')
(Mult:					'multiply by'			'multiply value by')) language: #English
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 2/6/2003 18:00' prior: 35794713!
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 morphClassesDeclaringViewerAdditions.
	classes do:
		[:aMorphClass | categorySymbols addAll: aMorphClass basicNew categoriesForViewer].
	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: #deffered.
						"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 addToTranslationTableFrom: #(
(:						'_'						'assign value')
(Incr:					'increase by'			'increase value by')
(Decr:					'decrease by'			'decrease value by')
(Mult:					'multiply by'			'multiply value by')) language: #English
! !

!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: 'nk 8/19/2002 11:30'!
morphClassesDeclaringViewerAdditions
	"Answer a list of actual morph classes implementing #additionsToViewerCategories"

	| survivors |

	survivors _ OrderedCollection new.
	(Smalltalk allImplementorsOf: #additionsToViewerCategories) do: [ :aMarker |
		(aMarker actualClass isMeta and: [ (aMarker actualClass soleInstance isKindOf: Morph class)]) ifTrue: [
			survivors add: aMarker actualClass soleInstance
		]
	].
	^ survivors
"EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sd 4/19/2003 12:16' prior: 35799073!
morphClassesDeclaringViewerAdditions
	"Answer a list of actual morph classes implementing 
	#additionsToViewerCategories "
	| survivors |
	survivors _ OrderedCollection new.
	(SystemNavigation new allImplementorsOf: #additionsToViewerCategories)
		do: [:aMarker | (aMarker actualClass isMeta
					and: [aMarker actualClass soleInstance isKindOf: Morph class])
				ifTrue: [survivors add: aMarker actualClass soleInstance]].
	^ survivors"EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'dvf 8/23/2003 11:52' prior: 35799659!
morphClassesDeclaringViewerAdditions
	"Answer a list of actual morph classes implementing 
	#additionsToViewerCategories "

	| survivors |
	survivors := OrderedCollection new.
	(self systemNavigation allImplementorsOf: #additionsToViewerCategories) 
		do: 
			[:aMarker | 
			(aMarker actualClass isMeta 
				and: [aMarker actualClass soleInstance isKindOf: Morph class]) 
					ifTrue: [survivors add: aMarker actualClass soleInstance]].
	^survivors	"EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! !

!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: 'sw 10/29/2001 05:26'!
setCategoryDocumentationStrings
	"Initialize the documentation strings associated with the old etoy categories, in English"

	self translateCategories: #(
(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')
(#'instance variables'	'instance variables'		'instance 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')
 ) language: #English
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 2/26/2003 23:08' prior: 35801199!
setCategoryDocumentationStrings
	"Initialize the documentation strings associated with the old etoy categories, in English"

	self translateCategories: #(
(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')
 ) language: #English
! !

!EToyVocabulary methodsFor: 'category list' stamp: 'sw 9/10/2001 08:50'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in aClass and lower"

	^ (anObject isKindOf: Player)
		ifTrue:
			[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:
					[#(scripts #'instance variables')])]
		ifFalse:
			[super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass]! !

!EToyVocabulary methodsFor: 'category list' stamp: 'sw 4/15/2003 23:49' prior: 35805111!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in aClass and lower"

	^ (anObject isKindOf: Player)
		ifTrue:
			[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: 'method list' stamp: 'sw 9/13/2001 17:27'!
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 == #scripts ifTrue:
			[^ aClass namedTileScriptSelectors].
		aCategoryName == #'instance variables' 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 4/15/2003 23:42' prior: 35806968!
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 9/17/2002 13:57'!
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  getHeading getScaleFactor

		getLeft getRight getTop getBottom  
		getLength getWidth 
		getTheta getDistance getHeadingTheta

		startScript: pauseScript: stopScript: startAll: pauseAll: stopAll: tellAllSiblings: doScript:

		getColor getUseGradientFill getSecondColor  getRadialGradientFill  getBorderWidth getBorderColor getBorderStyle getRoundedCorners getDropShadow getShadowColor 

		getGraphic getBaseGraphic)! !

!EToyVocabulary methodsFor: 'method list' stamp: 'sw 2/3/2002 23:26'!
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:)]
		ifFalse:
			[#()]! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'CdG 4/16/2002 10:17'!
addDutchVocabulary
	"Add a Dutch etoy vocabulary

		EToyVocabulary assureTranslationsAvailableFor: #Nederlands
     "
	self translateMethodInterfaceWordings: #(

(append:					'voeg toe'				'Voegt een objekt aan deze houder toe')
(prepend:					'voeg in'				'Voegt een objekt aan het begin van deze houder toe')
(beep:						'maak geluid'  				'Maak het aangegeven geluid')
(bounce:					'stuiter weg'					'Laat het objekt van de rand wegstuiteren en speel het aangegeven geluid wanneer dit gebeurt')
(cameraPoint 				'camerastandpunt'				'Het camerastandpunt van het objekt') 
(clear 						'wis grafiek'						'Wist de huidige grafiek')
(clearOwnersPenTrails		'wis pensporen in eigenaar'	'Wist alle pennesporen in de eigenaar')
(clearTurtleTrails 			'wis pensporen' 		'Wist alle pennesporen in het object')
(color:sees: 					'kleur ziet'			'Test of de aangegeven kleur van het objekt de andere kleur kan zien')
(deleteCard 					'wis kaart'				'Wist deze kaar uit de stapel')
(doMenuItem: 				'voer menu-item uit'	'Voert het aangegeven menupunt uit')
(emptyScript 				'leeg script'				'Een leeg script')
(fire						'vuur'						'Vuurt alle acties die bij deze knop horen af')
(firstPage 					'ga naar eerste pagina'		'Ga naar eerste pagina')
(followPath					'volg pad'					'Volg het gedefineerde pad')
(forward: 					'ga vooruit met'		'Beweegt het objekt vooruit in de huidige richting')
(goToFirstCardInBackground	'ga naar eerste kaart in achtergrond'	'Gaat naar de eerste kaart in de huidige achtergrond')
(goToFirstCardOfStack		'ga naar eerste kaart op stapel'	'Gaat naar de eerste kaart op de stapel')
(goToLastCardInBackground	'ga naar laatste kaart in achtergrond'	'Gaat naar de laatste kaart in de huidige achtergrond')
(goToLastCardOfStack		'ga naar laatste kaart op stapel'		'Gaat naar de laatste kaart op de stapel')
(goToNextCardInStack		'ga naar volgende kaart op stapel'		'Gaat naar de volgende kaart op de stapel')
(goToPreviousCardInStack	'ga naar vorige kaart op stapel'	'Gaat naar de vorige kaart op de stapel')
(goToRightOf:				'plaats rechts van'		'Zet het object rechts naast een ander object neer')
(goto:						'ga naar pagina'		'Gaat naar de aangegeven pagina')
(hide					'verstop je'					'Verstopt het object')
(initiatePainting			'begin met nieuwe tekening'		'Start met een nieuwe tekening')
(insertCard				'maak kaart aan'				'Maakt een nieuwe kaart aan en voegt deze in')
(lastPage				'laatste pagina'			'Gaat naar de laatste pagina')
(liftAllPens				'pak alle pennen op'			'Pakt alle pennen op die zich in het binnenste bevinden')
(loadSineWave			'laad sinusgolf'			'Laadt een sinusgolf als de huidige grafiek')
(loadSound:				'laad geluid'					'Laadt een bepaald geluid als de huidige grafiek')
(lowerAllPens			'zet alle pennen neer'			'Zet alle pennen neer die zich in het binnenste bevinden')
(makeNewDrawingIn:	'start nieuwe tekening in'	'Begint een nieuwe tekening in het aangegeven objekt')
(moveToward:			'ga in richting '				'Beweegt het objekt in de richting van het andere objekt')
(nextPage				'ga naar volgende pagina'		'Gaat naar de volgende pagina')
(pauseScript:			'stop script'					'Stopt het uitvoeren van een script')
(play					'speel geluid af'				'Speelt de huidige grafiek als geluid af')
(previousPage			'ga naar vorige pagina' 	'Gaat naar de vorige pagina')
(removeAll				'verwijder alles'				'Verwijdert en wist alle elementen')
(reverse				'omdraaien'						'Draait de inhoud van de grafiek om')
(roundUpStrays			'haal terug'					'Haalt alle objekten terug, als ze zich ergens verstoppen')
(seesColor:				'ziet de kleur'					'Test, of het objekt de aangegeven kleur ziet')
(show					'toon jezelf'						'Toont het objekt')
(shuffleContents			'mix inhoud'					'Mixt alle objekten in een willekeurige volgorde')
(stampAndErase			'stempel en verwijder je'		'Voegt de afbeelding van het objekt aan het pennespoor toe en verwijdert het vervolgens.')
(startScript:				'start script'					'Begint met het uitvoeren van een script')
(stopScript:				'stop script'					'Stopt met het uitvoeren van een script')
(tellAllSiblings:			'zeg tegen alle broers en zussen'		'Stuurt een bericht aan alle broers/zussen van het objekt')
(touchesA:				'raakt aan'					'Test, of een objekt van het aangegeven type aangeraakt wordt')
(turn:					'draai je'				'Verandert de richting van het objekt met het aangegeven aantal graden')
(unhideHiddenObjects	'toon verstopte objekten' 		'Laat alle verstopte objekten zien')
(wearCostumeOf: 		'draag kostuum van'				'Laat het kostuum van het aangegeven objekt zien')
(wrap					'wikkel je om'				'Wikkelt het objekt om de rand van zijn houder')

(getActWhen 			'Uitvoeringsstatus'	'Bepaalt wanneer het script uitgevoerd wordt')
(getAllButFirstCharacter	'Alle tekens behalve de eerste' 'Bevat alle tekens behalve het eerste teken')
(getAmount				'grootte'					'De grootte van de afwijking ten op zichte van het centrum')
(getAngle				'hoek'					'De hoek van de afwijking ten op zichte van het centrum')
(getBorderColor			'randkleur'		'De kleur van de rand')
(getBorderWidth			'randbreedte'		'De breedte van de rand')
(getBottom 				'onderkant'					'De onderkant van het objekt')
(getBrightnessUnder		'helderheid onder'			'De helderheid onder het midden van het objekt')
(getCharacters			'tekens'					'De tekens van de inhoud')
(getColor				'kleur' 					'De kleur van het objekt')
(getColorUnder 			'kleur eronder'			'De kleur onder het midden van het objekt')
(getConePosition			'Conuspositie'			'De positie van de conus van de luidspreker')
(getCursor				'Cursor'					'De huidige tekenaanwijzing')
(getDescending			'afdalend'				'Bepaalt of de kleinste waarde eerste getoond moet worden')
(getDistance				'afstand'				'De afstand tot de oorsprong van de houder')
(getFirstCharacter		'eerste teken'		'Het eerste teken van de inhoud')
(getFirstElement			'eerste element'			'Het eerste element van de inhoud')
(getFogColor				'nevelkleur'				'De kleur van de nevel')
(getFogDensity			'neveldichtheid'			'De dichtheid van de nevel')
(getFogRangeEnd		'nevelbegin'			'De beginafstand van de nevel')
(getFogRangeStart		'neveleinde'				'De eindafstand van de nevel')
(getFogType				'nevelsoort'				'Het soort nevel')
(getGraphic				'beeld'					'De afbeelding van het objekt')
(getGraphicAtCursor		'beeld bij cursor'			'De afbeelding van het objekt bij de cursor')
(getHeading				'richting'				'De richting waar het objekt in staat')
(getHeight				'hoogte'					'De hoogte van het objekt')
(getHolder				'houder'				'De houder van het objekt')
(getIndexInOwner		'index in eigenaar' 			'De positie van het objekt in zijn eigenaar')
"@@@: Folgendes sollte vermutlich die Hand und nicht die Maus referenzieren :@@@"
(getIsUnderMouse		'is muis erover'		'Test, of de mous op het objekt staat')
"@@@: Sollte vielleicht 'Griff' heissen, aber ich mag Knubbel :-) :@@@"
(getKnobColor			'greepkleur'			'De kleur van de greep')
(getLabel				'opschrift'			'Het opschrift van het objekt')
(getLastValue			'laatste waarde'			'De laatste invoerwaarde')
(getLeft					'linkerkant'			'De linkerkant van het objekt')
(getLeftRight			'links-rechts'			'De horizontale afwijking ten opzichte van het centrum')
(getLuminanceUnder	'lichtsterkte eronder'	'De lichtsterkte onder het objekt')
(getMaxVal				'maximale waarde'			'De maximale waarde van de regelaar')
(getMinVal				'minimale waarde'			'De minimale waarde van de regelaar')
(getMouseX				'muis x-positie'		'De X koordinaat van de muispositie')
(getMouseY				'muis y-positie'		'De Y koordinaat van de muispositie')
(getNewClone			'kopieer je'			'Maakt een kopie van het objekt')
(getNumberAtCursor		'aantal bij cursor'			'Het aantal bij de cursor')
(getNumericValue		'waarde van regelaar'				'De huidige waarde van de regelaar')
(getObtrudes				'steekt uit'			'Test of het object uit zijn houder uitsteekt')
(getPenColor				'penkleur'				'De kleur van de pen')
(getPenDown			'pen neer'				'De status van de pen (op/neer)')
(getPenSize				'pengrootte'			'De doorsnede van de pen')
(getRight				'rechterkant'			'De rechterkant van het objekt')
(getRoundedCorners		'afgeronde hoeken'			'Test of hoeken afgerond moeten worden')
(getSampleAtCursor		'steekproef'				'Een steekproef van de waarde bij de cursor')
(getSaturationUnder		'verzadiging eronder'	'De verzadiging van de kleur onder het objekt')
(getScaleFactor			'schalingsfaktor'		'De schalingsfaktor van het objekt')
(getTheta				'theta'					'De hoek met de X-as')
(getTop					'bovenkant'			'De bovenkant van het objekt')
(getTruncate			'afronden'				'Bepaalt of slechts gehele getallen gebruikt worden')
(getUpDown				'erboven-onder'			'De verticale afwijking ten opzichte van het centrum')
(getValueAtCursor		'objekt bij cursor'		'Het objekt bij de huidige cursorpositie')
(getViewingByIcon 		'symboolweergave'		'Bepaalt of het objekt met zijn symbool moet worden weergegeven')
(getX					'x'						'De X koordinaat van het objekt')
(getY					'y'						'De Y koordinaat van het objekt')
(getWidth				'breedte'					'De breedte van het objekt')) language: #Nederlands.


	self translateCategories: #(
(basic					Simpel					'Standaardzicht')
(#'book navigation'		#'Boeknavigatie'		'Navigatie in boeken')
(button					Knop					'Het objekt als knop')
(collections				Houder				'Het objekt als houder')
(fog					Nevel					'3D Nevel eigenschappen')
(geometry				Geometrie				'Over de geometrief van het objekt')
(#'color & border'		#'Kleur & Rand'			'Over kleuren en randen')
(graphics				Grafisch					'Grafische eigenschappen')
(#'instance variables'	Variabelen				'Variabelen van het objekt')
(joystick				Joystick					'Het objekt als joystick')
(miscellaneous			Overige			'Alles dat nergens anders bij past')
(motion					Beweging				'Bewegingseigenschappen')
(paintbox				Tekenpalet				'Het tekenpalet')
(#'pen trails'			Pennesporen				'Alles over het achterlaten van pennesporen')
(#'pen use'				Pengebruik					'Het gebruik van pennen')
(playfield				Speelveld				'Het speelveld')
(sampling				Meten					'Het meten van waarden')
(scripts					Scripts					'Al je scripts')
(slider					Regelaar					'Het objekt als regelaar')
(speaker				Luidspreker			'Het objekt als luidspreker')
(#'stack navigation'		Stapelnavigatie		'Navigatie in stapels')
(storyboard				Storyboard				'Storyboard')
(tests					Tests					'Verscheidene tests')
(text					Tekst						'Het objekt als tekst')
(viewing				Observatie				'Zoals je het objekt ziet')
(vector					Vector					'Het objekt als vector')
 ) language: #Nederlands "nou ja, nederlands... ;-) - CdG"
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:45' prior: 35811535!
addDutchVocabulary
	"Add a Dutch etoy vocabulary

		EToyVocabulary assureTranslationsAvailableFor: #Nederlands
     "
	self translateMethodInterfaceWordings: #(

(append:					'voeg toe'				'Voegt een objekt aan deze houder toe')
(prepend:					'voeg in'				'Voegt een objekt aan het begin van deze houder toe')
(beep:						'maak geluid'  				'Maak het aangegeven geluid')
(bounce:					'stuiter weg'					'Laat het objekt van de rand wegstuiteren en speel het aangegeven geluid wanneer dit gebeurt')
(cameraPoint 				'camerastandpunt'				'Het camerastandpunt van het objekt') 
(clear 						'wis grafiek'						'Wist de huidige grafiek')
(clearOwnersPenTrails		'wis pensporen in eigenaar'	'Wist alle pennesporen in de eigenaar')
(clearTurtleTrails 			'wis pensporen' 		'Wist alle pennesporen in het object')
(color:sees: 					'kleur ziet'			'Test of de aangegeven kleur van het objekt de andere kleur kan zien')
(deleteCard 					'wis kaart'				'Wist deze kaar uit de stapel')
(doMenuItem: 				'voer menu-item uit'	'Voert het aangegeven menupunt uit')
(emptyScript 				'leeg script'				'Een leeg script')
(fire						'vuur'						'Vuurt alle acties die bij deze knop horen af')
(firstPage 					'ga naar eerste pagina'		'Ga naar eerste pagina')
(followPath					'volg pad'					'Volg het gedefineerde pad')
(forward: 					'ga vooruit met'		'Beweegt het objekt vooruit in de huidige richting')
(goToFirstCardInBackground	'ga naar eerste kaart in achtergrond'	'Gaat naar de eerste kaart in de huidige achtergrond')
(goToFirstCardOfStack		'ga naar eerste kaart op stapel'	'Gaat naar de eerste kaart op de stapel')
(goToLastCardInBackground	'ga naar laatste kaart in achtergrond'	'Gaat naar de laatste kaart in de huidige achtergrond')
(goToLastCardOfStack		'ga naar laatste kaart op stapel'		'Gaat naar de laatste kaart op de stapel')
(goToNextCardInStack		'ga naar volgende kaart op stapel'		'Gaat naar de volgende kaart op de stapel')
(goToPreviousCardInStack	'ga naar vorige kaart op stapel'	'Gaat naar de vorige kaart op de stapel')
(goToRightOf:				'plaats rechts van'		'Zet het object rechts naast een ander object neer')
(goto:						'ga naar pagina'		'Gaat naar de aangegeven pagina')
(hide					'verstop je'					'Verstopt het object')
(initiatePainting			'begin met nieuwe tekening'		'Start met een nieuwe tekening')
(insertCard				'maak kaart aan'				'Maakt een nieuwe kaart aan en voegt deze in')
(lastPage				'laatste pagina'			'Gaat naar de laatste pagina')
(liftAllPens				'pak alle pennen op'			'Pakt alle pennen op die zich in het binnenste bevinden')
(loadSineWave			'laad sinusgolf'			'Laadt een sinusgolf als de huidige grafiek')
(loadSound:				'laad geluid'					'Laadt een bepaald geluid als de huidige grafiek')
(lowerAllPens			'zet alle pennen neer'			'Zet alle pennen neer die zich in het binnenste bevinden')
(makeNewDrawingIn:	'start nieuwe tekening in'	'Begint een nieuwe tekening in het aangegeven objekt')
(moveToward:			'ga in richting '				'Beweegt het objekt in de richting van het andere objekt')
(nextPage				'ga naar volgende pagina'		'Gaat naar de volgende pagina')
(pauseScript:			'stop script'					'Stopt het uitvoeren van een script')
(play					'speel geluid af'				'Speelt de huidige grafiek als geluid af')
(previousPage			'ga naar vorige pagina' 	'Gaat naar de vorige pagina')
(removeAll				'verwijder alles'				'Verwijdert en wist alle elementen')
(reverse				'omdraaien'						'Draait de inhoud van de grafiek om')
(roundUpStrays			'haal terug'					'Haalt alle objekten terug, als ze zich ergens verstoppen')
(seesColor:				'ziet de kleur'					'Test, of het objekt de aangegeven kleur ziet')
(show					'toon jezelf'						'Toont het objekt')
(shuffleContents			'mix inhoud'					'Mixt alle objekten in een willekeurige volgorde')
(stampAndErase			'stempel en verwijder je'		'Voegt de afbeelding van het objekt aan het pennespoor toe en verwijdert het vervolgens.')
(startScript:				'start script'					'Begint met het uitvoeren van een script')
(stopScript:				'stop script'					'Stopt met het uitvoeren van een script')
(tellAllSiblings:			'zeg tegen alle broers en zussen'		'Stuurt een bericht aan alle broers/zussen van het objekt')
(touchesA:				'raakt aan'					'Test, of een objekt van het aangegeven type aangeraakt wordt')
(turn:					'draai je'				'Verandert de richting van het objekt met het aangegeven aantal graden')
(unhideHiddenObjects	'toon verstopte objekten' 		'Laat alle verstopte objekten zien')
(wearCostumeOf: 		'draag kostuum van'				'Laat het kostuum van het aangegeven objekt zien')
(wrap					'wikkel je om'				'Wikkelt het objekt om de rand van zijn houder')

(getActWhen 			'Uitvoeringsstatus'	'Bepaalt wanneer het script uitgevoerd wordt')
(getAllButFirstCharacter	'Alle tekens behalve de eerste' 'Bevat alle tekens behalve het eerste teken')
(getAmount				'grootte'					'De grootte van de afwijking ten op zichte van het centrum')
(getAngle				'hoek'					'De hoek van de afwijking ten op zichte van het centrum')
(getBorderColor			'randkleur'		'De kleur van de rand')
(getBorderWidth			'randbreedte'		'De breedte van de rand')
(getBottom 				'onderkant'					'De onderkant van het objekt')
(getBrightnessUnder		'helderheid onder'			'De helderheid onder het midden van het objekt')
(getCharacters			'tekens'					'De tekens van de inhoud')
(getColor				'kleur' 					'De kleur van het objekt')
(getColorUnder 			'kleur eronder'			'De kleur onder het midden van het objekt')
(getConePosition			'Conuspositie'			'De positie van de conus van de luidspreker')
(getCursor				'Cursor'					'De huidige tekenaanwijzing')
(getDescending			'afdalend'				'Bepaalt of de kleinste waarde eerste getoond moet worden')
(getDistance				'afstand'				'De afstand tot de oorsprong van de houder')
(getFirstCharacter		'eerste teken'		'Het eerste teken van de inhoud')
(getFirstElement			'eerste element'			'Het eerste element van de inhoud')
(getFogColor				'nevelkleur'				'De kleur van de nevel')
(getFogDensity			'neveldichtheid'			'De dichtheid van de nevel')
(getFogRangeEnd		'nevelbegin'			'De beginafstand van de nevel')
(getFogRangeStart		'neveleinde'				'De eindafstand van de nevel')
(getFogType				'nevelsoort'				'Het soort nevel')
(getGraphic				'beeld'					'De afbeelding van het objekt')
(getGraphicAtCursor		'beeld bij cursor'			'De afbeelding van het objekt bij de cursor')
(getHeading				'richting'				'De richting waar het objekt in staat')
(getHeight				'hoogte'					'De hoogte van het objekt')
(getHolder				'houder'				'De houder van het objekt')
(getIndexInOwner		'index in eigenaar' 			'De positie van het objekt in zijn eigenaar')
"@@@: Folgendes sollte vermutlich die Hand und nicht die Maus referenzieren :@@@"
(getIsUnderMouse		'is muis erover'		'Test, of de mous op het objekt staat')
"@@@: Sollte vielleicht 'Griff' heissen, aber ich mag Knubbel :-) :@@@"
(getKnobColor			'greepkleur'			'De kleur van de greep')
(getLabel				'opschrift'			'Het opschrift van het objekt')
(getLastValue			'laatste waarde'			'De laatste invoerwaarde')
(getLeft					'linkerkant'			'De linkerkant van het objekt')
(getLeftRight			'links-rechts'			'De horizontale afwijking ten opzichte van het centrum')
(getLuminanceUnder	'lichtsterkte eronder'	'De lichtsterkte onder het objekt')
(getMaxVal				'maximale waarde'			'De maximale waarde van de regelaar')
(getMinVal				'minimale waarde'			'De minimale waarde van de regelaar')
(getMouseX				'muis x-positie'		'De X koordinaat van de muispositie')
(getMouseY				'muis y-positie'		'De Y koordinaat van de muispositie')
(getNewClone			'kopieer je'			'Maakt een kopie van het objekt')
(getNumberAtCursor		'aantal bij cursor'			'Het aantal bij de cursor')
(getNumericValue		'waarde van regelaar'				'De huidige waarde van de regelaar')
(getObtrudes				'steekt uit'			'Test of het object uit zijn houder uitsteekt')
(getPenColor				'penkleur'				'De kleur van de pen')
(getPenDown			'pen neer'				'De status van de pen (op/neer)')
(getPenSize				'pengrootte'			'De doorsnede van de pen')
(getRight				'rechterkant'			'De rechterkant van het objekt')
(getRoundedCorners		'afgeronde hoeken'			'Test of hoeken afgerond moeten worden')
(getSampleAtCursor		'steekproef'				'Een steekproef van de waarde bij de cursor')
(getSaturationUnder		'verzadiging eronder'	'De verzadiging van de kleur onder het objekt')
(getScaleFactor			'schalingsfaktor'		'De schalingsfaktor van het objekt')
(getTheta				'theta'					'De hoek met de X-as')
(getTop					'bovenkant'			'De bovenkant van het objekt')
(getTruncate			'afronden'				'Bepaalt of slechts gehele getallen gebruikt worden')
(getUpDown				'erboven-onder'			'De verticale afwijking ten opzichte van het centrum')
(getValueAtCursor		'objekt bij cursor'		'Het objekt bij de huidige cursorpositie')
(getViewingByIcon 		'symboolweergave'		'Bepaalt of het objekt met zijn symbool moet worden weergegeven')
(getX					'x'						'De X koordinaat van het objekt')
(getY					'y'						'De Y koordinaat van het objekt')
(getWidth				'breedte'					'De breedte van het objekt')) language: #Nederlands.


	self translateCategories: #(
(basic					Simpel					'Standaardzicht')
(#'book navigation'		#'Boeknavigatie'		'Navigatie in boeken')
(button					Knop					'Het objekt als knop')
(collections				Houder				'Het objekt als houder')
(fog					Nevel					'3D Nevel eigenschappen')
(geometry				Geometrie				'Over de geometrief van het objekt')
(#'color & border'		#'Kleur & Rand'			'Over kleuren en randen')
(graphics				Grafisch					'Grafische eigenschappen')
(variables				Variabelen				'Variabelen van het objekt')
(joystick				Joystick					'Het objekt als joystick')
(miscellaneous			Overige			'Alles dat nergens anders bij past')
(motion					Beweging				'Bewegingseigenschappen')
(paintbox				Tekenpalet				'Het tekenpalet')
(#'pen trails'			Pennesporen				'Alles over het achterlaten van pennesporen')
(#'pen use'				Pengebruik					'Het gebruik van pennen')
(playfield				Speelveld				'Het speelveld')
(sampling				Meten					'Het meten van waarden')
(scripts					Scripts					'Al je scripts')
(slider					Regelaar					'Het objekt als regelaar')
(speaker				Luidspreker			'Het objekt als luidspreker')
(#'stack navigation'		Stapelnavigatie		'Navigatie in stapels')
(storyboard				Storyboard				'Storyboard')
(tests					Tests					'Verscheidene tests')
(text					Tekst						'Het objekt als tekst')
(viewing				Observatie				'Zoals je het objekt ziet')
(vector					Vector					'Het objekt als vector')
 ) language: #Nederlands "nou ja, nederlands... ;-) - CdG"
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 9/14/2001 10:54'!
addEnglishVocabulary
	"A no-op since the english version of the etoy vocabulary is intrinsic"! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'ar 12/27/2001 00:04'!
addGermanVocabulary
	"Add a German etoy vocabulary"
	self translateMethodInterfaceWordings: #(

(append:					'hänge an'				'Fügt ein Objekt in diesen Behälter ein')
(prepend:					'hänge davor'				'Fügt ein Objekt in diesen Behälter ein')
(beep:						'mache Geräusch'  				'Macht das angegebene Geräusch')
(bounce:					'pralle ab'					'Läßt das Objekt vom Rand seines Behälters abprallen und spielt das angegebene Geräusch, wenn es außerhalb ist')
(cameraPoint 				'Kamerapunkt'				'Der Kamerapunkt des Objektes') 
(clear 						'lösche Graph'						'Löscht den momentanen Graphen')
(clearOwnersPenTrails		'lösche Stiftspuren im Eigner'	'Löscht alle Stiftspuren im Eigner')
(clearTurtleTrails 			'lösche Stiftspuren' 		'Löscht all Stiftspuren im Objekt')
(color:sees: 					'Farbe sieht'			'Überprüft, ob die angebene Farbe des Objektes die Testfarbe sehen kann')
(deleteCard 					'lösche Karte'				'Löscht diese Karte aus dem Stapel')
(doMenuItem: 				'führe Menüpunkt aus'	'Führt den angebenen Menüpunkt aus')
(emptyScript 				'leeres Skript'				'Ein leeres Skript')
(fire						'feuer'						'Führt alle zugehörigen Aktionen dieses Schalters aus')
(firstPage 					'gehe zur ersten Seite'		'Geht zur ersten Seite')
(followPath					'folge Pfad'					'Folge dem definierten Pfad')
(forward: 					'gehe vorwärts um'		'Bewegt das Objekt vorwärts in seiner momentanen Richtung')
(goToFirstCardInBackground	'gehe zur ersten Karte im Hintergund'	'Geht zur ersten Karte im momentanen Hintergrund')
(goToFirstCardOfStack		'gehe zur ersten Karte im Stapel'	'Geht zur ersten Karte im Stapel')
(goToLastCardInBackground	'gehe zur letzten Karte im Hintergund'	'Geht zur letzten Karte im momentanen Hintergrund')
(goToLastCardOfStack		'gehe zur letzten Karte im Stapel'		'Geht zur letzten Karte im Stapel')
(goToNextCardInStack		'gehe zur nächsten Karte im Stapel'		'Geht zur nächsten Karte im momentanen Hintergrund')
(goToPreviousCardInStack	'gehe zur vorherigen Karte im Stapel'	'Geht zur vorherigen Karte im momentanen Hintergrund')
(goToRightOf:				'plaziere rechts von'		'Setzt das Objekt rechts neben ein anderes')
(goto:						'gehe zur Seite'		'Geht zur angegebenen Seite')
(hide					'verstecke Dich'					'Versteckt das Objekt')
(initiatePainting			'beginne neue Zeichnung'		'Beginnt eine neue Zeichnung')
(insertCard				'erzeuge Karte'				'Erzeugt eine neue Karte und fügt sie ein.')
(lastPage				'gehe zur letzten Seite'			'Geht zur letzten Seite')
(liftAllPens				'nimm alle Stifte hoch'			'Nimmt alle Stifte hoch, die sich im Inneren befinden')
(loadSineWave			'lade Sinuswelle'			'Lädt eine Sinuswelle als momentanen Graph')
(loadSound:				'lade Geräusch'					'Lädt das angegebene Geräusch als momentanen Graph')
(lowerAllPens			'setze alle Stifte ab'			'Setzt alle Stifte ab, die sich im Inneren befinden')
(makeNewDrawingIn:	'beginne neue Zeichnung in'	'Beginnt eine neue Zeichnung im angegebenen Objekt')
(moveToward:			'gehe in Richtung '				'Bewegt das Objekt in Richtung eines anderen Objektes')
(nextPage				'gehe zur nächsten Seite'		'Geht zur nächsten Seite')
(pauseScript:			'stoppe Skript'					'Hält ein Skript an')
(play					'spiele Gerausch ab'				'Spielt den momentanen Graphen als Geräusch ab')
(previousPage			'gehe zur vorherigen Seite'	'Geht zur vorherigen Seite')
(removeAll				'entferne alles'				'Entfernt und löscht alle Elemente')
(reverse				'umdrehen'						'Dreht den Inhalt des Graphen um')
(roundUpStrays			'hole zurück'					'Holt alle Objekte zurück, falls sie sich irgendwo verstecken')
(seesColor:				'sieht die Farbe'					'Überprüft, ob das Objekt die angegebene Farbe sieht')
(show					'zeige Dich'						'Zeigt das Objekt')
(shuffleContents			'mische Inhalt'					'Mischt alle Objekte zufällig')
(stampAndErase			'stanze und lösche Dich'		'Fügt das Abbild des Objektes den Stiftspurent hinzu und löscht es anschließend.')
(startScript:				'starte Skript'					'Beginnt die wiederholte Ausführung eines Skriptes')
(stopScript:				'stoppe Script'				'Beendet die wiederholte Ausführung eines Skriptes')
(tellAllSiblings:			'sage den Geschwistern'		'Sendet eine Nachricht zu allen Geschwistern des Objektes')
(touchesA:				'berührt'					'Überprüft, ob ein Objekt des angegebenen Typs berührt wird')
(turn:					'drehe Dich um'				'Ändert die Richtung des Objektes um den angegebenen Winkel')
(unhideHiddenObjects	'zeige versteckte Objekte' 		'Zeigt alle versteckten Objekte an')
(wearCostumeOf: 		'trage Kostüm von'				'Trägt das Kostüm eines anderen Objektes')
(wrap					'wickel Dich rum'				'Wickelt das Objekt um den Rand seines Behälters')

(getActWhen 			'Ausführungsstatus'	'Bestimmt, wann das Skript ausgeführt wird')
(getAllButFirstCharacter	'Alle Buchstaben außer dem Ersten' 'Enthält alle Buchstaben außer dem Ersten')
(getAmount				'Betrag'					'Der Betrag der Abweichung vom Zentrum')
(getAngle				'Winkel'					'Der Winkel der Abweichung vom Zentrum')
(getBorderColor			'Randfarbe'		'Die Farbe des Randes')
(getBorderWidth			'Randbreite'		'Die Breite des Randes')
(getBottom 				'untere Kante'					'Die untere Kante des Objektes')
(getBrightnessUnder		'Helligkeit darunter'			'Die Helligkeit unter dem Zentrum des Objektes')
(getCharacters			'Buchstaben'					'Die Buchstaben des Inhalts')
(getColor				'Farbe' 					'Die Farbe des Objektes')
(getColorUnder 			'Farbe darunter'			'Die Farbe unter dem Zentrum des Objektes')
(getConePosition			'Membranposition'			'Die Position der Membran des Lautsprechers')
(getCursor				'Zeiger'					'Der momentane Zeigerindex')
(getDescending			'Absteigend'				'Bestimmt, ob der kleinste Wert zuerst gezeigt werden soll')
(getDistance				'Distanz'				'Die Distanz zum Ursprung des Behälters')
(getFirstCharacter		'Erster Buchstabe'		'Der erste Buchstabe des Inhalts')
(getFirstElement			'Erstes Element'			'Das erste Element des Inhalts')
(getFogColor				'Nebelfarbe'				'Die Farbe des Nebels')
(getFogDensity			'Nebeldichte'			'Die Dichte des Nebels')
(getFogRangeEnd		'Nebelanfang'			'Die Anfangsdistanz des Nebels')
(getFogRangeStart		'Nebelende'				'Die Enddistanz des Nebels')
(getFogType				'Nebeltyp'				'Der Typ des Nebels')
(getGraphic				'Bild'					'Das Bild des Objektes')
(getGraphicAtCursor		'Bild am Zeiger'			'Das Bild des Objektes am Zeiger')
(getHeading				'Richtung'				'Die Richtung in die das Objekt weist')
(getHeight				'Höhe'					'Die Höhe des Objektes')
(getHolder				'Behälter'				'Der Behälter dieses Objekt')
(getIndexInOwner		'Eignerindex' 			'Der Index des Objektes in seinem Eigner')
"@@@: Folgendes sollte vermutlich die Hand und nicht die Maus referenzieren :@@@"
(getIsUnderMouse		'ist Maus darüber'		'Überprüft, ob die Maus über dem Objekt ist')
"@@@: Sollte vielleicht 'Griff' heissen, aber ich mag Knubbel :-) :@@@"
(getKnobColor			'Knubbelfarbe'			'Die Farbe des Knubbels')
(getLabel				'Beschriftung'			'Die Beschriftung des Objektes')
(getLastValue			'letzter Wert'			'Der letzte Eingabewert')
(getLeft					'linke Kante'			'Die linke Kante des Objektes')
(getLeftRight			'links-rechts'			'Die horizontale Abweichung vom Zentrum')
(getLuminanceUnder	'Leuchtkraft darunter'	'Die Leuchtkraft unter dem Objekt')
(getMaxVal				'Maximalwert'			'Der maximale Wert des Reglers')
(getMinVal				'Minimalwert'			'Der minimale Wert des Reglers')
(getMouseX				'Maus X-Position'		'Die X Koordinate der Mausposition')
(getMouseY				'Maus Y-Position'		'Die Y Koordinate der Mausposition')
(getNewClone			'kopiere Dich'			'Erzeugt eine Kopie des Objektes')
(getNumberAtCursor		'Zahl am Zeiger'			'Die Zahl am Zeiger')
(getNumericValue		'Reglerwert'				'Der momentane Wert des Reglers')
(getObtrudes				'ragt hinaus'			'Überprüft, ob das Objekt aus seinem Eigner herausragt')
(getPenColor				'Stiftfarbe'				'Die Farbe des Stiftes')
(getPenDown			'Stift unten'				'Der Status des Stiftes')
(getPenSize				'Stiftgröße'			'Der Durchmesser des Stiftes')
(getRight				'rechte Kante'			'Die rechte Kante des Objektes')
(getRoundedCorners		'runde Ecken'			'Bestimmt, ob Ecken abgerundet werden')
(getSampleAtCursor		'Stichprobe'				'Eine Stichprobe des Wertes an der momentanen Zeigerposition')
(getSaturationUnder		'Sättigung darunter'	'Die Sättigung der Farbe unter dem Objekt')
(getScaleFactor			'Skalierungsfaktor'		'Der Skalierungsfaktor des Objektes')
(getTheta				'Theta'					'Der ''Zentrums-Ursprungs-Rechts'' Winkel (huh?)')
(getTop					'obere Kante'			'Die obere Kante des Objekts')
(getTruncate			'Abrunden'				'Bestimmt, ob nur ganze Zahlen benutzt werden')
(getUpDown				'hoch-runter'			'Die vertikale Abweichung vom Zentrum')
(getValueAtCursor		'Objekt am Zeiger'		'Das Objekt an der momentanen Zeigerposition')
(getViewingByIcon 		'Symboldarstellung'		'Bestimmt, ob Objekte symbolisch oder normal dargestellt werden')
(getX					'x'						'Die X Koordinate des Objektes')
(getY					'y'						'Die Y Koordinate des Objektes')
(getWidth				'Breite'					'Die Breite des Objektes')) language: #Deutsch.


	self translateCategories: #(
(basic					Einfach					'Standardsicht')
(#'book navigation'		#'Buchnavigation'		'Navigation in Büchern')
(button					Schalter					'Das Objekt als Schalter')
(collections				Behälter				'Das Objekt als Behälter')
(fog					Nebel					'3D Nebel Eigenschaften')
(geometry				Geometrie				'Zur Geometrie des Objektes')
(#'color & border'		#'Farbe & Rand'			'Zum Thema Farben und Ränder')
(graphics				Graphik					'Graphische Eigenschaften')
(#'instance variables'	Variablen				'Variablen des Objektes')
(joystick				Joystick					'Das Objekt als Joystick')
(miscellaneous			Verschiedenes			'Alles was woanders nicht hinpaßt')
(motion					Bewegung				'Bewegungseigenschaften')
(paintbox				Malpalette				'Die Zeichenpalette')
(#'pen trails'			Stiftspuren				'Alles zum Thema Spuren hinterlassen')
(#'pen use'				Stifte					'Verwendung von Stiften')
(playfield				Spielfeld				'ja ich weiß auch nicht...')
(sampling				Messen					'Messungen von Werten')
(scripts					Skripte					'Alle Deine Skripte')
(slider					Regler					'Das Objekt als Regler')
(speaker				Lautsprecher			'Das Objekt als Lautsprecher')
(#'stack navigation'		Stapelnavigation		'Navigation in Stapeln')
(storyboard				Storyboard				'Später mal...')
(tests					Tests					'Verschiedene Tests')
(text					Text						'Das Objekt als Text')
(viewing				Betrachtung				'Wie man''s so sieht')
(vector					Vektor					'Das Objekt als Vektor')
 ) language: #Deutsch
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:45' prior: 35832985!
addGermanVocabulary
	"Add a German etoy vocabulary"
	self translateMethodInterfaceWordings: #(

(append:					'hänge an'				'Fügt ein Objekt in diesen Behälter ein')
(prepend:					'hänge davor'				'Fügt ein Objekt in diesen Behälter ein')
(beep:						'mache Geräusch'  				'Macht das angegebene Geräusch')
(bounce:					'pralle ab'					'Läßt das Objekt vom Rand seines Behälters abprallen und spielt das angegebene Geräusch, wenn es außerhalb ist')
(cameraPoint 				'Kamerapunkt'				'Der Kamerapunkt des Objektes') 
(clear 						'lösche Graph'						'Löscht den momentanen Graphen')
(clearOwnersPenTrails		'lösche Stiftspuren im Eigner'	'Löscht alle Stiftspuren im Eigner')
(clearTurtleTrails 			'lösche Stiftspuren' 		'Löscht all Stiftspuren im Objekt')
(color:sees: 					'Farbe sieht'			'Überprüft, ob die angebene Farbe des Objektes die Testfarbe sehen kann')
(deleteCard 					'lösche Karte'				'Löscht diese Karte aus dem Stapel')
(doMenuItem: 				'führe Menüpunkt aus'	'Führt den angebenen Menüpunkt aus')
(emptyScript 				'leeres Skript'				'Ein leeres Skript')
(fire						'feuer'						'Führt alle zugehörigen Aktionen dieses Schalters aus')
(firstPage 					'gehe zur ersten Seite'		'Geht zur ersten Seite')
(followPath					'folge Pfad'					'Folge dem definierten Pfad')
(forward: 					'gehe vorwärts um'		'Bewegt das Objekt vorwärts in seiner momentanen Richtung')
(goToFirstCardInBackground	'gehe zur ersten Karte im Hintergund'	'Geht zur ersten Karte im momentanen Hintergrund')
(goToFirstCardOfStack		'gehe zur ersten Karte im Stapel'	'Geht zur ersten Karte im Stapel')
(goToLastCardInBackground	'gehe zur letzten Karte im Hintergund'	'Geht zur letzten Karte im momentanen Hintergrund')
(goToLastCardOfStack		'gehe zur letzten Karte im Stapel'		'Geht zur letzten Karte im Stapel')
(goToNextCardInStack		'gehe zur nächsten Karte im Stapel'		'Geht zur nächsten Karte im momentanen Hintergrund')
(goToPreviousCardInStack	'gehe zur vorherigen Karte im Stapel'	'Geht zur vorherigen Karte im momentanen Hintergrund')
(goToRightOf:				'plaziere rechts von'		'Setzt das Objekt rechts neben ein anderes')
(goto:						'gehe zur Seite'		'Geht zur angegebenen Seite')
(hide					'verstecke Dich'					'Versteckt das Objekt')
(initiatePainting			'beginne neue Zeichnung'		'Beginnt eine neue Zeichnung')
(insertCard				'erzeuge Karte'				'Erzeugt eine neue Karte und fügt sie ein.')
(lastPage				'gehe zur letzten Seite'			'Geht zur letzten Seite')
(liftAllPens				'nimm alle Stifte hoch'			'Nimmt alle Stifte hoch, die sich im Inneren befinden')
(loadSineWave			'lade Sinuswelle'			'Lädt eine Sinuswelle als momentanen Graph')
(loadSound:				'lade Geräusch'					'Lädt das angegebene Geräusch als momentanen Graph')
(lowerAllPens			'setze alle Stifte ab'			'Setzt alle Stifte ab, die sich im Inneren befinden')
(makeNewDrawingIn:	'beginne neue Zeichnung in'	'Beginnt eine neue Zeichnung im angegebenen Objekt')
(moveToward:			'gehe in Richtung '				'Bewegt das Objekt in Richtung eines anderen Objektes')
(nextPage				'gehe zur nächsten Seite'		'Geht zur nächsten Seite')
(pauseScript:			'stoppe Skript'					'Hält ein Skript an')
(play					'spiele Gerausch ab'				'Spielt den momentanen Graphen als Geräusch ab')
(previousPage			'gehe zur vorherigen Seite'	'Geht zur vorherigen Seite')
(removeAll				'entferne alles'				'Entfernt und löscht alle Elemente')
(reverse				'umdrehen'						'Dreht den Inhalt des Graphen um')
(roundUpStrays			'hole zurück'					'Holt alle Objekte zurück, falls sie sich irgendwo verstecken')
(seesColor:				'sieht die Farbe'					'Überprüft, ob das Objekt die angegebene Farbe sieht')
(show					'zeige Dich'						'Zeigt das Objekt')
(shuffleContents			'mische Inhalt'					'Mischt alle Objekte zufällig')
(stampAndErase			'stanze und lösche Dich'		'Fügt das Abbild des Objektes den Stiftspurent hinzu und löscht es anschließend.')
(startScript:				'starte Skript'					'Beginnt die wiederholte Ausführung eines Skriptes')
(stopScript:				'stoppe Script'				'Beendet die wiederholte Ausführung eines Skriptes')
(tellAllSiblings:			'sage den Geschwistern'		'Sendet eine Nachricht zu allen Geschwistern des Objektes')
(touchesA:				'berührt'					'Überprüft, ob ein Objekt des angegebenen Typs berührt wird')
(turn:					'drehe Dich um'				'Ändert die Richtung des Objektes um den angegebenen Winkel')
(unhideHiddenObjects	'zeige versteckte Objekte' 		'Zeigt alle versteckten Objekte an')
(wearCostumeOf: 		'trage Kostüm von'				'Trägt das Kostüm eines anderen Objektes')
(wrap					'wickel Dich rum'				'Wickelt das Objekt um den Rand seines Behälters')

(getActWhen 			'Ausführungsstatus'	'Bestimmt, wann das Skript ausgeführt wird')
(getAllButFirstCharacter	'Alle Buchstaben außer dem Ersten' 'Enthält alle Buchstaben außer dem Ersten')
(getAmount				'Betrag'					'Der Betrag der Abweichung vom Zentrum')
(getAngle				'Winkel'					'Der Winkel der Abweichung vom Zentrum')
(getBorderColor			'Randfarbe'		'Die Farbe des Randes')
(getBorderWidth			'Randbreite'		'Die Breite des Randes')
(getBottom 				'untere Kante'					'Die untere Kante des Objektes')
(getBrightnessUnder		'Helligkeit darunter'			'Die Helligkeit unter dem Zentrum des Objektes')
(getCharacters			'Buchstaben'					'Die Buchstaben des Inhalts')
(getColor				'Farbe' 					'Die Farbe des Objektes')
(getColorUnder 			'Farbe darunter'			'Die Farbe unter dem Zentrum des Objektes')
(getConePosition			'Membranposition'			'Die Position der Membran des Lautsprechers')
(getCursor				'Zeiger'					'Der momentane Zeigerindex')
(getDescending			'Absteigend'				'Bestimmt, ob der kleinste Wert zuerst gezeigt werden soll')
(getDistance				'Distanz'				'Die Distanz zum Ursprung des Behälters')
(getFirstCharacter		'Erster Buchstabe'		'Der erste Buchstabe des Inhalts')
(getFirstElement			'Erstes Element'			'Das erste Element des Inhalts')
(getFogColor				'Nebelfarbe'				'Die Farbe des Nebels')
(getFogDensity			'Nebeldichte'			'Die Dichte des Nebels')
(getFogRangeEnd		'Nebelanfang'			'Die Anfangsdistanz des Nebels')
(getFogRangeStart		'Nebelende'				'Die Enddistanz des Nebels')
(getFogType				'Nebeltyp'				'Der Typ des Nebels')
(getGraphic				'Bild'					'Das Bild des Objektes')
(getGraphicAtCursor		'Bild am Zeiger'			'Das Bild des Objektes am Zeiger')
(getHeading				'Richtung'				'Die Richtung in die das Objekt weist')
(getHeight				'Höhe'					'Die Höhe des Objektes')
(getHolder				'Behälter'				'Der Behälter dieses Objekt')
(getIndexInOwner		'Eignerindex' 			'Der Index des Objektes in seinem Eigner')
"@@@: Folgendes sollte vermutlich die Hand und nicht die Maus referenzieren :@@@"
(getIsUnderMouse		'ist Maus darüber'		'Überprüft, ob die Maus über dem Objekt ist')
"@@@: Sollte vielleicht 'Griff' heissen, aber ich mag Knubbel :-) :@@@"
(getKnobColor			'Knubbelfarbe'			'Die Farbe des Knubbels')
(getLabel				'Beschriftung'			'Die Beschriftung des Objektes')
(getLastValue			'letzter Wert'			'Der letzte Eingabewert')
(getLeft					'linke Kante'			'Die linke Kante des Objektes')
(getLeftRight			'links-rechts'			'Die horizontale Abweichung vom Zentrum')
(getLuminanceUnder	'Leuchtkraft darunter'	'Die Leuchtkraft unter dem Objekt')
(getMaxVal				'Maximalwert'			'Der maximale Wert des Reglers')
(getMinVal				'Minimalwert'			'Der minimale Wert des Reglers')
(getMouseX				'Maus X-Position'		'Die X Koordinate der Mausposition')
(getMouseY				'Maus Y-Position'		'Die Y Koordinate der Mausposition')
(getNewClone			'kopiere Dich'			'Erzeugt eine Kopie des Objektes')
(getNumberAtCursor		'Zahl am Zeiger'			'Die Zahl am Zeiger')
(getNumericValue		'Reglerwert'				'Der momentane Wert des Reglers')
(getObtrudes				'ragt hinaus'			'Überprüft, ob das Objekt aus seinem Eigner herausragt')
(getPenColor				'Stiftfarbe'				'Die Farbe des Stiftes')
(getPenDown			'Stift unten'				'Der Status des Stiftes')
(getPenSize				'Stiftgröße'			'Der Durchmesser des Stiftes')
(getRight				'rechte Kante'			'Die rechte Kante des Objektes')
(getRoundedCorners		'runde Ecken'			'Bestimmt, ob Ecken abgerundet werden')
(getSampleAtCursor		'Stichprobe'				'Eine Stichprobe des Wertes an der momentanen Zeigerposition')
(getSaturationUnder		'Sättigung darunter'	'Die Sättigung der Farbe unter dem Objekt')
(getScaleFactor			'Skalierungsfaktor'		'Der Skalierungsfaktor des Objektes')
(getTheta				'Theta'					'Der ''Zentrums-Ursprungs-Rechts'' Winkel (huh?)')
(getTop					'obere Kante'			'Die obere Kante des Objekts')
(getTruncate			'Abrunden'				'Bestimmt, ob nur ganze Zahlen benutzt werden')
(getUpDown				'hoch-runter'			'Die vertikale Abweichung vom Zentrum')
(getValueAtCursor		'Objekt am Zeiger'		'Das Objekt an der momentanen Zeigerposition')
(getViewingByIcon 		'Symboldarstellung'		'Bestimmt, ob Objekte symbolisch oder normal dargestellt werden')
(getX					'x'						'Die X Koordinate des Objektes')
(getY					'y'						'Die Y Koordinate des Objektes')
(getWidth				'Breite'					'Die Breite des Objektes')) language: #Deutsch.


	self translateCategories: #(
(basic					Einfach					'Standardsicht')
(#'book navigation'		#'Buchnavigation'		'Navigation in Büchern')
(button					Schalter					'Das Objekt als Schalter')
(collections				Behälter				'Das Objekt als Behälter')
(fog					Nebel					'3D Nebel Eigenschaften')
(geometry				Geometrie				'Zur Geometrie des Objektes')
(#'color & border'		#'Farbe & Rand'			'Zum Thema Farben und Ränder')
(graphics				Graphik					'Graphische Eigenschaften')
(variables				Variablen				'Variablen des Objektes')
(joystick				Joystick					'Das Objekt als Joystick')
(miscellaneous			Verschiedenes			'Alles was woanders nicht hinpaßt')
(motion					Bewegung				'Bewegungseigenschaften')
(paintbox				Malpalette				'Die Zeichenpalette')
(#'pen trails'			Stiftspuren				'Alles zum Thema Spuren hinterlassen')
(#'pen use'				Stifte					'Verwendung von Stiften')
(playfield				Spielfeld				'ja ich weiß auch nicht...')
(sampling				Messen					'Messungen von Werten')
(scripts					Skripte					'Alle Deine Skripte')
(slider					Regler					'Das Objekt als Regler')
(speaker				Lautsprecher			'Das Objekt als Lautsprecher')
(#'stack navigation'		Stapelnavigation		'Navigation in Stapeln')
(storyboard				Storyboard				'Später mal...')
(tests					Tests					'Verschiedene Tests')
(text					Text						'Das Objekt als Text')
(viewing				Betrachtung				'Wie man''s so sieht')
(vector					Vektor					'Das Objekt als Vektor')
 ) language: #Deutsch
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 9/13/2001 20:12'!
addKiswahiliVocabulary
	"Add a Kiswahili vocabulary"

	self translateMethodInterfaceWordings: #(

(append:					'tia mwishoni'				'weka kitu hicho mwishoni')
(beep:						'fanya kelele'  				'piga kelele fulani')
(bounce:					'ruka duta'					'ruka duta kama mpira')
(cameraPoint 				'penye kamera'				'mahali penya kamera') 
(clear 						'kumba'						'ondoa vilivyokwemo')
(clearOwnersPenTrails		'ondoa nyayo'				'ondoa nyayo za wino')
(clearTurtleTrails 			'ondoa nyayo ndani' 		'ondoa nyayo za wino zilzo ndani')
(color:sees: 					'rangi yaona rangi'			'kama rangi fulana yaona rangi nyingine')
(deleteCard 					'tupa karata'				'tupa karata hii')
(doMenuItem: 				'fanya uchaguzi'			'fanya uchaguzi fulani')
(doScript:					'piga script'					'piga script ya jina fulani mara moja')
(emptyScript 				'script tupu'				'tengeneza script mpya tupu')
(fire						'waka'						'waka script, yaani kuianzisha')
(firstPage 					'nenda mwanzoni'			'nenda penye ukurasa wa kwanza')
(followPath					'fuata njia'					'fuata njia iliyofanywa kabla')
(forward: 					'nenda mbele'				'sogea mbela kwa kiasi fulani')
(goToFirstCardInBackground	'endea kwanza ya nyuma'	'endea karata kwanza ya nyuma')
(goToFirstCardOfStack		'endea kwanza ya stack'	'endea karata iliyo ya kwanza ya stack')
(goToLastCardInBackground	'endea mwisho ya nyuma'	'endea karata ya mwisho ya nyuma')
(goToLastCardOfStack		'endea mwisho ya stack'		'endea karata ya mwisho ya stack')
(goToNextCardInStack		'endea karata ifuatayo'		'endea karata itakayofuata penye stack')
(goToPreviousCardInStack	'endea karata itanguliayo'	'endea karata kliyonitangulia penye stack')
(goToRightOf:				'endea karibu ya kulia'		'sogea hata nipo upande wa kulia kuhusu kitu fulani')
(goto:						'endea mahali fulani'		'endea mahali fulani')
(hide					'ficha'							'nifanywe ili nisionekane')
(initiatePainting			'anza kupiga picha'				'anza kupiga picha mpya')
(insertCard				'weka karata mpya'				'weka karata mpya ndani ya stack')
(lastPage				'ukurasa wa mwisho'			'endea ukurasa ya mwisho')
(liftAllPens				'inua kalamu zote'				'inua kalamu zote zilizomo ndani, ili zisipige rangi')
(loadSineWave			'pakia wimbi la sine'			'pakia wimibi (la kitrigonometry) la sine')
(loadSound:				'pakia kelele'					'pakia kelele fulani')
(lowerAllPens			'telemsha kalamu zote'			'telemsha kalamu zote ya vitu vyote vilivyomo ndani')
(makeNewDrawingIn:	'anza kupiga picha kiwanjani'	'anza kupaga picha mpya ndani ya kiwanja')
(moveToward:			'nenda upande wa'				'nenda upande wa kitu fulani')
(nextPage				'endea ukurasa ufuatao'		'nenda ukurasani unaofuata')
(pauseScript:			'pumzisha script'				'pumzisha script fulani')
(pauseAll:				'pumzisha script zote'			'pumzisha script fulani katika mwenyewe na ndugu zangu wote')
(play					'cheza'							'cheza, basi!!')
(previousPage			'endea ukurasa uliotangulia'	'enda ukurasa uliotangulia ukurusa huu')
(removeAll				'ondoa vyote vilivyokuwemo'	'ondoa vitu vyote vilvyomo dani')
(reverse				'kinyume'						'kinyume cha upande')
(roundUpStrays			'kusanya'						'sanya vitu vilovyopotoleka')
(seesColor:				'yaona rangi'					'kama naona rangi fulani')
(show					'onyesha'						'fanya hata naonekana')
(shuffleContents			'changanya'					'changanya orodha ya ndani')
(stampAndErase			'piga chapa na kufuta'			'piga chapa, halafu kufuta')
(startScript:				'anzisha script'					'anzisha script ya jina fulani')
(startAll:				'anzisha script zote'				'anzisha script fulani penye mwenyewe na ndugu zangu wote')
(stopAll:					'simamisha script zote'			'simamisha script fulani penye mwenyewe na ndugu zangu wote')
(stopScript:				'simamisa skriptu'				'simamisha script ya jana fulani')
(tellAllSiblings:			'watangazie ndugu'				'tangaza habari kwa ndugu zangu wote')
(touchesA:				'yagusa'						'kama nagusa kitu cha aina fulani')
(turn:					'geuka'							'geuka kwa pembe fulani')
(unhideHiddenObjects	'onyesha vilivyofichwa' 		'onyesha vitu ndani vilivyofichwa')
(wearCostumeOf: 		'vaa nguo za'					'vaa nguo za mtu mwingine')
(wrap					'zunguka'						'baada ya kutoka, ingia n''gambo')

(getActWhen 			'waka kama'			'lini ya waka')
(getAllButFirstCharacter	'herufi ila ya kwanza' 'herufi zote isipokuwa ile ya kwanza tu')
(getAmount				'kiasi'					'kiasi gani')
(getAngle				'pembe'					'pembe iliyopo (degree)')
(getBorderColor			'rangi ya mpaka'		'rangi ya mpaka wangu')
(getBorderWidth			'upana wa mpaka'		'upana wa mpaka wangu')
(getBottom 				'chini'					'chini yangu')
(getBrightnessUnder		'mng''aro chini'			'mwangaza chini yangu')
(getCharacters			'herufi'					'herufi zangu')
(getColor				'rangi' 					'rangi yangu')
(getColorUnder 			'rangi chini'			'rangi chini yangu')
(getConePosition			'penye cone'			'mahali penye cone')
(getCursor				'kidole'					'namba ya kitu ndani kilichagulwa')
(getDescending			'kama yaenda chini'	'kama naonyesha vitu chini')
(getDistance				'urefu'					'urefu kutoka asili')
(getFirstCharacter		'herufi ya kwanza'		'herufi yangu ya kwanza')
(getFirstElement			'kitu cha kwanza'		'kitu changu cha ndani cha kwanza')
(getFogColor				'rangi ya ukungu'		'rangi ya ukungu wangu')
(getFogDensity			'nguvu wa ukungu'	'nguvu ya ukungu wangu')
(getFogRangeEnd		'mwisho wa ukungu'	'mwisho wa upana wa ukungu wangu')
(getFogRangeStart		'mwanzo wa ukungu'	'mwanzo wa upana wa ukungu wangu')
(getFogType				'aina ya ukungu'		'aina ya ukungu wangu')
(getGraphic				'picha'					'picha ninayonyesha')
(getGraphicAtCursor		'picha penye kidolee'	'picha iliyopo penye kidole changu')
(getHeading				'upande'				'upande gani ninayoelekea')
(getHeight				'urefu'					'urefu wangu')
(getHolder				'mshikoi'				'kitu niliomo ndani yake')
(getIndexInOwner		'namba kataki mwenyeji' 'namba niliyo nayo katika mwenyeji')
(getIsUnderMouse		'chini kipanya'			'kama nipo chini ya kipanya')
(getKnobColor			'rangi ya ndani'		'rangi ya sehemu yangu ya ndani')
(getLabel				'tangazo'				'iliyoandishwa juu yangu')
(getLastValue			'mapimo'				'iliyokuwemo ndani')
(getLeft					'kushoto'				'mpaka wa kushoto')
(getLeftRight			'kiasi cha sawasawa'	'kiasi cha kushoto ama kulia')
(getLuminanceUnder	'uNg''aa chini'			'uNg''aa ya sehemu chini yangu')
(getMaxVal				'kiasi cha juu'			'kiasi cha juu humu ndani')
(getMinVal				'kiasi cha chini'		'kiasi cha chini humu ndani')
(getMouseX				'x ya kipanya'			'mahali pa x pa kipanya')
(getMouseY				'y ya kipanya'			'mahali pa y pa kipanya')
(getNewClone			'nakala'				'fanya nakala yangu')
(getNumberAtCursor		'namba kidoleni'		'namba iliyopo kidoleni')
(getNumericValue		'namba humu'			'namba iliyopo katika kituc hicho')
(getObtrudes				'jiingiliza'				'kama kitu hicho hujiingiliza')
(getPenColor				'rangi ya kalamu'		'rangi ninayotumia kwa kalamu')
(getPenDown			'kalamu chini'			'kama kalamu hukaa chini')
(getPenSize				'upana wa kalamu'		'urefu wa kalamu ninayotumia')
(getRight				'kulia'					'mpaka wa kulia')
(getRoundedCorners		'viringisha'				'tumia pembe zilizoviringishwa')
(getSampleAtCursor		'kiasi kidoleni'			'kiasi kilichopo kidoleni')
(getSaturationUnder		'kunyewesha chini'		'kiasi cha kunyewesha chini ya kati yangu')
(getScaleFactor			'kuzidisha kwa'			'kiasi ninachozidishwa nacho')
(getTheta				'theta'					'pemba kwa x-axis')
(getTop					'juu'					'mpaka wa juu')
(getTruncate			'kata'					'kama kukata ama sivyo')
(getUpDown				'juu/chini'				'kiasi cha juu ama cha chini')
(getValueAtCursor		'mchezaji kidoleni'		'mchechazji aliyepo kidoneni')
(getViewingByIcon 		'angalia kwa picha'		'kama vitu vilivyomo ndani huanagaliwa kwa picha ama sivyo')
(getX					'x'						'mahali pa x')
(getY					'y'						'mahali ya y')
(getWidth				'upana'					'upana wangu')) language: #Kiswahili.

	self translateCategories: #(
(basic					muhimu				'mambo muhimu muhimu')
(#'book navigation'		#'kuongoza vitabu'		'kuhusu kuongozea vitabu')
(button					kifungo					'mambo kuhusu vifungo')
(collections				mikusanyo				'kuhusu mikusanyo ya vitu')
(fog					ukungu					'kuhusu ukungu (3D)')
(geometry				kupimia					'urefu na kadhaliki')
(#'color & border'		#'rangi & mpaka'		'kuhusu rangi na mpaka')
(graphics				picha					'mambo kuhusu picha')
(#'instance variables'	badiliko					'data zilizoundwa na yule atumiaye')
(joystick				#'fimbo la furaha'		'kuhusu fimbo la furaha, yaani "joystick"')
(miscellaneous			mbalimbali				'mambo mbalimbali')
(motion					kusogea					'kwenda, kuegeuka, etc.')
(paintbox				#'kupiga rangi'			'vitu kuhusu kupigia rangi')
(#'pen trails'			#'nyayo za kalamu'		'kuhusu nyay za kalamu')
(#'pen use'				#'kalamu'				'kuhusu kalamu')
(playfield				kiwanja					'vitu kuhusu kiwanjani')
(sampling				kuchagua				'mambo kuhusu kuchagua')
(scripts					taratibu				'taratibu zilizoundwa na atumiaye')
(slider					telezo					'kitu kionyeshacho kiasi cha namba fulani')
(speaker				spika					'kuhusu spika za kelele')
(#'stack navigation'		#'kuongoza chungu'	'kuhusu kuongozea chungu')
(storyboard				kusimulia				'kusimilia hadithi')
(tests					kama					'amua kama hali fulani i kweli ama sivyo')
(text					maneno					'maandiko ya maneno')
(viewing				kuangaliwa				'kuhusu kuangalia vitu')
(vector					vektor					'kuhusu vektor')
) language: #Kiswahili.

self addToTranslationTableFrom: 

#((:						'_'						'tia ndani')
(Incr:					'pamoja na'				'tia thamani + fulani')
(Decr:					'toa'					'tia thamani - fulani')
(Mult:					'mara'					'tia thamani * fulani')) language: #Kiswahili.
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:46' prior: 35854176!
addKiswahiliVocabulary
	"Add a Kiswahili vocabulary"

	self translateMethodInterfaceWordings: #(

(append:					'tia mwishoni'				'weka kitu hicho mwishoni')
(beep:						'fanya kelele'  				'piga kelele fulani')
(bounce:					'ruka duta'					'ruka duta kama mpira')
(cameraPoint 				'penye kamera'				'mahali penya kamera') 
(clear 						'kumba'						'ondoa vilivyokwemo')
(clearOwnersPenTrails		'ondoa nyayo'				'ondoa nyayo za wino')
(clearTurtleTrails 			'ondoa nyayo ndani' 		'ondoa nyayo za wino zilzo ndani')
(color:sees: 					'rangi yaona rangi'			'kama rangi fulana yaona rangi nyingine')
(deleteCard 					'tupa karata'				'tupa karata hii')
(doMenuItem: 				'fanya uchaguzi'			'fanya uchaguzi fulani')
(doScript:					'piga script'					'piga script ya jina fulani mara moja')
(emptyScript 				'script tupu'				'tengeneza script mpya tupu')
(fire						'waka'						'waka script, yaani kuianzisha')
(firstPage 					'nenda mwanzoni'			'nenda penye ukurasa wa kwanza')
(followPath					'fuata njia'					'fuata njia iliyofanywa kabla')
(forward: 					'nenda mbele'				'sogea mbela kwa kiasi fulani')
(goToFirstCardInBackground	'endea kwanza ya nyuma'	'endea karata kwanza ya nyuma')
(goToFirstCardOfStack		'endea kwanza ya stack'	'endea karata iliyo ya kwanza ya stack')
(goToLastCardInBackground	'endea mwisho ya nyuma'	'endea karata ya mwisho ya nyuma')
(goToLastCardOfStack		'endea mwisho ya stack'		'endea karata ya mwisho ya stack')
(goToNextCardInStack		'endea karata ifuatayo'		'endea karata itakayofuata penye stack')
(goToPreviousCardInStack	'endea karata itanguliayo'	'endea karata kliyonitangulia penye stack')
(goToRightOf:				'endea karibu ya kulia'		'sogea hata nipo upande wa kulia kuhusu kitu fulani')
(goto:						'endea mahali fulani'		'endea mahali fulani')
(hide					'ficha'							'nifanywe ili nisionekane')
(initiatePainting			'anza kupiga picha'				'anza kupiga picha mpya')
(insertCard				'weka karata mpya'				'weka karata mpya ndani ya stack')
(lastPage				'ukurasa wa mwisho'			'endea ukurasa ya mwisho')
(liftAllPens				'inua kalamu zote'				'inua kalamu zote zilizomo ndani, ili zisipige rangi')
(loadSineWave			'pakia wimbi la sine'			'pakia wimibi (la kitrigonometry) la sine')
(loadSound:				'pakia kelele'					'pakia kelele fulani')
(lowerAllPens			'telemsha kalamu zote'			'telemsha kalamu zote ya vitu vyote vilivyomo ndani')
(makeNewDrawingIn:	'anza kupiga picha kiwanjani'	'anza kupaga picha mpya ndani ya kiwanja')
(moveToward:			'nenda upande wa'				'nenda upande wa kitu fulani')
(nextPage				'endea ukurasa ufuatao'		'nenda ukurasani unaofuata')
(pauseScript:			'pumzisha script'				'pumzisha script fulani')
(pauseAll:				'pumzisha script zote'			'pumzisha script fulani katika mwenyewe na ndugu zangu wote')
(play					'cheza'							'cheza, basi!!')
(previousPage			'endea ukurasa uliotangulia'	'enda ukurasa uliotangulia ukurusa huu')
(removeAll				'ondoa vyote vilivyokuwemo'	'ondoa vitu vyote vilvyomo dani')
(reverse				'kinyume'						'kinyume cha upande')
(roundUpStrays			'kusanya'						'sanya vitu vilovyopotoleka')
(seesColor:				'yaona rangi'					'kama naona rangi fulani')
(show					'onyesha'						'fanya hata naonekana')
(shuffleContents			'changanya'					'changanya orodha ya ndani')
(stampAndErase			'piga chapa na kufuta'			'piga chapa, halafu kufuta')
(startScript:				'anzisha script'					'anzisha script ya jina fulani')
(startAll:				'anzisha script zote'				'anzisha script fulani penye mwenyewe na ndugu zangu wote')
(stopAll:					'simamisha script zote'			'simamisha script fulani penye mwenyewe na ndugu zangu wote')
(stopScript:				'simamisa skriptu'				'simamisha script ya jana fulani')
(tellAllSiblings:			'watangazie ndugu'				'tangaza habari kwa ndugu zangu wote')
(touchesA:				'yagusa'						'kama nagusa kitu cha aina fulani')
(turn:					'geuka'							'geuka kwa pembe fulani')
(unhideHiddenObjects	'onyesha vilivyofichwa' 		'onyesha vitu ndani vilivyofichwa')
(wearCostumeOf: 		'vaa nguo za'					'vaa nguo za mtu mwingine')
(wrap					'zunguka'						'baada ya kutoka, ingia n''gambo')

(getActWhen 			'waka kama'			'lini ya waka')
(getAllButFirstCharacter	'herufi ila ya kwanza' 'herufi zote isipokuwa ile ya kwanza tu')
(getAmount				'kiasi'					'kiasi gani')
(getAngle				'pembe'					'pembe iliyopo (degree)')
(getBorderColor			'rangi ya mpaka'		'rangi ya mpaka wangu')
(getBorderWidth			'upana wa mpaka'		'upana wa mpaka wangu')
(getBottom 				'chini'					'chini yangu')
(getBrightnessUnder		'mng''aro chini'			'mwangaza chini yangu')
(getCharacters			'herufi'					'herufi zangu')
(getColor				'rangi' 					'rangi yangu')
(getColorUnder 			'rangi chini'			'rangi chini yangu')
(getConePosition			'penye cone'			'mahali penye cone')
(getCursor				'kidole'					'namba ya kitu ndani kilichagulwa')
(getDescending			'kama yaenda chini'	'kama naonyesha vitu chini')
(getDistance				'urefu'					'urefu kutoka asili')
(getFirstCharacter		'herufi ya kwanza'		'herufi yangu ya kwanza')
(getFirstElement			'kitu cha kwanza'		'kitu changu cha ndani cha kwanza')
(getFogColor				'rangi ya ukungu'		'rangi ya ukungu wangu')
(getFogDensity			'nguvu wa ukungu'	'nguvu ya ukungu wangu')
(getFogRangeEnd		'mwisho wa ukungu'	'mwisho wa upana wa ukungu wangu')
(getFogRangeStart		'mwanzo wa ukungu'	'mwanzo wa upana wa ukungu wangu')
(getFogType				'aina ya ukungu'		'aina ya ukungu wangu')
(getGraphic				'picha'					'picha ninayonyesha')
(getGraphicAtCursor		'picha penye kidolee'	'picha iliyopo penye kidole changu')
(getHeading				'upande'				'upande gani ninayoelekea')
(getHeight				'urefu'					'urefu wangu')
(getHolder				'mshikoi'				'kitu niliomo ndani yake')
(getIndexInOwner		'namba kataki mwenyeji' 'namba niliyo nayo katika mwenyeji')
(getIsUnderMouse		'chini kipanya'			'kama nipo chini ya kipanya')
(getKnobColor			'rangi ya ndani'		'rangi ya sehemu yangu ya ndani')
(getLabel				'tangazo'				'iliyoandishwa juu yangu')
(getLastValue			'mapimo'				'iliyokuwemo ndani')
(getLeft					'kushoto'				'mpaka wa kushoto')
(getLeftRight			'kiasi cha sawasawa'	'kiasi cha kushoto ama kulia')
(getLuminanceUnder	'uNg''aa chini'			'uNg''aa ya sehemu chini yangu')
(getMaxVal				'kiasi cha juu'			'kiasi cha juu humu ndani')
(getMinVal				'kiasi cha chini'		'kiasi cha chini humu ndani')
(getMouseX				'x ya kipanya'			'mahali pa x pa kipanya')
(getMouseY				'y ya kipanya'			'mahali pa y pa kipanya')
(getNewClone			'nakala'				'fanya nakala yangu')
(getNumberAtCursor		'namba kidoleni'		'namba iliyopo kidoleni')
(getNumericValue		'namba humu'			'namba iliyopo katika kituc hicho')
(getObtrudes				'jiingiliza'				'kama kitu hicho hujiingiliza')
(getPenColor				'rangi ya kalamu'		'rangi ninayotumia kwa kalamu')
(getPenDown			'kalamu chini'			'kama kalamu hukaa chini')
(getPenSize				'upana wa kalamu'		'urefu wa kalamu ninayotumia')
(getRight				'kulia'					'mpaka wa kulia')
(getRoundedCorners		'viringisha'				'tumia pembe zilizoviringishwa')
(getSampleAtCursor		'kiasi kidoleni'			'kiasi kilichopo kidoleni')
(getSaturationUnder		'kunyewesha chini'		'kiasi cha kunyewesha chini ya kati yangu')
(getScaleFactor			'kuzidisha kwa'			'kiasi ninachozidishwa nacho')
(getTheta				'theta'					'pemba kwa x-axis')
(getTop					'juu'					'mpaka wa juu')
(getTruncate			'kata'					'kama kukata ama sivyo')
(getUpDown				'juu/chini'				'kiasi cha juu ama cha chini')
(getValueAtCursor		'mchezaji kidoleni'		'mchechazji aliyepo kidoneni')
(getViewingByIcon 		'angalia kwa picha'		'kama vitu vilivyomo ndani huanagaliwa kwa picha ama sivyo')
(getX					'x'						'mahali pa x')
(getY					'y'						'mahali ya y')
(getWidth				'upana'					'upana wangu')) language: #Kiswahili.

	self translateCategories: #(
(basic					muhimu				'mambo muhimu muhimu')
(#'book navigation'		#'kuongoza vitabu'		'kuhusu kuongozea vitabu')
(button					kifungo					'mambo kuhusu vifungo')
(collections				mikusanyo				'kuhusu mikusanyo ya vitu')
(fog					ukungu					'kuhusu ukungu (3D)')
(geometry				kupimia					'urefu na kadhaliki')
(#'color & border'		#'rangi & mpaka'		'kuhusu rangi na mpaka')
(graphics				picha					'mambo kuhusu picha')
(variables				badiliko					'data zilizoundwa na yule atumiaye')
(joystick				#'fimbo la furaha'		'kuhusu fimbo la furaha, yaani "joystick"')
(miscellaneous			mbalimbali				'mambo mbalimbali')
(motion					kusogea					'kwenda, kuegeuka, etc.')
(paintbox				#'kupiga rangi'			'vitu kuhusu kupigia rangi')
(#'pen trails'			#'nyayo za kalamu'		'kuhusu nyay za kalamu')
(#'pen use'				#'kalamu'				'kuhusu kalamu')
(playfield				kiwanja					'vitu kuhusu kiwanjani')
(sampling				kuchagua				'mambo kuhusu kuchagua')
(scripts					taratibu				'taratibu zilizoundwa na atumiaye')
(slider					telezo					'kitu kionyeshacho kiasi cha namba fulani')
(speaker				spika					'kuhusu spika za kelele')
(#'stack navigation'		#'kuongoza chungu'	'kuhusu kuongozea chungu')
(storyboard				kusimulia				'kusimilia hadithi')
(tests					kama					'amua kama hali fulani i kweli ama sivyo')
(text					maneno					'maandiko ya maneno')
(viewing				kuangaliwa				'kuhusu kuangalia vitu')
(vector					vektor					'kuhusu vektor')
) language: #Kiswahili.

self addToTranslationTableFrom: 

#((:						'_'						'tia ndani')
(Incr:					'pamoja na'				'tia thamani + fulani')
(Decr:					'toa'					'tia thamani - fulani')
(Mult:					'mara'					'tia thamani * fulani')) language: #Kiswahili.
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'kfr 12/29/2001 16:20'!
addNorwegianVocabulary
	"Add a Norwegian vocabulary. "

	self translateMethodInterfaceWordings: #(
(append: 'legg til' 'Legg til objektet i mitt innehold')
(beep: 'spill lyd' 'Spill denne lyden')
(bounce: 'sprett' 'sprett bort fra kanten om den treffes')
(cameraPoint 'kameraposisjon' 'kamerans posisjon')
(clear 'rens' 'Rens bort bildet')
(clearOwnersPenTrails 'rens alla pennestrøk' 'Rens bort alle pennestrøk i pennens lekeplass')
(clearTurtleTrails 'rens skilpaddestrøk' 'Rens bort alle skilpaddestrøk på innsiden')
(color:sees: 'farge syns' 'Om valgte farge ser angitt farge')
(deleteCard 'Ta bort kort' 'Ta bort dette kortet')
(doMenuItem: 'utfør menyvalg' 'utfør menyvalget')
(doScript: 'kjør' 'kjør skriptet en gang, ved nesta tick')
(emptyScript 'tomt skript' 'et tomt skript')
(fire 'starta' 'starter alle knapphendelser for dette objektet')
(firstPage 'førsta siden' 'gå till førsta siden')
(followPath 'følg vei' 'følg denne veien')
(forward: 'framover med' 'Flytter objektet framover i objektets nåværende rettning')
(getActWhen 'kjør når' 'Når skriptet skal kjøres')
(getAllButFirstCharacter 'alle uten om førsta' 'Alle mine tegn uten om det første')
(getAmount 'størrelse' 'Forflyttningens størrelse')
(getAngle 'vinkel' 'Vinkelforflyttningens størrelse')
(getBorderColor 'kantfarge' 'Fargen på objektets kant')
(getBorderWidth 'kantbredde' 'Bredden på objektets kant')
(getBottom 'bunn' 'Den nederste kanten')
(getBrightnessUnder 'kontrast' 'Kontrasten under objektets mittpunkt')
(getCharacters 'tegn' 'Tegnet i mitt innehold')
(getColor 'farge' 'Objektets farge')
(getColorUnder 'farge under' 'Fargen under objektets mittpunkt')
(getConePosition 'høytalerposition' 'høytalerens position')
(getCursor 'markør' 'Markørens nåværende position, ombytt til første om det er mulig')
(getDescending 'fallende' 'Sier om den minste verdien er øverst / til venstre (fallende = false) eller nederst / til høyre (fallande = true)')
(getDistance 'avstand' 'Lengden på vektoren mellom utgangspunktet og objektets posisjon')
(getFirstCharacter 'første tegnet' 'Det første tegnet i mitt innehold')
(getFirstElement 'førsta elementet' 'Det førsta objektet i mitt innehold')
(getFogColor 'tåkens farge' 'Fargen på tåken som benyttes')
(getFogDensity 'tåkens tetthet' 'Tettheten på tåken som benyttes')
(getFogRangeEnd 'tåkens intervalslutt' 'Intervalets slutt på tåken som benyttes')
(getFogRangeStart 'tåkens intervalstart' 'Intervalets start på tåken som benyttes')
(getFogType 'tåkens typ' 'Typen av tåke som benyttes')
(getGraphic 'bilde' 'Bildet som bæres av objektet')
(getGraphicAtCursor 'bilde ved markør' 'Bildet som bæres av objektet ved markøren')
(getHeading 'rettning' 'I vilken rettning objektet peker. 0 er rett opp')
(getHeight 'høyde' 'Høyden')
(getHolder 'beholder' 'objektets beholder')
(getIndexInOwner 'elementnummer' 'mitt indeksnummer i min beholdere')
(getIsUnderMouse 'er under muspekeren' 'om objektet befinner seg under muspekeren')
(getKnobColor 'håndtakets farge' 'Håndtakets farge')
(getLabel 'etikett' 'Teksten på knappen')
(getLastValue 'seneste verdi' 'Seneste beregnede verdi')
(getLeft 'venstre' 'Den venstre kanten')
(getLeftRight 'venstre/høyre' 'Horisontel forflyttning')
(getLuminanceUnder 'lysstyrke under' 'Lysstyrken under objektets mittpunkt')
(getMaxVal 'maxverdi' 'Tallet som representerer når håndtaket er lengst til høyre eller lengst ned, den største verdien som håndtaket gir.')
(getMinVal 'minverdi' 'Tallet som representerer når håndtaket er lengst til venstre eller høyest opp, den minste verdien som håndtaket gir.')
(getMouseX 'mus x' 'Muspekerens x-koordinat')
(getMouseY 'mus y' 'Muspekerens y-koordinat')
(getNewClone 'kopia' 'returnerer en kopi av det her objektet')
(getNumberAtCursor 'tall ved markør' 'tallet ved markøren')
(getNumericValue 'numeriskt verdi' 'Et tall som representerer den aktuelle posisjonen av håndtaket.')
(getObtrudes 'stikker ut' 'om objektet stikker ut over beholderens kant')
(getPenColor 'pennefarge' 'fargen på blekket i pennen')
(getPenDown 'pen nedtrykt' 'om pennen er nedtrykt nå')
(getPenSize 'pennens bredde' 'pennens bredde')
(getRight 'høyre' 'Den høyre kanten')
(getRoundedCorners 'rundede hjørner' 'om hjørnene skal være runde')
(getSampleAtCursor 'verdi ved markør' 'Nåværende verdi ved markørens posisjon')
(getSaturationUnder 'mettning under' 'Fargemettning under objektets mittpunkt')
(getScaleFactor 'skala' 'Objektets skala')
(getTheta 'theta' 'Vinkelen mellom den positive x-axelen og vektoren mellom utgangspunktet og objektets posisjon')
(getTop 'toppen' 'Den øverste kanten')
(getTruncate 'heltall' 'Om bare heltall anvendes som verdi, om bråktal ikke er tillatt.')
(getUpDown 'opp/ner' 'Vertikal forflyttning')
(getValueAtCursor 'spiller ved markør' 'objektet ved markøren')
(getViewingByIcon 'normalt synssett' 'Synsettet på inneholdet er normal')
(getWidth 'bredd' 'Bredden')
(getX 'x' 'X-koordinaten')
(getY 'y' 'Y-koordinaten')
(goToFirstCardInBackground 'gå til første i bakgrunnen' 'Gå til det første kortet i den nåværende bakgrunnen')
(goToFirstCardOfStack 'gå til første kortet i stacken' 'Gå til første korten i hele stacken')
(goToLastCardInBackground 'gå til siste kortet i bakgrunnen' 'Gå til det siste kortet i den nåværende bakgrunnen')
(goToLastCardOfStack 'gå til siste kortet i stacken' 'Gå til det siste kortet i hele stacken')
(goToNextCardInStack 'gå till neste kort' 'Gå til neste kort i stacken')
(goToPreviousCardInStack 'gå til forrige kort' 'Gå til det forrige kortet i stacken')
(goToRightOf: 'plassere etter' 'plassere dette objekt til høyre om et annet')
(goto: 'gå til' 'gå til angitt side')
(hide 'gjem' 'gjør objektet usynligt')
(initiatePainting 'begynn malning' 'Begynn malning av et nytt objekt i den vanlige lekeplatsen.')
(insertCard 'legg inn kort' 'Skap et nytt kort')
(lastPage 'siste siden' 'gå til siste siden')
(liftAllPens 'løft alle penner' 'Løft pennene på mitt inneholds alle objekt.')
(loadSineWave 'åpne sinusbølge' 'Åpne en sinusbølge som nåværende graf')
(loadSound: 'åpne lyd' 'Åpne angivet lyd som nåværende lyd')
(lowerAllPens 'senk alle penner' 'Senk pennene på mitt inneholds alle objekt.')
(makeNewDrawingIn: 'bgynn malning i' 'lag en ny malning i angiven lekeplats')
(moveToward: 'flytte mot' 'flytte mot angivet objekt')
(nextPage 'nesta side' 'gå til neste side')
(pauseAll: 'pause alle' 'pause skriptet i objektet och alle dets slekninger')
(pauseScript: 'pause skript' 'pause skriptet')
(play 'spela' 'Spill nåværende graf som en lyd')
(previousPage 'foregående side' 'gå til foregående side')
(removeAll 'ta bort alle' 'Ta bort alle element fra lekeplatsen')
(reverse 'reversere' 'Reversere grafen')
(roundUpStrays 'samle inn bortsprungne' 'Samle inn alle deler utenfor beholderen så at de blir synlige igen.')
(seesColor: 'er over farge' 'om noen del av objektet er over den angitte fargen')
(show 'vise' 'gjør objektet synlig')
(shuffleContents 'blande innehold' 'Blande lekeplatsens innehold')
(stampAndErase 'stemple og forsvinn' 'legg til mitt bilde som tegnestrek och forsvinn')
(startAll: 'start alle' 'start skriptet tickende i objektet och alla dets slekninger.')
(startScript: 'start skript' 'start skriptet tickende')
(stopAll: 'stopp alle' 'gjør skriptet "normalt" i objektet och alla dets slektninger')
(stopScript: 'stopp skript' 'gjør skriptet "normalt" i objektet')
(tellAllSiblings: 'si til slekninger' 'send et meddelende til alla slekninger')
(touchesA: 'rörer' 'Om jeg rörer noe som ser ut som...')
(turn: 'sving med' 'Endre objektets retning med angitt mengde')
(unhideHiddenObjects 'vise alle gjemte objekt' 'Gjør alle gjemte objekt synlige.')
(wearCostumeOf: 'se ut som' 'bær samme drakt som...')
(wrap 'fold over kant' 'fold over kanten om det er passende')) language: #Norsk.

	self translateCategories: #(
(basic					'elementære'				'et antall viktige saker')
(#'book navigation'		'boknavigering'			'saker som har med bøker och stackar å gjøre')
(button					'knapp'					'objektet betraktet som en knapp man kan trykke på')
(collections				'samlinger'				'objektet betraktet som en samling av andre objekt')
(fog					'tåke'					'3-dimensionell tåke')
(geometry				'geometri' 				'verdier og koordinater')
(#'color & border'		'farger & kanter'		'saker som har med farger og kanter på objekt å gjøre')
(graphics				'grafikk'					'objektet betraktat som et bilde')
(#'instance variables'	'instansvariabler'		'instansvariabler tilhørende dette objektet')
(joystick				'joystick	'				'objektet som en joystick')
(miscellaneous			'diverse' 				'diverse kommander')
(motion					'rørelse' 				'saker som har med forflyttning och vridning å gjøre')
(paintbox				'maleskrin'				'malepaletten')
(#'pen trails'			'pennestrøk'				'saker som har med strøk som pennen tegner å gjøre)
(#'pen use'				'pen bruk' 		'bruk av et objekts pen')
(playfield				'lekeplats'					'objektet som beholdere for andre synlige objekt')
(sampling				'prøvetagning'			'prøvetagning')
(scripts					'skript'					'metoder lagt til dette objektet')
(slider					'håndtak'			'nyttige funksjoner for håndtak')
(speaker				'høytaler'				'objektet sett som en høytaler')
(#'stack navigation'		'stacknavigering'		'navigering innen en stack')
(storyboard				'storyboard'				'storyboard')
(tests					'tester'					'for å lage ja/nei tester i script')
(text					'tekst'					'Objektet som tekst')
(viewing				'seer'					'Saker som har med olika seeren å gjøre')
(vector					'vektor'					'Objektet som en vektor')
 ) language: #Norsk.

	self addToTranslationTableFrom: #(
(:						'_'						'gi verdi')
(Incr:					'øke med'			'øka verdi med')
(Decr:					'minske med'			'minske verdi med')
(Mult:					'multiplicera med'			'multiplisere verdi med'')) language: #Norsk! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:46' prior: 35873183!
addNorwegianVocabulary
	"Add a Norwegian vocabulary. "

	self translateMethodInterfaceWordings: #(
(append: 'legg til' 'Legg til objektet i mitt innehold')
(beep: 'spill lyd' 'Spill denne lyden')
(bounce: 'sprett' 'sprett bort fra kanten om den treffes')
(cameraPoint 'kameraposisjon' 'kamerans posisjon')
(clear 'rens' 'Rens bort bildet')
(clearOwnersPenTrails 'rens alla pennestrøk' 'Rens bort alle pennestrøk i pennens lekeplass')
(clearTurtleTrails 'rens skilpaddestrøk' 'Rens bort alle skilpaddestrøk på innsiden')
(color:sees: 'farge syns' 'Om valgte farge ser angitt farge')
(deleteCard 'Ta bort kort' 'Ta bort dette kortet')
(doMenuItem: 'utfør menyvalg' 'utfør menyvalget')
(doScript: 'kjør' 'kjør skriptet en gang, ved nesta tick')
(emptyScript 'tomt skript' 'et tomt skript')
(fire 'starta' 'starter alle knapphendelser for dette objektet')
(firstPage 'førsta siden' 'gå till førsta siden')
(followPath 'følg vei' 'følg denne veien')
(forward: 'framover med' 'Flytter objektet framover i objektets nåværende rettning')
(getActWhen 'kjør når' 'Når skriptet skal kjøres')
(getAllButFirstCharacter 'alle uten om førsta' 'Alle mine tegn uten om det første')
(getAmount 'størrelse' 'Forflyttningens størrelse')
(getAngle 'vinkel' 'Vinkelforflyttningens størrelse')
(getBorderColor 'kantfarge' 'Fargen på objektets kant')
(getBorderWidth 'kantbredde' 'Bredden på objektets kant')
(getBottom 'bunn' 'Den nederste kanten')
(getBrightnessUnder 'kontrast' 'Kontrasten under objektets mittpunkt')
(getCharacters 'tegn' 'Tegnet i mitt innehold')
(getColor 'farge' 'Objektets farge')
(getColorUnder 'farge under' 'Fargen under objektets mittpunkt')
(getConePosition 'høytalerposition' 'høytalerens position')
(getCursor 'markør' 'Markørens nåværende position, ombytt til første om det er mulig')
(getDescending 'fallende' 'Sier om den minste verdien er øverst / til venstre (fallende = false) eller nederst / til høyre (fallande = true)')
(getDistance 'avstand' 'Lengden på vektoren mellom utgangspunktet og objektets posisjon')
(getFirstCharacter 'første tegnet' 'Det første tegnet i mitt innehold')
(getFirstElement 'førsta elementet' 'Det førsta objektet i mitt innehold')
(getFogColor 'tåkens farge' 'Fargen på tåken som benyttes')
(getFogDensity 'tåkens tetthet' 'Tettheten på tåken som benyttes')
(getFogRangeEnd 'tåkens intervalslutt' 'Intervalets slutt på tåken som benyttes')
(getFogRangeStart 'tåkens intervalstart' 'Intervalets start på tåken som benyttes')
(getFogType 'tåkens typ' 'Typen av tåke som benyttes')
(getGraphic 'bilde' 'Bildet som bæres av objektet')
(getGraphicAtCursor 'bilde ved markør' 'Bildet som bæres av objektet ved markøren')
(getHeading 'rettning' 'I vilken rettning objektet peker. 0 er rett opp')
(getHeight 'høyde' 'Høyden')
(getHolder 'beholder' 'objektets beholder')
(getIndexInOwner 'elementnummer' 'mitt indeksnummer i min beholdere')
(getIsUnderMouse 'er under muspekeren' 'om objektet befinner seg under muspekeren')
(getKnobColor 'håndtakets farge' 'Håndtakets farge')
(getLabel 'etikett' 'Teksten på knappen')
(getLastValue 'seneste verdi' 'Seneste beregnede verdi')
(getLeft 'venstre' 'Den venstre kanten')
(getLeftRight 'venstre/høyre' 'Horisontel forflyttning')
(getLuminanceUnder 'lysstyrke under' 'Lysstyrken under objektets mittpunkt')
(getMaxVal 'maxverdi' 'Tallet som representerer når håndtaket er lengst til høyre eller lengst ned, den største verdien som håndtaket gir.')
(getMinVal 'minverdi' 'Tallet som representerer når håndtaket er lengst til venstre eller høyest opp, den minste verdien som håndtaket gir.')
(getMouseX 'mus x' 'Muspekerens x-koordinat')
(getMouseY 'mus y' 'Muspekerens y-koordinat')
(getNewClone 'kopia' 'returnerer en kopi av det her objektet')
(getNumberAtCursor 'tall ved markør' 'tallet ved markøren')
(getNumericValue 'numeriskt verdi' 'Et tall som representerer den aktuelle posisjonen av håndtaket.')
(getObtrudes 'stikker ut' 'om objektet stikker ut over beholderens kant')
(getPenColor 'pennefarge' 'fargen på blekket i pennen')
(getPenDown 'pen nedtrykt' 'om pennen er nedtrykt nå')
(getPenSize 'pennens bredde' 'pennens bredde')
(getRight 'høyre' 'Den høyre kanten')
(getRoundedCorners 'rundede hjørner' 'om hjørnene skal være runde')
(getSampleAtCursor 'verdi ved markør' 'Nåværende verdi ved markørens posisjon')
(getSaturationUnder 'mettning under' 'Fargemettning under objektets mittpunkt')
(getScaleFactor 'skala' 'Objektets skala')
(getTheta 'theta' 'Vinkelen mellom den positive x-axelen og vektoren mellom utgangspunktet og objektets posisjon')
(getTop 'toppen' 'Den øverste kanten')
(getTruncate 'heltall' 'Om bare heltall anvendes som verdi, om bråktal ikke er tillatt.')
(getUpDown 'opp/ner' 'Vertikal forflyttning')
(getValueAtCursor 'spiller ved markør' 'objektet ved markøren')
(getViewingByIcon 'normalt synssett' 'Synsettet på inneholdet er normal')
(getWidth 'bredd' 'Bredden')
(getX 'x' 'X-koordinaten')
(getY 'y' 'Y-koordinaten')
(goToFirstCardInBackground 'gå til første i bakgrunnen' 'Gå til det første kortet i den nåværende bakgrunnen')
(goToFirstCardOfStack 'gå til første kortet i stacken' 'Gå til første korten i hele stacken')
(goToLastCardInBackground 'gå til siste kortet i bakgrunnen' 'Gå til det siste kortet i den nåværende bakgrunnen')
(goToLastCardOfStack 'gå til siste kortet i stacken' 'Gå til det siste kortet i hele stacken')
(goToNextCardInStack 'gå till neste kort' 'Gå til neste kort i stacken')
(goToPreviousCardInStack 'gå til forrige kort' 'Gå til det forrige kortet i stacken')
(goToRightOf: 'plassere etter' 'plassere dette objekt til høyre om et annet')
(goto: 'gå til' 'gå til angitt side')
(hide 'gjem' 'gjør objektet usynligt')
(initiatePainting 'begynn malning' 'Begynn malning av et nytt objekt i den vanlige lekeplatsen.')
(insertCard 'legg inn kort' 'Skap et nytt kort')
(lastPage 'siste siden' 'gå til siste siden')
(liftAllPens 'løft alle penner' 'Løft pennene på mitt inneholds alle objekt.')
(loadSineWave 'åpne sinusbølge' 'Åpne en sinusbølge som nåværende graf')
(loadSound: 'åpne lyd' 'Åpne angivet lyd som nåværende lyd')
(lowerAllPens 'senk alle penner' 'Senk pennene på mitt inneholds alle objekt.')
(makeNewDrawingIn: 'bgynn malning i' 'lag en ny malning i angiven lekeplats')
(moveToward: 'flytte mot' 'flytte mot angivet objekt')
(nextPage 'nesta side' 'gå til neste side')
(pauseAll: 'pause alle' 'pause skriptet i objektet och alle dets slekninger')
(pauseScript: 'pause skript' 'pause skriptet')
(play 'spela' 'Spill nåværende graf som en lyd')
(previousPage 'foregående side' 'gå til foregående side')
(removeAll 'ta bort alle' 'Ta bort alle element fra lekeplatsen')
(reverse 'reversere' 'Reversere grafen')
(roundUpStrays 'samle inn bortsprungne' 'Samle inn alle deler utenfor beholderen så at de blir synlige igen.')
(seesColor: 'er over farge' 'om noen del av objektet er over den angitte fargen')
(show 'vise' 'gjør objektet synlig')
(shuffleContents 'blande innehold' 'Blande lekeplatsens innehold')
(stampAndErase 'stemple og forsvinn' 'legg til mitt bilde som tegnestrek och forsvinn')
(startAll: 'start alle' 'start skriptet tickende i objektet och alla dets slekninger.')
(startScript: 'start skript' 'start skriptet tickende')
(stopAll: 'stopp alle' 'gjør skriptet "normalt" i objektet och alla dets slektninger')
(stopScript: 'stopp skript' 'gjør skriptet "normalt" i objektet')
(tellAllSiblings: 'si til slekninger' 'send et meddelende til alla slekninger')
(touchesA: 'rörer' 'Om jeg rörer noe som ser ut som...')
(turn: 'sving med' 'Endre objektets retning med angitt mengde')
(unhideHiddenObjects 'vise alle gjemte objekt' 'Gjør alle gjemte objekt synlige.')
(wearCostumeOf: 'se ut som' 'bær samme drakt som...')
(wrap 'fold over kant' 'fold over kanten om det er passende')) language: #Norsk.

	self translateCategories: #(
(basic					'elementære'				'et antall viktige saker')
(#'book navigation'		'boknavigering'			'saker som har med bøker och stackar å gjøre')
(button					'knapp'					'objektet betraktet som en knapp man kan trykke på')
(collections				'samlinger'				'objektet betraktet som en samling av andre objekt')
(fog					'tåke'					'3-dimensionell tåke')
(geometry				'geometri' 				'verdier og koordinater')
(#'color & border'		'farger & kanter'		'saker som har med farger og kanter på objekt å gjøre')
(graphics				'grafikk'					'objektet betraktat som et bilde')
(variables				'instansvariabler'		'instansvariabler tilhørende dette objektet')
(joystick				'joystick	'				'objektet som en joystick')
(miscellaneous			'diverse' 				'diverse kommander')
(motion					'rørelse' 				'saker som har med forflyttning och vridning å gjøre')
(paintbox				'maleskrin'				'malepaletten')
(#'pen trails'			'pennestrøk'				'saker som har med strøk som pennen tegner å gjøre)
(#'pen use'				'pen bruk' 		'bruk av et objekts pen')
(playfield				'lekeplats'					'objektet som beholdere for andre synlige objekt')
(sampling				'prøvetagning'			'prøvetagning')
(scripts					'skript'					'metoder lagt til dette objektet')
(slider					'håndtak'			'nyttige funksjoner for håndtak')
(speaker				'høytaler'				'objektet sett som en høytaler')
(#'stack navigation'		'stacknavigering'		'navigering innen en stack')
(storyboard				'storyboard'				'storyboard')
(tests					'tester'					'for å lage ja/nei tester i script')
(text					'tekst'					'Objektet som tekst')
(viewing				'seer'					'Saker som har med olika seeren å gjøre')
(vector					'vektor'					'Objektet som en vektor')
 ) language: #Norsk.

	self addToTranslationTableFrom: #(
(:						'_'						'gi verdi')
(Incr:					'øke med'			'øka verdi med')
(Decr:					'minske med'			'minske verdi med')
(Mult:					'multiplicera med'			'multiplisere verdi med'')) language: #Norsk! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'ls 3/20/2004 14:37' prior: 35883167!
addNorwegianVocabulary
	"Add a Norwegian vocabulary. "

	self translateMethodInterfaceWordings: #(
(append: 'legg til' 'Legg til objektet i mitt innehold')
(beep: 'spill lyd' 'Spill denne lyden')
(bounce: 'sprett' 'sprett bort fra kanten om den treffes')
(cameraPoint 'kameraposisjon' 'kamerans posisjon')
(clear 'rens' 'Rens bort bildet')
(clearOwnersPenTrails 'rens alla pennestrøk' 'Rens bort alle pennestrøk i pennens lekeplass')
(clearTurtleTrails 'rens skilpaddestrøk' 'Rens bort alle skilpaddestrøk på innsiden')
(color:sees: 'farge syns' 'Om valgte farge ser angitt farge')
(deleteCard 'Ta bort kort' 'Ta bort dette kortet')
(doMenuItem: 'utfør menyvalg' 'utfør menyvalget')
(doScript: 'kjør' 'kjør skriptet en gang, ved nesta tick')
(emptyScript 'tomt skript' 'et tomt skript')
(fire 'starta' 'starter alle knapphendelser for dette objektet')
(firstPage 'førsta siden' 'gå till førsta siden')
(followPath 'følg vei' 'følg denne veien')
(forward: 'framover med' 'Flytter objektet framover i objektets nåværende rettning')
(getActWhen 'kjør når' 'Når skriptet skal kjøres')
(getAllButFirstCharacter 'alle uten om førsta' 'Alle mine tegn uten om det første')
(getAmount 'størrelse' 'Forflyttningens størrelse')
(getAngle 'vinkel' 'Vinkelforflyttningens størrelse')
(getBorderColor 'kantfarge' 'Fargen på objektets kant')
(getBorderWidth 'kantbredde' 'Bredden på objektets kant')
(getBottom 'bunn' 'Den nederste kanten')
(getBrightnessUnder 'kontrast' 'Kontrasten under objektets mittpunkt')
(getCharacters 'tegn' 'Tegnet i mitt innehold')
(getColor 'farge' 'Objektets farge')
(getColorUnder 'farge under' 'Fargen under objektets mittpunkt')
(getConePosition 'høytalerposition' 'høytalerens position')
(getCursor 'markør' 'Markørens nåværende position, ombytt til første om det er mulig')
(getDescending 'fallende' 'Sier om den minste verdien er øverst / til venstre (fallende = false) eller nederst / til høyre (fallande = true)')
(getDistance 'avstand' 'Lengden på vektoren mellom utgangspunktet og objektets posisjon')
(getFirstCharacter 'første tegnet' 'Det første tegnet i mitt innehold')
(getFirstElement 'førsta elementet' 'Det førsta objektet i mitt innehold')
(getFogColor 'tåkens farge' 'Fargen på tåken som benyttes')
(getFogDensity 'tåkens tetthet' 'Tettheten på tåken som benyttes')
(getFogRangeEnd 'tåkens intervalslutt' 'Intervalets slutt på tåken som benyttes')
(getFogRangeStart 'tåkens intervalstart' 'Intervalets start på tåken som benyttes')
(getFogType 'tåkens typ' 'Typen av tåke som benyttes')
(getGraphic 'bilde' 'Bildet som bæres av objektet')
(getGraphicAtCursor 'bilde ved markør' 'Bildet som bæres av objektet ved markøren')
(getHeading 'rettning' 'I vilken rettning objektet peker. 0 er rett opp')
(getHeight 'høyde' 'Høyden')
(getHolder 'beholder' 'objektets beholder')
(getIndexInOwner 'elementnummer' 'mitt indeksnummer i min beholdere')
(getIsUnderMouse 'er under muspekeren' 'om objektet befinner seg under muspekeren')
(getKnobColor 'håndtakets farge' 'Håndtakets farge')
(getLabel 'etikett' 'Teksten på knappen')
(getLastValue 'seneste verdi' 'Seneste beregnede verdi')
(getLeft 'venstre' 'Den venstre kanten')
(getLeftRight 'venstre/høyre' 'Horisontel forflyttning')
(getLuminanceUnder 'lysstyrke under' 'Lysstyrken under objektets mittpunkt')
(getMaxVal 'maxverdi' 'Tallet som representerer når håndtaket er lengst til høyre eller lengst ned, den største verdien som håndtaket gir.')
(getMinVal 'minverdi' 'Tallet som representerer når håndtaket er lengst til venstre eller høyest opp, den minste verdien som håndtaket gir.')
(getMouseX 'mus x' 'Muspekerens x-koordinat')
(getMouseY 'mus y' 'Muspekerens y-koordinat')
(getNewClone 'kopia' 'returnerer en kopi av det her objektet')
(getNumberAtCursor 'tall ved markør' 'tallet ved markøren')
(getNumericValue 'numeriskt verdi' 'Et tall som representerer den aktuelle posisjonen av håndtaket.')
(getObtrudes 'stikker ut' 'om objektet stikker ut over beholderens kant')
(getPenColor 'pennefarge' 'fargen på blekket i pennen')
(getPenDown 'pen nedtrykt' 'om pennen er nedtrykt nå')
(getPenSize 'pennens bredde' 'pennens bredde')
(getRight 'høyre' 'Den høyre kanten')
(getRoundedCorners 'rundede hjørner' 'om hjørnene skal være runde')
(getSampleAtCursor 'verdi ved markør' 'Nåværende verdi ved markørens posisjon')
(getSaturationUnder 'mettning under' 'Fargemettning under objektets mittpunkt')
(getScaleFactor 'skala' 'Objektets skala')
(getTheta 'theta' 'Vinkelen mellom den positive x-axelen og vektoren mellom utgangspunktet og objektets posisjon')
(getTop 'toppen' 'Den øverste kanten')
(getTruncate 'heltall' 'Om bare heltall anvendes som verdi, om bråktal ikke er tillatt.')
(getUpDown 'opp/ner' 'Vertikal forflyttning')
(getValueAtCursor 'spiller ved markør' 'objektet ved markøren')
(getViewingByIcon 'normalt synssett' 'Synsettet på inneholdet er normal')
(getWidth 'bredd' 'Bredden')
(getX 'x' 'X-koordinaten')
(getY 'y' 'Y-koordinaten')
(goToFirstCardInBackground 'gå til første i bakgrunnen' 'Gå til det første kortet i den nåværende bakgrunnen')
(goToFirstCardOfStack 'gå til første kortet i stacken' 'Gå til første korten i hele stacken')
(goToLastCardInBackground 'gå til siste kortet i bakgrunnen' 'Gå til det siste kortet i den nåværende bakgrunnen')
(goToLastCardOfStack 'gå til siste kortet i stacken' 'Gå til det siste kortet i hele stacken')
(goToNextCardInStack 'gå till neste kort' 'Gå til neste kort i stacken')
(goToPreviousCardInStack 'gå til forrige kort' 'Gå til det forrige kortet i stacken')
(goToRightOf: 'plassere etter' 'plassere dette objekt til høyre om et annet')
(goto: 'gå til' 'gå til angitt side')
(hide 'gjem' 'gjør objektet usynligt')
(initiatePainting 'begynn malning' 'Begynn malning av et nytt objekt i den vanlige lekeplatsen.')
(insertCard 'legg inn kort' 'Skap et nytt kort')
(lastPage 'siste siden' 'gå til siste siden')
(liftAllPens 'løft alle penner' 'Løft pennene på mitt inneholds alle objekt.')
(loadSineWave 'åpne sinusbølge' 'Åpne en sinusbølge som nåværende graf')
(loadSound: 'åpne lyd' 'Åpne angivet lyd som nåværende lyd')
(lowerAllPens 'senk alle penner' 'Senk pennene på mitt inneholds alle objekt.')
(makeNewDrawingIn: 'bgynn malning i' 'lag en ny malning i angiven lekeplats')
(moveToward: 'flytte mot' 'flytte mot angivet objekt')
(nextPage 'nesta side' 'gå til neste side')
(pauseAll: 'pause alle' 'pause skriptet i objektet och alle dets slekninger')
(pauseScript: 'pause skript' 'pause skriptet')
(play 'spela' 'Spill nåværende graf som en lyd')
(previousPage 'foregående side' 'gå til foregående side')
(removeAll 'ta bort alle' 'Ta bort alle element fra lekeplatsen')
(reverse 'reversere' 'Reversere grafen')
(roundUpStrays 'samle inn bortsprungne' 'Samle inn alle deler utenfor beholderen så at de blir synlige igen.')
(seesColor: 'er over farge' 'om noen del av objektet er over den angitte fargen')
(show 'vise' 'gjør objektet synlig')
(shuffleContents 'blande innehold' 'Blande lekeplatsens innehold')
(stampAndErase 'stemple og forsvinn' 'legg til mitt bilde som tegnestrek och forsvinn')
(startAll: 'start alle' 'start skriptet tickende i objektet och alla dets slekninger.')
(startScript: 'start skript' 'start skriptet tickende')
(stopAll: 'stopp alle' 'gjør skriptet "normalt" i objektet och alla dets slektninger')
(stopScript: 'stopp skript' 'gjør skriptet "normalt" i objektet')
(tellAllSiblings: 'si til slekninger' 'send et meddelende til alla slekninger')
(touchesA: 'rörer' 'Om jeg rörer noe som ser ut som...')
(turn: 'sving med' 'Endre objektets retning med angitt mengde')
(unhideHiddenObjects 'vise alle gjemte objekt' 'Gjør alle gjemte objekt synlige.')
(wearCostumeOf: 'se ut som' 'bær samme drakt som...')
(wrap 'fold over kant' 'fold over kanten om det er passende')) language: #Norsk.

	self translateCategories: #(
(basic					'elementære'				'et antall viktige saker')
(#'book navigation'		'boknavigering'			'saker som har med bøker och stackar å gjøre')
(button					'knapp'					'objektet betraktet som en knapp man kan trykke på')
(collections				'samlinger'				'objektet betraktet som en samling av andre objekt')
(fog					'tåke'					'3-dimensionell tåke')
(geometry				'geometri' 				'verdier og koordinater')
(#'color & border'		'farger & kanter'		'saker som har med farger og kanter på objekt å gjøre')
(graphics				'grafikk'					'objektet betraktat som et bilde')
(variables				'instansvariabler'		'instansvariabler tilhørende dette objektet')
(joystick				'joystick	'				'objektet som en joystick')
(miscellaneous			'diverse' 				'diverse kommander')
(motion					'rørelse' 				'saker som har med forflyttning och vridning å gjøre')
(paintbox				'maleskrin'				'malepaletten')
(#'pen trails'			'pennestrøk'				'saker som har med strøk som pennen tegner å gjøre')
(#'pen use'				'pen bruk' 		'bruk av et objekts pen')
(playfield				'lekeplats'					'objektet som beholdere for andre synlige objekt')
(sampling				'prøvetagning'			'prøvetagning')
(scripts					'skript'					'metoder lagt til dette objektet')
(slider					'håndtak'			'nyttige funksjoner for håndtak')
(speaker				'høytaler'				'objektet sett som en høytaler')
(#'stack navigation'		'stacknavigering'		'navigering innen en stack')
(storyboard				'storyboard'				'storyboard')
(tests					'tester'					'for å lage ja/nei tester i script')
(text					'tekst'					'Objektet som tekst')
(viewing				'seer'					'Saker som har med olika seeren å gjøre')
(vector					'vektor'					'Objektet som en vektor')
 ) language: #Norsk.

	self addToTranslationTableFrom: #(
(:						'_'						'gi verdi')
(Incr:					'øke med'			'øka verdi med')
(Decr:					'minske med'			'minske verdi med')
(Mult:					'multiplicera med'			'multiplisere verdi med')) language: #Norsk! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/28/2002 16:23'!
addSpanishVocabulary

   "'Español' translation by Diego Gómez Deck and Germán Morales"
   " á é í ó ú ñ Ñ "

   self translateMethodInterfaceWordings: #(
(append:                   'agregar al final'                    'Agregar el objeto a mi contenido, poniéndolo después de todos los otros objetos actualmente contenidos por mi')
(beep:                     'sonar'                               'Reproducir el sonido especificado')
(bounce:                   'rebotar'                             'Rebotar si toca el borde')
(cameraPoint               'punto de la cámara'                  'El punto de la cámara')
(clear                     'limpiar'                             'Limpia el gráfico del contenido actual')
(clearOwnersPenTrails      'limpiar todos los rastros del lápiz'       'Limpiar todos los rastros del lápiz en mi contenedor')
(clearTurtleTrails         'limpiar los rastros del lápiz'       'Limpiar los rastros del lápiz en el interior')
(color:sees:               'color ve'                            'Si el color dado ve el otro color')
(deleteCard                'borrar tarjeta'                      'Borrar la tarjeta actual')
(doMenuItem:               'realizar la opción del menú'         'Realizar la opción del menú')
(doScript:                 'realizar'                            'Realizar el guión dado una vez, en el próximo instante')
(emptyScript               'guión vacío'                         'Un guión vacío')
(fire                      'activar'                             'Activar todas y cada una de las acciones del botón de este objeto')
(firstPage                 'primera página'                      'Ir a la primera página')
(followPath                'seguir el camino'                    'Seguir el camino')
(forward:                  'avanzar'                             'Mover el objeto hacia adelante en la dirección del objeto')
(getActWhen                'activar cuando'                      'Cuando se debe activar el guión')
(getAllButFirstCharacter   'todos excepto el primero'            'Todos mis caracteres excepto el primero')
(getAmount                 'desplazamiento'                      'La cantidad de desplazamiento')
(getAngle                  'ángulo'                              'El desplazamiento angular')
(getBorderColor            'color del borde'                     'El color del borde del objeto')
(getBorderWidth            'ancho del borde'                     'El ancho del borde del objeto')
(getBottom                 'abajo'                               'El borde de abajo')
(getBrightnessUnder        'brillo debajo'                       'El brillo debajo del centro del objeto')
(getCharacters             'caracteres'                          'Los caracteres en mi contenido')
(getColor                  'color'                               'El color del objeto')
(getColorUnder             'color debajo'                        'El color debajo del centro del objeto')
(getConePosition           'posición del cono'                   'La posición del cono del altavoz')
(getCursor                 'cursor'                              'La posición actual del cursor, trasladado al principio si es apropiado')
(getDescending             'descendiente'                        'Verdadero si el menor valor está arriba o a la izquierda, falso si está abajo o a la derecha')
(getDistance               'distancia'                           'El largo del vector que conecta el origen a la posición del objeto')
(getFirstCharacter         'primer caracter'                     'El primer caracter de mi contenido')
(getFirstElement           'primer elemento'                     'El primer objeto de mi contenido')
(getFogColor               'color de la niebla'                  'El color de la niebla que se está aplicando')
(getFogDensity             'intensidad de la niebla'             'La intensidad de la niebla que se está aplicando')
(getFogRangeEnd            'niebla hasta'                        'Hasta donde se aplica la niebla')
(getFogRangeStart          'niebla desde'                        'Desde donde se aplica la niebla')
(getFogType                'tipo de niebla'                      'El tipo de la niebla que se está aplicando')
(getGraphic                'gráfico'                             'El gráfico usado actualmente')
(getGraphicAtCursor        'gráfico en el cursor'                'El gráfico usado por el objeto en el cursor')
(getHeading                'dirección'                           'En que dirección está mirando el objeto. Cero significa hacia arriba')
(getHeight                 'altura'                              'La altura del objeto')
(getHolder                 'contenedor'                          'El contenedor del objeto')
(getIndexInOwner           'número de elemento'                     'Mi número dentro de mi contenedor')
(getIsUnderMouse           'debajo del ratón'                    'Si el objeto está debajo de la posición actual del ratón')
(getKnobColor              'color de la perilla'                 'El color del deslizador')
(getLabel                  'etiqueta'                            'La etiqueta del botón')
(getLastValue              'último valor'                        'El último valor obtenido')
(getLeft                   'izquierda'                           'El borde de la izquierda')
(getLeftRight              'desplazamiento izquierda - derecha'  'El desplazamiento horizontal')
(getLuminanceUnder         'luminiscencia debajo'                'La luminiscencia debajo del centro del objeto')
(getMaxVal                 'máximo valor'                        'El número representado cuando la perilla está a la derecha o abajo del deslizador. Este es el máximo valor devuelto por el deslizador')
(getMinVal                 'mínimo valor'                        'El número representado cuando la perilla está a la izquierda o arriba  del deslizador. Este es el mínimo valor devuelto por el deslizador')
(getMouseX                 'x del ratón'                         'La coordenada X del puntero del ratón')
(getMouseY                 'y del ratón'                         'La coordenada Y del puntero del ratón')
(getNewClone               'copiar'                              'Devuelve una copia de este objeto')
(getNumberAtCursor         'número en el cursor'                 'El número en el cursor')
(getNumericValue           'valor numérico'                      'Un número representando la posición actual de la perilla')
(getObtrudes               'sobresale'                         'Si el objeto sobresale de los bordes de su contenedor')
(getPenColor               'color del lápiz'                     'El color del lápiz')
(getPenDown                'lápiz bajo'                          'Si el lápiz está bajo')
(getPenSize                'tamaño del lápiz'                    'El ancho del lápiz')
(getRight                  'derecha'                             'El borde derecho')
(getRoundedCorners         'esquinas redondeadas'                'Si las esquinas deberían ser redondeadas')
(getSampleAtCursor         'muestra en el cursor'                'El valor de la muestra en la posición actual del cursor')
(getSaturationUnder        'saturación debajo'                   'La saturación debajo del centro del objeto')
(getScaleFactor            'factor de escala'                    'El factor de escala por el cual el objeto es magnificado')
(getTheta                  'theta'                               'El ángulo entre el eje X positivo y el vector que conecta el origen a la posición del objeto')
(getTop                    'arriba'                              'El borde de arriba')
(getTruncate               'truncado'                            'Si es verdadero, solo números son usados como valores; si es falso, valores fraccionarios son permitidos')
(getUpDown                 'desplazamiento arriba - abajo'       'El desplazamiento vertical')
(getValueAtCursor          'objeto en el cursor'                 'El objeto actualmente en el cursor')
(getViewingByIcon          'vista normal'                        'Si los contenidos son vistos normalmente')
(getWidth                  'ancho'                               'El ancho')
(getX                      'x'                                   'La coordenada X')
(getY                      'y'                                   'La coordenada Y')
(goToFirstCardInBackground 'ir a la primera tarjeta del fondo'   'Ir a la primera tarjeta del fondo actual')
(goToFirstCardOfStack      'ir a la primera tarjeta de la pila'  'Ir a la primera tarjeta de la pila completa')
(goToLastCardInBackground  'ir a la última tarjeta del fondo'    'Ir a la última tarjeta del fondo actual')
(goToLastCardOfStack       'ir a la última tarjeta de la pila'   'Ir a la última tarjeta de la pila completa')
(goToNextCardInStack       'ir a la próxima tarjeta de la pila'  'Ir a la próxima tarjeta')
(goToPreviousCardInStack   'ir a la anterior tarjeta de la pila' 'Ir a la anterior tarjeta')
(goToRightOf:              'alinear después de'                     'Ubicar este objeto a la derecha de otro')
(goto:                     'ir a'                                'Ir a la página dada')
(hide                      'ocultar'                             'Hacer invisible al objeto')
(include:                  'incluir'                             'Agregar el objeto a mi contenido')
(initiatePainting          'iniciar pintado'                     'Iniciar el pintado de nuevos objetos en el campo de juegos estandar')
(insertCard                'insertar nueva tarjeta'              'Insertar una nueva tarjeta')
(lastPage                  'última página'                       'Ir a la última página')
(liftAllPens               'levantar todos los lápices'          'Levantar los lápices de todos los objetos en mi interior')
(loadSineWave              'cargar forma de onda senoidal'       'Cargar una forma de onda senoidal como el gráfico actual')
(loadSound:                'cargar sonido'                       'Cargar el sonido especificado dentro del gráfico actual')
(lowerAllPens              'bajar todos los lápices'             'Bajar los lápices de todos los objetos en mi interior')
(makeNewDrawingIn:         'empezar pintado en'                  'Crear un nuevo dibujo en el campo de juegos especificado')
(moveToward:               'mover hacia'                         'Mover hacia el objeto dado')
(nextPage                  'próxima página'                      'Ir a la próxima página')
(pauseAll:                 'pausar todo'                         'Hacer que todos los guiones se pausen en el objeto y en todos sus hermanos')
(pauseScript:              'pausar guión'                        'Hacer que se pause el guión dado')
(play                      'reproducir'                          'Reproducir el gráfico actual como un sonido')
(prepend:                  'agregar adelante'                    'Agregar el objeto a mi contenido, poniéndolo antes que todos los otros objetos actualmente contenidos por mi')
(previousPage              'página anterior'                     'Ir a la página anterior')
(removeAll                 'remover todo'                        'Remover todos los elementos del campo de juegos')
(reverse                   'invertir'                            'Invertir el gráfico')
(roundUpStrays             'reunir perdidos'                       'Traer todas las partes fuera del contenedor nuevamente a la vista')
(seesColor:                'sobre color'                         'Si alguna parte del objeto esta sobre el color dado')
(show                      'mostrar'                             'Hacer visible el objeto')
(shuffleContents           'mezclar el contenido'                'Mezclar el contenido del campo de juegos')
(stampAndErase             'estampar y borrar'                   'Estampar mi imagen al rastro del lápiz y salir')
(startAll:                 'comenzar todo'                       'Comenzar el latido del guión en el objeto y en todos sus hermanos')
(startScript:              'comenzar guión'                      'Comenzar el latido del guión dado')
(stopAll:                  'parar todos'                         'Hacer que el estado del guión dado sea "normal" en el objeto y en todos sus hermanos')
(stopScript:               'detener guión'                         'Hacer que el estado del guión dado sea "normal"')
(tellAllSiblings:          'decir a todos los hermanos'          'Enviar un mensaje a todos los hermanos')
(touchesA:                 'toca un'                             'Si toco algo que parece como...')
(turn:                     'girar'                               'Cambiar la dirección del objeto en la cantidad especificada')
(unhideHiddenObjects       'mostrar objetos ocultos'             'Mostrar todos los objetos ocultos')
(wearCostumeOf:            'lucir como'                          'Usar el traje de...')

(wrap                      'ajusta'                                'traslada al otro borde si es apropiado')
(penArrowheads             'puntas de flecha en el lápiz'        'Si muestra puntas de flecha al final de cada trazo del lápiz')
(dropShadow                'sombra'                              'Si muestra la sombra')
(shadowColor               'color de la sombra'                  'Color de la sombra')
(clipSubmorphs             'cortar submorphs'                    'Si cortar o no mis submorphs')

) language: #'Español'.

   self translateCategories: #(
(basic                 'básico'                 'Unas pocas cosas importantes')
(#'book navigation'    'navegacion del libro'   'Relativo a libros, pilas, etc.')
(button                'botón'                  'Para pensar este objeto como un botón')
(collections           'colecciones'            'Para pensar este objeto como una colección')
(fog                   'niebla'                 'Niebla 3D')
(geometry              'geometría'              'Medidas y coordenadas')
(#'color & border'     'color y borde'          'Asuntos relacionados con colores y bordes de objetos')
(graphics              'gráficos'               'Para pensar este objeto como una imagen')
(#'instance variables' 'variables de instancia' 'Variables de instancia agregadas por este objeto')
(joystick              'joystick'               'El objeto como un Joystick')
(miscellaneous         'misceláneo'             'Comandos varios')
(scripting             'guiones'                'Comandos para  comenzar y parar guiones, etc.')
(motion                'movimiento'             'Asuntos relacionados con el movimiento y el giro')
(paintbox              'paleta de pintor'       'La paleta del pintor')
(#'pen trails'         'rastros del lápiz'      'Relacionados a los rastros dejados por los lápices')
(#'pen use'            'uso del lápiz'          'Uso del lápiz del objeto')
(playfield             'campo de juegos'        'El objeto como un contenedor para otros objetos visibles')
(sampling              'muestreo'               'Muestreo')
(scripts               'guiones'                'Guiones agregados por este objeto')
(slider                'deslizador'             'Funciones útiles para deslizadores')
(speaker               'altavoz'                'El objeto como un altavoz de audio')
(#'stack navigation'   'navegación de pila'     'Navegación dentro de una pila')
(storyboard            'pizarra de historia'    'Pizarra de historia')
(tests                 'pruebas'                'Pruebas por verdadero/falso, para usar en cuadros de "Prueba" de guiones')
(text                  'texto'                  'El objeto como texto')
(viewing               'visualización'          'Asuntos relacionados a visualización')
(vector                'vector'                 'El objeto como un vector')
(layout                'disposición'            'Disposición de los objetos contenidos')
(#'drag & drop'        'arrastrar y soltar'     'Arrastrar y soltar')
(observation           'observación'            'Observación')

 ) language: #'Español'.

        self addToTranslationTableFrom: #(
(:                                                '_'                                                'asignar el valor')
(Incr: 'incrementar por' 'incrementar el valor por')
(Decr: 'reducir por' 'reducir el valor por')
(Mult: 'multiplicar por' 'multiplicar el valor por')) language: #'Español'
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:46' prior: 35903255!
addSpanishVocabulary

   "'Español' translation by Diego Gómez Deck and Germán Morales"
   " á é í ó ú ñ Ñ "

   self translateMethodInterfaceWordings: #(
(append:                   'agregar al final'                    'Agregar el objeto a mi contenido, poniéndolo después de todos los otros objetos actualmente contenidos por mi')
(beep:                     'sonar'                               'Reproducir el sonido especificado')
(bounce:                   'rebotar'                             'Rebotar si toca el borde')
(cameraPoint               'punto de la cámara'                  'El punto de la cámara')
(clear                     'limpiar'                             'Limpia el gráfico del contenido actual')
(clearOwnersPenTrails      'limpiar todos los rastros del lápiz'       'Limpiar todos los rastros del lápiz en mi contenedor')
(clearTurtleTrails         'limpiar los rastros del lápiz'       'Limpiar los rastros del lápiz en el interior')
(color:sees:               'color ve'                            'Si el color dado ve el otro color')
(deleteCard                'borrar tarjeta'                      'Borrar la tarjeta actual')
(doMenuItem:               'realizar la opción del menú'         'Realizar la opción del menú')
(doScript:                 'realizar'                            'Realizar el guión dado una vez, en el próximo instante')
(emptyScript               'guión vacío'                         'Un guión vacío')
(fire                      'activar'                             'Activar todas y cada una de las acciones del botón de este objeto')
(firstPage                 'primera página'                      'Ir a la primera página')
(followPath                'seguir el camino'                    'Seguir el camino')
(forward:                  'avanzar'                             'Mover el objeto hacia adelante en la dirección del objeto')
(getActWhen                'activar cuando'                      'Cuando se debe activar el guión')
(getAllButFirstCharacter   'todos excepto el primero'            'Todos mis caracteres excepto el primero')
(getAmount                 'desplazamiento'                      'La cantidad de desplazamiento')
(getAngle                  'ángulo'                              'El desplazamiento angular')
(getBorderColor            'color del borde'                     'El color del borde del objeto')
(getBorderWidth            'ancho del borde'                     'El ancho del borde del objeto')
(getBottom                 'abajo'                               'El borde de abajo')
(getBrightnessUnder        'brillo debajo'                       'El brillo debajo del centro del objeto')
(getCharacters             'caracteres'                          'Los caracteres en mi contenido')
(getColor                  'color'                               'El color del objeto')
(getColorUnder             'color debajo'                        'El color debajo del centro del objeto')
(getConePosition           'posición del cono'                   'La posición del cono del altavoz')
(getCursor                 'cursor'                              'La posición actual del cursor, trasladado al principio si es apropiado')
(getDescending             'descendiente'                        'Verdadero si el menor valor está arriba o a la izquierda, falso si está abajo o a la derecha')
(getDistance               'distancia'                           'El largo del vector que conecta el origen a la posición del objeto')
(getFirstCharacter         'primer caracter'                     'El primer caracter de mi contenido')
(getFirstElement           'primer elemento'                     'El primer objeto de mi contenido')
(getFogColor               'color de la niebla'                  'El color de la niebla que se está aplicando')
(getFogDensity             'intensidad de la niebla'             'La intensidad de la niebla que se está aplicando')
(getFogRangeEnd            'niebla hasta'                        'Hasta donde se aplica la niebla')
(getFogRangeStart          'niebla desde'                        'Desde donde se aplica la niebla')
(getFogType                'tipo de niebla'                      'El tipo de la niebla que se está aplicando')
(getGraphic                'gráfico'                             'El gráfico usado actualmente')
(getGraphicAtCursor        'gráfico en el cursor'                'El gráfico usado por el objeto en el cursor')
(getHeading                'dirección'                           'En que dirección está mirando el objeto. Cero significa hacia arriba')
(getHeight                 'altura'                              'La altura del objeto')
(getHolder                 'contenedor'                          'El contenedor del objeto')
(getIndexInOwner           'número de elemento'                     'Mi número dentro de mi contenedor')
(getIsUnderMouse           'debajo del ratón'                    'Si el objeto está debajo de la posición actual del ratón')
(getKnobColor              'color de la perilla'                 'El color del deslizador')
(getLabel                  'etiqueta'                            'La etiqueta del botón')
(getLastValue              'último valor'                        'El último valor obtenido')
(getLeft                   'izquierda'                           'El borde de la izquierda')
(getLeftRight              'desplazamiento izquierda - derecha'  'El desplazamiento horizontal')
(getLuminanceUnder         'luminiscencia debajo'                'La luminiscencia debajo del centro del objeto')
(getMaxVal                 'máximo valor'                        'El número representado cuando la perilla está a la derecha o abajo del deslizador. Este es el máximo valor devuelto por el deslizador')
(getMinVal                 'mínimo valor'                        'El número representado cuando la perilla está a la izquierda o arriba  del deslizador. Este es el mínimo valor devuelto por el deslizador')
(getMouseX                 'x del ratón'                         'La coordenada X del puntero del ratón')
(getMouseY                 'y del ratón'                         'La coordenada Y del puntero del ratón')
(getNewClone               'copiar'                              'Devuelve una copia de este objeto')
(getNumberAtCursor         'número en el cursor'                 'El número en el cursor')
(getNumericValue           'valor numérico'                      'Un número representando la posición actual de la perilla')
(getObtrudes               'sobresale'                         'Si el objeto sobresale de los bordes de su contenedor')
(getPenColor               'color del lápiz'                     'El color del lápiz')
(getPenDown                'lápiz bajo'                          'Si el lápiz está bajo')
(getPenSize                'tamaño del lápiz'                    'El ancho del lápiz')
(getRight                  'derecha'                             'El borde derecho')
(getRoundedCorners         'esquinas redondeadas'                'Si las esquinas deberían ser redondeadas')
(getSampleAtCursor         'muestra en el cursor'                'El valor de la muestra en la posición actual del cursor')
(getSaturationUnder        'saturación debajo'                   'La saturación debajo del centro del objeto')
(getScaleFactor            'factor de escala'                    'El factor de escala por el cual el objeto es magnificado')
(getTheta                  'theta'                               'El ángulo entre el eje X positivo y el vector que conecta el origen a la posición del objeto')
(getTop                    'arriba'                              'El borde de arriba')
(getTruncate               'truncado'                            'Si es verdadero, solo números son usados como valores; si es falso, valores fraccionarios son permitidos')
(getUpDown                 'desplazamiento arriba - abajo'       'El desplazamiento vertical')
(getValueAtCursor          'objeto en el cursor'                 'El objeto actualmente en el cursor')
(getViewingByIcon          'vista normal'                        'Si los contenidos son vistos normalmente')
(getWidth                  'ancho'                               'El ancho')
(getX                      'x'                                   'La coordenada X')
(getY                      'y'                                   'La coordenada Y')
(goToFirstCardInBackground 'ir a la primera tarjeta del fondo'   'Ir a la primera tarjeta del fondo actual')
(goToFirstCardOfStack      'ir a la primera tarjeta de la pila'  'Ir a la primera tarjeta de la pila completa')
(goToLastCardInBackground  'ir a la última tarjeta del fondo'    'Ir a la última tarjeta del fondo actual')
(goToLastCardOfStack       'ir a la última tarjeta de la pila'   'Ir a la última tarjeta de la pila completa')
(goToNextCardInStack       'ir a la próxima tarjeta de la pila'  'Ir a la próxima tarjeta')
(goToPreviousCardInStack   'ir a la anterior tarjeta de la pila' 'Ir a la anterior tarjeta')
(goToRightOf:              'alinear después de'                     'Ubicar este objeto a la derecha de otro')
(goto:                     'ir a'                                'Ir a la página dada')
(hide                      'ocultar'                             'Hacer invisible al objeto')
(include:                  'incluir'                             'Agregar el objeto a mi contenido')
(initiatePainting          'iniciar pintado'                     'Iniciar el pintado de nuevos objetos en el campo de juegos estandar')
(insertCard                'insertar nueva tarjeta'              'Insertar una nueva tarjeta')
(lastPage                  'última página'                       'Ir a la última página')
(liftAllPens               'levantar todos los lápices'          'Levantar los lápices de todos los objetos en mi interior')
(loadSineWave              'cargar forma de onda senoidal'       'Cargar una forma de onda senoidal como el gráfico actual')
(loadSound:                'cargar sonido'                       'Cargar el sonido especificado dentro del gráfico actual')
(lowerAllPens              'bajar todos los lápices'             'Bajar los lápices de todos los objetos en mi interior')
(makeNewDrawingIn:         'empezar pintado en'                  'Crear un nuevo dibujo en el campo de juegos especificado')
(moveToward:               'mover hacia'                         'Mover hacia el objeto dado')
(nextPage                  'próxima página'                      'Ir a la próxima página')
(pauseAll:                 'pausar todo'                         'Hacer que todos los guiones se pausen en el objeto y en todos sus hermanos')
(pauseScript:              'pausar guión'                        'Hacer que se pause el guión dado')
(play                      'reproducir'                          'Reproducir el gráfico actual como un sonido')
(prepend:                  'agregar adelante'                    'Agregar el objeto a mi contenido, poniéndolo antes que todos los otros objetos actualmente contenidos por mi')
(previousPage              'página anterior'                     'Ir a la página anterior')
(removeAll                 'remover todo'                        'Remover todos los elementos del campo de juegos')
(reverse                   'invertir'                            'Invertir el gráfico')
(roundUpStrays             'reunir perdidos'                       'Traer todas las partes fuera del contenedor nuevamente a la vista')
(seesColor:                'sobre color'                         'Si alguna parte del objeto esta sobre el color dado')
(show                      'mostrar'                             'Hacer visible el objeto')
(shuffleContents           'mezclar el contenido'                'Mezclar el contenido del campo de juegos')
(stampAndErase             'estampar y borrar'                   'Estampar mi imagen al rastro del lápiz y salir')
(startAll:                 'comenzar todo'                       'Comenzar el latido del guión en el objeto y en todos sus hermanos')
(startScript:              'comenzar guión'                      'Comenzar el latido del guión dado')
(stopAll:                  'parar todos'                         'Hacer que el estado del guión dado sea "normal" en el objeto y en todos sus hermanos')
(stopScript:               'detener guión'                         'Hacer que el estado del guión dado sea "normal"')
(tellAllSiblings:          'decir a todos los hermanos'          'Enviar un mensaje a todos los hermanos')
(touchesA:                 'toca un'                             'Si toco algo que parece como...')
(turn:                     'girar'                               'Cambiar la dirección del objeto en la cantidad especificada')
(unhideHiddenObjects       'mostrar objetos ocultos'             'Mostrar todos los objetos ocultos')
(wearCostumeOf:            'lucir como'                          'Usar el traje de...')

(wrap                      'ajusta'                                'traslada al otro borde si es apropiado')
(penArrowheads             'puntas de flecha en el lápiz'        'Si muestra puntas de flecha al final de cada trazo del lápiz')
(dropShadow                'sombra'                              'Si muestra la sombra')
(shadowColor               'color de la sombra'                  'Color de la sombra')
(clipSubmorphs             'cortar submorphs'                    'Si cortar o no mis submorphs')

) language: #'Español'.

   self translateCategories: #(
(basic                 'básico'                 'Unas pocas cosas importantes')
(#'book navigation'    'navegacion del libro'   'Relativo a libros, pilas, etc.')
(button                'botón'                  'Para pensar este objeto como un botón')
(collections           'colecciones'            'Para pensar este objeto como una colección')
(fog                   'niebla'                 'Niebla 3D')
(geometry              'geometría'              'Medidas y coordenadas')
(#'color & border'     'color y borde'          'Asuntos relacionados con colores y bordes de objetos')
(graphics              'gráficos'               'Para pensar este objeto como una imagen')
(variables			 'variables de instancia' 'Variables de instancia agregadas por este objeto')
(joystick              'joystick'               'El objeto como un Joystick')
(miscellaneous         'misceláneo'             'Comandos varios')
(scripting             'guiones'                'Comandos para  comenzar y parar guiones, etc.')
(motion                'movimiento'             'Asuntos relacionados con el movimiento y el giro')
(paintbox              'paleta de pintor'       'La paleta del pintor')
(#'pen trails'         'rastros del lápiz'      'Relacionados a los rastros dejados por los lápices')
(#'pen use'            'uso del lápiz'          'Uso del lápiz del objeto')
(playfield             'campo de juegos'        'El objeto como un contenedor para otros objetos visibles')
(sampling              'muestreo'               'Muestreo')
(scripts               'guiones'                'Guiones agregados por este objeto')
(slider                'deslizador'             'Funciones útiles para deslizadores')
(speaker               'altavoz'                'El objeto como un altavoz de audio')
(#'stack navigation'   'navegación de pila'     'Navegación dentro de una pila')
(storyboard            'pizarra de historia'    'Pizarra de historia')
(tests                 'pruebas'                'Pruebas por verdadero/falso, para usar en cuadros de "Prueba" de guiones')
(text                  'texto'                  'El objeto como texto')
(viewing               'visualización'          'Asuntos relacionados a visualización')
(vector                'vector'                 'El objeto como un vector')
(layout                'disposición'            'Disposición de los objetos contenidos')
(#'drag & drop'        'arrastrar y soltar'     'Arrastrar y soltar')
(observation           'observación'            'Observación')

 ) language: #'Español'.

        self addToTranslationTableFrom: #(
(:                                                '_'                                                'asignar el valor')
(Incr: 'incrementar por' 'incrementar el valor por')
(Decr: 'reducir por' 'reducir el valor por')
(Mult: 'multiplicar por' 'multiplicar el valor por')) language: #'Español'
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'gh 9/27/2001 16:32'!
addSwedishVocabulary
	"Add a Swedish vocabulary. Well, ok, perhaps better translations could be made...
	I might have simplified a few word choices to be better suited for kids like 'sudda' instead of 'rensa' (two words for 'clear'). Hmm, this was hard... :-)"

	self translateMethodInterfaceWordings: #(
(append: 'lägg till' 'Lägg till objektet i mitt innehåll')
(beep: 'spela ljud' 'Spela upp angivet ljud')
(bounce: 'studsa' 'studsa bort från kanten ifall den träffas')
(cameraPoint 'kameraposition' 'kamerans position')
(clear 'sudda' 'Sudda bildens innehåll')
(clearOwnersPenTrails 'sudda alla pennstreck' 'Sudda alla pennstreck i pennans lekplats')
(clearTurtleTrails 'sudda pennstreck' 'Sudda alla pennstreck på insidan')
(color:sees: 'färg syns' 'ifall vald färg ser angiven färg')
(deleteCard 'Ta bort kort' 'Ta bort det nuvarande kortet')
(doMenuItem: 'utför menyval' 'utför menyvalet')
(doScript: 'kör' 'kör skriptet en gång, vid nästa tick')
(emptyScript 'tomt skript' 'ett tomt skript')
(fire 'starta' 'startar alla knapphändelser för detta objekt')
(firstPage 'första sidan' 'gå till första sidan')
(followPath 'följ väg' 'följ den utsatta vägen')
(forward: 'framåt med' 'Flyttar objektet framåt i objektets nuvarande riktning')
(getActWhen 'kör när' 'När skriptet skall köras')
(getAllButFirstCharacter 'alla utom första' 'Alla mina tecken utom det första')
(getAmount 'storlek' 'Förflyttningens storlek')
(getAngle 'vinkel' 'Vinkelförflyttningens storlek')
(getBorderColor 'kantfärg' 'Färgen på objektets kant')
(getBorderWidth 'kantbredd' 'Bredden på objektets kant')
(getBottom 'botten' 'Den nedersta kanten')
(getBrightnessUnder 'kontrast' 'Kontrasten under objektets mittpunkt')
(getCharacters 'tecken' 'Tecknen i mitt innehåll')
(getColor 'färg' 'Objektets färg')
(getColorUnder 'färg under' 'Färgen under objektets mittpunkt')
(getConePosition 'högtalarposition' 'högtalarens position')
(getCursor 'markör' 'Markörens nuvarande position, omväxlad till början ifall det är lämpligt')
(getDescending 'fallande' 'Säger ifall det minsta värdet är överst/till vänster (fallande = false) eller nederst/till höger (fallande = true)')
(getDistance 'avstånd' 'Längden på vektorn mellan ursprungspunkten och objektets position')
(getFirstCharacter 'första tecknet' 'Det första tecknet i mitt innehåll')
(getFirstElement 'första elementet' 'Det första objektet i mitt innehåll')
(getFogColor 'dimmans färg' 'Färgen på dimman som appliceras')
(getFogDensity 'dimmans densitet' 'Densiteten på dimman som appliceras')
(getFogRangeEnd 'dimmans intervallslut' 'Intervallets slut på dimman som appliceras')
(getFogRangeStart 'dimmans intervallstart' 'Intervallets start på dimman som appliceras')
(getFogType 'dimmans typ' 'Typen av dimma som appliceras')
(getGraphic 'bild' 'Bilden som bärs av objektet')
(getGraphicAtCursor 'bild vid markör' 'Bilden som bärs av objektet vid markören')
(getHeading 'riktning' 'Åt vilket håll objektet pekar. 0 är rakt upp')
(getHeight 'höjd' 'Höjden')
(getHolder 'behållare' 'objektets behållare')
(getIndexInOwner 'elementnummer' 'mitt index i min behållare')
(getIsUnderMouse 'är under muspekaren' 'ifall objektet befinner sig under muspekaren')
(getKnobColor 'draghandtagets färg' 'Draghandtagets färg')
(getLabel 'etikett' 'Texten på knappen')
(getLastValue 'senaste värde' 'Senast beräknade värde')
(getLeft 'vänster' 'Den vänstra kanten')
(getLeftRight 'vänster/höger' 'Horisontell förflyttning')
(getLuminanceUnder 'ljusstyrka under' 'Ljusstyrkan under objektets mittpunkt')
(getMaxVal 'maxvärde' 'Talet som representerar när draghandtaget är längst till höger eller längst ner, det största värdet som draghandtaget ger.')
(getMinVal 'minvärde' 'Talet som representerar när draghandtaget är längst till vänster eller högst upp, det minsta värdet som draghandtaget ger.')
(getMouseX 'mus x' 'Muspekarens x-koordinat')
(getMouseY 'mus y' 'Muspekarens y-koordinat')
(getNewClone 'kopia' 'returnerar en kopia det här objektet')
(getNumberAtCursor 'tal vid markör' 'talet vid markören')
(getNumericValue 'numeriskt värde' 'Ett tal som representerar den aktuella positionen av draghandtaget.')
(getObtrudes 'sticker ut' 'ifall objektet sticker ut över behållarens kant')
(getPenColor 'pennfärg' 'färgen på bläcket i pennan')
(getPenDown 'penna nedtryckt' 'ifall pennan är nedtryckt just nu')
(getPenSize 'pennans bredd' 'pennans bredd')
(getRight 'höger' 'Den högra kanten')
(getRoundedCorners 'rundade hörn' 'Ifall hörnen skall vara runda')
(getSampleAtCursor 'värde vid markör' 'Nuvarande värde vid markörens position')
(getSaturationUnder 'mättnad under' 'Mättnaden under objektets mittpunkt')
(getScaleFactor 'skalfaktor' 'Objektets förstoringsfaktor')
(getTheta 'theta' 'Vinkeln mellan den positiva x-axeln och vektorn mellan ursprungspunkten och objektets position')
(getTop 'toppen' 'Den översta kanten')
(getTruncate 'trunkera' 'Ifall endast heltal används som värden, om inte är bråktal också tillåtna.')
(getUpDown 'upp/ner' 'Vertikal förflyttning')
(getValueAtCursor 'spelare vid markör' 'objektet vid markören')
(getViewingByIcon 'normalvy' 'vyn på innehållet är normal')
(getWidth 'bredd' 'Bredden')
(getX 'x' 'X-koordinaten')
(getY 'y' 'Y-koordinaten')
(goToFirstCardInBackground 'gå till första i bakgrunden' 'Gå till det första kortet i den nuvarande bakgrunden')
(goToFirstCardOfStack 'gå till första kortet i stacken' 'Gå till första korten i hela stacken')
(goToLastCardInBackground 'gå till sista kortet i bakgrunden' 'Gå till det sista kortet i den nuvarande bakgrunden')
(goToLastCardOfStack 'gå till sista kortet i stacken' 'Gå till det sista kortet i hela stacken')
(goToNextCardInStack 'gå till nästa kort' 'Gå till nästa kort i stacken')
(goToPreviousCardInStack 'gå till förra kortet' 'Gå till det föregående kortet i stacken')
(goToRightOf: 'align after' 'placera detta objekt till höger om ett annat')
(goto: 'gå till' 'gå till angiven sida')
(hide 'göm' 'gör objektet osynligt')
(initiatePainting 'börja målning' 'Påbörja målning av ett nytt objekt i den vanliga lekplatsen.')
(insertCard 'stoppa in kort' 'Skapa ett nytt kort')
(lastPage 'sista sidan' 'gå till sista sidan')
(liftAllPens 'lyft alla pennor' 'Lyft pennorna på mitt innehålls alla objekt.')
(loadSineWave 'ladda sinusvåg' 'Ladda en sinusvåg som nuvarande graf')
(loadSound: 'ladda ljud' 'Ladda angivet ljud som nuvarnde graf')
(lowerAllPens 'sänk alla pennor' 'Sänk pennorna på mitt innehålls alla objekt.')
(makeNewDrawingIn: 'påbörja målning i' 'gör en ny målning i angiven lekplats')
(moveToward: 'flytta mot' 'flytta mot angivet objekt')
(nextPage 'nästa sida' 'gå till nästa sida')
(pauseAll: 'pausa alla' 'pausa skriptet i objektet och alla dess kusiner')
(pauseScript: 'pausa skript' 'pausa skriptet')
(play 'spela' 'Spela nuvarande graf som ett ljud')
(previousPage 'föregående sida' 'gå till föregående sida')
(removeAll 'ta bort alla' 'Ta bort alla element från lekplatsen')
(reverse 'reversera' 'Reversera grafen')
(roundUpStrays 'samla in bortsprungna' 'Samla in alla delar utanför behållaren så att de blir synliga igen.')
(seesColor: 'är över färg' 'ifall någon del av objektet är över den givna färgen')
(show 'visa' 'gör objektet synligt')
(shuffleContents 'blanda innehåll' 'Blanda lekplatsens innehåll')
(stampAndErase 'stämpla och försvinn' 'lägg till min bild som ritstreck och försvinn')
(startAll: 'starta alla' 'starta skriptet tickande i objektet och alla dess kusiner.')
(startScript: 'starta skript' 'starta skriptet tickande')
(stopAll: 'stoppa alla' 'gör skriptet "normalt" i objektet och alla dess kusiner')
(stopScript: 'stoppa skript' 'gör skriptet "normalt" i objektet')
(tellAllSiblings: 'säg till kusiner' 'skicka ett meddelande till alla kusiner')
(touchesA: 'vidrör' 'Ifall jag vidrör något som ser ut som...')
(turn: 'sväng med' 'Ändra objektets riktning med angiven mängd')
(unhideHiddenObjects 'visa alla gömda objekt' 'Gör alla gömda objekt synliga.')
(wearCostumeOf: 'se ut som' 'bär samma dräkt som...')
(wrap 'växla över kant' 'växla över kanten ifall det är lämpligt')) language: #Svenska.

	self translateCategories: #(
(basic					'grunder'				'ett antal viktiga saker')
(#'book navigation'		'boknavigering'			'saker som har att göra med böcker och stackar med mera')
(button					'knapp'					'objektet betraktat som en knapp man kan trycka på')
(collections				'samlingar'				'objektet betraktat som en samling av andra objekt')
(fog					'dimma'					'3-dimensionell dimma')
(geometry				'geometri' 				'mätvärden och koordinater')
(#'color & border'		'färger & kanter'		'saker som har att göra med färger och kanter på objekt')
(graphics				'grafik'					'objektet betraktat som en bild')
(#'instance variables'	'instansvariabler'		'instansvariabler tillagda i detta objekt')
(joystick				'joystick	'				'objektet som en joystick')
(miscellaneous			'diverse' 				'diverse kommandon')
(motion					'rörelse' 				'saker som har att göra med förflyttning och vridning')
(paintbox				'målarlåda'				'målarpaletten')
(#'pen trails'			'pennstreck'				'saker som har att göra med streck som pennan ritar')
(#'pen use'				'pennanvändning' 		'användning av ett objekts penna')
(playfield				'lekplats'					'objektet som behållare för andra synliga objekt')
(sampling				'provtagning'			'provtagning')
(scripts					'skript'					'metoder tillagda i detta objekt')
(slider					'draghandtag'			'användbara funktioner för draghandtag')
(speaker				'högtalare'				'objektet betraktat som en högtalare')
(#'stack navigation'		'stacknavigering'		'navigering inom en stack')
(storyboard				'storyboard'				'storyboard')
(tests					'tester'					'ja/nej tester, för användning skriptens testytor')
(text					'text'					'Objektet som text')
(viewing				'vyer'					'Saker som har att göra med olika vyer')
(vector					'vektor'					'Objektet som en vektor')
 ) language: #Svenska.

	self addToTranslationTableFrom: #(
(:						'_'						'tilldela värde')
(Incr:					'öka med'			'öka värde med')
(Decr:					'minska med'			'minska värde med')
(Mult:					'multiplicera med'			'multiplicera värde med')) language: #Svenska
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 4/15/2003 23:46' prior: 35936883!
addSwedishVocabulary
	"Add a Swedish vocabulary. Well, ok, perhaps better translations could be made...
	I might have simplified a few word choices to be better suited for kids like 'sudda' instead of 'rensa' (two words for 'clear'). Hmm, this was hard... :-)"

	self translateMethodInterfaceWordings: #(
(append: 'lägg till' 'Lägg till objektet i mitt innehåll')
(beep: 'spela ljud' 'Spela upp angivet ljud')
(bounce: 'studsa' 'studsa bort från kanten ifall den träffas')
(cameraPoint 'kameraposition' 'kamerans position')
(clear 'sudda' 'Sudda bildens innehåll')
(clearOwnersPenTrails 'sudda alla pennstreck' 'Sudda alla pennstreck i pennans lekplats')
(clearTurtleTrails 'sudda pennstreck' 'Sudda alla pennstreck på insidan')
(color:sees: 'färg syns' 'ifall vald färg ser angiven färg')
(deleteCard 'Ta bort kort' 'Ta bort det nuvarande kortet')
(doMenuItem: 'utför menyval' 'utför menyvalet')
(doScript: 'kör' 'kör skriptet en gång, vid nästa tick')
(emptyScript 'tomt skript' 'ett tomt skript')
(fire 'starta' 'startar alla knapphändelser för detta objekt')
(firstPage 'första sidan' 'gå till första sidan')
(followPath 'följ väg' 'följ den utsatta vägen')
(forward: 'framåt med' 'Flyttar objektet framåt i objektets nuvarande riktning')
(getActWhen 'kör när' 'När skriptet skall köras')
(getAllButFirstCharacter 'alla utom första' 'Alla mina tecken utom det första')
(getAmount 'storlek' 'Förflyttningens storlek')
(getAngle 'vinkel' 'Vinkelförflyttningens storlek')
(getBorderColor 'kantfärg' 'Färgen på objektets kant')
(getBorderWidth 'kantbredd' 'Bredden på objektets kant')
(getBottom 'botten' 'Den nedersta kanten')
(getBrightnessUnder 'kontrast' 'Kontrasten under objektets mittpunkt')
(getCharacters 'tecken' 'Tecknen i mitt innehåll')
(getColor 'färg' 'Objektets färg')
(getColorUnder 'färg under' 'Färgen under objektets mittpunkt')
(getConePosition 'högtalarposition' 'högtalarens position')
(getCursor 'markör' 'Markörens nuvarande position, omväxlad till början ifall det är lämpligt')
(getDescending 'fallande' 'Säger ifall det minsta värdet är överst/till vänster (fallande = false) eller nederst/till höger (fallande = true)')
(getDistance 'avstånd' 'Längden på vektorn mellan ursprungspunkten och objektets position')
(getFirstCharacter 'första tecknet' 'Det första tecknet i mitt innehåll')
(getFirstElement 'första elementet' 'Det första objektet i mitt innehåll')
(getFogColor 'dimmans färg' 'Färgen på dimman som appliceras')
(getFogDensity 'dimmans densitet' 'Densiteten på dimman som appliceras')
(getFogRangeEnd 'dimmans intervallslut' 'Intervallets slut på dimman som appliceras')
(getFogRangeStart 'dimmans intervallstart' 'Intervallets start på dimman som appliceras')
(getFogType 'dimmans typ' 'Typen av dimma som appliceras')
(getGraphic 'bild' 'Bilden som bärs av objektet')
(getGraphicAtCursor 'bild vid markör' 'Bilden som bärs av objektet vid markören')
(getHeading 'riktning' 'Åt vilket håll objektet pekar. 0 är rakt upp')
(getHeight 'höjd' 'Höjden')
(getHolder 'behållare' 'objektets behållare')
(getIndexInOwner 'elementnummer' 'mitt index i min behållare')
(getIsUnderMouse 'är under muspekaren' 'ifall objektet befinner sig under muspekaren')
(getKnobColor 'draghandtagets färg' 'Draghandtagets färg')
(getLabel 'etikett' 'Texten på knappen')
(getLastValue 'senaste värde' 'Senast beräknade värde')
(getLeft 'vänster' 'Den vänstra kanten')
(getLeftRight 'vänster/höger' 'Horisontell förflyttning')
(getLuminanceUnder 'ljusstyrka under' 'Ljusstyrkan under objektets mittpunkt')
(getMaxVal 'maxvärde' 'Talet som representerar när draghandtaget är längst till höger eller längst ner, det största värdet som draghandtaget ger.')
(getMinVal 'minvärde' 'Talet som representerar när draghandtaget är längst till vänster eller högst upp, det minsta värdet som draghandtaget ger.')
(getMouseX 'mus x' 'Muspekarens x-koordinat')
(getMouseY 'mus y' 'Muspekarens y-koordinat')
(getNewClone 'kopia' 'returnerar en kopia det här objektet')
(getNumberAtCursor 'tal vid markör' 'talet vid markören')
(getNumericValue 'numeriskt värde' 'Ett tal som representerar den aktuella positionen av draghandtaget.')
(getObtrudes 'sticker ut' 'ifall objektet sticker ut över behållarens kant')
(getPenColor 'pennfärg' 'färgen på bläcket i pennan')
(getPenDown 'penna nedtryckt' 'ifall pennan är nedtryckt just nu')
(getPenSize 'pennans bredd' 'pennans bredd')
(getRight 'höger' 'Den högra kanten')
(getRoundedCorners 'rundade hörn' 'Ifall hörnen skall vara runda')
(getSampleAtCursor 'värde vid markör' 'Nuvarande värde vid markörens position')
(getSaturationUnder 'mättnad under' 'Mättnaden under objektets mittpunkt')
(getScaleFactor 'skalfaktor' 'Objektets förstoringsfaktor')
(getTheta 'theta' 'Vinkeln mellan den positiva x-axeln och vektorn mellan ursprungspunkten och objektets position')
(getTop 'toppen' 'Den översta kanten')
(getTruncate 'trunkera' 'Ifall endast heltal används som värden, om inte är bråktal också tillåtna.')
(getUpDown 'upp/ner' 'Vertikal förflyttning')
(getValueAtCursor 'spelare vid markör' 'objektet vid markören')
(getViewingByIcon 'normalvy' 'vyn på innehållet är normal')
(getWidth 'bredd' 'Bredden')
(getX 'x' 'X-koordinaten')
(getY 'y' 'Y-koordinaten')
(goToFirstCardInBackground 'gå till första i bakgrunden' 'Gå till det första kortet i den nuvarande bakgrunden')
(goToFirstCardOfStack 'gå till första kortet i stacken' 'Gå till första korten i hela stacken')
(goToLastCardInBackground 'gå till sista kortet i bakgrunden' 'Gå till det sista kortet i den nuvarande bakgrunden')
(goToLastCardOfStack 'gå till sista kortet i stacken' 'Gå till det sista kortet i hela stacken')
(goToNextCardInStack 'gå till nästa kort' 'Gå till nästa kort i stacken')
(goToPreviousCardInStack 'gå till förra kortet' 'Gå till det föregående kortet i stacken')
(goToRightOf: 'align after' 'placera detta objekt till höger om ett annat')
(goto: 'gå till' 'gå till angiven sida')
(hide 'göm' 'gör objektet osynligt')
(initiatePainting 'börja målning' 'Påbörja målning av ett nytt objekt i den vanliga lekplatsen.')
(insertCard 'stoppa in kort' 'Skapa ett nytt kort')
(lastPage 'sista sidan' 'gå till sista sidan')
(liftAllPens 'lyft alla pennor' 'Lyft pennorna på mitt innehålls alla objekt.')
(loadSineWave 'ladda sinusvåg' 'Ladda en sinusvåg som nuvarande graf')
(loadSound: 'ladda ljud' 'Ladda angivet ljud som nuvarnde graf')
(lowerAllPens 'sänk alla pennor' 'Sänk pennorna på mitt innehålls alla objekt.')
(makeNewDrawingIn: 'påbörja målning i' 'gör en ny målning i angiven lekplats')
(moveToward: 'flytta mot' 'flytta mot angivet objekt')
(nextPage 'nästa sida' 'gå till nästa sida')
(pauseAll: 'pausa alla' 'pausa skriptet i objektet och alla dess kusiner')
(pauseScript: 'pausa skript' 'pausa skriptet')
(play 'spela' 'Spela nuvarande graf som ett ljud')
(previousPage 'föregående sida' 'gå till föregående sida')
(removeAll 'ta bort alla' 'Ta bort alla element från lekplatsen')
(reverse 'reversera' 'Reversera grafen')
(roundUpStrays 'samla in bortsprungna' 'Samla in alla delar utanför behållaren så att de blir synliga igen.')
(seesColor: 'är över färg' 'ifall någon del av objektet är över den givna färgen')
(show 'visa' 'gör objektet synligt')
(shuffleContents 'blanda innehåll' 'Blanda lekplatsens innehåll')
(stampAndErase 'stämpla och försvinn' 'lägg till min bild som ritstreck och försvinn')
(startAll: 'starta alla' 'starta skriptet tickande i objektet och alla dess kusiner.')
(startScript: 'starta skript' 'starta skriptet tickande')
(stopAll: 'stoppa alla' 'gör skriptet "normalt" i objektet och alla dess kusiner')
(stopScript: 'stoppa skript' 'gör skriptet "normalt" i objektet')
(tellAllSiblings: 'säg till kusiner' 'skicka ett meddelande till alla kusiner')
(touchesA: 'vidrör' 'Ifall jag vidrör något som ser ut som...')
(turn: 'sväng med' 'Ändra objektets riktning med angiven mängd')
(unhideHiddenObjects 'visa alla gömda objekt' 'Gör alla gömda objekt synliga.')
(wearCostumeOf: 'se ut som' 'bär samma dräkt som...')
(wrap 'växla över kant' 'växla över kanten ifall det är lämpligt')) language: #Svenska.

	self translateCategories: #(
(basic					'grunder'				'ett antal viktiga saker')
(#'book navigation'		'boknavigering'			'saker som har att göra med böcker och stackar med mera')
(button					'knapp'					'objektet betraktat som en knapp man kan trycka på')
(collections				'samlingar'				'objektet betraktat som en samling av andra objekt')
(fog					'dimma'					'3-dimensionell dimma')
(geometry				'geometri' 				'mätvärden och koordinater')
(#'color & border'		'färger & kanter'		'saker som har att göra med färger och kanter på objekt')
(graphics				'grafik'					'objektet betraktat som en bild')
(variables				'instansvariabler'		'instansvariabler tillagda i detta objekt')
(joystick				'joystick	'				'objektet som en joystick')
(miscellaneous			'diverse' 				'diverse kommandon')
(motion					'rörelse' 				'saker som har att göra med förflyttning och vridning')
(paintbox				'målarlåda'				'målarpaletten')
(#'pen trails'			'pennstreck'				'saker som har att göra med streck som pennan ritar')
(#'pen use'				'pennanvändning' 		'användning av ett objekts penna')
(playfield				'lekplats'					'objektet som behållare för andra synliga objekt')
(sampling				'provtagning'			'provtagning')
(scripts					'skript'					'metoder tillagda i detta objekt')
(slider					'draghandtag'			'användbara funktioner för draghandtag')
(speaker				'högtalare'				'objektet betraktat som en högtalare')
(#'stack navigation'		'stacknavigering'		'navigering inom en stack')
(storyboard				'storyboard'				'storyboard')
(tests					'tester'					'ja/nej tester, för användning skriptens testytor')
(text					'text'					'Objektet som text')
(viewing				'vyer'					'Saker som har att göra med olika vyer')
(vector					'vektor'					'Objektet som en vektor')
 ) language: #Svenska.

	self addToTranslationTableFrom: #(
(:						'_'						'tilldela värde')
(Incr:					'öka med'			'öka värde med')
(Decr:					'minska med'			'minska värde med')
(Mult:					'multiplicera med'			'multiplicera värde med')) language: #Svenska
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 9/14/2001 10:52'!
assureTranslationsAvailableFor: aLanguageSymbol
	"Any vocabulary that has translations for the language gets this called when language switches "

	| initializer |
	initializer _ Vocabulary initializerForLanguageSymbol: aLanguageSymbol.
	initializer ifNotNil: [self perform: initializer].! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 1/16/2002 18:16'!
templateForLanguageTranslation
	
"Edit this method such that the second element of each triplet has the translated wording and the third element has the translated help-message; give the edited method a name of the form #addLangVocabulary, and be sure to change the language name in the three places that it occurs, as #YourLanguage, below.

A complete translation consists, as in #addKiswahiliVocabulary, of calls to three methods, namely:
	translateMethodInterfaceWordings:language: 
	translateCategories:language:
	addToTranslationTableFrom:language: 

After editing this method into the one that holds your language translations, the next step is to edit #assureTranslationsAvailableFor: so that it calls the method you just created when appropriate.   Consult #addKiswahiliVocabulary and its sender for a complete example to emulate."

	self translateMethodInterfaceWordings: #(
(append: 'include at end' 'Add the object to my content, placing it after all the other objects currently within me.')
(beep: 'make sound' 'Make the specified sound')
(bounce: 'bounce' 'bounce off the edge if hit')
(cameraPoint #cameraPoint 'the camera point')
(clear 'clear' 'Clear the graph of current contents')
(clearOwnersPenTrails 'clear all pen trails' 'clear all pen trails in my containing playfield')
(clearTurtleTrails 'clear pen trails' 'Clear all the pen trails in the interior.')
(color:sees: 'color  sees' 'whether the given color sees the given color')
(deleteCard 'deleteCard' 'Delete the current card')
(doMenuItem: 'do menu item' 'do the menu item')
(doScript: 'do' 'run the given script once, on the next tick')
(emptyScript 'emptyScript' 'an empty script')
(fire 'fire' 'trigger any and all of this object''s button actions')
(firstPage 'firstPage' 'go to first page')
(followPath 'followPath' 'follow the yellow brick road')
(forward: 'forward by' 'Moves the object forward in the direction it is heading')
(getActWhen #actWhen 'When the script should fire')
(getAllButFirstCharacter #allButFirst 'All my characters except the first one')
(getAmount #amount 'The amount of displacement')
(getAngle #angle 'The angular displacement')
(getBorderColor #borderColor 'The color of the object''s border')
(getBorderWidth #borderWidth 'The width of the object''s border')
(getBottom #bottom 'The bottom edge')
(getBrightnessUnder #brightnessUnder 'The brightness under the center of the object')
(getCharacters #characters 'The characters in my contents')
(getColor #color 'The color of the object')
(getColorUnder #colorUnder 'The color under the center of the object')
(getConePosition #conePosition 'the position of the speaker cone')
(getCursor #cursor 'The current cursor location, wrapped back to the beginning if appropriate')
(getDescending #descending 'Tells whether the smallest value is at the top/left (descending = false) or at the bottom/right (descending = true)')
(getDistance #distance 'The length of the vector connecting the origin to the object''s position')
(getFirstCharacter #firstCharacter 'The first character in my contents')
(getFirstElement #firstElement 'The first object in my contents')
(getFogColor #fogColor 'The color of fog being applied')
(getFogDensity #fogDensity 'The density of fog being applied')
(getFogRangeEnd #fogRangeEnd 'The range start of fog being applied')
(getFogRangeStart #fogRangeStart 'The range start of fog being applied')
(getFogType #fogType 'The type of fog being applied')
(getGraphic #graphic 'The picture currently being worn')
(getGraphicAtCursor #graphicAtCursor 'the graphic worn by the object at the cursor')
(getHeading #heading 'Which direction the object is facing.  0 is straight up')
(getHeight #height 'The height')
(getHolder #holder 'the object''s container')
(getIndexInOwner #elementNumber 'my index in my container')
(getIsUnderMouse #isUnderMouse 'whether the object is under the current mouse position')
(getKnobColor #knobColor 'The color of the slider')
(getLabel #label 'The wording on the button')
(getLastValue #lastValue 'The last value obtained')
(getLeft #left 'The left edge')
(getLeftRight #leftRight 'The horizontal displacement')
(getLuminanceUnder #luminanceUnder 'The luminance under the center of the object')
(getMaxVal #maxVal 'The number represented when the knob is at the right or bottom of the slider; the largest value returned by the slider.')
(getMinVal #minVal 'The number represented when the knob is at the left or top of the slider; the smallest value returned by the slider.')
(getMouseX #mouseX 'The x coordinate of the mouse pointer')
(getMouseY #mouseY 'The y coordinate of the mouse pointer')
(getNewClone #copy 'returns a copy of this object')
(getNumberAtCursor #numberAtCursor 'the number at the cursor')
(getNumericValue #numericValue 'A number representing the current position of the knob.')
(getObtrudes #obtrudes 'whether the object sticks out over its container''s edge')
(getPenColor #penColor 'the color of ink used by the pen')
(getPenDown #penDown 'whether the pen is currently down')
(getPenSize #penSize 'the width of the pen')
(getRight #right 'The right edge')
(getRoundedCorners #roundedCorners 'Whether corners should be rounded')
(getSampleAtCursor #sampleAtCursor 'The sample value at the current cursor location')
(getSaturationUnder #saturationUnder 'The saturation under the center of the object')
(getScaleFactor #scaleFactor 'The factor by which the object is magnified')
(getTheta #theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position')
(getTop #top 'The top edge')
(getTruncate #truncate 'If true, only whole numbers are used as values; if false, fractional values are allowed.')
(getUpDown #upDown 'The vertical displacement')
(getValueAtCursor #playerAtCursor 'the object currently at the cursor')
(getViewingByIcon #viewingNormally 'whether contents are viewed normally')
(getWidth #width 'The width')
(getX #x 'The x coordinate')
(getY #y 'The y coordinate')
(goToFirstCardInBackground 'goToFirstCardInBackground' 'Go to the first card of the current background')
(goToFirstCardOfStack 'goToFirstCardOfStack' 'Go to the first card of the entire stack')
(goToLastCardInBackground 'goToLastCardInBackground' 'Go to the last card of the current background')
(goToLastCardOfStack 'goToLastCardOfStack' 'Go to the last card of the entire stack')
(goToNextCardInStack 'goToNextCardInStack' 'Go to the next card')
(goToPreviousCardInStack 'goToPreviousCardInStack' 'Go to the previous card')
(goToRightOf: 'align after' 'place this object to the right of another')
(goto: 'goto:' 'go to the given page')
(hide 'hide' 'make the object invisible')
(initiatePainting 'initiatePainting' 'Initiate painting of a new object in the standard playfield.')
(insertCard 'insertCard' 'Create a new card')
(lastPage 'lastPage' 'go to last page')
(liftAllPens 'lift all pens' 'Lift the pens on all the objects in my interior.')
(loadSineWave 'loadSineWave' 'Load a sine wave as the current graph')
(loadSound: 'loadSound:' 'Load the specified sound into the current graph')
(lowerAllPens 'lower all pens' 'Lower the pens on all the objects in my interior.')
(makeNewDrawingIn: 'start painting in' 'make a new drawing in the specified playfield')
(moveToward: 'move toward' 'move toward the given object')
(nextPage 'nextPage' 'go to next page')
(pauseAll: 'pause all' 'make the given script be "paused" in the object and all of its siblings')
(pauseScript: 'pause script' 'make the given script be "paused"')
(play 'play' 'Play the current graph as a sound')
(prepend: 'include at beginning' 'Add the object to my content, placing it before all the other objects currently within me.')
(previousPage 'previousPage' 'go to previous page')
(removeAll 'removeAll' 'Remove all elements from the playfield')
(reverse 'reverse' 'Reverse the graph')
(roundUpStrays 'roundUpStrays' 'Bring all out-of-container subparts back into view.')
(seesColor: #isOverColor 'whether any part of the object is over the given color')
(show 'show' 'make the object visible')
(shuffleContents 'shuffleContents' 'Shuffle the contents of the playfield')
(stampAndErase 'stampAndErase' 'add my image to the pen trails and go away')
(startAll: 'start All' 'start the given script ticking in the object and all of its siblings.')
(startScript: 'start script' 'start the given script ticking')
(stopAll: 'stop all' 'make the given script be "normal" in the object and all of its siblings')
(stopScript: 'stop script' 'make the given script be "normal"')
(tellAllSiblings: 'tell all siblings' 'send a message to all siblings')
(touchesA: #touchesA 'whether I touch something that looks like...')
(turn: 'turn by' 'Change the heading of the object by the specified amount')
(unhideHiddenObjects 'unhideHiddenObjects' 'Unhide all hidden objects.')
(wearCostumeOf: 'look like' 'wear the costume of...')
(wrap 'wrap' 'wrap off the edge if appropriate')) language: #YourLanguage.

	self translateCategories: #(
(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')
(#'instance variables'	'instance variables'		'instance variables added by this object')
(joystick				'joystick	'				'the object as a Joystick')
(miscellaneous			'miscellaneous' 			'various commands')
(scripting				'scripting'				'commands to start and stop scripts, etc.')
(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')
(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')
(viewing				'viewing'				'matters relating to viewing')
(vector					'vector'					'The object as a vector')
 ) language: #YourLanguage.

	self addToTranslationTableFrom: #(
(:						'_'						'assign value')
(Incr:					'increase by'			'increase value by')
(Decr:					'decrease by'			'decrease value by')
(Mult:					'multiply by'			'multiply value by')) language: #YourLanguage
! !

!EToyVocabulary methodsFor: 'language translations' stamp: 'sw 2/26/2003 23:35' prior: 35958280!
templateForLanguageTranslation
	
"Edit this method such that the second element of each triplet has the translated wording and the third element has the translated help-message; give the edited method a name of the form #addLangVocabulary, and be sure to change the language name in the three places that it occurs, as #YourLanguage, below.

A complete translation consists, as in #addKiswahiliVocabulary, of calls to three methods, namely:
	translateMethodInterfaceWordings:language: 
	translateCategories:language:
	addToTranslationTableFrom:language: 

After editing this method into the one that holds your language translations, the next step is to edit #assureTranslationsAvailableFor: so that it calls the method you just created when appropriate.   Consult #addKiswahiliVocabulary and its sender for a complete example to emulate."

	self translateMethodInterfaceWordings: #(
(append: 'include at end' 'Add the object to my content, placing it after all the other objects currently within me.')
(beep: 'make sound' 'Make the specified sound')
(bounce: 'bounce' 'bounce off the edge if hit')
(cameraPoint #cameraPoint 'the camera point')
(clear 'clear' 'Clear the graph of current contents')
(clearOwnersPenTrails 'clear all pen trails' 'clear all pen trails in my containing playfield')
(clearTurtleTrails 'clear pen trails' 'Clear all the pen trails in the interior.')
(color:sees: 'color  sees' 'whether the given color sees the given color')
(deleteCard 'deleteCard' 'Delete the current card')
(doMenuItem: 'do menu item' 'do the menu item')
(doScript: 'do' 'run the given script once, on the next tick')
(emptyScript 'emptyScript' 'an empty script')
(fire 'fire' 'trigger any and all of this object''s button actions')
(firstPage 'firstPage' 'go to first page')
(followPath 'followPath' 'follow the yellow brick road')
(forward: 'forward by' 'Moves the object forward in the direction it is heading')
(getActWhen #actWhen 'When the script should fire')
(getAllButFirstCharacter #allButFirst 'All my characters except the first one')
(getAmount #amount 'The amount of displacement')
(getAngle #angle 'The angular displacement')
(getBorderColor #borderColor 'The color of the object''s border')
(getBorderWidth #borderWidth 'The width of the object''s border')
(getBottom #bottom 'The bottom edge')
(getBrightnessUnder #brightnessUnder 'The brightness under the center of the object')
(getCharacters #characters 'The characters in my contents')
(getColor #color 'The color of the object')
(getColorUnder #colorUnder 'The color under the center of the object')
(getConePosition #conePosition 'the position of the speaker cone')
(getCursor #cursor 'The current cursor location, wrapped back to the beginning if appropriate')
(getDescending #descending 'Tells whether the smallest value is at the top/left (descending = false) or at the bottom/right (descending = true)')
(getDistance #distance 'The length of the vector connecting the origin to the object''s position')
(getFirstCharacter #firstCharacter 'The first character in my contents')
(getFirstElement #firstElement 'The first object in my contents')
(getFogColor #fogColor 'The color of fog being applied')
(getFogDensity #fogDensity 'The density of fog being applied')
(getFogRangeEnd #fogRangeEnd 'The range start of fog being applied')
(getFogRangeStart #fogRangeStart 'The range start of fog being applied')
(getFogType #fogType 'The type of fog being applied')
(getGraphic #graphic 'The picture currently being worn')
(getGraphicAtCursor #graphicAtCursor 'the graphic worn by the object at the cursor')
(getHeading #heading 'Which direction the object is facing.  0 is straight up')
(getHeight #height 'The height')
(getHolder #holder 'the object''s container')
(getIndexInOwner #elementNumber 'my index in my container')
(getIsUnderMouse #isUnderMouse 'whether the object is under the current mouse position')
(getKnobColor #knobColor 'The color of the slider')
(getLabel #label 'The wording on the button')
(getLastValue #lastValue 'The last value obtained')
(getLeft #left 'The left edge')
(getLeftRight #leftRight 'The horizontal displacement')
(getLuminanceUnder #luminanceUnder 'The luminance under the center of the object')
(getMaxVal #maxVal 'The number represented when the knob is at the right or bottom of the slider; the largest value returned by the slider.')
(getMinVal #minVal 'The number represented when the knob is at the left or top of the slider; the smallest value returned by the slider.')
(getMouseX #mouseX 'The x coordinate of the mouse pointer')
(getMouseY #mouseY 'The y coordinate of the mouse pointer')
(getNewClone #copy 'returns a copy of this object')
(getNumberAtCursor #numberAtCursor 'the number at the cursor')
(getNumericValue #numericValue 'A number representing the current position of the knob.')
(getObtrudes #obtrudes 'whether the object sticks out over its container''s edge')
(getPenColor #penColor 'the color of ink used by the pen')
(getPenDown #penDown 'whether the pen is currently down')
(getPenSize #penSize 'the width of the pen')
(getRight #right 'The right edge')
(getRoundedCorners #roundedCorners 'Whether corners should be rounded')
(getSampleAtCursor #sampleAtCursor 'The sample value at the current cursor location')
(getSaturationUnder #saturationUnder 'The saturation under the center of the object')
(getScaleFactor #scaleFactor 'The factor by which the object is magnified')
(getTheta #theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position')
(getTop #top 'The top edge')
(getTruncate #truncate 'If true, only whole numbers are used as values; if false, fractional values are allowed.')
(getUpDown #upDown 'The vertical displacement')
(getValueAtCursor #playerAtCursor 'the object currently at the cursor')
(getViewingByIcon #viewingNormally 'whether contents are viewed normally')
(getWidth #width 'The width')
(getX #x 'The x coordinate')
(getY #y 'The y coordinate')
(goToFirstCardInBackground 'goToFirstCardInBackground' 'Go to the first card of the current background')
(goToFirstCardOfStack 'goToFirstCardOfStack' 'Go to the first card of the entire stack')
(goToLastCardInBackground 'goToLastCardInBackground' 'Go to the last card of the current background')
(goToLastCardOfStack 'goToLastCardOfStack' 'Go to the last card of the entire stack')
(goToNextCardInStack 'goToNextCardInStack' 'Go to the next card')
(goToPreviousCardInStack 'goToPreviousCardInStack' 'Go to the previous card')
(goToRightOf: 'align after' 'place this object to the right of another')
(goto: 'goto:' 'go to the given page')
(hide 'hide' 'make the object invisible')
(initiatePainting 'initiatePainting' 'Initiate painting of a new object in the standard playfield.')
(insertCard 'insertCard' 'Create a new card')
(lastPage 'lastPage' 'go to last page')
(liftAllPens 'lift all pens' 'Lift the pens on all the objects in my interior.')
(loadSineWave 'loadSineWave' 'Load a sine wave as the current graph')
(loadSound: 'loadSound:' 'Load the specified sound into the current graph')
(lowerAllPens 'lower all pens' 'Lower the pens on all the objects in my interior.')
(makeNewDrawingIn: 'start painting in' 'make a new drawing in the specified playfield')
(moveToward: 'move toward' 'move toward the given object')
(nextPage 'nextPage' 'go to next page')
(pauseAll: 'pause all' 'make the given script be "paused" in the object and all of its siblings')
(pauseScript: 'pause script' 'make the given script be "paused"')
(play 'play' 'Play the current graph as a sound')
(prepend: 'include at beginning' 'Add the object to my content, placing it before all the other objects currently within me.')
(previousPage 'previousPage' 'go to previous page')
(removeAll 'removeAll' 'Remove all elements from the playfield')
(reverse 'reverse' 'Reverse the graph')
(roundUpStrays 'roundUpStrays' 'Bring all out-of-container subparts back into view.')
(seesColor: #isOverColor 'whether any part of the object is over the given color')
(show 'show' 'make the object visible')
(shuffleContents 'shuffleContents' 'Shuffle the contents of the playfield')
(stampAndErase 'stampAndErase' 'add my image to the pen trails and go away')
(startAll: 'start All' 'start the given script ticking in the object and all of its siblings.')
(startScript: 'start script' 'start the given script ticking')
(stopAll: 'stop all' 'make the given script be "normal" in the object and all of its siblings')
(stopScript: 'stop script' 'make the given script be "normal"')
(tellAllSiblings: 'tell all siblings' 'send a message to all siblings')
(touchesA: #touchesA 'whether I touch something that looks like...')
(turn: 'turn by' 'Change the heading of the object by the specified amount')
(unhideHiddenObjects 'unhideHiddenObjects' 'Unhide all hidden objects.')
(wearCostumeOf: 'look like' 'wear the costume of...')
(wrap 'wrap' 'wrap off the edge if appropriate')) language: #YourLanguage.

	self translateCategories: #(
(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')
(scripting				'scripting'				'commands to start and stop scripts, etc.')
(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')
(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')
(viewing				'viewing'				'matters relating to viewing')
(vector					'vector'					'The object as a vector')
 ) language: #YourLanguage.

	self addToTranslationTableFrom: #(
(:						'_'						'assign value')
(Incr:					'increase by'			'increase value by')
(Decr:					'decrease by'			'decrease value by')
(Mult:					'multiply by'			'multiply value by')) language: #YourLanguage
! !

!EUCJPTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 10:09'!
leadingChar

	^ JISX0208 leadingChar
! !

!EUCJPTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 16:00'!
unicodeClass

	^ UnicodeJapanese.
! !

!EUCJPTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 10:11'!
encodingNames 

	^ #('euc-jp' ) copy
! !

!EUCKRTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 15:19'!
leadingChar

	^ KSX1001 leadingChar
! !

!EUCKRTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 16:00'!
unicodeClass

	^ UnicodeKorean.
! !

!EUCKRTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 3/31/2003 11:36'!
encodingNames 

	^ #('ks-c-5601-1987' 'euc-kr' ) copy
! !

!EUCKRTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 15:19'!
example1
	"EUCKRTextConverter example1"

	| fileStream |
	fileStream _ FileStream newFileNamed: 'test.kr'.
	fileStream converter: EUCKRTextConverter new.
	fileStream nextPut: (MultiCharacter value: 50335081).
	fileStream nextPut: (MultiCharacter value: 50334733).
	fileStream close
! !

!EUCKRTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 15:19'!
example2
	"EUCKRTextConverter example2"

	| writeStream fileStream |
	writeStream _ WriteStream on: String new.
	fileStream _ FileStream fileNamed: 'test.kr'.
	fileStream converter: EUCKRTextConverter new.
	[fileStream atEnd] whileFalse: [writeStream nextPut: fileStream next].
	fileStream close.
	^ writeStream contents
! !

!EUCTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 10:09'!
leadingChar

	^ self subclassResponsibility
! !

!EUCTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 15:59'!
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: [self errorMalformedInput].
	offset _ 16rA1.
	value1 _ character1 asciiValue - offset.
	value2 _ character2 asciiValue - offset.
	nonUnicodeChar _ MultiCharacter leadingChar: self leadingChar code: value1 * 94 + value2.
	^ self unicodeClass value: nonUnicodeChar asUnicode.
! !

!EUCTextConverter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/7/2003 19:55'!
nextPut: aCharacter toStream: aStream 
	| value leadingChar nonUnicodeChar value1 value2 |
	aStream isBinary ifTrue: [
		aCharacter class == Character ifTrue: [
			aStream basicNextPut: aCharacter.
			^ aStream
		].
		aCharacter class == MultiCharacter ifTrue: [
			aStream nextInt32Put: aCharacter value.
			^ aStream
		]
	].
	value _ aCharacter charCode.
	leadingChar _ aCharacter leadingChar.
	(leadingChar = 0 and: [value < 128]) ifTrue: [
		aStream basicNextPut: (Character value: value).
		^ aStream
	].
	
	nonUnicodeChar _ self nonUnicodeClass charFromUnicode: 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: 'as yet unclassified' stamp: 'yo 10/4/2003 15:48'!
nonUnicodeClass

	^ (EncodedCharSet charsetAt: self leadingChar).
! !

!EUCTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 15:37'!
unicodeClass

	self subclassResponsibility
! !

!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 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 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: 'sw 3/28/2001 19:46'!
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: '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! !

!ElementTranslation methodsFor: 'access' stamp: 'sw 5/22/2001 10:34'!
helpMessage
	"Answer the helpMessage"

	^ helpMessage! !

!ElementTranslation methodsFor: 'access' stamp: 'sw 5/22/2001 10:33'!
wording
	"Answer the wording"

	^ wording! !

!ElementTranslation methodsFor: 'initialization' stamp: 'sw 9/12/2001 23:00'!
language
	"Answer the natural language symbol of the receiver"

	^ naturalLanguageSymbol ifNil: [naturalLanguageSymbol _ #English]! !

!ElementTranslation methodsFor: 'initialization' stamp: 'sw 9/12/2001 10:15'!
wording: aWording helpMessage: aHelpMessage language: aLanguageSymbol
	"Set state directly"

	wording _ aWording.
	helpMessage _ aHelpMessage.
	naturalLanguageSymbol _ aLanguageSymbol! !

!ElementTranslation methodsFor: 'printing' stamp: 'sw 9/12/2001 16:08'!
printOn: aStream
	"Print the receiver on the stream"

	aStream nextPutAll: '('.
	super printOn: aStream.
	aStream nextPutAll: ' language: ', naturalLanguageSymbol asString, ' wording: ', wording asString, ')'! !

!ElementTranslation methodsFor: 'translation' stamp: 'dgd 12/4/2003 20:22'!
translated
	"answer the receiver translated to the current language"
	| translatedWording translatedHelpMessage |
	
	translatedWording := wording isNil
				ifFalse: [wording asString translated].
	translatedHelpMessage := helpMessage isNil
				ifFalse: [helpMessage asString translated].
	""
	^ self class new
		wording: translatedWording
		helpMessage: translatedHelpMessage
		language: self currentWorld currentNaturalLanguage! !

!ElementTranslation class methodsFor: 'instance creation' stamp: 'sw 9/12/2001 10:16'!
fromPair: wordingAndHelpMessagePair language: aLanguageSymbol
	"Answer an instance with the given wording and help message"

	^ self new wording: wordingAndHelpMessagePair first helpMessage: wordingAndHelpMessagePair second language: aLanguageSymbol! !

!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: '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' prior: 20426294!
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 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 class methodsFor: 'parts bin' stamp: 'tk 11/13/2001 02:23'!
descriptionForPartsBin
	^ self partName:	'Ellipse'
		categories:		#('Graphics' ' Basic 1 ')
		documentation:	'An elliptical or circular shape'! !

!EllipseMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:03'!
initialize

	self registerInFlapsRegistry.	! !

!EllipseMorph class methodsFor: '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: '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] ! !

!EmphasizedMenu methodsFor: 'emphasis' stamp: 'fc 2/19/2004 22:07' prior: 20433825!
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' prior: 20434102!
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 methodsFor: 'examples' stamp: 'fc 2/19/2004 22:06' prior: 20435593!
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: 'fc 2/19/2004 22:08' prior: 20436134!
example3
	"EmphasizedMenu example3"

	^ (self
		selectionAndEmphasisPairs: #('how' #bold 'well' #normal 'does' #italic 'this' #struckOut 'work' #normal))
		startUpWithCaption: 'A Menu with Emphases'! !

!EmptyInitializeTest methodsFor: 'patterns' stamp: 'Noury Bouraqadi 9/16/2003 13:01'!
obsoleteAnsweringSuperInitialize

	^super initialize	! !

!EmptyInitializeTest methodsFor: 'patterns' stamp: 'Noury Bouraqadi 9/16/2003 12:59'!
obsoleteEmptyInitialize
	"Should be implemented only by Object"! !

!EmptyInitializeTest methodsFor: 'patterns' stamp: 'Noury Bouraqadi 9/16/2003 13:00'!
obsoleteSuperInitialize

	super initialize	! !

!EmptyInitializeTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 13:16'!
classesToTest
	"Its Ok if Object has a method #initialize"

	^super classesToTest copyWithout: Object! !

!EmptyInitializeTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 12:56'!
obsoleteMethodSelector
	^#initialize! !

!EncodedCharSet class methodsFor: 'class methods' 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: 'class methods' 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: 'class methods' stamp: 'yo 10/14/2003 16:27'!
charFromUnicode: unicode

	| table index |
	unicode < 256 ifTrue: [^ Character value: unicode].

	table _ self ucsTable.
	index _ table indexOf: unicode.
	index = 0 ifTrue: [
		^ nil.
	].

	^ MultiCharacter leadingChar: self leadingChar code: index - 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 12/27/2002 05:48'!
encodedCharSets

	^ EncodedCharSets
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 8/18/2003 18:40'!
initialize
"
	self initialize
"
	self allSubclassesDo: [:each | each initialize].

	EncodedCharSets _ Array new: 256.

	EncodedCharSets at: 1 put: Latin1.
	EncodedCharSets at: 2 put: JISX0208.
	EncodedCharSets at: 3 put: GB2312.
	EncodedCharSets at: 4 put: KSX1001.
	EncodedCharSets at: 5 put: JISX0208.
	EncodedCharSets at: 6 put: UnicodeJapanese.
	EncodedCharSets at: 7 put: UnicodeSimplifiedChinese.
	EncodedCharSets at: 8 put: UnicodeKorean.
	EncodedCharSets at: 9 put: GB2312.
	EncodedCharSets at: 10 put: UnicodeTraditionalChinese.
	EncodedCharSets at: 11 put: UnicodeVietnamese.
	EncodedCharSets at: 13 put: KSX1001.
	EncodedCharSets at: 18 put: UnicodeLatinExtendedAB.
	EncodedCharSets at: 19 put: UnicodeIPA.
	EncodedCharSets at: 20 put: UnicodeSpacingModifiers.
	EncodedCharSets at: 21 put: UnicodeCombiningDiacritical.
	EncodedCharSets at: 22 put: UnicodeGreek.
	EncodedCharSets at: 23 put: UnicodeCyrillic.
	EncodedCharSets at: 24 put: UnicodeArmenian.
	EncodedCharSets at: 25 put: UnicodeHebrew.
	EncodedCharSets at: 26 put: UnicodeArabic.
	EncodedCharSets at: 27 put: UnicodeSyriac.
	EncodedCharSets at: 28 put: UnicodeThaana.
	EncodedCharSets at: 29 put: UnicodeDevanagari.
	EncodedCharSets at: 30 put: UnicodeBengali.
	EncodedCharSets at: 31 put: UnicodeGurmukhi.
	EncodedCharSets at: 32 put: UnicodeGujarati.
	EncodedCharSets at: 33 put: UnicodeOriya.
	EncodedCharSets at: 34 put: UnicodeTamil.
	EncodedCharSets at: 35 put: UnicodeTelugu.
	EncodedCharSets at: 36 put: UnicodeKannada.
	EncodedCharSets at: 37 put: UnicodeMalayalam.
	EncodedCharSets at: 38 put: UnicodeSinhala.
	EncodedCharSets at: 39 put: UnicodeThai.
	EncodedCharSets at: 40 put: UnicodeLao.
	EncodedCharSets at: 41 put: UnicodeTibetan.
	EncodedCharSets at: 42 put: UnicodeMyanmar.
	EncodedCharSets at: 43 put: UnicodeGeorgian.
	EncodedCharSets at: 44 put: UnicodeEthiopic.
	EncodedCharSets at: 45 put: UnicodeCherokee.
	EncodedCharSets at: 46 put: UnicodeCanadianAboriginal.
	EncodedCharSets at: 47 put: UnicodeOgham.
	EncodedCharSets at: 48 put: UnicodeRunic.
	EncodedCharSets at: 49 put: UnicodeTagalog.
	EncodedCharSets at: 50 put: UnicodeHanunoo.
	EncodedCharSets at: 51 put: UnicodeBuhid.
	EncodedCharSets at: 52 put: UnicodeTagbanwa.
	EncodedCharSets at: 53 put: UnicodeKhmer.
	EncodedCharSets at: 54 put: UnicodeMongolian.
	EncodedCharSets at: 55 put: UnicodeLatinExtendedAdditional.
	EncodedCharSets at: 56 put: UnicodeGreekExtended.
	EncodedCharSets at: 57 put: UnicodeGeneralPunctuation.
	EncodedCharSets at: 58 put: UnicodeSuperAndSubscript.
	EncodedCharSets at: 59 put: UnicodeCurrencySymbols.
	EncodedCharSets at: 60 put: UnicodeCombiningDiacriticalForSymbols.
	EncodedCharSets at: 61 put: UnicodeLetterlikeSymbols.
	EncodedCharSets at: 62 put: UnicodeNumberForms.
	EncodedCharSets at: 63 put: UnicodeArrows.
	EncodedCharSets at: 64 put: UnicodeMathOperators.
	EncodedCharSets at: 65 put: UnicodeMiscTechnical.
	EncodedCharSets at: 66 put: UnicodeControlPictures.
	EncodedCharSets at: 67 put: UnicodeOCRs.
	EncodedCharSets at: 68 put: UnicodeEnclosedAlnums.
	EncodedCharSets at: 69 put: UnicodeBoxDrawing.
	EncodedCharSets at: 70 put: UnicodeBlockElements.
	EncodedCharSets at: 71 put: UnicodeGeometricShapes.
	EncodedCharSets at: 72 put: UnicodeMiscSymbols.
	EncodedCharSets at: 73 put: UnicodeDingbats.
	EncodedCharSets at: 74 put: UnicodeMiscMathSymbolsA.
	EncodedCharSets at: 75 put: UnicodeSupplementalArrowsA.
	EncodedCharSets at: 76 put: UnicodeBraille.
	EncodedCharSets at: 77 put: UnicodeSupplementalArrowsB.
	EncodedCharSets at: 78 put: UnicodeMiscMathSymbolsB.
	EncodedCharSets at: 79 put: UnicodeSupplementalMathOperators.
	EncodedCharSets at: 80 put: UnicodeYiSyllables.
	EncodedCharSets at: 81 put: UnicodeYiRadicals.
	EncodedCharSets at: 82 put: UnicodeAlphabeticPresentations.
	EncodedCharSets at: 83 put: UnicodeArabicPresentationsA.
	EncodedCharSets at: 84 put: UnicodeCombiningHalfMarks.
	EncodedCharSets at: 85 put: UnicodeArabicPresentationsB.
	EncodedCharSets at: 86 put: UnicodeOldItalic.
	EncodedCharSets at: 87 put: UnicodeGothic.
	EncodedCharSets at: 88 put: UnicodeDeseret.
	EncodedCharSets at: 89 put: UnicodeByzantineMusicals.
	EncodedCharSets at: 90 put: UnicodeMusicalSymbols.
	EncodedCharSets at: 91 put: UnicodeMathAlnumSymbols.
	EncodedCharSets at: 92 put: UnicodeTags.
	EncodedCharSets at: 256 put: Unicode! !

!EncodedCharSet class methodsFor: 'class methods' 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: 'class methods' 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: 'class methods' 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: 'class methods' 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: 'yo 11/10/2002 10:55'!
languageClass

	^ Smalltalk primaryLanguage.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/2/2002 16:32'!
charSetSize

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/4/2002 22:57'!
charsetAt: encoding

	^ EncodedCharSets at: encoding + 1 ifAbsent: [EncodedCharSets at: 1].
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/2/2002 16:32'!
compoundTextFinalChar

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:31'!
compoundTextSequence

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/2/2002 16:32'!
leadingChar

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/4/2002 14:43'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/4/2002 22:51'!
printingDirection

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 10/7/2002 17:00'!
scanSelector

	self subclassResponsibility.
"
	^ #basicScanCharactersFrom:to:in:rightX:stopConditions:kern:
"! !

!EncodedCharSet class methodsFor: 'as yet unclassified' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable latin1Table.
! !

!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'!
isBreakableAt: index in: text

	self subclassResponsibility.
! !

!Encoder methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 18:46' prior: 20438498!
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' 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: 'encoding' stamp: 'RAA 2/5/2001 10:44'!
encodeVariable: name sourceRange: range ifUnknown: action
	| varNode |
	varNode _ scopeTable at: name
			ifAbsent: 
				[(self lookupInPools: name 
					ifFound: [:assoc | varNode _ self global: assoc name: name])
					ifTrue: [varNode]
					ifFalse: [action value]].
	range ifNotNil: [
		name first isUppercase ifTrue:
			[globalSourceRanges addLast: { name. range. false }]. ].

	(varNode isTemp and: [varNode scope < 0]) ifTrue: [
		OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope'].
	].
	^ varNode! !

!Encoder methodsFor: 'encoding' stamp: 'yo 11/11/2002 10:22' prior: 36001309!
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: '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' prior: 20446741!
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' stamp: 'yo 11/11/2002 10:23' prior: 20447454!
possibleVariablesFor: proposedVariable

	| results |
	results _ proposedVariable correctAgainstDictionary: scopeTable
								continuedFrom: nil.
	proposedVariable first canBeGlobalVarInitial ifTrue:
		[ results _ class possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results.
! !

!English methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:27'!
name
	"answer the receiver's name"
	^ #'English'! !

!EnglishEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 10/24/2002 13:41'!
defaultEncodingName

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk 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].
	^ nil
! !

!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: 'editing' stamp: 'dgd 2/22/2003 14:23' prior: 20473135!
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: '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: 'dgd 2/22/2003 14:24' prior: 20478153!
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' prior: 20478681!
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: 'menu' stamp: 'dgd 8/30/2003 21:19' prior: 20480410!
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' prior: 20481242!
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: '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! !

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/14/2003 20:17' prior: 20488673!
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! !

!Environment methodsFor: 'system conversion' stamp: 'ar 8/16/2001 13:25'!
browseIndirectRefs  "Smalltalk browseIndirectRefs"

	| cm lits browseList foundOne allClasses n |

	self flag: #mref.		"no senders at the moment. also no Environments at the moment"

	browseList _ OrderedCollection new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Locating methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit isVariableBinding ifTrue:
							[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue: [
						browseList add: (
							MethodReference new
								setStandardClass: cl 
								methodSymbol: sel
						)
					]]]]].

	Smalltalk 
		browseMessageList: browseList asSortedCollection
		name: 'Indirect Global References'
		autoSelect: nil! !

!Environment methodsFor: 'system conversion' stamp: 'sd 4/16/2003 08:52' prior: 36013717!
browseIndirectRefs  "Smalltalk browseIndirectRefs"

	| cm lits browseList foundOne allClasses n |

	self flag: #mref.		"no senders at the moment. also no Environments at the moment"

	browseList _ OrderedCollection new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Locating methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit isVariableBinding ifTrue:
							[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue: [
						browseList add: (
							MethodReference new
								setStandardClass: cl 
								methodSymbol: sel
						)
					]]]]].

	self systemNavigation 
		browseMessageList: browseList asSortedCollection
		name: 'Indirect Global References'
		autoSelect: nil! !

!Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:16' prior: 36014920!
browseIndirectRefs  "Smalltalk browseIndirectRefs"

	| cm lits browseList foundOne allClasses n |

	self flag: #mref.		"no senders at the moment. also no Environments at the moment"

	browseList _ OrderedCollection new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Locating methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit isVariableBinding ifTrue:
							[(lit value == cl or: [(cl bindingOf: lit key) notNil])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue: [
						browseList add: (
							MethodReference new
								setStandardClass: cl 
								methodSymbol: sel
						)
					]]]]].

	self systemNavigation 
		browseMessageList: browseList asSortedCollection
		name: 'Indirect Global References'
		autoSelect: nil! !

!Environment methodsFor: 'system conversion' stamp: 'ar 8/16/2001 13:25'!
rewriteIndirectRefs   "Smalltalk rewriteIndirectRefs"
	"For all classes, identify all methods with references to globals outside their direct access path.
	For each of these, call another method to rewrite the source with proper references."

	| cm lits envtForVar envt foundOne allClasses n |
	envtForVar _ Dictionary new.  "Dict of varName -> envt name"
	Smalltalk associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500])
			ifTrue: [envt associationsDo:
						[:a | envtForVar at: a key put: assn key]]].

	"Allow compiler to compile refs to globals out of the direct reference path"
	Preferences enable: #lenientScopeForGlobals.

	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Updating indirect global references in source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit isVariableBinding ifTrue:
							[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue:
						[self rewriteSourceForSelector: sel inClass: cl using: envtForVar]]].
			]].

	Preferences disable: #lenientScopeForGlobals.

! !

!Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:17' prior: 36017325!
rewriteIndirectRefs   "Smalltalk rewriteIndirectRefs"
	"For all classes, identify all methods with references to globals outside their direct access path.
	For each of these, call another method to rewrite the source with proper references."

	| cm lits envtForVar envt foundOne allClasses n |
	envtForVar _ Dictionary new.  "Dict of varName -> envt name"
	Smalltalk associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500])
			ifTrue: [envt associationsDo:
						[:a | envtForVar at: a key put: assn key]]].

	"Allow compiler to compile refs to globals out of the direct reference path"
	Preferences enable: #lenientScopeForGlobals.

	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Updating indirect global references in source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit isVariableBinding ifTrue:
							[(lit value == cl or: [(cl bindingOf: lit key) notNil])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue:
						[self rewriteSourceForSelector: sel inClass: cl using: envtForVar]]].
			]].

	Preferences disable: #lenientScopeForGlobals.

! !

!Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:17' prior: 20501080!
rewriteSourceForSelector: selector inClass: aClass using: envtForVar
	"Rewrite the source code for the method in question so that all global references out of the direct access path are converted to indirect global references.  This is done by parsing the source with a lenient parser able to find variables in any environment.  Then the parse tree is consulted for the source code ranges of each reference that needs to be rewritten and the pattern to which it should be rewritten.  Note that assignments, which will take the form
	envt setValueOf: #GlobalName to: ...
may generate spurious message due to agglutination of keywords with the value expression."

	| code methodNode edits varName eName envt |
	code _ aClass sourceCodeAt: selector.
	methodNode _ Compiler new parse: code in: aClass notifying: nil.
	edits _ OrderedCollection new.
	methodNode encoder globalSourceRanges do:
		[:tuple |   "{ varName. srcRange. store }"
		(aClass bindingOf: (varName _ tuple first asSymbol)) notNil ifFalse:
			["This is a remote global.  Add it as reference to be edited."
			edits addLast: { varName. tuple at: 2. tuple at: 3 }]].
	"Sort the edits by source position."
	edits _ edits asSortedCollection: [:a :b | a second first < b second first].
	edits reverseDo:
		[:edit | varName _ edit first.
		(eName _ envtForVar at: varName ifAbsent: [nil]) ifNotNil:
			["If varName is not already exported, define an export method"
			envt _ self at: eName.
			(envt class includesSelector: varName) ifFalse:
				[envt class compile: (self exportMethodFor: varName)
						 classified: 'exports'].
			"Replace each access out of scope with a proper remote reference"
			code _ code copyReplaceFrom: edit second first
						to: edit second last
						with: eName , ' ' , varName]].

	aClass compile: code classified: (aClass organization categoryOfElement: selector)! !

!Environment methodsFor: 'system conversion' stamp: 'ar 8/16/2001 13:25'!
tallyIndirectRefs   "Smalltalk tallyIndirectRefs"
	"For all classes, tally the number of references to globals outside their inherited environment.  Then determine the 'closest' environment that resolves most of them.  If the closest environment is different from the one in whick the class currently resides, then enter the class name with the tallies of its references to all other environments.
	Return a triplet:
	A dictionary of all classes for which this is so, with those tallies,
	A dictionary giving the classes that would be happier in each of the other categories,
	A list of the variable names sorted by number of occurrences."

	| tallies refs cm lits envtForVar envt envtRefs allRefs newCategories cat allClasses n |
	envtForVar _ Dictionary new.  "Dict of varName -> envt name"
	allRefs _ Bag new.
	Smalltalk associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500])
			ifTrue: [envt associationsDo:
						[:a | envtForVar at: a key put: assn key]]].

	tallies _ Dictionary new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Scanning methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			refs _ Set new.
			{ cls. cls class } do:
			[:cl | cl selectors do:
				[:sel | cm _ cl compiledMethodAt: sel.
				lits _ cm literals.
				lits do:
					[:lit | lit isVariableBinding ifTrue:
						[(lit value == cl or: [cls canFindWithoutEnvironment: lit key])
							ifFalse: [refs add: lit key]]]]].
		envtRefs _ Bag new.
		refs asSet do:
			[:varName |
			envtRefs add: (envtForVar at: varName)
					withOccurrences: (refs occurrencesOf: varName).
			(envtRefs sortedCounts isEmpty or: [envtRefs sortedCounts first value == (Smalltalk keyAtValue: cls environment)])
				ifFalse: [allRefs add: varName withOccurrences: (refs occurrencesOf: varName).
						tallies at: cls name put: envtRefs sortedCounts.
						Transcript cr; print: envtRefs sortedCounts; endEntry]]]].

	newCategories _ Dictionary new.
	tallies associationsDo:
		[:assn | cat _ assn value first value.
		(newCategories includesKey: cat) ifFalse:
			[newCategories at: cat put: Array new].
		newCategories at: cat put: ((newCategories at: cat) copyWith: assn key)].
	^ { tallies. newCategories. allRefs sortedCounts }! !

!Environment methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:08'!
bindingOf: varName
	^self associationAtOrAbove: varName ifAbsent:[nil]! !

!Environment methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:08' prior: 36024834!
bindingOf: varName
	^self associationAtOrAbove: varName ifAbsent:[nil]! !

!Environment class methodsFor: 'system conversion' stamp: 'sd 4/17/2003 21:32' prior: 20508062!
computePrerequisites
	"We say one environment is a prerequisite of another if classes defined  
	in the other inherit from classes in the first.  
	Compute a dictionary with an entry for every non-kernel environment. 
	That entry is another dictionary giving the names of any prerequisite  
	environments and the list of classes that require it."
	"Environment computePrerequisites."
	"<-- inspect this"
	| bigCats bigCat preReqs supCat dict kernelCategories |
	bigCats _ IdentityDictionary new.
	kernelCategories _ Environment new kernelCategories.
	self flag: #NotSureOfTheSmalltalkReference. "sd"
	Smalltalk allClasses
		do: [:cl | 
			bigCat _ (cl category asString copyUpTo: '-' first) asSymbol.
			(kernelCategories includes: bigCat)
				ifTrue: [bigCat _ #Kernel].
			bigCats at: cl name put: bigCat].
	preReqs _ IdentityDictionary new.
	self flag: #NotSureAboutTheSmalltalkReferenceHere.
	"sd"
	Smalltalk allClasses
		do: [:cl | cl superclass
				ifNotNil: [bigCat _ bigCats at: cl name.
					supCat _ bigCats at: cl superclass name.
					bigCat ~~ supCat
						ifTrue: [dict _ preReqs
										at: bigCat
										ifAbsent: [preReqs at: bigCat put: IdentityDictionary new].
							dict
								at: supCat
								put: ((dict
										at: supCat
										ifAbsent: [Array new])
										copyWith: cl name)]]].
	^ preReqs! !

!Environment class methodsFor: 'system conversion' stamp: 'sw 5/23/2001 14:27'!
reorganizeEverything
	"Undertake a grand reorganization.
	Environment reorganizeEverything.
	"

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(self confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ self inform: 'No changes were made'].

	Smalltalk newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk.
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	Smalltalk newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Environment class methodsFor: 'system conversion' stamp: 'sd 5/23/2003 15:15' prior: 36026580!
reorganizeEverything
	"Undertake a grand reorganization.
	Environment reorganizeEverything.
	"

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(self confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ self inform: 'No changes were made'].

	ChangeSet  newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk.
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	Smalltalk newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Environment class methodsFor: 'system conversion' stamp: 'nk 7/2/2003 08:59' prior: 36029107!
reorganizeEverything
	"Undertake a grand reorganization.
	Environment reorganizeEverything.
	"

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(self confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ self inform: 'No changes were made'].

	ChangeSet  newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk.
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	ChangeSet newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Environment class methodsFor: 'system conversion' stamp: 'nk 7/2/2003 08:59' prior: 36031634!
reorganizeEverything
	"Undertake a grand reorganization.
	Environment reorganizeEverything.
	"

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(self confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ self inform: 'No changes were made'].

	ChangeSet  newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk.
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	ChangeSet newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Environment class methodsFor: 'system conversion' stamp: 'ajh 9/13/2002 23:01' prior: 36034161!
reorganizeEverything
	"Undertake a grand reorganization.
	Environment reorganizeEverything.
	"

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(self confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ self inform: 'No changes were made'].

	ChangeSet newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk at: #Smalltalk put: (SmalltalkEnvironment newFrom: Smalltalk).
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	ChangeSet newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

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

!EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0!
I provide a simple way to test the equality properties of any object.!
!Error methodsFor: 'private' stamp: 'ajh 2/1/2003 00:54'!
isResumable
	"Determine whether an exception is resumable."

	^ false! !

!Error methodsFor: 'exceptionDescription' stamp: 'ajh 9/4/2002 19:24' prior: 20513405!
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! !

!EtoyLoginMorph methodsFor: 'actions' stamp: 'ar 9/24/2000 00:08'!
doCancel

	self delete.
	cancelBlock ifNotNil:[cancelBlock value].! !

!EtoyLoginMorph methodsFor: 'actions' stamp: 'ar 9/25/2000 13:38'!
doOK

	| proposed |

	proposed _ theNameMorph contents string.
	proposed size = 0 ifTrue: [^self inform: 'Please enter your login name'].
	proposed size > 24 ifTrue: [^self inform: 'Please make the name 24 characters or less'].
	(Project isBadNameForStoring: proposed) ifTrue: [
		^self inform: 'Please remove any funny characters'
	].
	(actionBlock value: proposed) ifTrue:[self delete].! !

!EtoyLoginMorph methodsFor: 'actions' stamp: 'dgd 2/21/2003 22:36' prior: 36040186!
doOK
	| proposed |
	proposed := theNameMorph contents string.
	proposed isEmpty ifTrue: [^self inform: 'Please enter your login name'].
	proposed size > 24 
		ifTrue: [^self inform: 'Please make the name 24 characters or less'].
	(Project isBadNameForStoring: proposed) 
		ifTrue: [^self inform: 'Please remove any funny characters'].
	(actionBlock value: proposed) ifTrue: [self delete]! !

!EtoyLoginMorph methodsFor: 'actions' stamp: 'dgd 10/8/2003 18:58' prior: 36040663!
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: 'ar 9/23/2000 13:48'!
buttonColor

	^color darker! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'gm 3/11/2003 21:51' prior: 36041632!
buttonColor
	^ Color paleYellow darker!
]style[(11 4 23)f2b,f2,f1cred;! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:48'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString font: self myFont;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:49'!
cancelButton

	^self
		buttonNamed: 'Cancel' 
		action: #doCancel 
		color: self buttonColor 
		help: 'Cancel this login operation.'! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:48'!
myFont

	^(TextStyle named: #ComicBold) fontOfSize: 16! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'nk 7/12/2003 08:40' prior: 36042459!
myFont

	^ Preferences standardEToysFont! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:50'!
okButton

	^self
		buttonNamed: 'OK' 
		action: #doOK 
		color: self buttonColor 
		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,f2c143041000,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,f2c148046000,f2,f2cblue;i,f2,f2cblue;i,f2,f2cmagenta;,f2,f2c198198122,f2,f2cmagenta;,f2,f2c198198122,f2,f2c198198122,f2,f2c198198122,f2,f2c198198122,f2,f2cmagenta;,f2,f2c198198122,f2,f2c198198122,f2,f2c198198122,f2,f2cblue;i,f2,f2cmagenta;,f2,f2cblue;i,f2,f2c198198122,f2,f2cmagenta;,f2,f2cblue;i! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'ar 8/23/2001 21:36'!
initialize
	| fs |
	super initialize.
	self beSticky.
	fs _ 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) }.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	color _ Color paleYellow.
	borderWidth _ 8.
	borderColor _ color darker.
	self layoutInset: 4.
	self useRoundedCorners.
	self rebuild.
	fs origin: bounds origin.
	fs direction: 0@self fullBounds height.
	self fillStyle: fs.! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:28' prior: 36044107!
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 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).! !

!EventHandler methodsFor: 'access' stamp: 'RAA 5/29/2001 10:25'!
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 classThatUnderstands:
					mouseDownSelector) name , ' ', mouseDownSelector].
	mouseMoveRecipient ifNotNil:
		[list add: (mouseMoveRecipient class classThatUnderstands:
					mouseMoveSelector) name , ' ', mouseMoveSelector].
	mouseStillDownRecipient ifNotNil:
		[list add: (mouseStillDownRecipient class classThatUnderstands:
					mouseStillDownSelector) name , ' ', mouseStillDownSelector].
	mouseUpRecipient ifNotNil:
		[list add: (mouseUpRecipient class classThatUnderstands:
					mouseUpSelector) name , ' ', mouseUpSelector].
	mouseEnterRecipient ifNotNil:
		[list add: (mouseEnterRecipient class classThatUnderstands:
					mouseEnterSelector) name , ' ', mouseEnterSelector].
	mouseLeaveRecipient ifNotNil:
		[list add: (mouseLeaveRecipient class classThatUnderstands:
					mouseLeaveSelector) name , ' ', mouseLeaveSelector].
	mouseEnterDraggingRecipient ifNotNil:
		[list add: (mouseEnterDraggingRecipient class classThatUnderstands:
					mouseEnterDraggingSelector) name , ' ', mouseEnterDraggingSelector].
	mouseLeaveDraggingRecipient ifNotNil:
		[list add: (mouseLeaveDraggingRecipient class classThatUnderstands:
					mouseLeaveDraggingSelector) name , ' ', mouseLeaveDraggingSelector].
	doubleClickRecipient ifNotNil:
		[list add: (doubleClickRecipient class classThatUnderstands:
					doubleClickSelector) name , ' ', doubleClickSelector].
	keyStrokeRecipient ifNotNil:
		[list add: (keyStrokeRecipient class classThatUnderstands:
					keyStrokeSelector) name , ' ', keyStrokeSelector].
	^ list! !

!EventHandler methodsFor: 'access' prior: 36046485!
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' stamp: 'RAA 5/29/2001 10:33'!
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 classThatUnderstands: 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' prior: 36050268!
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: 'copying' stamp: 'tk 2/20/2001 18:46'!
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"
	gestureDictionaryOrName _ gestureDictionaryOrName.!
]style[(25 108 10 129)f1b,f1,f1LDeepCopier Comment;,f1! !

!EventHandler methodsFor: 'copying' stamp: 'nk 2/14/2004 18:24' prior: 36052344!
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: 'jcg 9/21/2001 13:06'!
doubleClickTimeout: event fromMorph: sourceMorph 
	^ self
		send: doubleClickTimeoutSelector
		to: doubleClickTimeoutRecipient
		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: '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: '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]]]! !

!EventHandler methodsFor: '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: 'initialization' stamp: 'jcg 9/21/2001 12:58'!
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:
		[gestureRecipient _ recipient. gestureSelector _ selector. ^ self].
	self error: 'Event name, ' , eventName , ' is not recognizable.'
! !

!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:16' prior: 36057900!
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: 'nk 2/15/2004 08:16'!
onGestureSend: selector to: recipient
	gestureRecipient _ recipient.
	gestureSelector _ selector.! !

!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59' prior: 36061437!
onGestureSend: selector to: recipient! !

!EventHandler methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:40' prior: 20530706!
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: 'NS 2/20/2001 20:23'!
handlesGestureStart: evt
	"Does the associated morph want to handle gestures?"

	^ gestureRecipient notNil and: [gestureRecipient gestureDictionary notNil]! !

!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:29' prior: 36062354!
handlesGestureStart: evt
	"Might the associated morph want to handle gestures?"

	^ gestureRecipient notNil and: [gestureRecipient gestureDictionary notNil]! !

!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:57' prior: 36062595!
handlesGestureStart: evt
	"Does the associated morph want to handle gestures?"
	^false! !

!EventHandler methodsFor: 'testing' stamp: 'hmm 3/15/2001 22:02'!
handlesMouseDown: evt
	mouseDownRecipient ifNotNil: [^ true].
	mouseStillDownRecipient ifNotNil: [^ true].
	mouseUpRecipient ifNotNil: [^ true].
	(self handlesClickOrDrag: evt) ifTrue:[^true].
	gestureSelector ifNotNil: [^true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:13' prior: 36062994!
handlesMouseDown: evt
	mouseDownRecipient ifNotNil: [^ true].
	mouseStillDownRecipient ifNotNil: [^ true].
	mouseUpRecipient ifNotNil: [^ true].
	(self handlesClickOrDrag: evt) ifTrue:[^true].
	^self handlesGestureStart: evt! !

!EventManager methodsFor: 'copying' stamp: 'reThink 3/3/2001 10:22'!
copy

	| answer |
	answer := super copy.
	answer release.
	^answer! !

!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: '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 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: 'releasing' stamp: 'reThink 2/18/2001 15:34'!
releaseActionMapFor: anObject

	self actionMaps
		removeKey: anObject
		ifAbsent: []! !

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

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

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

!EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 2/22/2003 19:01' prior: 20542029!
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: 'sw 5/23/2001 14:28'!
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: oldSize printString , ' events reduced to ' , tape size printString.
	voiceRecorder ifNotNil: [voiceRecorder suppressSilence].
	saved _ false.
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 9/21/2003 17:54' prior: 36075769!
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: 'dgd 2/21/2003 23:15' prior: 20547273!
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.
	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.
			lastEvent := nextEvent isMouse ifTrue: [nextEvent] ifFalse: [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: 'nk 7/11/2003 07:37' prior: 36076822!
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: 'fileIn/Out' stamp: 'dgd 2/21/2003 23:15' prior: 20548899!
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: 'dgd 2/21/2003 23:16' prior: 20552295!
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: 
			[(Smalltalk at: #RequestBoxMorph
				ifAbsent: 
					[^self writeTape: (FillInTheBlank request: 'Tape to write'
								initialAnswer: 'tapeName.tape')]) 
					request: 'Tape to write'
					respondTo: self
					selector: #writeTape:]! !

!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' prior: 20538259!
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: 'RAA 6/14/2001 16:33'!
buttonFor: data 

	| b |
	b _ SimpleButtonMorph new 
		target: self;
		label: data first asString;
		actionSelector: data first.
	data second ifNotNil: [b width: data second].
	data third ifNotNil: [b setBalloonText: data third].
	^b! !

!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' prior: 20540674!
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: '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 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: 'hg 8/3/2000 17:24'!
openTapeFromFile: fullName
	"Open an eventRecorder tape for playback."
 
	(EventRecorderMorph new readTape: fullName) rewind openInWorld! !

!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'los 2/26/2004 11:46' prior: 36086163!
openTapeFromFile: fullName
	"Open an eventRecorder tape for playback."
 
	(self new) readTape: fullName; openInWorld! !

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

!EventSensor methodsFor: 'accessing' stamp: 'nk 4/12/2004 19:36'!
eventTicklerProcess
	"Answer my event tickler process, if any"
	^EventTicklerProcess! !

!EventSensor methodsFor: 'accessing' stamp: 'JMM 10/5/2001 13:46'!
flushAllButDandDEvents
	| newQueue oldQueue  |
	
	newQueue _ SharedQueue new.
	self eventQueue ifNil: 
		[self 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]].
	self eventQueue: newQueue.
! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:48' prior: 36087040!
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 2/14/2001 00:03'!
peekButtons
	inputSemaphore signal.
	^mouseButtons! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:41' prior: 36088041!
peekButtons
	self fetchMoreEvents.
	^mouseButtons! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:51' prior: 20562507!
peekEvent
	"Look ahead at the next event."
	eventQueue ifNil:[^nil].
	self fetchMoreEvents.
	^eventQueue peek! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/8/2001 21:45'!
peekMousePt
	^mousePosition! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/14/2001 00:01'!
peekPosition
	inputSemaphore signal. "get latest state"
	^mousePosition! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:41' prior: 36088589!
peekPosition
	self fetchMoreEvents.
	^mousePosition! !

!EventSensor methodsFor: 'initialize' stamp: 'JMM 10/5/2001 12:43'!
initialize
	"Initialize the receiver"
	mouseButtons _ 0.
	mousePosition _ 0@0.
	keyboardBuffer _ SharedQueue new.
	interruptKey _ interruptKey ifNil:[2094].  "cmd-."
	interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil:[Semaphore new].
	self flushAllButDandDEvents.
	inputProcess _ nil.
	inputSemaphore _ Semaphore new.
! !

!EventSensor methodsFor: 'initialize' stamp: 'ar 2/6/2004 14:45' prior: 36088870!
initialize
	"Initialize the receiver"
	mouseButtons _ 0.
	mousePosition _ 0@0.
	keyboardBuffer _ SharedQueue new.
	interruptKey _ interruptKey ifNil:[2094].  "cmd-."
	interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil:[Semaphore new].
	self flushAllButDandDEvents.
	inputSemaphore _ Semaphore new.
! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 3/18/2004 14:52' prior: 36089291!
initialize
	"Initialize the receiver"
	mouseButtons := 0.
	mousePosition := 0 @ 0.
	keyboardBuffer := SharedQueue new.
	self setInterruptKey: (interruptKey ifNil: [$. asciiValue bitOr: 16r0800 ]). 	"cmd-."
	hadInterrupt := false.
	interruptSemaphore := (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new].
	self flushAllButDandDEvents.
	inputSemaphore := Semaphore new.
	hasInputSemaphore := false.! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:21' prior: 36089692!
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: 'ar 2/6/2004 14:45' prior: 20558952!
shutDown
	inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 20:13' prior: 36090659!
shutDown
	super shutDown.
	EventTicklerProcess ifNotNil: [
		EventTicklerProcess terminate.
		EventTicklerProcess _ nil. ].
	inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].
! !

!EventSensor methodsFor: 'initialize' stamp: 'JMM 10/5/2001 12:54'!
startUp
	"Run the I/O process"
	self shutDown.
	self initialize.
	self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
	inputProcess _ [self ioProcess] forkAt: Processor lowIOPriority.
	super startUp.
	Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents].! !

!EventSensor methodsFor: 'initialize' stamp: 'ar 2/6/2004 14:45' prior: 36091110!
startUp
	"Run the I/O process"
	self shutDown.
	self initialize.
	self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
	super startUp.
	Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents].! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 3/18/2004 14:59' prior: 36091483!
startUp
	"Run the I/O process"
	self shutDown.
	self initialize.
	self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
	super startUp.
	Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents].

	"Attempt to discover whether the input semaphore is actually being signaled."
	hasInputSemaphore := false.
	inputSemaphore initSignals.
! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:25' prior: 36091791!
startUp
	"Run the I/O process"
	self shutDown.
	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: 'initialize' stamp: 'nk 6/21/2004 10:42' prior: 36092238!
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: 'jlb 2/24/2002 10:57'!
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: (EventSensorConstants at: #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: 'mouse' stamp: 'ar 5/18/2003 18:27' prior: 36093150!
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 4/12/2004 19:25'!
installEventTickler
	"Initialize the interrupt watcher process. Terminate the old process if any."
	"Sensor installEventTickler"

	EventTicklerProcess ifNotNil: [EventTicklerProcess terminate].
	EventTicklerProcess _ [self eventTickler] newProcess.
	EventTicklerProcess priority: Processor lowIOPriority.
	EventTicklerProcess resume.
! !

!EventSensor methodsFor: 'private' stamp: 'nk 6/21/2004 10:40' prior: 36095355!
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: 'RAA 2/10/2001 23:16'!
nextEventFromQueue
	"Return the next event from the receiver."
	eventQueue isEmpty ifTrue:[inputSemaphore signal].
	EventPollFrequency _ 500.	"since Squeak is taking the event, reset to normal delay"
	eventQueue isEmpty
		ifTrue:[^nil]
		ifFalse:[^eventQueue next]! !

!EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:42' prior: 36096487!
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 2/9/2001 19:10'!
nextEventSynthesized
	"Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this."
	| kbd array buttons pos modifiers mapped |
	"First check for keyboard"
	array _ Array new: 8.
	kbd _ self primKbdNext.
	kbd = nil ifFalse:
		["simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^ array].

	"Then check for mouse"
	buttons _ self buttons.
	pos _ self primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
	^ array! !

!EventSensor methodsFor: 'private' stamp: 'nk 3/17/2004 07:09' prior: 36097081!
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: 'di 10/1/2001 20:53'!
primKbdNext
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| evtBuf |
	inputSemaphore signal.
	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: 'ar 2/6/2004 14:41' prior: 36100568!
primKbdNext
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| evtBuf |
	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: 'di 10/1/2001 21:23'!
primKbdPeek
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| char |
	inputSemaphore signal.
	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: 'ar 2/6/2004 14:41' prior: 36101502!
primKbdPeek
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| char |
	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: 'di 10/1/2001 20:48'!
primMouseButtons
	inputSemaphore signal.
	self flushNonKbdEvents.
	^ mouseButtons! !

!EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:42' prior: 36102680!
primMouseButtons
	self fetchMoreEvents.
	self flushNonKbdEvents.
	^ mouseButtons! !

!EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:48'!
primMousePt
	inputSemaphore signal.
	self flushNonKbdEvents.
	^ mousePosition! !

!EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:41' prior: 36102994!
primMousePt
	self fetchMoreEvents.
	self flushNonKbdEvents.
	^ mousePosition! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 2/6/2004 14:44'!
fetchMoreEvents
	"Fetch more events from the VM"
	| eventBuffer type |
	"Reset input semaphore so clients can wait for the next events after this one"
	inputSemaphore initSignals.
	eventBuffer _ Array new: 8.
	[self primGetNextEvent: eventBuffer.
	type _ eventBuffer at: 1.
	type = EventTypeNone] whileFalse:[self processEvent: eventBuffer].
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'nk 3/18/2004 14:58' prior: 36103303!
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 ].

	eventBuffer := Array new: 8.
	[self primGetNextEvent: eventBuffer.
	type := eventBuffer at: 1.
	type = EventTypeNone]
		whileFalse: [self processEvent: eventBuffer].

	"Remember the last time that I checked for events."
	lastEventPoll := Time millisecondClockValue! !

!EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/12/2004 20:01' prior: 36103734!
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: 'nk 2/11/2002 12:18'!
processEvent: evt
	"Process a single event. This method is run at high priority."
	| type |
	type _ evt at: 1.

	"Check if the event is a user interrupt"
	(type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[
		((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]])
			 ifTrue:["interrupt key is meta - not reported as event"
					^interruptSemaphore signal].

	"Store the event in the queue if there's any"
	type = EventTypeMouse ifTrue:
		[evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)].

	type = EventTypeKeyboard ifTrue:
		["swap ctrl/alt keys"
		KeyDecodeTable at: { evt at: 3 . evt at: 5 } ifPresent: [:a |
			evt at: 3 put: a first;
				at: 5 put: a second]].

	self queueEvent: evt.

	"Update state for InputSensor."
	EventTypeMouse = type ifTrue:[self processMouseEvent: evt].
	EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt]! !

!EventSensor methodsFor: 'private-I/O' stamp: 'nk 3/18/2004 13:58' prior: 36104932!
processEvent: evt
	"Process a single event. This method is run at high priority."
	| type |
	type _ evt at: 1.

	"Check if the event is a user interrupt"
	(type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[
		((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]])
			 ifTrue:["interrupt key is meta - not reported as event"
					hadInterrupt _ true.
					^interruptSemaphore signal].

	"Store the event in the queue if there's any"
	type = EventTypeMouse ifTrue:
		[evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)].

	type = EventTypeKeyboard ifTrue:
		["swap ctrl/alt keys"
		KeyDecodeTable at: { evt at: 3 . evt at: 5 } ifPresent: [:a |
			evt at: 3 put: a first;
				at: 5 put: a second]].

	self queueEvent: evt.

	"Update state for InputSensor."
	EventTypeMouse = type ifTrue:[self processMouseEvent: evt].
	EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt]! !

!EventSensor methodsFor: 'private-I/O' stamp: 'nk 2/11/2002 12:18' prior: 36105890!
processEvent: evt
	"Process a single event. This method is run at high priority."
	| type |
	type _ evt at: 1.

	"Check if the event is a user interrupt"
	(type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[
		((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]])
			 ifTrue:["interrupt key is meta - not reported as event"
					^interruptSemaphore signal].

	"Store the event in the queue if there's any"
	type = EventTypeMouse ifTrue:
		[evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)].

	type = EventTypeKeyboard ifTrue:
		["swap ctrl/alt keys"
		KeyDecodeTable at: { evt at: 3 . evt at: 5 } ifPresent: [:a |
			evt at: 3 put: a first;
				at: 5 put: a second]].

	self queueEvent: evt.

	"Update state for InputSensor."
	EventTypeMouse = type ifTrue:[self processMouseEvent: evt].
	EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt]! !

!EventSensor methodsFor: 'private-I/O' stamp: '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 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 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.! !

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

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

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

!ExampleSetTest methodsFor: 'Testing'!
testAdd
	empty add: 5.
	self assert: (empty includes: 5)
			! !

!ExampleSetTest methodsFor: 'Testing'!
testGrow
	empty addAll: (1 to: 100).
	self assert: empty size = 100
			! !

!ExampleSetTest methodsFor: 'Testing'!
testIllegal
	self 
		should: [empty at: 5] 
		raise: TestResult error.
	self 
		should: [empty at: 5 put: #abc] 
		raise: TestResult error
			! !

!ExampleSetTest methodsFor: 'Testing'!
testIncludes
	self assert: (full includes: 5).
	self assert: (full includes: #abc)
			! !

!ExampleSetTest methodsFor: 'Testing'!
testOccurrences
	self assert: (empty occurrencesOf: 0) = 0.
	self assert: (full occurrencesOf: 5) = 1.
	full add: 5.
	self assert: (full occurrencesOf: 5) = 1
			! !

!ExampleSetTest methodsFor: 'Testing'!
testRemove
	full remove: 5.
	self assert: (full includes: #abc).
	self deny: (full includes: 5)
			! !

!ExampleSetTest methodsFor: 'Running'!
setUp
	empty := Set new.
	full := Set with: 5 with: #abc
			! !

!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: '*Refactory-RBAddons' stamp: 'ajh 2/16/2003 17:37'!
searchFrom: aContext
	" Set the context where the handler search will start. "

	signalContext := aContext contextTag! !

!Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:32' prior: 20574599!
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' prior: 20574854!
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' prior: 20575203!
pass
	"Yield control to the enclosing exception action for the receiver."

	handlerContext nextHandlerContext handleSignal: self! !

!Exception methodsFor: 'handling' stamp: 'pnm 8/16/2000 14:45'!
resignalAs: replacementException
	"Signal an alternative exception in place of the receiver."

	thisContext unwindTo: initialContext.
	replacementException initialContext: initialContext.
	resignalException := replacementException.
	thisContext swapSender: thisContext sender sender! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/22/2003 23:04' prior: 36121550!
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' prior: 20575916!
resume
	"Return from the message that signaled the receiver."

	self resume: nil! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:14' prior: 20576075!
resume: resumptionValue
	"Return resumptionValue as the value of the signal message."

	self isResumable ifFalse: [IllegalResumeAttempt signal].
	self resumeUnchecked: resumptionValue! !

!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: 'pnm 8/16/2000 15:00'!
retry
	"Abort an exception handler and re-evaluate its protected block."

	thisContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	handlerContext restart! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:36' prior: 36123026!
retry
	"Abort an exception handler and re-evaluate its protected block."

	handlerContext restart! !

!Exception methodsFor: 'handling' stamp: 'pnm 8/16/2000 15:00'!
retryUsing: alternativeBlock
	"Abort an exception handler and evaluate a new block in place of the handler's protected block."

	handlerContext receiver: alternativeBlock.
	self retry! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37' prior: 36123457!
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' prior: 20577008!
return
	"Return nil as the value of the block protected by the active exception handler."

	self return: nil! !

!Exception methodsFor: 'handling' stamp: 'ar 3/9/2001 01:18'!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."
	| handlerHomeContext |
	handlerHomeContext _ [nil] ifProperUnwindSupportedElseSignalAboutToReturn.
	initialContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	handlerHomeContext == nil
		ifFalse: [handlerContext sender swapSender: handlerHomeContext].
	^returnValue! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37' prior: 36124170!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."

	handlerContext return: returnValue! !

!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 10/24/2002 19:24' prior: 36124875!
description
	"Return a textual description of the exception."

	^ self messageText ifNil: [self class name asString]! !

!Exception methodsFor: 'printing' stamp: 'pnm 8/16/2000 14:53' prior: 36125150!
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: 'pnm 8/16/2000 14:53'!
messageText
	"Return an exception's message text."

	^messageText! !

!Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33' prior: 36125609!
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: 'pnm 8/16/2000 15:04'!
receiver
	^initialContext receiver! !

!Exception methodsFor: 'printing' stamp: 'ajh 10/22/2001 14:24' prior: 36126015!
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: 'signaling' stamp: 'pnm 8/16/2000 15:00'!
messageText: signalerText
	"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33' prior: 36126481!
messageText: signalerText
	"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: 'signaling' stamp: 'ajh 2/1/2003 01:33' prior: 20579068!
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' prior: 20579511!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	self messageText: signalerText.
	^ self signal! !

!Exception methodsFor: 'priv handling' stamp: 'pnm 8/16/2000 14:53'!
defaultAction
	"The default action taken if the exception is signaled."

	self subclassResponsibility! !

!Exception methodsFor: 'priv handling' stamp: 'ajh 9/30/2001 15:33' prior: 36127377!
defaultAction
	"The default action taken if the exception is signaled."

	self subclassResponsibility! !

!Exception methodsFor: 'priv handling' stamp: 'pnm 8/16/2000 14:53'!
isResumable
	"Determine whether an exception is resumable."

	^false! !

!Exception methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:58' prior: 36127743!
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: '*sunit-preload' stamp: 'jp 3/17/2003 10:03'!
sunitExitWith: aValue
 
        self return: aValue! !

!Exception methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 10:03' prior: 36128178!
sunitExitWith: aValue
 
        self return: aValue! !

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54' prior: 20579933!
signal
	"Signal the occurrence of an exceptional condition."

	^ self new signal! !

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'pnm 8/16/2000 15:01'!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	| ex |
	ex := self new.
	ex initialContext: thisContext sender.
	^ex signal: signalerText! !

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54' prior: 36128644!
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' prior: 20580454!
, anotherException
	"Create an exception set."

	^ExceptionSet new
		add: self;
		add: anotherException;
		yourself! !

!Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 9/30/2001 15:33' prior: 20580653!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	(exception isKindOf: Halt) ifTrue: [^ false].
	^ exception isKindOf: self! !

!Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 8/5/2003 11:33' prior: 36129411!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	^ exception isKindOf: self! !

!Exception class methodsFor: 'Camp Smalltalk' stamp: 'jp 3/17/2003 10:04'!
sunitSignalWith: aString
  
        ^self signal: aString! !

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

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/12/1999 23:59'!
basicANSISignaledExceptionTestSelectors

	^#( simpleIsNestedTest simpleOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 11/14/1999 17:33'!
basicTestSelectors

       ^#( simpleEnsureTest simpleEnsureTestWithNotification simpleEnsureTestWithUparrow simpleEnsureTestWithError signalFromHandlerActionTest
               resumableFallOffTheEndHandler nonResumableFallOffTheEndHandler doubleResumeTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingElseString

	^'Do something else.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingExceptionalString

	^'Do something exceptional.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'!
doSomethingString

	^'Do something.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
doYetAnotherThingString

	^'Do yet another thing.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'!
log

	log == nil
		ifTrue: [log := OrderedCollection new].
	^log! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'!
suiteLog

	suiteLog == nil
		ifTrue: [suiteLog := OrderedCollection new].
	^suiteLog! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
testString

	^'This is only a test.'! !

!ExceptionTester methodsFor: '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: 'tests' stamp: 'tfei 11/14/1999 17:26'!
doubleResumeTest

       [self doSomething.
       MyResumableTestError signal.
       self doSomethingElse.
       MyResumableTestError signal.
       self doYetAnotherThing]
               on: MyResumableTestError
               do: [:ex | ex resume].! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'!
nonResumableFallOffTheEndHandler
	
	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'!
resumableFallOffTheEndHandler

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'!
signalFromHandlerActionTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[self doYetAnotherThing.
			MyTestError signal]! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'!
simpleEnsureTest

	[self doSomething.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'!
simpleEnsureTestWithError

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'!
simpleEnsureTestWithNotification

	[self doSomething.
	self methodWithNotification.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'!
simpleEnsureTestWithUparrow

	[self doSomething.
	true ifTrue: [^nil].
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'!
warningTest

	self log: 'About to signal warning.'.
	Warning signal: 'Ouch'.
	self log: 'Warning signal handled and resumed.'! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'!
doubleResumeTestResults

       ^OrderedCollection new
               add: self doSomethingString;
               add: self doSomethingElseString;
               add: self doYetAnotherThingString;
               yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'!
nonResumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'!
resumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'!
signalFromHandlerActionTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'!
simpleEnsureTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'!
simpleEnsureTestWithErrorResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'!
simpleEnsureTestWithNotificationResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'!
simpleEnsureTestWithUparrowResults

	^OrderedCollection new
		add: self doSomethingString;
"		add: self doSomethingElseString;"
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'!
runAllTests
	"ExceptionTester new runAllTests"

	self
		runBasicTests;
		runBasicANSISignaledExceptionTests! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'!
runBasicANSISignaledExceptionTests

	self basicANSISignaledExceptionTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'!
runBasicTests

	self basicTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'testing' stamp: 'tfei 8/19/1999 03:10'!
runTest: aSelector

	| expectedResult |
	[expectedResult := self perform: (aSelector, #Results) asSymbol.
	self logTest: aSelector.
	self clearLog.
	self perform: aSelector.
	] on: MyTestError
	  do: 
		[ :ex |
		self log: 'Unhandled Exception'.
		ex return: nil].
	self log = expectedResult
		ifTrue: [self logTestResult: 'succeeded']
		ifFalse: [self logTestResult: 'failed']! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:27'!
simpleIsNestedTest
	"uses resignalAs:"

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			ex isNested "expecting to detect handler in #runTest:"
				ifTrue:
					[self doYetAnotherThing.
					ex resignalAs: MyTestNotification new]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:36'!
simpleOuterTest
	"uses #resume"

	[[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | ex outer]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:37'!
simplePassTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex pass "expecting handler in #runTest:"]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 02:12'!
simpleResignalAsTest
	"ExceptionTester new simpleResignalAsTest"

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do:
			[:ex | ex resignalAs: MyTestError new]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'RAA 12/8/2000 12:58'!
simpleResumeTest

	"see if we can resume twice"

	| it |
	[self doSomething.
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	]
		on: MyResumableTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex resume: 3]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:02'!
simpleRetryTest

	| theMeaningOfLife |
	theMeaningOfLife := nil.
	[self doSomething.
	theMeaningOfLife == nil
		ifTrue: [MyTestError signal]
		ifFalse: [self doSomethingElse]]
			on: MyTestError
			do:
				[:ex |
				theMeaningOfLife := 42.
				self doYetAnotherThing.
				ex retry]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:03'!
simpleRetryUsingTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex | ex retryUsing: [self doYetAnotherThing]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:59'!
simpleReturnTest

	| it |
	it :=
		[self doSomething.
		MyTestError signal.
		self doSomethingElse]
			on: MyTestError
			do: [:ex | ex return: 3].
	it = 3 ifTrue: [self doYetAnotherThing]! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:09'!
simpleIsNestedTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simpleOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simplePassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:11'!
simpleResignalAsTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'RAA 12/8/2000 12:59'!
simpleResumeTestResults

	"see if we can resume twice"

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryUsingTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 02:22'!
simpleReturnTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTests methodsFor: 'private' stamp: 'md 3/25/2003 23:40'!
assertSuccess: anExceptionTester
	self should: [ ( anExceptionTester suiteLog first) endsWith:  'succeeded'].! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:43'!
testDoubleResume
	self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:44'!
testNonResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:44'!
testResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:44'!
testSignalFromHandlerActionTest
	self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:48'!
testSimpleEnsure
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:45'!
testSimpleEnsureTestWithError
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:46'!
testSimpleEnsureTestWithNotification
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:45'!
testSimpleEnsureTestWithUparrow
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:46'!
testSimpleIsNested
	self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:41'!
testSimpleOuter
	self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:42'!
testSimplePass
	self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:43'!
testSimpleResignalAs
	self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:48'!
testSimpleResume
	self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:48'!
testSimpleRetry
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:47'!
testSimpleRetryUsing
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'md 3/25/2003 23:48'!
testSimpleReturn
	self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! !

!ExternalAddress methodsFor: 'converting' stamp: 'bf 2/21/2001 23:50'!
asInteger
	"convert address to integer"
	^ self asByteArrayPointer unsignedLongAt: 1! !

!ExternalAddress methodsFor: 'converting' stamp: 'bf 2/21/2001 23:50'!
fromInteger: address
	"set my handle to point at address."
	"Do we really need this? bf 2/21/2001 23:48"

	| pointer |
	pointer _ ByteArray new: 4.
	pointer unsignedLongAt: 1 put: address.
	self basicAt: 1 put: (pointer byteAt: 1);
		basicAt: 2 put: (pointer byteAt: 2);
		basicAt: 3 put: (pointer byteAt: 3);
		basicAt: 4 put: (pointer byteAt: 4)
! !

!ExternalDropHandler methodsFor: 'testing' stamp: 'mir 1/10/2002 16:36'!
matchesExtension: aExtension
	(self extension isNil or: [aExtension isNil])
		ifTrue: [^false].
	^extension = 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 methodsFor: 'initialize' stamp: 'mir 1/10/2002 17:17'!
type: aType extension: anExtension action: anAction 
	action _ anAction.
	type _ aType.
	extension _ anExtension! !

!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 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 1/10/2002 16:32'!
lookupExternalDropHandler: stream

	| types extension |
	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]].
	^self defaultHandler! !

!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: 'mir 1/10/2002 15:59'!
registerStandardExternalDropHandlers
	"ExternalDropHandler registerStandardExternalDropHandlers"

	self registeredHandlers add: (
		ExternalDropHandler
			action: [:stream :pasteUp :event |
				pasteUp addMorph: (SketchMorph withForm: (Form fromBinaryStream: stream binary)) centeredNear: event position]
			type: 'image/'
			extension: nil)! !

!ExternalDropHandler class methodsFor: 'class initialization' stamp: 'nk 6/12/2004 16:15' prior: 36149305!
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 1/10/2002 17:23'!
defaultGZipHandler
	^ExternalDropHandler
		type: nil
		extension: 'gz'
		action: [:stream :pasteUp :event |
			stream viewGZipContents]! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 10/14/2002 15:26'!
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 _ SketchMorph withForm: image.
			pasteUp addMorph: sketch centeredNear: event position] 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! !

!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:50' prior: 20608970!
initialize
	"ExternalFunction initialize"
	self initializeErrorMessages.! !

!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:53'!
initializeErrorMessages
	"ExternalFunction initializeErrorConstants"
	FFIErrorMessages _ Dictionary new.
	FFIErrorMessages
		at: FFINoCalloutAvailable put: 'Callout mechanism not available';
		at: FFIErrorGenericError put: 'A call to an external function failed';
		at: FFIErrorNotFunction put: 'Only ExternalFunctions can be called';
		at: FFIErrorBadArgs put: 'Bad arguments in primitive invokation';
		at: FFIErrorBadArg put: 'Bad argument for external function';
		at: FFIErrorIntAsPointer put: 'Cannot use integer as pointer';
		at: FFIErrorBadAtomicType put: 'Unknown atomic type in external call';
		at: FFIErrorCoercionFailed put: 'Could not coerce arguments';
		at: FFIErrorWrongType put: 'Wrong type in external call';
		at: FFIErrorStructSize put: 'Bad structure size in external call';
		at: FFIErrorCallType put: 'Unsupported calling convention';
		at: FFIErrorBadReturn put: 'Cannot return the given type';
		at: FFIErrorBadAddress put: 'Bad function address';
		at: FFIErrorNoModule put: 'No module to load address from';
		at: FFIErrorAddressNotFound put: 'Unable to find function address';
		at: FFIErrorAttemptToPassVoid put: 'Cannot pass ''void'' parameter';
		at: FFIErrorModuleNotFound put: 'External module not found';
		at: FFIErrorBadExternalLibrary put: 'External library is invalid';
		at: FFIErrorBadExternalFunction put: 'External function is invalid';
		at: FFIErrorInvalidPointer put: 'Attempt to pass invalid pointer';
	yourself! !

!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 methodsFor: 'private' stamp: 'mir 6/25/2001 18:46'!
registeredClients
	RegisteredClients ifNil: [RegisteredClients _ Set new].
	^RegisteredClients! !

!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: '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: '-- all --' stamp: 'mir 11/16/2001 13:34'!
preferenceDirectory
	| prefDirName |
	prefDirName _ self preferenceDirectoryName.
	^(FileDirectory default directoryExists: prefDirName)
		ifTrue: [FileDirectory default directoryNamed: prefDirName]
		ifFalse: [
			((FileDirectory on: Smalltalk vmPath) directoryExists: prefDirName)
				ifTrue: [(FileDirectory on: Smalltalk vmPath) directoryNamed: prefDirName]
				ifFalse: [nil]]
! !

!ExternalSettings class methodsFor: '-- all --' stamp: 'sd 9/30/2003 14:01' prior: 36156313!
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]]
! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'eldeh 6/24/2003 15:53' prior: 20645143!
compileFields: specArray withAccessors: aBool 
	"Define all the fields in the receiver. 
	Return the newly compiled spec."
	| fieldName fieldType isPointerField externalType byteOffset typeSize typeSpec selfRefering |
	(specArray size > 0
			and: [specArray first class ~~ Array])
		ifTrue: [^ self compileAlias: specArray withAccessors: aBool].
	byteOffset _ 1.
	typeSpec _ WriteStream
				on: (WordArray new: 10).
	typeSpec nextPut: FFIFlagStructure.
	"dummy for size"
	specArray
		do: [:spec | 
			fieldName _ spec first.
			fieldType _ spec second.
			isPointerField _ fieldType last = $*.
			fieldType _ (fieldType findTokens: ' *') first.
			externalType _ ExternalType atomicTypeNamed: fieldType.
			selfRefering _ externalType == nil and: fieldType = self asString and: isPointerField.
			selfRefering
				ifTrue: [externalType _ ExternalType void asPointerType]
				ifFalse:
			[externalType == nil
				ifTrue: ["non-atomic"
					Symbol
						hasInterned: fieldType
						ifTrue: [:sym | externalType _ ExternalType structTypeNamed: sym]].
			externalType == nil
				ifTrue: [Transcript show: '(' , fieldType , ' is void)'.
					externalType _ ExternalType void].
			isPointerField
				ifTrue: [externalType _ externalType asPointerType]].
			typeSize _ externalType byteSize.
			spec size > 2
				ifTrue: ["extra size"
					spec third < typeSize
						ifTrue: [^ self error: 'Explicit type size is less than expected'].
					typeSize _ spec third].
			(fieldName ~~ #nil
					and: [aBool])
				ifTrue: [self
						defineFieldAccessorsFor: fieldName
						startingAt: byteOffset
						type: externalType].
			typeSpec
				nextPutAll: (externalType embeddedSpecWithSize: typeSize).
			byteOffset _ byteOffset + typeSize].
	compiledSpec _ typeSpec contents.
	compiledSpec
		at: 1
		put: (byteOffset - 1 bitOr: FFIFlagStructure).
	ExternalType noticeModificationOf: self.
	^ compiledSpec! !

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:45' prior: 20664561!
initializeFFIConstants
	"ExternalType initialize"
	AtomicTypeNames _ IdentityDictionary new.
	AtomicSelectors _ IdentityDictionary new.
	AtomicTypeNames
		at: FFITypeVoid put: 'void';
		at: FFITypeBool put: 'bool';
		at: FFITypeUnsignedByte put: 'byte';
		at: FFITypeSignedByte put: 'sbyte';
		at: FFITypeUnsignedShort put: 'ushort';
		at: FFITypeSignedShort put: 'short';
		at: FFITypeUnsignedInt put: 'ulong';
		at: FFITypeSignedInt put: 'ulong';
		at: FFITypeUnsignedLongLong put: 'ulonglong';
		at: FFITypeSignedLongLong put: 'longlong';
		at: FFITypeUnsignedChar put: 'char';
		at: FFITypeSignedChar put: 'schar';
		at: FFITypeSingleFloat put: 'float';
		at: FFITypeDoubleFloat put: 'double';
	yourself.

	AtomicSelectors
		at: FFITypeVoid put: #voidAt:;
		at: FFITypeBool put: #booleanAt:;
		at: FFITypeUnsignedByte put: #unsignedByteAt:;
		at: FFITypeSignedByte put: #signedByteAt:;
		at: FFITypeUnsignedShort put: #unsignedShortAt:;
		at: FFITypeSignedShort put: #signedShortAt:;
		at: FFITypeUnsignedInt put: #unsignedLongAt:;
		at: FFITypeSignedInt put: #signedLongAt:;
		at: FFITypeUnsignedLongLong put: #unsignedLongLongAt:;
		at: FFITypeSignedLongLong put: #signedLongLongAt:;
		at: FFITypeUnsignedChar put: #unsignedCharAt:;
		at: FFITypeSignedChar put: #signedCharAt:;
		at: FFITypeSingleFloat put: #floatAt:;
		at: FFITypeDoubleFloat put: #doubleAt:;
	yourself! !

!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: 'dgd 3/7/2003 14:25' prior: 20673348!
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! !

!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:54'!
initialize
	"FFIConstants initialize"
	self initializeTypeConstants.
	self initializeErrorConstants.
	self initializeCallingConventions.! !

!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:50'!
initializeCallingConventions
	FFICallTypeCDecl := 0.
	FFICallTypeApi := 1.
! !

!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:49'!
initializeErrorConstants
	"ExternalFunction initializeErrorConstants"

	"No callout mechanism available"
	FFINoCalloutAvailable := -1.
	"generic error"
	FFIErrorGenericError := 0.
	"primitive invoked without ExternalFunction"
	FFIErrorNotFunction := 1.
	"bad arguments to primitive call"
	FFIErrorBadArgs := 2.

	"generic bad argument"
	FFIErrorBadArg := 3.
	"int passed as pointer"
	FFIErrorIntAsPointer := 4.
	"bad atomic type (e.g., unknown)"
	FFIErrorBadAtomicType := 5.
	"argument coercion failed"
	FFIErrorCoercionFailed := 6.
	"Type check for non-atomic types failed"
	FFIErrorWrongType := 7.
	"struct size wrong or too large"
	FFIErrorStructSize := 8.
	"unsupported calling convention"
	FFIErrorCallType := 9.
	"cannot return the given type"
	FFIErrorBadReturn := 10.
	"bad function address"
	FFIErrorBadAddress := 11.
	"no module given but required for finding address"
	FFIErrorNoModule := 12.
	"function address not found"
	FFIErrorAddressNotFound := 13.
	"attempt to pass 'void' parameter"
	FFIErrorAttemptToPassVoid := 14.
	"module not found"
	FFIErrorModuleNotFound := 15.
	"external library invalid"
	FFIErrorBadExternalLibrary := 16.
	"external function invalid"
	FFIErrorBadExternalFunction := 17.
	"ExternalAddress points to ST memory (don't you dare to do this!!)"
	FFIErrorInvalidPointer := 18.! !

!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:34'!
initializeTypeConstants
	"type void"
	FFITypeVoid := 0.

	"type bool"
	FFITypeBool := 1.

	"basic integer types.
	note: (integerType anyMask: 1) = integerType isSigned"

	FFITypeUnsignedByte := 2.
	FFITypeSignedByte := 3.
	FFITypeUnsignedShort := 4.
	FFITypeSignedShort := 5.
	FFITypeUnsignedInt := 6.
	FFITypeSignedInt := 7.

	"64bit types"
	FFITypeUnsignedLongLong := 8.
	FFITypeSignedLongLong := 9.

	"special integer types"
	FFITypeUnsignedChar := 10.
	FFITypeSignedChar := 11.

	"float types"
	FFITypeSingleFloat := 12.
	FFITypeDoubleFloat := 13.

	"type flags"
	FFIFlagAtomic := 16r40000. "type is atomic"
	FFIFlagPointer := 16r20000. "type is pointer to base type"
	FFIFlagStructure := 16r10000. "baseType is structure of 64k length"
	FFIStructSizeMask := 16rFFFF. "mask for max size of structure"
	FFIAtomicTypeMask := 16r0F000000. "mask for atomic type spec"
	FFIAtomicTypeShift := 24. "shift for atomic type"
! !

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

!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: '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 11/19/2002 16:53'!
putFileStreamContents: fileStream as: fileNameOnServer
	"FTP a file to the server."


	self openPassiveDataConnection.
	self sendCommand: 'STOR ', fileNameOnServer.

	[self sendStreamContents: fileStream]
		ensure: [self closeDataSocket].

	self checkResponse.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54' prior: 36168937!
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: 'mir 11/13/2002 17:49'!
renameFileNamed: oldFileName to: newFileName
	self sendCommand: 'RNFR ' , oldFileName.
	self lookForCode: 200.
	self sendCommand: 'RNTO ' , newFileName.
	self lookForCode: 200! !

!FTPClient methodsFor: 'private protocol' stamp: 'mir 11/14/2002 18:13'!
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]
		whileTrue: [
			self checkForPendingError.
			bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf.
			1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)].
			currentlyRead _ currentlyRead + bytesRead]]
		on: ConnectionClosed
		do: [:ex | ].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:06' prior: 36170447!
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: 'mir 11/14/2002 18:13'!
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.
	[[true]
		whileTrue: [
			self checkForPendingError.
			bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf.
			1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]]]
		on: ConnectionClosed
		do: [:ex | ].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:04' prior: 36172103!
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: '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 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 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.')
! !

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

!FWT methodsFor: 'access' stamp: 'zz 3/2/2004 08:13' prior: 20843977!
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! !

!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: 'dgd 2/14/2003 21:49' prior: 21030549!
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! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:02'!
testAND
 self assert: (false & true) = false.
 self assert: (false & false) = false.! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:05'!
testAnd
 self assert: (false and: ['alternativeBlock']) = false.! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:59'!
testIfFalse
 self should: [(false ifFalse: ['alternativeBlock']) = 'alternativeBlock']. ! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:07'!
testIfFalseIfTrue
 self assert: (false ifFalse: ['falseAlternativeBlock'] 
                      ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. ! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:04'!
testIfTrue
 self assert: (false ifTrue: ['alternativeBlock']) = nil. ! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:09'!
testIfTrueIfFalse
 self assert: (false ifTrue: ['trueAlternativeBlock'] 
                      ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/25/2003 23:16'!
testNew
	self should: [False new] raise: TestResult error. ! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:30'!
testNot
 self should: [false not = true].! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 16:44'!
testOR
 self assert: (false | true) =  true.
 self assert: (false | false) = false.! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:05'!
testOr
 self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.! !

!FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 16:41'!
testPrintOn
 self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! !

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

!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: 'initialization' stamp: 'dvf 6/15/2002 18:34'!
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'"
	celeste _ aCeleste.
	to _ argTo.
	subject _ argSubject.
	messageText _ aText.
	theLinkToInclude _ linkText.
	textFields _ #().
! !

!FancyMailComposition methodsFor: 'initialization' stamp: 'nk 7/3/2003 09:41' prior: 36184574!
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: '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: 'dvf 6/15/2002 19:17'!
submit: sendNow

	| message |

	messageText _ self breakLines: self completeTheMessage atWidth: 999.
	message _ MailMessage from: messageText.
	SMTPSocket 
			deliverMailFrom: message from 
			to: (Array with: message to) 
			text: message text 
			usingServer: self smtpServer.
	self forgetIt.
! !

!FancyMailComposition methodsFor: 'actions' stamp: 'mir 5/13/2003 10:58' prior: 36186257!
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.
! !

!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' prior: 21054164!
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: 'initialization' stamp: 'dgd 2/14/2003 22:27'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color veryVeryLightGray! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:54' prior: 21054827!
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: 'menu' stamp: 'dgd 2/22/2003 19:38' prior: 21056494!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu
		add: 'background color' action: #setBackgroundColor:;
		add: 'pen color' action: #setPenColor:;
		add: 'pen size' action: #setPenSize:;
		add: 'fill' action: #fill;
		add: 'magnification' action: #setMagnification:;
		add: 'accept' action: #accept;
		add: 'revert' action: #revert;
		add: 'inspect' action: #inspectForm;
		add: 'file out' action: #fileOut;
		add: 'selection...' action: #selectionMenu:;
		add: 'tools...' action: #toolMenu:! !

!FatBitsPaint methodsFor: 'menu' stamp: 'dgd 10/8/2003 18:59' prior: 36189352!
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: 'nb 6/17/2003 12:25' prior: 21058435!
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: '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: 'nk 4/18/2004 19:04' prior: 21061809!
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! !

!FileContentsBrowser methodsFor: 'accessing' stamp: 'sw 5/23/2001 14:28'!
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: 'removing' prior: 21066027!
removeMessage
	| messageName |
	messageListIndex = 0
		ifTrue: [^ self].
	self okToChange
		ifFalse: [^ self].
	messageName _ self selectedMessageName.
	(SystemNavigation new confirmRemovalOf: messageName on: self selectedClassOrMetaClass)
		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 4/15/2003 16:13' prior: 36193517!
removeMessage
	| messageName |
	messageListIndex = 0
		ifTrue: [^ self].
	self okToChange
		ifFalse: [^ self].
	messageName _ self selectedMessageName.
	(self systemNavigation  confirmRemovalOf: messageName on: self selectedClassOrMetaClass)
		ifFalse: [^ false].
	self selectedClassOrMetaClass removeMethod: self selectedMessageName.
	self messageListIndex: 0.
	self setClassOrganizer.
	"In case organization not cached"
	self changed: #messageList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'ar 8/2/2003 21:00' prior: 36194058!
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: 'edit pane' stamp: 'dew 9/22/2001 23:06'!
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: #(0 0 0 0).
	^ contents symbolic asText! !

!FileContentsBrowser methodsFor: 'edit pane' stamp: 'sw 11/13/2001 08:41'!
selectedMessage
	"Answer a copy of the source code for the selected message selector."

	| class selector |
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	contents _ class sourceCodeAt: selector.
	Preferences browseWithPrettyPrint ifTrue: [contents _ Compiler new
					format: contents
					in: class
					notifying: nil
					decorated: Preferences colorWhenPrettyPrinting].
	self showingAnyKindOfDiffs ifTrue:
		[contents _ self
			methodDiffFor: contents
			class: self selectedClass
			selector: self selectedMessageName
			meta: self metaClassIndicated].
	^ contents asText makeSelectorBoldIn: class! !

!FileContentsBrowser methodsFor: 'diffs' stamp: 'sw 5/20/2001 21:03'!
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: 'fileIn/fileOut' stamp: 'nb 6/17/2003 12:25' prior: 21074497!
fileIntoNewChangeSet
	| p ff |
	(p _ self selectedPackage) ifNil: [^ Beeper beep].
	ff _ StandardFileStream readOnlyFileNamed: p fullPackageName.
	ChangeSorter newChangesFromStream: ff named: p packageName! !

!FileContentsBrowser methodsFor: 'metaclass' stamp: 'mu 9/4/2003 18:11' prior: 21077446!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."
	| selectedClass |
	selectedClass _ self selectedClass ifNil:[^nil].
	^self metaClassIndicated
		ifTrue: [selectedClass metaClass]
		ifFalse: [selectedClass]! !

!FileContentsBrowser methodsFor: 'metaclass' stamp: 'asm 10/6/2003 11:29' prior: 36197272!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

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

!FileContentsBrowser methodsFor: 'other' stamp: 'tpr 6/2/2003 13:22' prior: 21078031!
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: [SystemNavigation new browseAllCallsOn: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'other' stamp: 'nk 6/26/2003 21:43' prior: 36197887!
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 new browseAllCallsOn: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'other' stamp: 'bkv 8/13/2003 23:59' prior: 36198236!
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: 'dew 9/20/2001 19:03'!
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' stamp: 'asm 5/30/2003 18:11'!
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: 'creation' stamp: 'sw 6/24/2002 16:46'!
addLowerPanesTo: window at: nominalFractions with: editString

	| verticalOffset row innerFractions codePane infoPane infoHeight divider |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		borderColor: Color black;
		layoutPolicy: ProportionalLayout new.

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	infoPane _ PluggableTextMorph on: self text: #infoViewContents accept: nil
			readSelection: nil menu: nil.
	infoPane askBeforeDiscardingEdits: false.
	verticalOffset _ 0.
	innerFractions _ 0@0 corner: 1@0.
">>not with this browser--- at least not yet ---
	verticalOffset _ self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset.
	verticalOffset _ self addOptionalButtonsTo: row  at: innerFractions plus: verticalOffset.
<<<<"

	infoHeight _ 20.
	row 
		addMorph: (codePane borderWidth: 0)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@verticalOffset corner: 0@infoHeight negated)
		).
	divider _ BorderedSubpaneDividerMorph forTopEdge.
	Preferences alternativeWindowLook ifTrue:[
		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; hideScrollBarIndefinitely)
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-infoHeight) corner: 0@0)
		).
	window 
		addMorph: row
		frame: nominalFractions.

	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.

! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'nk 4/28/2004 10:18' prior: 36200133!
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 _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	infoPane _ PluggableTextMorph on: self text: #infoViewContents accept: nil
			readSelection: nil menu: nil.
	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.
	Preferences alternativeWindowLook ifTrue:[
		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: 'sw 11/13/2001 08:40'!
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 _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: width@110).
	topView 
		addSubView: browserCodeView 
		below: (hasSingleFile 
			ifTrue: [switchView]
			ifFalse: [packageListView]).

	infoView _ StringHolderView new
		model: self infoString;
		window: (0@0 extent: width@12);
		borderWidth: 1.
	topView addSubView: infoView below: browserCodeView.

	^ topView
! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'dew 1/7/2002 02:18'!
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 hideScrollBarIndefinitely.
			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: 'creation' stamp: 'nk 4/28/2004 10:18' prior: 36206930!
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: '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: 'initialize-release' stamp: 'dew 9/15/2001 16:19'!
defaultBrowserTitle
	^ '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 class methodsFor: 'instance creation' stamp: 'nk 2/17/2004 19:26'!
browseCompressedCodeStream: aStandardFileStream 
	"Browse the selected file in fileIn format."
	| zipped unzipped |
	zipped _ GZipReadStream on: aStandardFileStream.
	unzipped _ ReadStream on:  zipped contents asString.
	self browseStream: unzipped named: aStandardFileStream name.! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sw 2/16/2002 01:21'!
browseFile: aFilename
	"Open a file contents browser on a file of the given name"

	aFilename ifNil: [^ self beep].
	self browseFiles: (Array with: aFilename)! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nb 6/17/2003 12:25' prior: 36212094!
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: 'nk 7/24/2003 17:21'!
browseStream: aStream

	| package organizer packageDict browser |
	Cursor wait showWhile: [
		packageDict _ Dictionary new.
		organizer _ SystemOrganizer defaultList: Array new.
		package _ (FilePackage new fullName: aStream name; fileInFrom: aStream).
		packageDict 
			at: package packageName 
			put: package.
		organizer 
			classifyAll: package classes keys 
			under: package packageName.
		(browser := self new)
			systemOrganizer: organizer;
			packages: packageDict].
	self
		openBrowserView: browser createViews
		label: 'File Contents Browser'.
! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 2/17/2004 19:26' prior: 36212614!
browseStream: aStream

	self browseStream: aStream named: aStream name! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 2/17/2004 19:25'!
browseStream: aStream named: aString

	| package organizer packageDict browser |
	Cursor wait showWhile: [
		packageDict _ Dictionary 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 new)
			systemOrganizer: organizer;
			packages: packageDict].
	self
		openBrowserView: browser createViews
		label: 'File Contents Browser'.
! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sd 2/6/2002 21:33'!
fileReaderServicesForFile: fullName suffix: suffix

	^(FileStream isSourceFileSuffix: suffix)
		ifTrue: [ Array with: self serviceBrowseCode]
		ifFalse: [#()]
! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 7/16/2003 15:49' prior: 36214100!
fileReaderServicesForFile: fullName suffix: suffix

	^((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ])
		ifTrue: [ Array with: self serviceBrowseCode]
		ifFalse: [#()]
! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 2/17/2004 19:18' prior: 36214368!
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: 'instance creation' stamp: 'SD 11/14/2001 22:13'!
selectAndBrowseFile: aFileList
	"When no file are selected you can ask to browse several of them"

	| selectionPattern files |
	selectionPattern := FillInTheBlank request:'What files?' initialAnswer: aFileList pattern.
	files _ (aFileList directory fileNamesMatching: selectionPattern) 
				collect: [:each | aFileList directory fullNameFor: each].
	FileContentsBrowser browseFiles: files.


! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sw 2/17/2002 01:36'!
serviceBrowseCode
	"Answer the service of opening a file-contents browser"

	^ SimpleServiceEntry
		provider: self 
		label: 'code-file browser'
		selector: #browseFile:
		description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code'
		buttonLabel: 'code'! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 7/24/2003 17:22' prior: 36215512!
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 directory readOnlyFileNamed: fileList fileName ]! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 4/29/2004 10:35' prior: 36215925!
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: 'instance creation' stamp: 'nk 2/17/2004 19:21'!
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 directory readOnlyFileNamed: fileList fileName ]! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 4/29/2004 10:35' prior: 36216891!
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: 'instance creation' stamp: 'sd 2/1/2002 21:40'!
services

	^ Array with: self serviceBrowseCode

! !

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

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

!FileDirectory methodsFor: 'path access' stamp: 'sumim 11/14/2002 21:34' prior: 21090907!
pathParts
	"Return the path from the root of the file system to this directory as an array of directory names."
	pathName class == String ifTrue: [pathName _ pathName convertFromSystemString].
	^ pathName findTokens: self pathNameDelimiter asString! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tpr 10/13/2003 12:34' prior: 21092343!
oldFileOrNoneNamed: fileName
	"If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil."

	^ FileStream oldFileOrNoneNamed: fileName
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'nk 2/23/2001 11:35'!
directoryEntry
	^self containingDirectory entryAt: self localName! !

!FileDirectory methodsFor: 'enumeration' stamp: 'tpr 4/9/2002 17:24'!
directoryEntryFor: filenameOrPath
	"Answer the directory entry for the given file or path. Sorta like a poor man's stat()."
	| fName dir |
	FileDirectory 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: 'asm 12/6/2002 08:12' prior: 36219446!
directoryEntryFor: filenameOrPath
	"Answer the directory entry for the given file or path. Sorta like a poor man's stat()."
	| fName dir |
	FileDirectory activeDirectoryClass 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: 'tpr 10/13/2003 10:58' prior: 36220023!
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: 'yo 11/5/2002 15:02' prior: 21093730!
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"

	| entries |
	entries _ self directoryContentsFor: pathName.
	^ entries collect: [:s | s convertFromSystemName].
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'ar 3/15/2001 23:20'!
fullName
	"Return the full name of this directory."

	^pathName! !

!FileDirectory methodsFor: 'enumeration' stamp: 'ar 2/6/2001 15:48'!
localName
	"Return the local name of this directory."

	^FileDirectory localNameFor: pathName! !

!FileDirectory methodsFor: 'enumeration' stamp: 'mir 8/24/2001 12:01'!
matchingEntries: criteria
	"Ignore the filter criteria for now"
	^self entries! !

!FileDirectory methodsFor: 'enumeration' stamp: 'yo 11/5/2002 15:57' prior: 21095363!
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 _ entries collect: [:s | s convertFromSystemName].
			entries do: [:entry |
				(entry at: 4)
					ifTrue: [
						todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)).
						dirs _ dirs + 1]
					ifFalse: [
						files _ files + 1.
						bytes _ bytes + (entry at: 5)]]]].

	^ Array with: dirs with: files with: bytes
! !

!FileDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 13:08'!
acceptsUploads
	^true! !

!FileDirectory methodsFor: 'testing' stamp: 'hg 2/2/2002 16:09'!
directoryExists: filenameOrPath
	"Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory."
	"FileDirectory default directoryExists: FileDirectory default pathName"

	| fName dir |
	FileDirectory splitName: filenameOrPath to:
		[:filePath :name |
			fName _ name.
			filePath isEmpty
				ifTrue: [dir _ self]
				ifFalse: [dir _ FileDirectory on: filePath]].

	^dir exists and: [
		self isCaseSensitive 
			ifTrue:[dir directoryNames includes: fName]
			ifFalse:[dir directoryNames anySatisfy: [:name| name sameAs: fName]]].
! !

!FileDirectory methodsFor: 'testing' stamp: 'asm 12/6/2002 08:12' prior: 36223381!
directoryExists: filenameOrPath
	"Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory."
	"FileDirectory default directoryExists: FileDirectory default pathName"

	| fName dir |
	FileDirectory activeDirectoryClass splitName: filenameOrPath to:
		[:filePath :name |
			fName _ name.
			filePath isEmpty
				ifTrue: [dir _ self]
				ifFalse: [dir _ FileDirectory on: filePath]].

	^dir exists and: [
		self isCaseSensitive 
			ifTrue:[dir directoryNames includes: fName]
			ifFalse:[dir directoryNames anySatisfy: [:name| name sameAs: fName]]].
! !

!FileDirectory methodsFor: 'testing' stamp: 'ac 2/4/2004 11:37' prior: 36224080!
directoryExists: filenameOrPath
	"Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory."
	"FileDirectory default directoryExists: FileDirectory default pathName"

	| fName dir |
	FileDirectory activeDirectoryClass 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: 'tpr 2/17/2004 19:56' prior: 36224798!
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: 'nk 11/30/2002 14:06'!
exists
"Answer whether the directory exists"

	| result |
	result _ self primLookupEntryIn: pathName index: 1.
	^ result ~= #badDirectoryPath! !

!FileDirectory methodsFor: 'testing' stamp: 'asm 12/6/2002 08:12' prior: 21097109!
fileExists: filenameOrPath
	"Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory."
	"FileDirectory default fileExists: Smalltalk sourcesName"

	| fName dir |
	FileDirectory activeDirectoryClass 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: 'tpr 10/13/2003 10:59' prior: 36226437!
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: 'ar 5/30/2001 21:42'!
isAFileNamed: fName
	^FileStream isAFileNamed: (self fullNameFor: fName)! !

!FileDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:46'!
isRemoteDirectory
	"answer whatever the receiver is a remote directory"
	^ false! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 11/5/2002 15:58' prior: 21100544!
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) convertToSystemString.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 11/5/2002 15:58' prior: 21100859!
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) convertToSystemString.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'ar 12/12/2001 15:56'!
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)]
		until:[:result| result notNil]
		forFileNamed: fullName) == nil
			ifTrue: [^failBlock value].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 11/5/2002 15:56' prior: 36228720!
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) convertToSystemString]
		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: 'asm 11/7/2002 20:05' prior: 21097728!
fileOrDirectoryExists: filenameOrPath
	"Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory."
	"FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName"

	| fName dir |
	FileDirectory activeDirectoryClass 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: 'tpr 10/13/2003 10:59' prior: 36230241!
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: 'yo 11/5/2002 16:04' prior: 21101852!
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) convertToSystemString
		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: 'ar 4/24/2001 16: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 _ (self fullNameFor: 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: '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: 'ar 12/12/2001 15:57'!
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 to: newName]
		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 11/5/2002 15:56' prior: 36233528!
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 convertToSystemString to: newName convertToSystemString]
		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 11/5/2002 16:03' prior: 21105129!
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) convertToSystemString
		type: typeString
		creator: creatorString convertToSystemString.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'mir 11/30/2001 16:35'!
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'.
	^result! !

!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: 'sw 2/17/2002 02:32'!
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].
	self class splitName: fileName to:
		[:filePath :localName |
			correctedLocalName _ localName isEmpty 
				ifFalse: [self checkName: localName fixErrors: true]
				ifTrue: [localName].
			prefix _ self fullPathFor: filePath].
	prefix isEmpty
		ifTrue: [^correctedLocalName].
	prefix last = self pathNameDelimiter
		ifTrue:[^ prefix, correctedLocalName]
		ifFalse:[^ prefix, self slash, correctedLocalName]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'asm 12/6/2002 08:18' prior: 36237025!
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].
	FileDirectory activeDirectoryClass 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: 'tpr 10/13/2003 10:59' prior: 36238124!
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: 'ar 2/27/2001 22:23'!
isTypeFile
	^true! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'gh 1/22/2002 15:45'!
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: 'ar 2/27/2001 18:56'!
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: 'nk 12/13/2002 10:07'!
relativeNameFor: aFileName
	"Return the full name for aFileName, assuming that aFileName is a name relative to me."
	aFileName isEmpty ifTrue: [ ^pathName ].
	^aFileName first = self pathNameDelimiter
		ifTrue: [ pathName, aFileName ]
		ifFalse: [ pathName, self slash, aFileName ]
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'nk 12/13/2002 10:07' prior: 36241509!
relativeNameFor: aFileName
	"Return the full name for aFileName, assuming that aFileName is a name relative to me."
	aFileName isEmpty ifTrue: [ ^pathName ].
	^aFileName first = self pathNameDelimiter
		ifTrue: [ pathName, aFileName ]
		ifFalse: [ pathName, self slash, aFileName ]
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'nk 2/2/2001 15:18'!
url
	"Convert my path into a file:// type url.  Use slash instead of the local delimiter (:), and convert odd characters to %20 notation."

	"If slash (/) is not the file system delimiter, encode slashes before converting."
	| list |
	list _ self pathParts.
	^ String streamContents: [:strm |
		strm nextPutAll: 'file:'.
		list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP].
		strm nextPut: $/]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'gk 2/10/2004 13:23' prior: 36242255!
url
	"Convert my path into a file:// type url String."
	
	^self asUrl toText! !

!FileDirectory methodsFor: 'private' stamp: 'ar 5/30/2001 20:49'!
directoryContentsFor: fullPath
	"Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries index done entryArray |
	entries _ OrderedCollection new: 200.
	index _ 1.
	done _ false.
	[done] whileFalse: [
		entryArray _ self primLookupEntryIn: fullPath index: index.
		#badDirectoryPath = entryArray ifTrue: [
			^(InvalidDirectoryError pathName: pathName) signal].
		entryArray == nil
			ifTrue: [done _ true]
			ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)].
		index _ index + 1].

	^ entries asArray
! !

!FileDirectory methodsFor: 'private' stamp: 'yo 11/5/2002 15:53' prior: 36242912!
directoryContentsFor: fullPath
	"Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries index done entryArray |
	entries _ OrderedCollection new: 200.
	index _ 1.
	done _ false.
	[done] whileFalse: [
		entryArray _ self primLookupEntryIn: fullPath convertToSystemString index: index.
		#badDirectoryPath = entryArray ifTrue: [
			^(InvalidDirectoryError pathName: pathName) signal].
		entryArray == nil
			ifTrue: [done _ true]
			ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)].
		index _ index + 1].

	^ entries asArray
! !

!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 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: 'cmm 1/21/2002 23:11'!
assureExistenceOfPath: localPath
	"Make sure the local directory exists. If necessary, create all parts in between"

	(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: 'nk 3/13/2003 10:18' prior: 36244997!
assureExistenceOfPath: localPath
	"Make sure the local directory exists. If necessary, create all parts in between"
	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: 'squeaklets' stamp: 'mir 6/17/2001 23:42'!
downloadUrl
	^''! !

!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: '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: 'ar 9/5/2001 16:44'!
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: 'mir 9/5/2001 18:47'!
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 _ dirName! !

!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:13'!
hasEToyUserList
	^self eToyUserListUrl notNil or:[self eToyBaseFolderSpec notNil]! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'tpr 10/13/2003 10:49' prior: 21117663!
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: 'name utilities' stamp: 'tpr 3/6/2004 20:18' prior: 21118341!
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: 'jf 2/7/2004 17:22' prior: 21118877!
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: 'asm 12/6/2002 08:18' prior: 21119566!
dirPathFor: fullName 
	"Return the directory part the given name."
	self activeDirectoryClass
		splitName: fullName
		to: [:dirPath :localName | ^ dirPath]! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59' prior: 36250969!
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: 'asm 12/6/2002 08:18' prior: 21120800!
localNameFor: fullName 
	"Return the local part the given name."
	self activeDirectoryClass
		splitName: fullName
		to: [:dirPath :localName | ^ localName]! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59' prior: 36251636!
localNameFor: fullName 
	"Return the local part the given name."
	DirectoryClass
		splitName: fullName
		to: [:dirPath :localName | ^ localName]! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'hg 9/29/2001 14:35'!
startUp
	"Establish the platform-specific FileDirectory subclass. Do any platform-specific startup."
	self setDefaultDirectoryFrom: Smalltalk imageName.
	Preferences startInUntrustedDirectory 
		ifTrue:[	self setDefaultDirectory: SecurityManager default untrustedUserDirectory.
				"Make sure we have a place to go to"
				DefaultDirectory assureExistence].
	Smalltalk openSourceFiles.
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'sd 9/30/2003 14:01' prior: 36252121!
startUp
	"Establish the platform-specific FileDirectory subclass. Do any platform-specific startup."
	self setDefaultDirectoryFrom: SmalltalkImage current imageName.
	Preferences startInUntrustedDirectory 
		ifTrue:[	self setDefaultDirectory: SecurityManager default untrustedUserDirectory.
				"Make sure we have a place to go to"
				DefaultDirectory assureExistence].
	Smalltalk openSourceFiles.
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'sd 11/16/2003 12:02' prior: 36252607!
startUp
	"Establish the platform-specific FileDirectory subclass. Do any platform-specific startup."
	self setDefaultDirectoryFrom: SmalltalkImage current imageName.
	Preferences startInUntrustedDirectory 
		ifTrue:[	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: 'tpr 12/15/2003 12:03' prior: 36253107!
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: 'ar 5/30/2001 19:47'!
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 |
	self splitName: aFilename to:[:p :n| path _ p. localName _ n].
	^localName asUrlRelativeTo: (self on: path) url asUrl! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'asm 12/6/2002 08:18' prior: 36254265!
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 |
	self activeDirectoryClass
		splitName: aFilename
		to: [:p :n | 
			path _ p.
			localName _ n].
	^ localName asUrlRelativeTo: (self on: path) url asUrl! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 11:00' prior: 36254686!
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: 'create/delete file' stamp: 'tk 10/15/2002 14:34'!
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: Smalltalk imagePath) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	((vmp _ FileDirectory on: Smalltalk vmPath) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	((vmp _ vmp containingDirectory) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	^ nil! !

!FileDirectory class methodsFor: 'create/delete file' stamp: 'sd 9/30/2003 14:01' prior: 36255584!
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: 'system start up' stamp: 'ar 2/12/2001 15:30'!
openChanges: changesName forImage: imageName
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	| 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 current 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 current directory"
	fd _ DefaultDirectory.
	(fd fileExists: changesName)
		ifTrue: [changes _ fd readOnlyFileNamed: changesName].
	^changes
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'tpr 10/9/2003 16:27' prior: 36256925!
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: 'sw 5/23/2001 14:29'!
openSources: sourcesName andChanges: changesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	"Note: SourcesName and imageName are full paths; changesName is a  
	local name."

	| sources changes msg wmsg |
	msg _ 'Squeak cannot locate &fileRef.

Please check that the file is named properly and is in the
same directory as this image.  
Further explanation can found
in the startup window, ''How Squeak Finds Source Code''.'.
	wmsg _ 'Squeak cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'.

	sources _ self openSources: sourcesName forImage: imageName.
	changes _ self openChanges: changesName forImage: imageName.
	((sources == nil or: [sources atEnd])
		and: [Preferences valueOfFlag: #warnIfNoSourcesFile])
		ifTrue: 
			[self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName).
			Smalltalk platformName = 'Mac OS'
				ifTrue: [self inform: 'Make sure the sources file is not an Alias.']].
	(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: 'md 10/26/2003 13:17' prior: 36259644!
openSources: sourcesName andChanges: changesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	"Note: SourcesName and imageName are full paths; changesName is a  
	local name."

	| sources changes msg wmsg |
	msg _ 'Squeak cannot locate &fileRef.

Please check that the file is named properly and is in the
same directory as this image.  
Further explanation can found
in the startup window, ''How Squeak Finds Source Code''.'.
	wmsg _ 'Squeak cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'.

	sources _ self openSources: sourcesName forImage: imageName.
	changes _ self openChanges: changesName forImage: imageName.
	((sources == nil or: [sources atEnd])
		and: [Preferences valueOfFlag: #warnIfNoSourcesFile])
		ifTrue: 
			[self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName).
			SmalltalkImage current  platformName = 'Mac OS'
				ifTrue: [self inform: 'Make sure the sources file is not an Alias.']].
	(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: 'tpr 12/15/2003 12:02' prior: 36261859!
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.  
Further explanation can found
in the startup window, ''How Squeak Finds Source Code''.'.
	wmsg _ 'Squeak cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'.

	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: 'ar 2/12/2001 15:19'!
openSources: fullSourcesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	| sources fd sourcesName |
	sourcesName _ FileDirectory localNameFor: fullSourcesName.
	"look for the sources file or an alias to it in the VM's directory"
	fd _ FileDirectory on: Smalltalk 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
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'sd 9/30/2003 14:01' prior: 36266109!
openSources: fullSourcesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	| sources fd sourcesName |
	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
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'md 1/5/2004 18:05' prior: 36267338!
openSources: fullSourcesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."

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

!FileDirectory class methodsFor: 'system start up' stamp: 'tpr 2/17/2004 19:59' prior: 36268579!
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: 'ar 2/12/2001 15:39'!
setDefaultDirectory: directoryName
	"Initialize the default directory to the directory supplied. This method is called when the image starts up."
	| dirName |
	DirectoryClass _ self activeDirectoryClass.
	dirName _ directoryName.
	[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: 'tpr 10/13/2003 10:49' prior: 36271591!
setDefaultDirectory: directoryName
	"Initialize the default directory to the directory supplied. This method is called when the image starts up, very early in the #startUp sequence."
	DefaultDirectory _ self on: directoryName.! !

!FileDirectory class methodsFor: 'system start up' stamp: 'tpr 10/13/2003 10:39'!
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: 'sd 11/16/2003 13:13' prior: 21126730!
shutDown

	SmalltalkImage current closeSourceFiles.
! !

!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: 'class initialization' stamp: 'dgd 3/30/2003 18:27' prior: 21129206!
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.
	].! !

!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: 'aka 5/21/2003 00: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: '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 | ]! !

!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: 'aka 5/20/2003 14:26'!
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'.
! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'dgd 12/27/2003 14:17' prior: 21130300!
asString
	| result |
	result := itemName.
	('_*_' match: result)
		ifTrue: [result := (result copyFrom: 2 to: result size - 1) translated].
	^ result ! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ar 2/12/2001 16:22'!
directoryNamesFor: anItem
	^model directoryNamesFor: anItem! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'sps 12/27/2002 00:47' prior: 21131149!
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 isNil ifTrue:[
		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"
			(item pathParts size > 1)
		  ])
			ifTrue:[ hasContents _ self contents notEmpty. ].
		] on: Error do: [ hasContents _ true ].
			
	].
	^hasContents
! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'tpr 11/28/2003 14:02' prior: 36279209!
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: 'as yet unclassified' stamp: 'sps 12/5/2002 16:59' prior: 21131262!
setItem: anObject name: aString model: aModel

	item _ anObject.
	model _ aModel.
	itemName _ aString.
	hasContents _ nil.
! !

!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 methodsFor: 'exceptionInstantiator' stamp: 'LC 10/24/2001 21:50'!
fileName: aFileName fileClass: aClass 
	^ self new
		fileName: aFileName;
		fileClass: aClass! !

!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/15/2003 13:10'!
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 couldNotOpenFile: srcName].
	[dst _ FileStream forceNewFileNamed: dstName]
		on: FileDoesNotExistException
		do: [^ self couldNotOpenFile: 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/12/2004 16:17' prior: 36284715!
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' 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: 'SD 11/11/2001 14:21'!
compressFile
	"Compress the currently selected file"

	"this method may be a problem in the future but it will depend on the way Stream and decomposed. 
	It indirectly links Gzip to the fileList. Right now this is not a problem"
	(directory readOnlyFileNamed: self fullName) compressFile.
	self updateFileList! !

!FileList methodsFor: 'file list menu' stamp: 'ka 8/3/2001 21:12' prior: 36288707!
compressFile
	"Compress the currently selected file"

	| f |
	f _ StandardFileStream
				readOnlyFileNamed: (directory fullNameFor: self fullName).
	f compressFile.
	self updateFileList! !

!FileList methodsFor: 'file list menu' stamp: 'RAA 2/2/2002 08:18'!
dirAndFileName

	^{directory. fileName}! !

!FileList methodsFor: 'file list menu' stamp: 'sw 2/16/2002 00:08'!
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 
			labels: shiftMenu labelString 
			lines: shiftMenu lineArray
			selections: shiftMenu selections].
	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].
		maybeLine _ services size.
		(#('st' 'cs') 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)'				find)
			('find again (g)'		findAgain)
			('set search string (h)'	setSearchString)
			-
			('do again (j)'			again)
			('undo (z)'				undo)
			-
			('copy (c)'				copySelection)
			('cut (x)'				cut)
			('paste (v)'				paste)
			('paste...'				pasteRecent)
			-
			('do it (d)'				doIt)
			('print it (p)'			printIt)
			('inspect it (i)'			inspectIt)
			('fileIn selection (G)'	fileItIn)
			-
			('accept (s)'				accept)
			('cancel (l)'				cancel)
			-
			('more...'				shiftedYellowButtonActivity)).


	^ aMenu! !

!FileList methodsFor: 'file list menu' stamp: 'dgd 9/19/2003 11:20' prior: 36289474!
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 
			labels: shiftMenu labelString 
			lines: shiftMenu lineArray
			selections: shiftMenu selections].
	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].
		maybeLine _ services size.
		(#('st' 'cs') 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: 'yo 3/31/2003 11:30' prior: 36291280!
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 
			labels: shiftMenu labelString 
			lines: shiftMenu lineArray
			selections: shiftMenu selections].
	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.
		(#('st' 'cs') 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)'				find)
			('find again (g)'		findAgain)
			('set search string (h)'	setSearchString)
			-
			('do again (j)'			again)
			('undo (z)'				undo)
			-
			('copy (c)'				copySelection)
			('cut (x)'				cut)
			('paste (v)'				paste)
			('paste...'				pasteRecent)
			-
			('do it (d)'				doIt)
			('print it (p)'			printIt)
			('inspect it (i)'			inspectIt)
			('fileIn selection (G)'	fileItIn)
			-
			('accept (s)'				accept)
			('cancel (l)'				cancel)
			-
			('more...'				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: 'sw 7/4/2002 19:02'!
fullFileListMenu: aMenu shifted: aBoolean
	"Fill the menu with all possible items for the file list pane, regardless of selection."

	| services servicesPlus extraLines linePointer |
	aMenu title: 'all possible file operations'.
	servicesPlus := self servicesFromSelectorSpecs:  #(
		openImageInWindow: importImage: openAsBackground: 
		-
		fromFileName: openFromFile:  
		-
		openOn: fileIntoNewChangeSet: fileIn: browseChangesFile: putUpdate: browseRecentLogOnPath:
		-
		playMidiFile: openAsMovie: openAsFlash: openTTFFile:
		open3DSFile:  openTapeFromFile: openVRMLFile:
		-
		viewContents: saveContents: openOn:
		-
		
		removeLineFeeds: renderFile:
		-
		loadCRDictionary: loadCRDisplayProperties: ).
	extraLines _ OrderedCollection new.
	linePointer _ 1.
	services _ OrderedCollection new.
	servicesPlus doWithIndex:
		[:svc :ind |
			svc == #-
				ifTrue:
					[extraLines add: linePointer - 1]
				ifFalse:
					[services add: svc.
					linePointer _ linePointer + 1]].
	aMenu 
		addServices: services 
		for: self fullName
		extraLines: extraLines! !

!FileList methodsFor: 'file list menu' stamp: 'cwp 11/8/2002 13:36' prior: 36296023!
fullFileListMenu: aMenu shifted: aBoolean
	"Fill the menu with all possible items for the file list pane, regardless of selection."

	aMenu title: 'all possible file operations'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].
	aMenu addList: #(
		('open graphic in a window' 		openImageInWindow)
		('read graphic into ImageImports' 	importImage)
		('open graphic as background'		openAsBackground)
		-
		('load as morph'						openMorphFromFile)
		('load as project'					openProjectFromFile)
		('load as book'						openBookFromFile)
		-
		('play midi file'						playMidiFile)
		('open as movie'					openAsMovie)
		('open as Flash'						openAsFlash)
		('open true type font'				openAsTTF)
		('open 3DS file'						open3DSFile)
		('open for playback'				openTapeFromFile)
		('open in Wonderland'				openVRMLFile)
		('open in browser'					openInBrowser)
		-
		('fileIn'								fileInSelection)
		('file into new change set'			fileIntoNewChangeSet)
		('browse changes'					browseChanges)
		('browse code'						browseFile)
		-
		('view decompressed'				viewGZipContents)
		('decompress to file'					saveGZipContents)
		-
		('broadcast as update'				putUpdate)
		('remove line feeds'					removeLinefeeds)
		-
		('load Genie Gesture Dictionary'		loadCRDictionary)
		('load Genie Display Properties'		loadCRDisplayProperties))! !

!FileList methodsFor: 'file list menu' stamp: 'nk 10/14/2003 10:02' prior: 36297170!
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'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].

	lastProvider _ nil.
	(self itemsForFile: 'a.*') do: [ :svc |
		(lastProvider notNil and: [svc provider ~~ lastProvider])
			ifTrue: [ aMenu addLine ].
		aMenu add: svc label target: svc selector: svc requestSelector argument: (svc getArgumentsFrom: self).
		aMenu submorphs last setBalloonText: svc description.
		lastProvider _ svc provider.
		svc addDependent: self.
	].

	^aMenu! !

!FileList methodsFor: 'file list menu' stamp: 'asm 12/21/2003 17:13' prior: 36298587!
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'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].

	lastProvider _ nil.
	(self itemsForFile: 'a.*') do: [ :svc |
		(lastProvider notNil and: [svc provider ~~ lastProvider])
			ifTrue: [ aMenu addLine ].
		aMenu add: svc label target: svc selector: svc requestSelector argument: (svc getArgumentsFrom: self).
		Smalltalk isMorphic ifTrue: [aMenu submorphs last setBalloonText: svc description].
		lastProvider _ svc provider.
		svc addDependent: self.
	].

	^aMenu! !

!FileList methodsFor: 'file list menu' stamp: 'nk 2/15/2004 16:06' prior: 36299317!
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'.
	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/30/2002 01:15'!
itemsForAnyFile
	"Answer a list of universal services that could apply to any file"
	
	| services |
	services := OrderedCollection new: 5.
	services add: self serviceCopyName. 
	services add: self serviceRenameFile. 
	services add: self serviceDeleteFile.
	^ services! !

!FileList methodsFor: 'file list menu' stamp: 'sw 11/8/2003 13:32' prior: 36300754!
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 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: 'sd 1/31/2002 12:08'!
itemsForNoFile

	| services |
	services := OrderedCollection new: 6.
	services add: self serviceSortByName.
	services add: self serviceSortBySize.
	services add: (self serviceSortByDate useLineAfter: true).
	(self isFileSelected not and: [self class isReaderNamedRegistered: #FileContentsBrowser])
			ifTrue:[ services add: (self serviceBrowseCodeFiles useLineAfter: true)].
	services add: self serviceAddNewFile.
	services add: self serviceAddNewDirectory.
	^ 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: 'dgd 12/27/2003 12:18' prior: 21146733!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index ending |
	self okToChange ifFalse: [^ self].
	(response := FillInTheBlank
						request: ('New {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: 'dgd 9/21/2003 17:37' prior: 21148477!
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: 'yo 3/31/2003 11:25'!
getEncodedText

	Cursor read showWhile: [
		self selectEncoding.
		self changed: #contents].
! !

!FileList methodsFor: 'file menu action' stamp: 'dgd 12/27/2003 12:20' prior: 21162938!
renameFile
	"Rename the currently selected file"
	| newName response |
	listIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(response _ FillInTheBlank 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: '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' prior: 21136543!
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: 'SD 11/8/2001 21:22'!
modelWakeUp
	"User has entered or expanded the window -- reopen any remote connection."

	(directory isKindOf: ServerDirectory) 
		ifTrue: [directory wakeUp] "It would be good to implement a null method wakeUp on the root of directory"! !

!FileList methodsFor: 'initialization' stamp: 'dgd 12/27/2003 12:57' prior: 36307684!
modelWakeUp
	"User has entered or expanded the window -- reopen any remote connection."

	(directory notNil and:[directory isRemoteDirectory])
		ifTrue: [directory wakeUp] "It would be good to implement a null method wakeUp on the root of directory"! !

!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: '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: 'sw 11/30/2002 01:02'!
updateButtonRow
	"Dynamically update the contents of the button row, if any."

	| aWindow aRow |
	Smalltalk isMorphic ifFalse: [^ self].

	aWindow _ self dependents detect: [:m | (m isKindOf: SystemWindow) 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: 'initialization' stamp: 'gm 2/16/2003 20:38' prior: 36311080!
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: '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: 'sd 1/31/2002 22:24'!
serviceBrowseCodeFiles

	self flag: #stef.
	"Here we are breaking the registration mechanism by a direct reference to the fileContentsBrowser.
	The problem is that service is waiting for a filename and here this specific vicous service is used 
	when no file is selected. I think that we should change that"

	^  SimpleServiceEntry 
		provider: FileContentsBrowser
		label: 'browse code files' 
		selector: #selectAndBrowseFile:! !

!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: 'sw 11/8/2003 13:39'!
viewContentsInWorkspace
	"View the contents of my selected file in a new workspace"
	
	| aString aFileStream aName |
	aString _ (aFileStream _ directory readOnlyFileNamed: self fullName) contentsOfEntireFile.
	aName _ aFileStream localName.
	aFileStream close.
	(Workspace new contents: aString) openLabel: 'Workspace from ', aName! !

!FileList methodsFor: 'to be transformed in registration' 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: 'to be transformed in registration' 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: 'to be transformed in registration' 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: 'to be transformed in registration' 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: 'to be transformed in registration' stamp: 'dgd 9/19/2003 12:06' prior: 21145244!
volumeMenu: aMenu
	^ aMenu addList: {
			{'recent...' translated.		#recentDirs}.
			#-.
			{'add server...' translated.		#askServerInfo}.
			{'remove server...' translated.		#removeServer}.
			#-.
			{'delete directory...' translated.	#deleteDirectory}}.
! !

!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: 'dgd 9/21/2003 17:36' prior: 21141402!
deleteDirectory
	"Remove the currently selected directory"
	| localDir |
	directory entries size = 0 ifFalse:[^self inform:'Directory must be empty' translated].
	localDir _ directory pathParts last.
	(self confirm: ('Really delete {1}?' translated format:{localDir printString})) ifFalse: [^ self].
	self volumeListIndex: self volumeListIndex-1.
	directory deleteDirectory: localDir.
	self updateFileList.! !

!FileList methodsFor: 'volume list and pattern' stamp: 'tpr 11/28/2003 11:44' prior: 36321236!
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: '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: 'private' stamp: 'mu 8/22/2003 01:32' prior: 21168194!
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 allEncodingStates includes: brevityState) 
		ifTrue: [ ^self readContentsAsEncoding: brevityState].

	self halt: 'unknown state ' , brevityState printString! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:22' prior: 21169158!
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: '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' 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: 'sw 5/23/2001 14:31'!
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'.
		^ 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: type , ' contents cannot
meaningfully be saved at present.'.
	^ false  "failed"
! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:24' prior: 36326143!
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 8/13/2003 13:59'!
readContentsAsEncoding: encodingName
	| f writeStream converter |
	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 atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:13' prior: 21171853!
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].
	(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: 'dgd 12/27/2003 12:13' prior: 36328491!
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].
	(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: 'dgd 12/27/2003 12:11' prior: 21173046!
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].
	((size := f size)) > 5000 & brevity
		ifTrue: [data := f next: 10000. f close. brevityState := #briefHex]
		ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex].

	s := WriteStream on: (String new: data size*4).
	0 to: data size-1 by: 16 do:
		[:loc | s nextPutAll: loc hex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space].
		s cr].
	hexData := s contents.

	^ contents := ((size > 5000) & brevity
		ifTrue: ['File ''{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 4/21/2001 01:16' prior: 36332081!
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'].
	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 hex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (Character value: (data at: i)) hex; space].
		s cr].
	hexData _ s contents.

	^ contents _ ((size > 5000) & brevity
		ifTrue: ['File ''', fileName, ''' is ', size printString, ' bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
', hexData , '
------------------------------------------
... end of the first 5000 characters.']
		ifFalse: [hexData]).
! !

!FileList methodsFor: 'private' stamp: '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' prior: 21174238!
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: '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: 'sw 11/30/2002 01:19'!
updateFileList
	"Update my files list with file names in the current directory that match the pattern."

	Cursor execute showWhile:
		[list _ (pattern includes: $*) | (pattern includes: $#)
			ifTrue: [self listForPattern: pattern]
			ifFalse: [
				pattern isEmpty
					ifTrue: [self listForPattern: '*']
					ifFalse: [self listForPattern: '*', pattern, '*']].
		listIndex _ 0.
		volListIndex _ volList size.
		fileName _ nil.
		contents _ ''.
		self changed: #volumeListIndex.
		self changed: #fileList.
		self updateButtonRow]! !

!FileList methodsFor: 'private' stamp: 'nk 12/10/2002 07:57' prior: 36338059!
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 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 class methodsFor: 'instance creation' stamp: 'sbw 8/29/2001 19:36'!
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:.
	aFileList wantsOptionalButtons
		ifTrue: [buttons _ aFileList optionalButtonRow.
			divider _ BorderedSubpaneDividerMorph forBottomEdge.
			dividerDelta _ 0.
			Preferences alternativeWindowLook
				ifTrue: [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)).
			Preferences alternativeWindowLook
				ifTrue: [row borderWidth: 2]
				ifFalse: [row borderWidth: 0]]
		ifFalse: [fileListTop _ 0.
			window
				addMorph: fileListMorph
				frame: (0.3 @ fileListTop corner: 1 @ 0.3)]! !

!FileList class methodsFor: 'instance creation' stamp: 'nk 6/15/2003 13:04' prior: 36341922!
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.
			Preferences alternativeWindowLook
				ifTrue: [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)).
			Preferences alternativeWindowLook
				ifTrue: [row borderWidth: 2]
				ifFalse: [row borderWidth: 0]]
		ifFalse: [fileListTop _ 0.
			window
				addMorph: fileListMorph
				frame: (0.3 @ fileListTop corner: 1 @ 0.3)].! !

!FileList class methodsFor: 'instance creation' stamp: 'dew 1/7/2002 01:42'!
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.
	patternMorph _ PluggableTextMorph
				on: aFileList
				text: #pattern
				accept: #pattern:.
	patternMorph acceptOnCR: true.
	patternMorph hideScrollBarIndefinitely.
	divider _ BorderedSubpaneDividerMorph horizontal.
	dividerDelta _ 0.
	Preferences alternativeWindowLook
		ifTrue: [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)).
	Preferences alternativeWindowLook
		ifTrue: [row borderWidth: 2] ifFalse: [row borderWidth: 0]! !

!FileList class methodsFor: 'instance creation' stamp: 'nk 6/15/2003 13:04' prior: 36345973!
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 hideScrollBarIndefinitely.
	divider _ BorderedSubpaneDividerMorph horizontal.
	dividerDelta _ 0.
	Preferences alternativeWindowLook
		ifTrue: [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)).
	Preferences alternativeWindowLook
		ifTrue: [row borderWidth: 2] ifFalse: [row borderWidth: 0]! !

!FileList class methodsFor: 'instance creation' stamp: 'nk 4/28/2004 10:18' prior: 36347864!
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.
	Preferences alternativeWindowLook
		ifTrue: [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)).
	Preferences alternativeWindowLook
		ifTrue: [row borderWidth: 2] ifFalse: [row borderWidth: 0]! !

!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: '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: '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: 'class initialization' stamp: 'sd 2/6/2002 21:26'!
initialize
	"FileList initialize"

	RecentDirs := OrderedCollection new.
	(Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) do: 		[:providerMetaclass |
			self registerFileReader: providerMetaclass soleInstance]! !

!FileList class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:46' prior: 36354245!
initialize
	"FileList initialize"

	RecentDirs := OrderedCollection new.
	(self environment allClassesImplementing: #fileReaderServicesForFile:suffix:) do: 		[:providerMetaclass |
			self registerFileReader: providerMetaclass soleInstance].

	self registerInFlapsRegistry.! !

!FileList class methodsFor: 'class initialization' stamp: 'nb 5/7/2003 10:05' prior: 36354579!
initialize
	"FileList initialize"

	RecentDirs := OrderedCollection new.
	(SystemNavigation new allClassesImplementing: #fileReaderServicesForFile:suffix:) do: 		[:providerMetaclass |
			self registerFileReader: providerMetaclass soleInstance]! !

!FileList class methodsFor: 'class initialization' stamp: 'dvf 8/23/2003 12:17' prior: 36354951!
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: '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 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: 'SD 11/8/2001 21:11'!
registeredFileReaderClasses
	
	FileReaderRegistry ifNil: [FileReaderRegistry _ OrderedCollection new].
	^ FileReaderRegistry

	! !

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

!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: 'tpr 12/1/2003 17:14' prior: 21185857!
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: '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: 'mir 11/15/2001 18:20'!
limitedSuperSwikiDirectoryList

	| dir nameToShow dirList |

	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)
	].
	(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' prior: 36360739!
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 11/15/2001 18:17'!
limitedSuperSwikiPublishDirectoryList

	| dirList |

	dirList _ self publishingServers.
	ServerDirectory localProjectDirectories do: [ :each |
		dirList add: (FileDirectoryWrapper with: each name: each localName model: self)].
	dirList isEmpty
		ifTrue: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
	^dirList! !

!FileList2 methodsFor: 'initialization' stamp: 'mir 2/6/2004 17:25' prior: 36362874!
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: '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: '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: 'hg 8/3/2000 16:37'!
importImage
	"Import the given image file and store the resulting Form in the global dictionary
	ImageImports, at a key consisting of the short filename up to the first period.  "
	| key image |
	key _ fileName sansPeriodSuffix.
	image _ Form fromFileNamed: self fullName.
	Smalltalk imageImports at: key put: image.
! !

!FileList2 methodsFor: 'own services' stamp: 'sd 5/11/2003 22:15' prior: 36365388!
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: 'hg 8/3/2000 16:34'!
openImageInWindow
	"Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP.
	Fail if file format is not recognized."

	| image myStream |

	myStream _ (directory readOnlyFileNamed: fileName) binary.
	image _ Form fromBinaryStream: myStream.
	myStream close.

	Smalltalk isMorphic
		ifTrue: [(SketchMorph withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fileName]! !

!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: 'dew 9/6/2003 00:27'!
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 _ (CrLfFileStream readOnlyFileNamed: self fullName) contentsOfEntireFile.
	(StandardFileStream newFileNamed: self fullName) 
		nextPutAll: fileContents;
		close.! !

!FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 01:29'!
serviceCancel
	"Answer a service for hitting the cancel button"

	^ (SimpleServiceEntry new
		provider: self label: 'cancel' selector: #cancelHit 
		description: 'hit here to cancel ')
		extraSelector: nil;
		buttonLabel: 'cancel'! !

!FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09' prior: 36367559!
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: 'sw 2/22/2002 01:46'!
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')
		extraSelector: nil;
		buttonLabel: 'ok'! !

!FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09' prior: 36368156!
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: 'nk 7/16/2003 17:36'!
blueButtonForService: aService textColor: textColor inWindow: window

	| block |
	block _ [ aService performServiceFor: (aService getArgumentsFrom: self) ] copy fixTemps.
	^(window fancyText: aService buttonLabel capitalized ofSize: 15 color: textColor)
		setProperty: #buttonText toValue: aService buttonLabel capitalized;
		hResizing: #rigid;
		extent: 100@20;
		layoutInset: 4;
		borderWidth: 0;
		useRoundedCorners;
		setBalloonText: aService label;
		on: #mouseUp send: #value to: block 
! !

!FileList2 methodsFor: 'user interface' stamp: 'nk 2/15/2004 16:07' prior: 36369549!
blueButtonForService: aService textColor: textColor inWindow: window

	| block |
	block _ [ aService performServiceFor: self ] copy fixTemps.
	^(window fancyText: aService buttonLabel capitalized ofSize: 15 color: textColor)
		setProperty: #buttonText toValue: aService buttonLabel capitalized;
		hResizing: #rigid;
		extent: 100@20;
		layoutInset: 4;
		borderWidth: 0;
		useRoundedCorners;
		setBalloonText: aService label;
		on: #mouseUp send: #value to: block 
! !

!FileList2 methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'!
morphicDirectoryTreePane

	^self morphicDirectoryTreePaneFiltered: #initialDirectoryList
! !

!FileList2 methodsFor: 'user interface' stamp: 'LC 1/6/2002 07:20'!
morphicDirectoryTreePaneFiltered: aSymbol
	^(SimpleHierarchicalListMorph 
		on: self
		list: aSymbol
		selected: #currentDirectorySelected
		changeSelected: #setSelectedDirectoryTo:
		menu: nil
		keystroke: nil) autoDeselect: false
		
! !

!FileList2 methodsFor: 'user interface' stamp: 'nk 6/15/2003 13:06' prior: 36370833!
morphicDirectoryTreePaneFiltered: aSymbol
	^(SimpleHierarchicalListMorph 
		on: self
		list: aSymbol
		selected: #currentDirectorySelected
		changeSelected: #setSelectedDirectoryTo:
		menu: nil
		keystroke: nil)
			autoDeselect: false;
			enableDrag: false;
			enableDrop: true;
			yourself
		
! !

!FileList2 methodsFor: 'user interface' stamp: 'rww 12/13/2003 13:07' prior: 36371158!
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: 'nk 6/15/2003 13:05' prior: 21189607!
morphicFileListPane

	^(PluggableListMorph 
		on: self 
		list: #fileList 
		selected: #fileListIndex
		changeSelected: #fileListIndex: 
		menu: #fileListMenu:)
			enableDrag: true;
			enableDrop: false;
			yourself

! !

!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: '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: 'LC 1/5/2002 19:08'!
okHit
	ok _ true.
	currentDirectorySelected
		ifNil: [Smalltalk beep]
		ifNotNil: [modalView delete]! !

!FileList2 methodsFor: 'private' stamp: 'sd 5/11/2003 17:02' prior: 36375301!
okHit
	ok _ true.
	currentDirectorySelected
		ifNil: [self beep]
		ifNotNil: [modalView delete]! !

!FileList2 methodsFor: 'private' stamp: 'md 10/22/2003 15:27' prior: 36375484!
okHit
	ok _ true.
	currentDirectorySelected
		ifNil: [Beeper beep]
		ifNotNil: [modalView delete]! !

!FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:44'!
okHitForProjectLoader

	| areaOfProgress |
	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: '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 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"



!
]style[(169 38 41 43 39 48 41 36 36 4)f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1!
!FileList2 class methodsFor: 'class initialization' stamp: 'nk 6/14/2004 08:47'!
initialize
	Preferences
		addPreference: #useFileList2
		categories:  #(general)
		default: true
		balloonHelp: 'if true, then when you open a file list from the World menu, it''ll be an enhanced one'
		projectLocal:  false
		changeInformee:  self
		changeSelector: #useFileList2preferenceChanged! !

!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: 'blue ui' stamp: 'nk 7/16/2003 17:33'!
blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip

	^(window fancyText: aString ofSize: 15 color: textColor)
		setProperty: #buttonText toValue: aString;
		hResizing: #rigid;
		extent: 100@20;
		layoutInset: 4;
		borderWidth: 0;
		useRoundedCorners;
		setBalloonText: balloonText;
		on: #mouseUp send: sel to: recip
! !

!FileList2 class methodsFor: 'blue ui' stamp: 'nk 7/16/2003 17:13' prior: 21193199!
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: 'sjc 5/3/2003 21:38' prior: 21193954!
endingSpecs
"sjc3-May 2003-added jpeg extension"
	^#(
		('Art' ('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png')
			(('open image in a window' openImageInWindow 'View')
			('read image into ImageImports' importImage 'Import')
			('open image as background' openAsBackground 'World'))
		)

		('Morphs' ('morph' 'morphs' 'sp')
			(('load as morph' openMorphFromFile 'Morph')
			('load as project' openProjectFromFile 'Project'))
		)

		('Projects' ('extseg' 'project' 'pr') (('load as project' openProjectFromFile 'Load')))

		('Books' ('bo') (('load as book' openBookFromFile 'Open')))

		('Music' ('mid') (('play midi file' playMidiFile 'Play')))

		('Movies' ('movie') (('open as movie' openAsMovie 'Open')))

		"('Code' ('st' 'cs')
			(('fileIn' fileInSelection)
			('file into new change set' fileIntoNewChangeSet)
			('browse changes' browseChanges)
			('browse code' browseFile)
			('remove line feeds' removeLinefeeds)
			('broadcast as update' putUpdate))
		)"

		('Flash' ('swf') (('open as Flash' openAsFlash 'Open')))

		('TrueType' ('ttf') (('open true type font' openAsTTF 'Open')))

		('3ds' ('3ds') (('Open 3DS file' open3DSFile' Open')))

		('Tape' ('tape') (('open for playback' openTapeFromFile 'Open')))

		('Wonderland' ('wrl') (('open in Wonderland' openVRMLFile 'Open')))

		('HTML' ('htm' 'html') (('open in browser' openInBrowser 'Open')))

	)! !

!FileList2 class methodsFor: 'blue ui' stamp: 'nk 7/16/2003 18:02' prior: 36379955!
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'))
		('Books' ('bo'))
		('Music' ('mid'))
		('Movies' ('movie' 'mpg' 'mpeg' 'qt' 'mov'))
		"('Code' ('st' 'cs'))"
		('Flash' ('swf'))
		('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: 'ar 12/19/2001 11:30'!
morphicViewGeneralLoaderInWorld: aWorld
"
FileList2 morphicViewGeneralLoaderInWorld: self currentWorld
"
	| window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow |

	fileTypeInfo _ self endingSpecs.
	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList 
		fileSelectionBlock: self projectOnlySelectionBlock;
		modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.

	fileTypeButtons _ fileTypeInfo collect: [ :each |
		(self blueButtonText: each first textColor: Color gray inWindow: window)
			setProperty: #enabled toValue: true;
			hResizing: #shrinkWrap
	].
	buttons _ #('OK' 'Cancel') collect: [ :each |
		self blueButtonText: each textColor: textColor1 inWindow: window
	].
	treePane _ aFileList morphicDirectoryTreePane 
		extent: 250@300; 
		retractable: false;
		borderWidth: 0.
	fileListPane _ aFileList morphicFileListPane 
		extent: 350@300; 
		retractable: false;
		borderWidth: 0.
	window addARow: {window fancyText: 'Find...' ofSize: 21 color: textColor1}.
	fileTypeRow _ window addARowCentered: fileTypeButtons.
	actionRow _ window addARowCentered: {
		buttons first. 
		(Morph new extent: 30@5) color: Color transparent. 
		buttons second
	}.
	window
		addARow: {
			(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
			(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	fileTypeButtons do: [ :each | 
		each 
			on: #mouseUp 
			send: #value:value: 
			to: [ :evt :morph | 
				self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph.
			] fixTemps
	].
	buttons first on: #mouseUp send: #okHit to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	aFileList directoryChangeBlock: [ :newDir |
		self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir
	] fixTemps.
	aFileList directory: aFileList directory.
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	^ window openInWorld: aWorld.! !

!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: 'sw 2/22/2002 02:08'!
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: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttons _ #('OK' 'Cancel') collect: [ :each |
		self blueButtonText: each textColor: textColor1 inWindow: window
	].
	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' ofSize: 21 color: textColor1
		};
		addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second
		};
		addARow: {
			window fancyText: 'Please select a project' ofSize: 21 color: Color blue
		};
		addARow: {
			(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
			(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	buttons first 
		on: #mouseUp 
		send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit])
		to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 9/6/2003 19:53' prior: 36386047!
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: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttons _ #('OK' 'Cancel') collect: [ :each |
		self blueButtonText: each translated textColor: textColor1 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 ofSize: 21 color: textColor1
		};
		addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second
		};
		addARow: {
			window fancyText: 'Please select a project' translated ofSize: 21 color: Color blue
		};
		addARow: {
			(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
			(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	buttons first 
		on: #mouseUp 
		send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit])
		to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'ar 12/19/2001 11:30'!
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: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttonData _ Preferences enableLocalSave
		ifTrue: [#( 
			('Save' okHit 'Save in the place specified below, and in the 
	Squeaklets folder on your local disk') 
			('Save on local disk only' saveLocalOnlyHit 'saves in the Squeaklets folder')
			('Cancel' cancelHit 'return without saving') 
			)]
		ifFalse: [#( 
			('Save' okHit 'Save in the place specified below, and in the 
	Squeaklets folder on your local disk') 
			('Cancel' cancelHit 'return without saving') 
			)].
	buttons _ buttonData collect: [ :each |
		(self blueButtonText: each first textColor: textColor1 inWindow: window)
			setBalloonText: each third;
			hResizing: #shrinkWrap;
			on: #mouseUp send: each second to: aFileList
	].
	option _ aProject world 
		valueOfProperty: #SuperSwikiPublishOptions 
		ifAbsent: [#initialDirectoryList].
	aProject world removeProperty: #SuperSwikiPublishOptions.

	World height < 500 ifTrue: [
		treeExtent _ 350@150.
	] ifFalse: [
		treeExtent _ 350@300.
	].

	(treePane _ aFileList morphicDirectoryTreePaneFiltered: option) 
		extent: treeExtent; 
		retractable: false;
		borderWidth: 0.
	window
		addARowCentered: {
			window fancyText: 'Publish This Project' ofSize: 21 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' ofSize: 21 color: Color blue
		};
		addARow: {
			(
				window inAColumn: {
					(pane2 _ window inARow: {window inAColumn: {treePane}}) 
						useRoundedCorners; layoutInset: 6
				}
			) layoutInset: 10
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2 fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	window setProperty: #morphicLayerNumber toValue: 11.
	aFileList postOpen.
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	^ window ! !

!FileList2 class methodsFor: 'blue ui' stamp: 'jm 9/2/2003 21:14' prior: 36391623!
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: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttonData _ Preferences enableLocalSave
		ifTrue: [#( 
			('Save' okHit 'Save in the place specified below, and in the 
	Squeaklets folder on your local disk') 
			('Save on local disk only' saveLocalOnlyHit 'saves in the Squeaklets folder')
			('Cancel' cancelHit 'return without saving') 
			)]
		ifFalse: [#( 
			('Save' okHit 'Save in the place specified below, and in the 
	Squeaklets folder on your local disk') 
			('Cancel' cancelHit 'return without saving') 
			)].
	buttons _ buttonData collect: [ :each |
		(self blueButtonText: each first translated textColor: textColor1 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.

	World height < 500 ifTrue: [
		treeExtent _ 350@150.
	] ifFalse: [
		treeExtent _ 350@300.
	].

	(treePane _ aFileList morphicDirectoryTreePaneFiltered: option) 
		extent: treeExtent; 
		retractable: false;
		borderWidth: 0.
	window
		addARowCentered: {
			window fancyText: 'Publish This Project' translated ofSize: 21 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 ofSize: 21 color: Color blue
		};
		addARow: {
			(
				window inAColumn: {
					(pane2 _ window inARow: {window inAColumn: {treePane}}) 
						useRoundedCorners; layoutInset: 6
				}
			) layoutInset: 10
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2 fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	window setProperty: #morphicLayerNumber toValue: 11.
	aFileList postOpen.
	window 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: 'RAA 3/6/2001 12:40'!
modalFileSelector

	| window |

	window _ self morphicViewFileSelector.
	window openCenteredInWorld.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^(window valueOfProperty: #fileListModel) getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02' prior: 36398340!
modalFileSelector

	| window |

	window _ self morphicViewFileSelector.
	window openCenteredInWorld.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycle.
	].
	^(window valueOfProperty: #fileListModel) getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'RAA 3/6/2001 12:47'!
modalFileSelectorForSuffixes: aList

	| window aFileList |

	window _ self morphicViewFileSelectorForSuffixes: aList.
	aFileList _ window valueOfProperty: #fileListModel.
	window openCenteredInWorld.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^aFileList getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02' prior: 36398996!
modalFileSelectorForSuffixes: aList

	| window aFileList |

	window _ self morphicViewFileSelectorForSuffixes: aList.
	aFileList _ window valueOfProperty: #fileListModel.
	window openCenteredInWorld.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycle.
	].
	^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: 'gh 8/27/2002 15:10'!
modalFolderSelector: aDir

	| window fileModel |
	window _ self morphicViewFolderSelector: aDir.
	fileModel _ window model.
	window openInWorld: self currentWorld extent: 300@400.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02' prior: 36399937!
modalFolderSelector: aDir

	| window fileModel |
	window _ self morphicViewFolderSelector: aDir.
	fileModel _ window model.
	window openInWorld: self currentWorld extent: 300@400.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycle.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'RAA 7/1/2001 18:31'!
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.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02' prior: 36400737!
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.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycle.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02' prior: 21204643!
modalFolderSelectorForProjectLoad

	| window fileModel w |

	window _ self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false.
	fileModel _ window valueOfProperty: #FileList.
	w _ self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	window openInWorld: w.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycle.
	].
	^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: 'sw 3/6/2002 12:06'!
morphicViewFileSelectorForSuffixes: aList
	"Answer a morphic file-selector tool for the given suffix list"

	| dir aFileList window fixedSize midLine gap |
	dir _ FileDirectory default.
	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: 'dgd 9/19/2003 12:18' prior: 36402620!
morphicViewFileSelectorForSuffixes: aList
	"Answer a morphic file-selector tool for the given suffix list"

	| dir aFileList window fixedSize midLine gap |
	dir _ FileDirectory default.
	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' translated. 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: '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: 'nk 10/14/2003 12:41' prior: 21210336!
update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph

	| fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString |

	(morph valueOfProperty: #enabled) ifFalse: [^self].
	fileTypeRow submorphsDo: [ :sub |
		sub color: (
			sub == morph 
				ifTrue: [Color white] 
				ifFalse: [(sub valueOfProperty: #enabled) 
							ifTrue: [Color transparent] ifFalse: [Color gray]]
		).
	].
	fileTypeString _ morph valueOfProperty: #buttonText.

	aFileList _ window valueOfProperty: #FileList.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	actionRow removeAllMorphs.
	fileTypeInfo _ self endingSpecs.
	info2 _ fileTypeInfo detect: [ :each | each first = fileTypeString] ifNone: [self error: 'bad fileTypeString' ].
	fileSuffixes _ info2 second.
	fileActions _ info2 third.
	buttons _ fileActions collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ].
	buttons addLast: (self blueButtonText: 'Cancel' textColor: textColor1 inWindow: window balloonText: 'Cancel this search' selector: #cancelHit recipient: aFileList).
	buttons do: [ :each | actionRow addMorphBack: each].
	window fullBounds.
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	aFileList fileSelectionBlock: (
		self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each])
	).
	aFileList updateFileList.

! !

!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: 'preferences' stamp: 'nk 6/14/2004 09:04'!
useFileList2preferenceChanged
	| preferred quads registered |
	preferred := Preferences useFileList2
				ifTrue: [#FileList2]
				ifFalse: [#FileList].
	quads := Flaps registeredFlapsQuads
				at: 'Tools'
				ifAbsent: [^ self].
	registered := quads
				detect: [:quad | quad first startsWith: 'FileList']
				ifNone: [Flaps registerQuad: {
					preferred. 
					#prototypicalToolWindow.
					'File List'.
					'A File List is a tool for browsing folders and files on disks and FTP servers.'} 						forFlapNamed: 'Tools'.
					nil].
	registered
		ifNotNil: [registered at: 1 put: preferred].
	Flaps replaceToolsFlap! !

!FileList2 class methodsFor: 'preferences' stamp: 'kfr 6/20/2004 16:36' prior: 36409297!
useFileList2preferenceChanged
	| preferred quads registered |
	preferred := Preferences useFileList2
				ifTrue: [#FileList2]
				ifFalse: [#FileList].
	quads := Flaps registeredFlapsQuads
				at: 'Tools'
				ifAbsent: [^ self].
	registered := quads
				detect: [:quad | quad first  beginsWith: 'FileList']
				ifNone: [Flaps registerQuad: {
					preferred. 
					#prototypicalToolWindow.
					'File List'.
					'A File List is a tool for browsing folders and files on disks and FTP servers.'} 						forFlapNamed: 'Tools'.
					nil].
	registered
		ifNotNil: [registered at: 1 put: preferred].
	Flaps replaceToolsFlap! !

!FileList2 class methodsFor: '*smloader-override' stamp: 'nk 2/9/2001 15:50'!
morphicView
	| dir aFileList window fileListBottom midLine fileListTopOffset buttonPane |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir 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: 'sps 4/3/2004 20:40' prior: 36410705!
morphicView
	| dir aFileList window fileListBottom midLine fileListTopOffset buttonPane |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fileListTopOffset _ (TextStyle defaultFont pointSize * 2) + 14.
	fileListBottom _ 0.4.
	midLine _ 0.4.
	buttonPane _ aFileList optionalButtonRow addMorph:
		(aFileList morphicPatternPane vResizing: #spaceFill; yourself).
		
"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 lower pane is added. "
	Preferences scrollBarsOnRight 
		ifFalse:
			[self addFullPanesTo: window from: {
				{aFileList morphicFileContentsPane. 0@fileListBottom corner: 1@1. nil}.
				{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}.
			}]
		ifTrue:
			[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' prior: 36411692!
morphicView
	^ self morphicViewOnDirectory: FileDirectory default! !

!FileList2 class methodsFor: '*smloader-extension' stamp: 'btr 1/30/2004 00:56'!
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 ! !

!FileList2ModalDialogsTest methodsFor: 'running' stamp: 'LC 1/6/2002 08:45'!
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: 'LC 1/6/2002 08:50'!
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: 'LC 1/6/2002 08:55'!
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: 'LC 1/6/2002 09:01'!
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
! !

!FileList2ModalDialogsTest commentStamp: '<historical>' prior: 0!
TestRunner open!
!FileListTest methodsFor: 'private' stamp: 'sd 2/1/2002 23:04'!
checkIsServiceIsFromDummyTool: service
	
	^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList
	 	& service label = 'menu label'
		& (service instVarNamed: #selector) = #loadAFileForTheDummyTool:! !

!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: 'SD 11/10/2001 21:53'!
testMenuReturned
	"(self selector: #testToolRegistered) debug"

	self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! !

!FileListTest methodsFor: 'test' stamp: 'sd 2/6/2002 21:26'!
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)! !

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

!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!
!FilePackage methodsFor: 'accessing' stamp: 'ar 2/5/2004 16:17'!
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 isMetaClass 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: 'nk 2/18/2004 18:31' prior: 36419066!
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: 'ar 2/5/2004 15:11'!
removeDoIts
	doIts := OrderedCollection new.! !

!FilePackage methodsFor: 'initialize' stamp: 'ar 2/5/2004 15:14' prior: 21213237!
fromFileNamed: aName
	| stream |
	fullName := aName.
	stream := FileStream readOnlyFileNamed: aName.
	[self fileInFrom: stream] ensure:[stream close].! !

!FilePackage methodsFor: 'initialize' stamp: 'yo 8/27/2003 07:03'!
fromFileNamed: aName encoding: encodingName
	| stream |
	fullName := aName.
	stream := FileStream readOnlyFileNamed: aName.
	self fileInFrom: stream.! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'tk 3/7/2001 13:57'!
fileOut
	| fileName stream |
	fileName := FillInTheBlank request: 'Enter the file name' initialAnswer:''.
	stream := FileStream newFileNamed: fileName.
	sourceSystem isEmpty ifFalse:[
		stream nextChunkPut: sourceSystem printString;cr ].
	self fileOutOn: stream.
	stream cr; cr.
	self classes do:[:cls|
		cls needsInitialize ifTrue:[
			stream cr; nextChunkPut: cls name,' initialize']].
	stream cr.
	stream close.

	"DeepCopier new checkVariables."
! !

!FileStream methodsFor: 'accessing' stamp: 'ar 8/6/2001 18:34'!
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: 'nk 2/22/2001 17:07'!
directoryEntry
	^self directory entryAt: self localName! !

!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: 'editing' stamp: 'sw 3/11/2002 22:42'!
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' stamp: 'nk 2/2/2001 15:19'!
url
	"Convert my path into a file:// type url.  Use slash instead of the local delimiter (:), and convert odd characters to %32 notation."

	"If / is not the file system delimiter, encode / before converting."
	| list |
	list _ self directory pathParts.
	^ String streamContents: [:strm |
		strm nextPutAll: 'file:'.
		list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP].
		strm nextPut: $/; nextPutAll: self localName encodeForHTTP]! !

!FileStream methodsFor: 'file accessing' stamp: 'gk 2/10/2004 13:21' prior: 36424215!
url
	"Convert my path into a file:// type url String."
	
	^self asUrl toText! !

!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 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 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: 'concrete classes' stamp: 'yo 11/4/2002 14:49' prior: 21250899!
concreteStream
	"Who should we really direct class queries to?  "
	^ MultiByteFileStream "may change this to CrLfFileStream"
	"^ StandardFileStream may change this to CrLfFileStream"! !

!FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 16:58'!
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: 'mir 2/2/2001 17:14'!
httpPostMultipart: url args: argsDict
	| mimeBorder argsStream crLf fieldValue resultStream result |
	" do multipart/form-data encoding rather than x-www-urlencoded "

	crLf _ SimpleClientSocket 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 toText].
	"get the header of the reply"
	result _ resultStream upToEnd.
	^MIMEDocument content: result! !

!FileStream class methodsFor: 'browser requests' stamp: 'mir 5/13/2003 10:43' prior: 36427003!
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 toText].
	"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: 'mir 4/30/2001 18: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: 'initialize-release' stamp: 'hg 8/3/2000 18:00'!
initialize

	FileList registerFileReader: self! !

!FileStream class methodsFor: 'file reader services' stamp: 'sw 2/17/2002 05:07'!
fileIn: fullName
	"File in the entire contents of the file specified by the name provided"

	| fn ff |
	fullName ifNil: [^ self beep].
	ff _ self readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName).
	((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	ff fileIn! !

!FileStream class methodsFor: 'file reader services' stamp: 'nb 6/17/2003 12:25' prior: 36430919!
fileIn: fullName
	"File in the entire contents of the file specified by the name provided"

	| fn ff |
	fullName ifNil: [^ Beeper beep].
	ff _ self readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName).
	((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	ff fileIn! !

!FileStream class methodsFor: 'file reader services' stamp: 'sw 2/17/2002 00:03'!
fileReaderServicesForFile: fullName suffix: suffix
	"Answer services for the given file"

	^ (self isSourceFileSuffix: suffix)
		ifTrue:
			[{self serviceRemoveLineFeeds.
			self serviceFileIn}]
		ifFalse:
			[#()]! !

!FileStream class methodsFor: 'file reader services' stamp: 'nk 7/16/2003 15:49' prior: 36431723!
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: 'hg 8/3/2000 18:13'!
isSourceFileSuffix: suffix

	^(suffix = 'st') | (suffix = 'cs') | (suffix = '*')
! !

!FileStream class methodsFor: 'file reader services' stamp: 'LEG 10/24/2001 23:35'!
removeLineFeeds: fullName
	| fileContents |
	fileContents _ (CrLfFileStream readOnlyFileNamed: fullName) contentsOfEntireFile.
	(StandardFileStream 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: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!FileUrl methodsFor: 'printing' stamp: 'nk 2/2/2001 16:26'!
toText
	| s |
	s _ WriteStream on: String new.
	s nextPutAll: self schemeName.
	s nextPut: $:.
	s nextPutAll: self pathString.
	fragment ifNotNil: [ s nextPut: $#.  s nextPutAll: fragment encodeForHTTP ].
	^s contents! !

!FileUrl methodsFor: 'printing' stamp: 'gk 2/10/2004 10:49' prior: 36433858!
toText
	"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."

	^String streamContents: [:s |
		s nextPutAll: self schemeName, '://'.
		host ifNotNil: [s nextPutAll: host].
		s nextPut: $/; nextPutAll: self pathString.
		fragment ifNotNil: [ s 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: 'paths' stamp: 'nk 2/2/2001 16:38'!
pathDirString
	"Path to directory as url, using slash as delimiter"

	^ 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 2/10/2004 00:19' prior: 36435202!
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: 'nk 2/2/2001 17:50'!
pathForDirectory
	"Path using local file system's delimiter.  $\ or $:"

	^ String streamContents: [ :s |
		isAbsolute ifTrue: [ s nextPut: $/ ].
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: FileDirectory default pathNameDelimiter
			 ] ]! !

!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19' prior: 36435824!
pathForDirectory
	"Path using local file system's delimiter.  $\ or $:
	DOS paths with drive letters should not
	be prepended with a pathNameDelimiter even though
	they are absolute. Filename is left out."

	^String streamContents: [ :s |
		(self isAbsolute and: [self firstPartIsDriveLetter not])
			ifTrue: [ s nextPut: $/ ].
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: FileDirectory default pathNameDelimiter]]! !

!FileUrl methodsFor: 'paths' stamp: 'mga 8/6/2003 11:30' prior: 21255934!
pathForFile
	"Path using local file system's delimiter.  $\ or $:"
	| first |
	^String streamContents: [ :s |
		first _ self isAbsolute.
		self path do: [ :p |
			first ifTrue: [ s nextPut: FileDirectory default pathNameDelimiter ].
			first _ true.
			s nextPutAll: p ] ]! !

!FileUrl methodsFor: 'paths' stamp: 'gk 2/9/2004 20:24' prior: 36436704!
pathForFile
	"Path using local file system's delimiter.  $\ or $:
	DOS paths with drive letters should not
	be prepended with a pathNameDelimiter even though
	they are absolute."
	
	| first |
	^String streamContents: [ :s |
		first _ self isAbsolute and: [self firstPartIsDriveLetter not].
		self path do: [ :p |
			first ifTrue: [ s nextPut: FileDirectory default pathNameDelimiter ].
			first _ true.
			s nextPutAll: p ] ]! !

!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 10:22' prior: 21256260!
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: '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 2/10/2004 10:50'!
isAbsolute: aBoolean

	isAbsolute _ aBoolean! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15' prior: 21255158!
path
	"Return an ordered collection of the path elements."
	
	^path! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:16' prior: 21255286!
path: anArray
	"Set the collection of path elements."
	
	path _ anArray! !

!FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 13:06' prior: 21256605!
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: 'ar 5/30/2001 20:59'!
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:[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: 'downloading' stamp: 'gk 2/10/2004 00:50' prior: 36439011!
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:[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: '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' prior: 21253428!
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' prior: 21253952!
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 methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:45'!
scheme
	^ self schemeName.! !

!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34' prior: 36444501!
scheme
	^self class schemeName! !

!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34' prior: 21258169!
schemeName
	^self class schemeName! !

!FileUrl methodsFor: 'copying' stamp: 'gk 2/10/2004 09:52' prior: 21258253!
copy
	"Be sure not to share the path with the copy"

	^(self clone) path: path copy! !

!FileUrl commentStamp: 'gk 2/10/2004 10:56' 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 when sent #toText with a trailing slash.

- The FileUrl has an attribute isAbsolute which refers to 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 class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 12:16' prior: 21258511!
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! !

!FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'!
schemeName
	^'file'! !

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

!FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'th 9/17/2002 16:46' prior: 21266626!
controlInitialize

	model acceptOnCR ifFalse: [^ super controlInitialize].
	self setMark: self markBlock stringIndex.
	self setPoint: self pointBlock stringIndex.
	self initializeSelection.
	beginTypeInBlock _ nil.
! !

!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'sd 5/11/2003 17:07' prior: 21274020!
mouseDown: evt
	(self containsPoint: evt position) ifFalse:[^ self beep]. "sent in response to outside modal click"
	evt hand grabMorph: self. "allow repositioning"! !

!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'md 10/22/2003 16:20' prior: 36449351!
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: 'sd 11/8/2003 15:56'!
extent: aPoint 
	"change the receiver's extent"

	super extent: aPoint .
	self updateColor! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'nk 7/12/2003 10:07'!
createAcceptButton
	"create the [accept] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightGreen.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Accept(s)';
		 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 ] on: MessageNotUnderstood do: [ :ex | ].
	^ result! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'nk 6/25/2003 09:05' prior: 36450034!
createAcceptButton
	"create the [accept] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightGreen.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Accept(s)';
		 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: 'sd 11/13/2003 21:07' prior: 36450770!
createAcceptButton
	"create the [accept] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightGreen.
	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: 'nk 7/12/2003 10:08'!
createCancelButton
	"create the [cancel] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightRed.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Cancel(l)';
		 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 ] on: MessageNotUnderstood do: [ :ex | ].
	^ result! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'nk 6/25/2003 09:05' prior: 36452152!
createCancelButton
	"create the [cancel] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightRed.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Cancel(l)';
		 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: 'sd 11/13/2003 21:07' prior: 36452883!
createCancelButton
	"create the [cancel] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: Color lightRed.
	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: 'dgd 4/28/2003 21:07'!
createQueryTextMorph: queryString 
	"create the queryTextMorph"
	| result frame |
	result := TextMorph new contents: queryString.
	result setNameTo: 'query'.
	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: 'dgd 2/14/2003 20:58' prior: 21268739!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	Preferences roundedWindowCorners
		ifTrue: [self useRoundedCorners].
	
	self extent: 200 @ 70.
	responseUponCancel _ ''! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57' prior: 36455762!
initialize

	super initialize.
	self setDefaultParameters.
	self extent: 400 @ 150.
	responseUponCancel := ''.
	Preferences roundedMenuCorners
		ifTrue: [self useRoundedCorners].
	! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57'!
setDefaultParameters
	"change the receiver's appareance parameters"
	| 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.
	self layoutInset: 3! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'NS 7/9/2001 11:16'!
setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean
	| query frame topOffset accept cancel buttonAreaHeight |
	response _ initialAnswer.
	done _ false.
	self removeAllMorphs.

	self layoutPolicy: ProportionalLayout new.

	query _ TextMorph new contents: queryString.
	query setNameTo: 'query'.
	query lock.
		frame _ LayoutFrame new.
		frame topFraction: 0.0; topOffset: 2.
		frame leftFraction: 0.5; leftOffset: (query width // 2) negated.
	query layoutFrame: frame.
	self addMorph: query.
	topOffset _ query height + 4.

	accept _ SimpleButtonMorph new target: self; color: Color veryLightGray.
	accept label: 'Accept(s)'; actionSelector: #accept.
	accept setNameTo: 'accept'.
		frame _ LayoutFrame new.
		frame rightFraction: 0.5; rightOffset: -10; bottomFraction: 1.0; bottomOffset: -2.
	accept layoutFrame: frame.
	self addMorph: accept.

	cancel _ SimpleButtonMorph new target: self; color: Color veryLightGray.
	cancel label: 'Cancel(l)'; actionSelector: #cancel.
	cancel setNameTo: 'cancel'.
		frame _ LayoutFrame new.
		frame leftFraction: 0.5; leftOffset: 10; bottomFraction: 1.0; bottomOffset: -2.
	cancel layoutFrame: frame.
	self addMorph: cancel.
	buttonAreaHeight _ (accept height max: cancel height) + 4.

	textPane _ PluggableTextMorph on: self
		text: #response
		accept: #response:
		readSelection: #selectionInterval
		menu: #codePaneMenu:shifted:.
	textPane extent: answerExtent. 
	textPane hResizing: #spaceFill; vResizing: #spaceFill.
	textPane borderWidth: 2.
	textPane hasUnacceptedEdits: true.
	textPane acceptOnCR: acceptBoolean.
	textPane setNameTo: 'textPane'.
		frame _ LayoutFrame new.
		frame leftFraction: 0.0; rightFraction: 1.0; topFraction: 0.0; topOffset: topOffset; bottomFraction: 1.0; bottomOffset: buttonAreaHeight negated.
	textPane layoutFrame: frame.
	self addMorph: textPane.

	self extent: (query extent x max: answerExtent x) + 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight).
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'nk 7/12/2003 10:06' prior: 36457193!
setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean
	| query frame topOffset accept cancel buttonAreaHeight |
	response _ initialAnswer.
	done _ false.
	self removeAllMorphs.

	self layoutPolicy: ProportionalLayout new.

	query _ TextMorph new contents: queryString.
	query setNameTo: 'query'.
	query lock.
		frame _ LayoutFrame new.
		frame topFraction: 0.0; topOffset: 2.
		frame leftFraction: 0.5; leftOffset: (query width // 2) negated.
	query layoutFrame: frame.
	self addMorph: query.
	topOffset _ query height + 4.

	accept _ self createAcceptButton.
	self addMorph: accept.

	cancel _ self createCancelButton.
	self addMorph: cancel.
	buttonAreaHeight _ (accept height max: cancel height) + 4.

	textPane _ PluggableTextMorph on: self
		text: #response
		accept: #response:
		readSelection: #selectionInterval
		menu: #codePaneMenu:shifted:.
	textPane extent: answerExtent. 
	textPane hResizing: #spaceFill; vResizing: #spaceFill.
	textPane borderWidth: 2.
	textPane hasUnacceptedEdits: true.
	textPane acceptOnCR: acceptBoolean.
	textPane setNameTo: 'textPane'.
		frame _ LayoutFrame new.
		frame leftFraction: 0.0; rightFraction: 1.0; topFraction: 0.0; topOffset: topOffset; bottomFraction: 1.0; bottomOffset: buttonAreaHeight negated.
	textPane layoutFrame: frame.
	self addMorph: textPane.

	self extent: (query extent x max: answerExtent x) + 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight).
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58' prior: 36459277!
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: 'sd 11/8/2003 15:58'!
updateColor: aMorph color: aColor intensity: anInteger 
	"update the apareance of aMorph"
	| fill fromColor toColor |
	Preferences gradientMenu
		ifFalse: [^ self].
	fromColor := aColor.
	toColor := aColor.
	anInteger
		timesRepeat: [
			fromColor := fromColor lighter.
			toColor := toColor darker].
	fill := GradientFillStyle ramp: {0.0 -> fromColor. 1 -> toColor}.
	fill origin: aMorph topLeft.
	fill direction: aMorph width @ 0.
	fill radial: true.
	aMorph fillStyle: fill! !

!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'ar 3/17/2001 23:40'!
getUserResponse
	"Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."

	| w |
	w _ self world.
	w ifNil: [^ response].
	done _ false.
	[done] whileFalse: [World doOneCycle].
	self delete.
	World doOneCycle.
	^ response
! !

!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'nk 6/28/2003 15:24' prior: 36462978!
getUserResponse
	"Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."

	| w |
	w _ self world.
	w ifNil: [^ response].
	done _ false.
	w activeHand newKeyboardFocus: textPane.
	[done] whileFalse: [w doOneCycle].
	self delete.
	w doOneCycle.
	^ response
! !

!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'yo 8/18/2003 18:31' prior: 36463571!
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 isOctetString ifTrue: [^ response asOctetString] ifFalse: [^ response]].
	done _ false.
	w activeHand newKeyboardFocus: textPane.
	[done] whileFalse: [w doOneCycle].
	self delete.
	w doOneCycle.
	^ response isOctetString ifTrue: [response asOctetString] ifFalse: [response].
! !

!FillInTheBlankMorph class methodsFor: 'default constants' stamp: 'NS 7/9/2001 11:19'!
defaultAnswerExtent
	^ 200@60.! !

!FillInTheBlankMorph class methodsFor: 'default constants' stamp: 'dgd 4/27/2003 17:10' prior: 36464960!
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: '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! !

!FillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:41'!
mixed: fraction with: aColor
	^self asColor mixed: fraction with: aColor! !

!FillStyle commentStamp: '<historical>' prior: 0!
FillStyle is an abstract base class for fills in the BalloonEngine.!
!FishEyeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:39' prior: 21287803!
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' prior: 21288000!
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' prior: 21288643!
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: '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: 'menus' stamp: 'dgd 9/21/2003 17:55' prior: 21289091!
chooseMagnification
	self inform: 'Magnification is fixed, sorry.' translated! !

!FishEyeMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:47'!
descriptionForPartsBin
	^ self partName:	'FishEye'
		categories:		#('Useful')
		documentation:	'An extreme-wide-angle lens'! !

!FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:43'!
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'].
	
	^ self provideDefaultFlapIDBasedOn: wording! !

!FlapTab methodsFor: 'access' stamp: 'dgd 8/31/2003 18:58' prior: 36471390!
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: 'accessing' stamp: 'tk 9/25/2002 18:08'!
labelString
	^labelString! !

!FlapTab methodsFor: '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 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: 'dgd 8/30/2003 21:24' prior: 21293113!
edgeString
	^ 'cling to edge... (current: {1})' translated format: edgeToAdhereTo! !

!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: 'di 11/20/2001 07:44'!
setEdge: anEdge
	"Set the edge as indicated, if possible"

	| newOrientation |
	self edgeToAdhereTo = anEdge ifTrue: [^ self].
	newOrientation _ nil.
	self orientation == #vertical
		ifTrue: [(#(top bottom) includes: anEdge) ifTrue:
					[newOrientation _ #horizontal]]
		ifFalse: [(#(top bottom) includes: anEdge) ifFalse:
					[newOrientation _ #vertical]].
	self edgeToAdhereTo: anEdge.
	newOrientation ifNotNil: [self transposeParts].
	referent isInWorld ifTrue: [self positionReferent].
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'edge' stamp: 'dgd 10/17/2003 22:36' prior: 21294432!
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: 'sw 5/4/2001 23:26'!
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'! !

!FlapTab methodsFor: 'globalness' stamp: 'dgd 8/30/2003 21:36' prior: 36478812!
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: 'dgd 8/30/2003 21:29' prior: 21313496!
graphicalTabString
	^ (self isCurrentlyGraphical
		ifTrue: ['choose new graphic...']
		ifFalse: ['use graphical tab']) translated! !

!FlapTab methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49' prior: 21290586!
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: 'menu' stamp: 'sw 11/27/2001 10:52'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add further items to the menu as appropriate"

	aMenu add: 'tab color...' target: self action: #changeColor.
	aMenu add: 'flap color...' 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.,'.

	aMenu addLine.
	aMenu add: 'destroy this flap' action: #destroyFlap.

	"aMenu addUpdating: #slideString action: #toggleSlideBehavior.
	aMenu addUpdating: #inboardString action: #toggleInboardness.
	aMenu addUpdating: #thicknessString ('thickness... (current: ', self thickness printString, ')') action: #setThickness."

! !

!FlapTab methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:21' prior: 36481293!
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: 'dgd 9/21/2003 17:55' prior: 21296711!
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' prior: 21297004!
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: 'sw 4/17/2001 12:13'!
changeTabText
	"Allow the user to change the text on the tab"

	| reply |
	reply _ FillInTheBlank
		request: 'new wording for this tab:'
		initialAnswer: self existingWording.
	reply isEmptyOrNil ifTrue: [^ self].
	self useStringTab: reply.
	submorphs first delete.
	self
		assumeString: reply
		font: Preferences standardFlapFont
		orientation: (Flaps orientationForEdge: edgeToAdhereTo)
		color: nil! !

!FlapTab methodsFor: 'menu' stamp: 'sw 4/30/2001 18:49'!
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 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: 'dgd 9/5/2003 18:25' prior: 36485247!
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: 'gm 2/22/2003 13:11' prior: 21311600!
isCurrentlyTextual
	| first |
	^submorphs notEmpty and: 
			[((first := submorphs first) isKindOf: StringMorph) 
				or: [first isTextMorph]]! !

!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: '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: '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: 'sw 2/7/2002 17:24'!
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) ifTrue: [^ pair second]].

	^ self balloonText! !

!FlapTab methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 18:43' prior: 36487831!
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 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' prior: 21299405!
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' prior: 21299678!
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: '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: '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' prior: 21292737!
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: '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: '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 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: '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: 'sw 11/20/2001 13:49'!
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 bringFlapTabsToFront! !

!FlapTab methodsFor: 'solid tabs' stamp: 'dgd 2/21/2003 22:39' prior: 21314635!
changeTabThickness
	| newThickness |
	newThickness := FillInTheBlank request: 'New thickness:'
				initialAnswer: self tabThickness printString.
	newThickness notEmpty ifTrue: [self applyTabThickness: newThickness]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'dgd 8/30/2003 21:31' prior: 21315488!
solidTabString
	^ (self isCurrentlySolid
		ifTrue: ['currently using solid tab']
		ifFalse: ['use solid tab']) translated! !

!FlapTab methodsFor: 'submorphs-add/remove' stamp: 'sw 11/27/2001 12:13'!
dismissViaHalo
	"Dismiss the receiver (and its referent), unless it resists"

	self resistsRemoval ifTrue:
		[(PopUpMenu confirm: 'Really throw this flap away' trueChoice: 'Yes' falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]].

	referent delete.
	self delete! !

!FlapTab methodsFor: 'textual tabs' stamp: 'di 11/19/2001 22:47'!
assumeString: aString font: aFont orientation: orientationSymbol color: aColor
	| aTextMorph workString tabStyle |
	labelString _ aString asString.
	(orientationSymbol == #vertical)
		ifTrue: [workString _ String streamContents:
					[:s | labelString do: [:c | s nextPut: c]
							separatedBy: [s nextPut: Character cr]]]
		ifFalse: [workString _ labelString].

	tabStyle _ TextStyle new leading: -4; 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: 'aoy 2/15/2003 21:18' prior: 36497097!
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: -4;
				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: 'yo 7/16/2003 15:25' prior: 36497967!
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: 'dgd 8/30/2003 21:27' prior: 21312310!
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 2/21/2003 22:40' prior: 21312842!
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'].
	self 
		assumeString: stringToUse
		font: Preferences standardFlapFont
		orientation: self orientation
		color: colorToUse! !

!FlapTab methodsFor: 'textual tabs' stamp: 'dgd 10/8/2003 19:03' prior: 36500326!
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 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]]]! !

!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 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: '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: 'di 11/19/2001 23:38'!
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' 'Stack Tools' 'Squeak' 'Menu' 'Widgets' 'Tools' 'Supplies' 'Scripting' 'Objects' 'Navigator') 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: 'dgd 10/7/2003 22:47' prior: 36504431!
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: 'asm 3/13/2003 11:22'!
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				authoringPrototype		'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: 'asm 3/13/2003 11:21'!
defaultsQuadsDefiningToolsFlap
	"Answer a structure defining the default Tools flap.
	previously in quadsDefiningToolsFlap"

	^ #(
	(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.')
	(FileList					prototypicalToolWindow		'File List'			'A File List is a tool for browsing folders and files on disks and on ftp types.')
	(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')

) asOrderedCollection! !

!Flaps class methodsFor: 'flaps registry' stamp: 'nk 6/14/2004 08:39' prior: 36512234!
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: { Preferences useFileList2 ifTrue: [ #FileList2 ] ifFalse: [ #FileList ].
				#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 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: '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: 'asm 3/13/2003 11:02'!
registeredFlapsQuadsAt: aLabel
	"Answer the list of dynamic flaps quads at aLabel"

	^ (self registeredFlapsQuads at: aLabel)
		removeAllSuchThat: [:q | (self environment at: q first) isNil]
! !

!Flaps class methodsFor: 'flaps registry' stamp: 'mu 5/24/2004 20:30' prior: 36519737!
registeredFlapsQuadsAt: aLabel
	"Answer the list of dynamic flaps quads at aLabel"

	^ (self registeredFlapsQuads at: aLabel)
		removeAllSuchThat: [:q | (self environment includesKey: q first) not]
! !

!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: 'flaps registry' stamp: 'asm 4/12/2003 14:36'!
unregisterQuadsWithReceiver: aReceiver 
	"delete all quads with receiver aReceiver."
	self registeredFlapsQuads
		do: [:assoc | assoc value
				removeAllSuchThat: [:q | (self environment at: (q first)) = 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: '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: '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: 'di 11/19/2001 23:08'!
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?') ifFalse: [^ self]].

	self globalFlapTabsIfAny do:
		[:aFlapTab | self removeFlapTab: aFlapTab keepInList: false.
		aFlapTab isInWorld ifTrue: [self error: 'Flap problem']].
	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: 'dgd 8/31/2003 19:01' prior: 36522007!
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 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 4/25/2001 01:46'!
explainFlaps

"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."
	
  
	"Open a window giving flap help."

	(StringHolder new contents: (self class firstCommentAt: #explainFlaps))
		openLabel: 'Flaps'

"Flaps explainFlaps"




	! !

!Flaps class methodsFor: 'menu commands' stamp: 'dgd 8/31/2003 19:02' prior: 36525462!
explainFlaps

"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."
	
  
	"Open a window giving flap help."

	(StringHolder new contents: (self class firstCommentAt: #explainFlaps) translated)
		openLabel: 'Flaps' translated

"Flaps explainFlaps"




	! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:49' prior: 36530777!
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: 'sw 6/14/2001 01:22'!
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'.
	supplies setToPopOutOnMouseOver: false.

	Smalltalk isMorphic ifTrue:
		[ActiveWorld addGlobalFlaps.
		ActiveWorld reformulateUpdatingMenus]! !

!Flaps class methodsFor: 'menu support' stamp: 'dgd 8/31/2003 19:39' prior: 36543457!
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: 'sw 5/4/2001 23:14'!
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."

	^ CurrentProjectRefactoring showSharedFlaps! !

!Flaps class methodsFor: 'menu support' stamp: 'sw 5/5/2001 03:01'!
suppressFlapsString
	"Answer the string to be shown in a menu to represent the suppress-flaps-in-this-project status"

	^ CurrentProjectRefactoring 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: 'sw 11/22/2001 10:17'!
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'.
			Preferences enable: #showProjectNavigator.
			self disableGlobalFlapWithID: 'Navigator'.]
		ifFalse:
			[self enableGlobalFlapWithID: 'Navigator'.
			ActiveWorld addGlobalFlaps].

	self doAutomaticLayoutOfFlapsIfAppropriate.
	Project current assureNavigatorPresenceMatchesPreference.
	ActiveWorld reformulateUpdatingMenus! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:26' prior: 36546162!
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: 'sw 6/11/2001 21:31'!
fileOutChanges
	"Bug workaround for squeak-flap 'fileOutChanges' buttons which for a while were mistakenly sending their requests here..."

	^ Utilities fileOutChanges! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sd 1/16/2004 21:33' prior: 36547566!
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: 'sw 11/22/2001 10:04'!
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') ifNil:
		[SharedFlapTabs add: self newNavigatorFlap delete].
	self enableGlobalFlapWithID: 'Navigator'.
	Preferences setPreference: #navigatorOnLeftEdge toValue: true.
	(self globalFlapTabWithID: 'Navigator') arrangeToPopOutOnMouseOver: true.
	ActiveWorld addGlobalFlaps.
	self doAutomaticLayoutOfFlapsIfAppropriate.
	Project current assureNavigatorPresenceMatchesPreference.
	! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:28' prior: 36548077!
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: 'sw 10/31/2001 16:44'!
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?'.
	aMenu defaultTarget: aMenu.
	#(left right top bottom) do:
		[:sym | aMenu add: sym selector: #selectMVCItem: argument: sym].
	edge _ aMenu invokeAt: self currentHand position in: self currentWorld.

	edge ifNotNil:
		[reply _ FillInTheBlank request: 'Wording for this flap: ' initialAnswer: 'Flap'.
		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: 'dgd 8/31/2003 18:58' prior: 36551030!
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: 'sw 7/19/2002 11:19'!
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'.  "Per request from Kim Rose, 7/19/02"
	SharedFlapTabs add: aSuppliesFlap.  "The #center designation doesn't quite work at the moment"
	SharedFlapTabs add: self newNavigatorFlap.

	self enableGlobalFlapWithID: 'Supplies'.
	self enableGlobalFlapWithID: 'Navigator'.

	SharedFlapsAllowed _ true.
	Project current flapsSuppressed: false.
	^ SharedFlapTabs

"Flaps addAndEnableEToyFlaps"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 18:59' prior: 36555004!
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"
	SharedFlapTabs add: self newNavigatorFlap.

	self enableGlobalFlapWithID: 'Supplies' translated.
	self enableGlobalFlapWithID: 'Navigator' translated.

	SharedFlapsAllowed _ true.
	Project current flapsSuppressed: false.
	^ SharedFlapTabs

"Flaps addAndEnableEToyFlaps"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'di 11/21/2001 16:33'!
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') ifNil:
			[SharedFlapTabs add: self newStackToolsFlap delete].
		self enableGlobalFlapWithID: 'Stack Tools'.
		(self globalFlapTabWithID: 'Navigator') ifNil:
			[SharedFlapTabs add: self newNavigatorFlap delete].
		self enableGlobalFlapWithID: 'Navigator'.
		self currentWorld addGlobalFlaps]! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 18:44' prior: 36556909!
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: 'sw 2/7/2002 16:26'!
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.
	SharedFlapTabs add: self newNavigatorFlap.
	SharedFlapTabs add: self newPaintingFlap.

	self disableGlobalFlapWithID: 'Stack Tools'.
	self disableGlobalFlapWithID: 'Painting'.
	self disableGlobalFlapWithID: 'Navigator'.

	^ SharedFlapTabs! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 10/7/2003 22:47' prior: 36558329!
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.
	SharedFlapTabs add: self newNavigatorFlap.
	SharedFlapTabs add: self newPaintingFlap.
	self disableGlobalFlapWithID: 'Stack Tools' translated.
	self disableGlobalFlapWithID: 'Painting' translated.
	self disableGlobalFlapWithID: 'Navigator' translated.
	^ SharedFlapTabs! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 11:22'!
defaultsQuadsDefiningPlugInSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image.
	previously in quadsDefiningPlugInSuppliesFlap"

	^  #(
	(ObjectsTool				newStandAlone				'Object Catalog'		'A tool that lets you browse the catalog of available objects')
	(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you see and control all the running scripts in your project')
	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')
	(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')
	(TextMorph				authoringPrototype			'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 3/3/2004 14:29' prior: 36559983!
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')
	(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				authoringPrototype			'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: 'di 11/19/2001 21:09'!
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 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' 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 color: Color red muchLighter.
	aStrip autoLineLayout: true.
	
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:38' prior: 36565135!
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 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 color: Color red muchLighter.
	aStrip autoLineLayout: true.
	
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 7/19/2002 11:00'!
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'.
	navBar fullBounds.  "to establish width"
	
	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab setName: 'Navigator' 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' "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:03' prior: 36570935!
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: 'di 11/19/2001 21:22'!
newObjectsFlap
	"Answer a fully-instantiated flap named 'Objects' to be placed at the top of the screen.  Not currently called; this worked once, but probably not at the moment."

	|  aFlapTab anObjectsTool |
	anObjectsTool _ ObjectsTool new.
	anObjectsTool initializeForFlap.
	anObjectsTool showCategories.

	aFlapTab _ FlapTab new referent: anObjectsTool beSticky.
	aFlapTab setName: 'Objects' 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.
	
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:56' prior: 36572948!
newObjectsFlap
	"Answer a fully-instantiated flap named 'Objects' to be placed at the top of the screen.  Not currently called; this worked once, but probably not at the moment."

	|  aFlapTab anObjectsTool |
	anObjectsTool _ ObjectsTool new.
	anObjectsTool initializeForFlap.
	anObjectsTool showCategories.

	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.
	
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 4/30/2001 19:02'!
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'.
	aFlapTab setProperty: #priorWording toValue: 'Paint'.
	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.'.

	aFlapTab fullBounds. "force layout"
	aFlapTab position: (0@6).
	self currentWorld addMorphFront: aFlapTab.  
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:50' prior: 36574608!
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: 'sw 4/21/2002 07:13'!
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' 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.'.
	aFlap addCenteredAtBottom: aClock offset: anOffset.

	buttonColor _  Color cyan muchLighter.
	bb _ SimpleButtonMorph new target: Smalltalk.
	bb color: buttonColor.
	aButton _ bb copy.
	aButton actionSelector: #saveSession.
	aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.'.
	aButton label: 'save' font: (aFont _ ScriptingSystem fontForTiles).
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ bb copy target: Utilities.
	aButton actionSelector: #updateFromServer.
	aButton label: 'load code updates' font: aFont.
	aButton color: buttonColor.
	aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ SimpleButtonMorph new target: Smalltalk; actionSelector: #aboutThisSystem;
		label: 'about this system' font: aFont.
	aButton color: buttonColor.
	aButton setBalloonText: 'click here to find out version information'.
	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' "! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 9/1/2003 11:42' prior: 36577382!
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: Smalltalk.
	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: Smalltalk; 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: 'sd 11/16/2003 14:13' prior: 36579876!
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: Smalltalk; 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: 'di 11/19/2001 22:26'!
newStackToolsFlap
	"Add a flap with stack tools in it"

	| aFlapTab aStrip |
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight from:	 self quadsDefiningStackToolsFlap.

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Stack Tools' 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 color: (Color red muchLighter "alpha: 0.2").
	aStrip extent: self currentWorld width @ 70.

	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Stack Tools' "! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:40' prior: 36585061!
newStackToolsFlap
	"Add a flap with stack tools in it"

	| aFlapTab aStrip |
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight 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 color: (Color red muchLighter "alpha: 0.2").
	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: 'sw 6/11/2002 14:00'!
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 from:	 quads.

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Supplies' 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 @ 78.
	aStrip beFlap: true.
	aStrip color: Color red muchLighter.
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Supplies' "! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:39' prior: 36587051!
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 from:	 quads.

	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 @ 78.
	aStrip beFlap: true.
	aStrip color: Color red muchLighter.
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Supplies' translated"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 3/3/2004 13:00' prior: 36588157!
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 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 @ 78.
	aStrip beFlap: true.
	aStrip color: Color red muchLighter.
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Supplies' translated"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'di 11/19/2001 22:26'!
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 from: self quadsDefiningToolsFlap.
 
	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Tools' 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.
	aStrip color: (Color orange muchLighter alpha: 0.8).
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Tools' "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:41' prior: 36590455!
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 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.
	aStrip color: (Color orange muchLighter alpha: 0.8).
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Tools' translated "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'di 11/19/2001 22:26'!
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 from:	 self quadsDefiningWidgetsFlap.

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Widgets' 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 color: (Color blue muchLighter alpha: 0.8).
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Widgets' "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:43' prior: 36592105!
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 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 color: (Color blue muchLighter alpha: 0.8).
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Widgets' translated "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 6/14/2002 13:48'!
quadsDefiningPlugInSuppliesFlap
	"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' 		'A tool that lets you see and control all the running scripts in your project')
	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')
	(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')
	(TextMorph				authoringPrototype			'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'))! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:52' prior: 36593848!
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: 'sw 3/3/2004 13:38' prior: 36596069!
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: 'sw 4/8/2002 00:53'!
quadsDefiningStackToolsFlap
	"Answer a structure defining the items on the default system Stack Tools flap"

	^ #(
	(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'))

	"Flaps replaceGlobalFlapwithID: 'Stack Tools'"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:25' prior: 36596639!
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: 'sw 8/12/2001 16:57'!
quadsDefiningSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap"

	^  #(
	(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.')
	(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')
		).! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26' prior: 36598007!
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: 'sw 1/29/2002 16:52'!
quadsDefiningToolsFlap
	"Answer a structure defining the default Tools flap"

	^ #(
	(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.')
	(FileList					prototypicalToolWindow		'File List'			'A File List is a tool for browsing folders and files on disks and on ftp types.')
	(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')

)! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:51' prior: 36599975!
quadsDefiningToolsFlap
	"Answer a structure defining the default Tools flap"

	^ self registeredFlapsQuadsAt: 'Tools'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 6/11/2002 14:33'!
quadsDefiningWidgetsFlap
	"Answer a structure defining the default Widgets flap"

	^ #(
	(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')
	)! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26' prior: 36602415!
quadsDefiningWidgetsFlap
	"Answer a structure defining the default Widgets flap"

	^ self registeredFlapsQuadsAt: 'Widgets'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 7/12/2001 18:11'!
quadsDeiningScriptingFlap
	"Answer a structure defining the default items in the Scripting flap"

	^ #(
	(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')

		) ! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26' prior: 36603958!
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 4/8/2002 08:35'!
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' ifTrue: [replacement _ self newStackToolsFlap].
	flapID = 'Supplies' ifTrue: [replacement _ self newSuppliesFlap].
	flapID = 'Tools' ifTrue: [replacement _ self newToolsFlap].
	flapID = 'Widgets' ifTrue: [replacement _ self newWidgetsFlap].
	flapID = 'Navigator' ifTrue: [replacement _ self newNavigatorFlap].
	flapID = 'Squeak' ifTrue: [replacement _ self newSqueakFlap].
	replacement ifNil: [^ self].
	self addGlobalFlap: replacement.
	self currentWorld ifNotNil: [self currentWorld addGlobalFlaps]

"Flaps replaceFlapwithID: 'Widgets' "! !

!Flaps class methodsFor: 'replacement' stamp: 'dgd 10/7/2003 22:47' prior: 36606640!
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 newSuppliesFlap].
	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: 'di 11/19/2001 22:20'!
replaceToolsFlap
	"if there is a global tools flap, replace it with an updated one."

	self replaceGlobalFlapwithID: 'Tools' 

"Flaps replaceToolsFlap"! !

!Flaps class methodsFor: 'replacement' stamp: 'dgd 8/31/2003 19:41' prior: 36610172!
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: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: '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: '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 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: 'sw 11/22/2001 07:14'!
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)] ifFalse: [#()].

	Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapsWithIDs: ids

"Flaps positionNavigatorAndOtherFlapsAccordingToPreference"! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:27' prior: 36613578!
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: 'sw 11/22/2001 06:53'!
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 Supplies)
	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' ifTrue:
			[ft referent left: (ft center x - (ft referent width//2) max: 0)]]
! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:29' prior: 36614584!
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: 'di 11/22/2001 12:17'!
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' 'Navigator' 'Supplies' 'Widgets' 'Stack Tools' 'Tools' 'Painting') do:
			[:id | (self globalFlapTabWithID: id) ifNotNilDo:
				[:ft | unordered remove: ft.
				id = 'Painting' 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') ifNotNilDo:
		[:ft | ft referent left: (ft center x - (ft referent width//2) max: 0)].
	self positionNavigatorAndOtherFlapsAccordingToPreference.
! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 10/7/2003 22:47' prior: 36617994!
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.
! !

!Flaps class methodsFor: 'class initialization' stamp: 'nk 6/14/2004 08:37'!
initialize
	self initializeFlapsQuads! !

!FlapsTest methodsFor: 'initialize-release' stamp: 'cE 10/10/2003 19:08'!
setUp
	"I am the method in which your test is initialized. 
If you have ressources to build, put them here."! !

!FlapsTest methodsFor: 'initialize-release' stamp: 'cE 10/10/2003 19:08'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !

!FlapsTest methodsFor: 'testing' stamp: 'cE 10/12/2003 19:54'!
testRegisteredFlapsQuads
	"Defaults are defined in Flaps class>>defaultQuadsDefining...
	If you change something there, do the following afterwards:
	Flaps initializeFlapsQuads"

	| allQuads absentClasses absentSelectors |
	allQuads _ OrderedCollection new.
	absentClasses _ OrderedCollection new.
	Flaps registeredFlapsQuads valuesDo: [:each | allQuads addAll: each].
	allQuads do: [:each | | theObject |
		theObject _ each at: 1.
		Smalltalk
			at: theObject
			ifAbsent: [absentClasses add: each]].
	self
		assert: absentClasses isEmpty
		description: 'There are absent classes: ' , absentClasses asString.
	absentSelectors _ OrderedCollection new.
	allQuads do: [:each | | theClass theSelector |
		theClass _ (Smalltalk at: (each at: 1)) class.
		theSelector _ each at: 2.
		(theClass canUnderstand: theSelector)
			ifFalse: [absentSelectors add: each]].
	self
		assert: absentSelectors isEmpty
		description: 'There are absent selectors: ' , absentSelectors asString! !

!FlapsTest 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.!
!FlashButtonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41' prior: 21329582!
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.
! !

!FlashCharacterMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41' prior: 21339677!
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.! !

!FlashFileReader methodsFor: 'reading' stamp: 'sd 1/30/2004 15:17' prior: 21357543!
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: 'ar 5/4/2001 16:25'!
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 (',version printString,') is higher than 
the currently supported version (', self maximumSupportedVersion printString,'). 
It may contain features that are not supported 
and it may not display correctly.
Do you want to continue?') 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: 'dgd 9/21/2003 17:38' prior: 36623882!
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: '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 tags' stamp: 'mir 6/11/2001 13:06'!
processDefineBitsJPEG2: data
	| id image decoder |
	id _ data nextWord.
	decoder _ FlashJPEGDecoder new.
	decoder isStreaming: self isStreaming.
	decoder decodeJPEGTables: data.
	data atEnd
		ifFalse: [
			image _ decoder decodeNextImageFrom: data.
			Preferences compressFlashImages ifTrue:[image _ image asFormOfDepth: 8].
			self recordBitmap: id data: image].
	^true! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 5/4/2001 16:22'!
maximumSupportedVersion
	^3! !

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

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

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

!FlashMorph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:58' prior: 21441166!
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 2/11/2002 12:08'!
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 == nil]) ifTrue:[
		Preferences extractFlashInHighQuality ifTrue:[dup defaultAALevel: 2].
		Preferences extractFlashInHighestQuality ifTrue:[dup defaultAALevel: 4].
	].
	^dup! !

!FlashMorph methodsFor: 'copying' stamp: 'dgd 2/22/2003 14:24' prior: 36630101!
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: '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' prior: 21439720!
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: 'menu' stamp: 'dgd 8/30/2003 21:42' prior: 21438442!
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' prior: 21438755!
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: 'gm 2/28/2003 00:16' prior: 21439331!
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)! !

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

!FlashMorphingMorph methodsFor: 'copying' stamp: 'dgd 2/21/2003 23:04' prior: 21471279!
updateReferencesUsing: aDictionary 
	| srcMorph dstMorph |
	super updateReferencesUsing: aDictionary.
	srcMorph := submorphs at: submorphs size - 1.
	dstMorph := submorphs last.
	self removeAllMorphs.
	self from: srcMorph to: dstMorph! !

!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: 'e-toy support' stamp: 'mir 6/13/2001 14:42'!
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.
	^(SketchMorph 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: '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' prior: 21474065!
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: '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: 'dgd 9/20/2003 16:42' prior: 21476447!
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' prior: 21476791!
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: 'menu' stamp: 'dgd 8/30/2003 21:42' prior: 21486732!
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: 'player' stamp: 'mir 6/13/2001 14:45'!
shouldRememberCostumes
	^false! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 3/17/2001 23:41'!
playProjectTransitionFrom: oldProject to: newProject entering: aBoolean
	"Play the transition from the old to the new project."

	Smalltalk isMorphic ifFalse: [^ self]. "Not in MVC"
	self stopPlaying.
	owner ifNotNil:[
		self stopStepping.
		owner privateRemoveMorph: self.
		owner _ nil].
	aBoolean ifTrue:[
		self updateProjectFillsFrom: newProject.
	] ifFalse:[
		self updateProjectFillsFrom: oldProject.
		self setProperty: #transitionBackground toValue: newProject imageForm.
	].
	self frameNumber: 1.
	self loopFrames: false.
	(self valueOfProperty: #fullScreenTransition ifAbsent:[false])
		ifTrue:[self bounds: self world bounds].
	self comeToFront.
	self startStepping.
	self startPlaying.
	[playing] whileTrue: [World doOneCycleNow].
	self stopPlaying.
	self stopStepping.
	owner privateRemoveMorph: self.
	owner _ nil.
	self removeProperty: #transitionBackground.
	Display deferUpdates: true.
	ActiveWorld fullDrawOn: (Display getCanvas).
	Display deferUpdates: false.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 8/10/2003 18:17' prior: 36643050!
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: '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: 'private' stamp: 'ar 6/12/2001 06:37'!
privateFullMoveBy: delta
	self handleBoundsChange:[super privateMoveBy: delta]! !

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


))

)
! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'dgd 5/1/2003 21:05' prior: 21494449!
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' prior: 21494774!
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: 'initialization' stamp: 'dgd 9/20/2003 16:43' prior: 21496110!
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! !

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

!FlashSpriteMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38' prior: 21510387!
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: '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].! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42' prior: 21524007!
player
	"answer the receiver's player"
	^ player! !

!FlashThumbnailMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:35'!
drawOn: aCanvas
	(player == nil or:[frameNumber == nil]) 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: 'drawing' stamp: 'dgd 2/22/2003 13:29' prior: 36650829!
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! !

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

!FlexMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:44' prior: 21528156!
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.
! !

!Float methodsFor: 'arithmetic' stamp: 'hh 10/3/2000 11:46' prior: 21537184!
/ 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' stamp: 'RAH 4/25/2000 19:49' prior: 21537765!
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: 'mathematical functions' stamp: 'AFi 11/23/2002 21:06' prior: 21542210!
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: 'RAH 4/25/2000 19:49' prior: 21544371!
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: '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: '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 class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	#Numeric.
	"add 200/01/19 For <number> protocol support."
	^ 1.0! !

!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: 'ar 9/7/2001 23:04'!
negated
	^self clone *= -1! !

!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: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'!
sum

	<primitive: 'primitiveSum' module: 'FloatArrayPlugin'>
	^ super sum! !

!FloatTest methodsFor: 'as yet unclassified' stamp: 'md 4/16/2003 15:02'!
testIsZero
	self assert: 0.0 isZero.
	self deny:  0.1 isZero.! !

!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 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.!
!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' prior: 21595181!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutInset: 0;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap ! !

!FontSet class methodsFor: 'compiling' stamp: 'jlb 10/6/2001 12:16'!
compileFont: strikeFont 
	| tempName literalString header |
	tempName _ 'FontTemp.sf2'.
	strikeFont writeAsStrike2named: tempName.
	literalString _ (FileStream readOnlyFileNamed: tempName) contentsOfEntireFile fullPrintString.
	header _ 'sizeNNN
	^ self fontNamed: ''NNN'' fromLiteral:
' copyReplaceAll: 'NNN' with: ( strikeFont name , (strikeFont pointSize asString )).
	self class
		compile: header , literalString
		classified: 'fonts'
		notifying: nil.
	FileDirectory default deleteFileNamed: tempName
! !

!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' stamp: 'ar 5/17/2001 15:45'!
depth
	^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! !

!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: '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' 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: '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' 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: '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/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/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/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' 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 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 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: '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: '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: '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' 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' 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: '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: '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: '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: 'ar 5/17/2001 15:38'!
readFrom: aBinaryStream
	"Reads the receiver from the given binary stream with the format:
		depth, extent, offset, bits."
	| 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].
	bits _ Bitmap newFromStream: aBinaryStream.
	bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?'].
	^ self
! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:44' prior: 36682774!
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' prior: 21671356!
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' 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: 'ar 6/16/2002 17:53'!
writeBMPfileNamed: fName  "Display writeBMPfileNamed: 'display.bmp'"
	BMPReadWriter putForm: self onFileNamed: fName! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:35'!
writeBitsOn: file
	bits writeOn: file! !

!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: 'mu 8/17/2003 00:36' prior: 21676956!
writeOn: file
	"Write the receiver on the file in the format
		depth, extent, offset, bits."
	self writeAttributesOn: file.
	self writeBitsOn: file! !

!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' 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' 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 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/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/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: '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: '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 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: '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: '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' prior: 21624414!
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: 'postscript generation' stamp: 'ar 5/17/2001 15:36'!
bitsPerComponent
	^self depth <= 8 ifTrue:[self depth] ifFalse:[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: '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: 'postscript generation' stamp: 'ar 5/17/2001 15:43'!
numComponents
	^self depth <= 8 ifTrue:[1] ifFalse:[3].
! !

!Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46' prior: 21708343!
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: '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: 'mir 9/14/2002 17:18'!
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."
		"And even more ugly is the fact that those frickin' RWB...etc streams open positioned at the end"
		aStream _ (RWBinaryOrTextStream with: byteStream contents) reset.
	] ifFalse:[
		aStream _ byteStream.
	].
	img _ [Form fromBinaryStream: aStream] on: Error do:[:ex| nil].
	img ifNil:[^nil].
	img displayOn: self.
	img _ nil.! !

!Form methodsFor: 'resources' stamp: 'ar 12/9/2002 16:04' prior: 36706001!
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: 'ar 3/2/2001 20:45'!
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 = Smalltalk isBigEndian ifFalse:[
		bits swapBytesFrom: 1 to: bits size.
	].! !

!Form methodsFor: 'resources' stamp: 'sd 6/28/2003 09:48' prior: 36707271!
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 = Smalltalk 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: 'ar 2/27/2001 15:07'!
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: (Smalltalk endianness == #big ifTrue:[1] ifFalse:[0]).
	].
	aStream nextNumber: 4 put: bits size.
	aStream nextPutAll: bits.
! !

!Form methodsFor: 'resources' stamp: 'sd 9/30/2003 13:41' prior: 36709104!
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: 'ar 5/14/2001 23:33'!
magnify: aRectangle by: scale smoothing: cellSize
        "Answer a Form created as a scaling of the receiver.
        Scale may be a Float, and may be greater or less than 1.0."
        | newForm |
        newForm _ self blankCopyOf: aRectangle scaledBy: scale.
        (WarpBlt current toForm: newForm)
                sourceForm: self;
                colorMap: (self 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' stamp: 'ar 5/14/2001 23:33'!
rotateBy: direction centerAt: aPoint
	"Return a rotated copy of the receiver. 
	direction = #none, #right, #left, or #pi"
	| newForm quad rot |
	direction == #none ifTrue: [^ self].
	newForm _ self class extent: (direction = #pi ifTrue: [width@height]
											ifFalse: [height@width]) depth: depth.
	quad _ self boundingBox innerCorners.
	rot _ #(right pi left) indexOf: direction.
	(WarpBlt current toForm: newForm)
		sourceForm: self;
		colorMap: (self 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 5/14/2001 23:33'!
rotateBy: deg magnify: scale smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees and magnify.  "
	"rot is the destination form, big enough for any angle."

	| side rot warp r1 pts p bigSide |
	side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.
	bigSide _ (side * scale) rounded.
	rot _ Form extent: bigSide@bigSide depth: self depth.
	warp _ (WarpBlt current toForm: rot)
		sourceForm: self;
		colorMap: (self 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 smoothing: 2) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:34'!
rotateBy: deg smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees."
	"rot is the destination form, bit enough for any angle."
	| side rot warp r1 pts p center |
	side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.
	rot _ Form extent: side@side depth: self depth.
	center _ rot extent // 2.

	"Now compute the sin and cos constants for the rotation angle." 
	warp _ (WarpBlt current toForm: rot)
		sourceForm: self;
		colorMap: (self colormapIfNeededFor: rot);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form over.
	r1 _ rot boundingBox align: center with: self boundingBox center.

	pts _ r1 innerCorners collect:
		[:pt | p _ pt - r1 center.
		(r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @
		(r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].
	warp copyQuad: pts toRect: rot boundingBox.
	^ rot
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5) smoothing: 2) display].
f display
"! !

!Form methodsFor: '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: '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 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: 'ar 2/10/2004 17:18'!
isTranslucent
	"Answer whether this form may be translucent"
	^self depth = 32! !

!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' 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: '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 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 class methodsFor: 'instance creation' stamp: 'ar 6/16/2002 18:57'!
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."
	^ Smalltalk imageReaderClass formFromStream: aBinaryStream
! !

!Form class methodsFor: 'instance creation' stamp: 'nk 7/7/2003 18:19' prior: 36720556!
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' 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: '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: '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: 'initialize-release' stamp: 'hg 8/3/2000 16:25'!
initialize

	FileList registerFileReader: self! !

!Form class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:35'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'bmp') | (suffix = 'gif') | (suffix = 'jpg') | (suffix =
'form') | (suffix = '*') | (suffix = 'png')
		ifTrue: [ self services ]
		ifFalse: [#()]
! !

!Form class methodsFor: 'fileIn/Out' stamp: 'sjc 5/3/2003 21:39' prior: 36723200!
fileReaderServicesForFile: fullName suffix: suffix
"sjc3-May 2003-added jpeg extension"

	^(suffix = 'bmp') | (suffix = 'gif') | (suffix = 'jpg') | (suffix = 'jpeg') | (suffix =
'form') | (suffix = '*') | (suffix = 'png')
		ifTrue: [ self services ]
		ifFalse: [#()]
! !

!Form class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 18:01' prior: 36723497!
fileReaderServicesForFile: fullName suffix: suffix

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

!Form class methodsFor: 'fileIn/Out' stamp: 'sw 10/25/2002 15:38'!
importImage: fullName
	"Import the given image file and store the resulting Form in the global dictionary
	ImageImports, at a key consisting of the short filename up to the first period."

	| image |
	image _ Form fromFileNamed: fullName.
	Smalltalk imageImports at: (FileDirectory localNameFor: fullName) sansPeriodSuffix put: image! !

!Form class methodsFor: 'fileIn/Out' stamp: 'sd 5/11/2003 22:17' prior: 36724118!
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."

	| image |
	image _ Form fromFileNamed: fullName.
	Imports default importImage: image named: (FileDirectory localNameFor: fullName) sansPeriodSuffix ! !

!Form class methodsFor: 'fileIn/Out' 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: 'fileIn/Out' stamp: 'mir 3/4/2002 15:03'!
openImageInWindow: fullName
	"Handle five file formats: GIF, JPG, PNG, Form stoteOn: (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: [(SketchMorph withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fullName]! !

!Form class methodsFor: 'fileIn/Out' stamp: 'BJP 11/19/2003 21:15' prior: 36725212!
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: [(SketchMorph withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fullName]! !

!Form class methodsFor: 'fileIn/Out' 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: 'fileIn/Out' 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: 'fileIn/Out' 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: 'fileIn/Out' stamp: 'sd 2/1/2002 21:43'!
services

	^ Array 
		with: self serviceImageImports
		with: self serviceOpenImageInWindow
		with: self serviceImageAsBackground ! !

!Form class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!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: '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: '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' 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: 'ar 12/14/2001 18:15'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	port isFXBlt "FXBlt has a very different setup"
		ifTrue:[self setStencilColor: aColor form: stencilForm]
		ifFalse:[self setPaintColor: aColor.
				port colorMap: 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: '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-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-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: '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 12/30/2001 16:35'!
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;
                clipRect: port clipRect.
	warp cellSize: cellSize.
	warp sourceForm: aForm.
	warp warpBits! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:49'!
setClearColor: aColor
	"Install a new clear color - e.g., a color is used for clearing the background"
	| clearColor |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	clearColor _ aColor ifNil:[Color transparent].
	clearColor isColor ifFalse:[
		(clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: clearColor; combinationRule: Form over].
	"Okay, so clearColor really *is* a color"
	port sourceForm: nil.
	port combinationRule: Form over.
	port fillPattern: clearColor.
	self depth = 8 ifTrue:[
		"Use a stipple pattern"
		port fillColor: (form balancedPatternFor: clearColor)].
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:49'!
setFillColor: aColor
	"Install a new color used for filling."
	| screen patternWord fillColor |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	fillColor _ self shadowColor ifNil:[aColor].
	fillColor ifNil:[fillColor _ Color transparent].
	fillColor isColor ifFalse:[
		(fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: fillColor; combinationRule: Form over].
	"Okay, so fillColor really *is* a color"
	port sourceForm: nil.
	fillColor isTranslucent ifFalse:[
		port combinationRule: Form over.
		port fillPattern: fillColor.
		self depth = 8 ifTrue:[
			"In 8 bit depth it's usually a good idea to use a stipple pattern"
			port fillColor: (form balancedPatternFor: fillColor)].
		^self].
	"fillColor is some translucent color"

	(port isFXBlt and:[self depth >= 8]) ifTrue:[
		"FXBlt setup for full alpha mapped transfer"
		port fillColor: (fillColor bitPatternForDepth: 32).
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		^port combinationRule: Form blend].

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha masked transfer"
		port fillPattern: fillColor.
		self depth = 16
			ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30]
			ifFalse:[port combinationRule: Form blend].
		^self].
	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: fillColor alpha depth: self depth.
	patternWord _ form pixelWordFor: fillColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:49'!
setPaintColor: aColor
	"Install a new color used for filling."
	| paintColor screen patternWord |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	paintColor _ self shadowColor ifNil:[aColor].
	paintColor ifNil:[paintColor _ Color transparent].
	paintColor isColor ifFalse:[
		(paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: paintColor; combinationRule: Form paint].
	"Okay, so paintColor really *is* a color"
	port sourceForm: nil.
	(paintColor isTranslucent) ifFalse:[
		port fillPattern: paintColor.
		port combinationRule: Form paint.
		self depth = 8 ifTrue:[
			port fillColor: (form balancedPatternFor: paintColor)].
		^self].
	"paintColor is translucent color"
	(port isFXBlt and:[self depth >= 8]) ifTrue:[
		"FXBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		port fillColor: (paintColor bitPatternForDepth: 32).
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		port combinationRule: Form blend.
		^self].

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		self depth = 16
			ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31]
			ifFalse:[port combinationRule: Form blend].
		^self].

	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: paintColor alpha depth: self depth.
	patternWord _ form pixelWordFor: paintColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:39'!
setStencilColor: aColor form: sourceForm
	"Install a new color used for stenciling through FXBlt.
	Stenciling in general is done mapping all colors of source form
	to the stencil color and installing the appropriate source key.
	However, due to possible transparency we may have to install the
	color map as source map so that sourceForm gets mapped to a 32bit
	ARGB pixel value before the color combination is done. If we don't
	need translucency we can just use the regular color map (faster!!)"
	| stencilColor screen patternWord |
	port isFXBlt ifFalse:[^self]. "Not appropriate for BitBlt"
	port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil.
	stencilColor _ self shadowColor ifNil:[aColor].
	stencilColor isColor ifFalse:[^self]. "No way"
	(stencilColor isTranslucent) ifFalse:[
		"If the paint color is not translucent we can use a simpler
		transformation going through a single color map."
		port sourceKey: 0. "The transparent source key"
		port fillPattern: stencilColor.
		port colorMap: (ColorMap colors: port fillColor).
		port fillColor: nil.
		^port combinationRule: Form over].
	(self depth >= 8) ifTrue:[
		"For transparent stenciling, things are more complicated.
		We need to install the transparent stencil color as source map
		so that all colors are mapped to the stencil color and afterwards
		blended with the destination."
		port sourceKey: 0. "The transparent source key"
		port fillPattern: stencilColor.
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		port sourceMap: (ColorMap colors: (stencilColor bitPatternForDepth: 32)).
		port fillColor: nil.
		port combinationRule: Form blend.
		^self].
	"Translucent stenciling in < 8bit depth requires three parts,
	a color map, a fill pattern and the appropriate combination rule."
	port colorMap: (ColorMap colors: (Color maskingMap: form depth)).
	screen _ Color translucentMaskFor: stencilColor alpha depth: self depth.
	patternWord _ form pixelWordFor: stencilColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint! !

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

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/5/2003 23:00' prior: 21766014!
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: 'md 11/14/2003 16:36' prior: 21768517!
curve
	"Conic-section specified by three points designated by: first point--press 
	red button second point--release red button third point--click red button. 
	The resultant curve on the display is displayed according to the current 
	form and mode."

	| firstPoint secondPoint thirdPoint curve |
	"sensor noButtonPressed ifTrue: [^self]."
	firstPoint _ self cursorPoint.
	form
		displayOn: Display
		at: firstPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	secondPoint _ self trackFormUntil: [sensor noButtonPressed].
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	thirdPoint _ self trackFormUntil: [sensor redButtonPressed].
	form
		displayOn: Display
		at: thirdPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	curve _ CurveFitter new.
	curve firstPoint: firstPoint.
	curve secondPoint: secondPoint.
	curve thirdPoint: thirdPoint.
	curve form: form.
	curve
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	sensor waitNoButton! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 16:21' prior: 36745109!
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' stamp: 'BG 12/12/2003 15:51' prior: 21771019!
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' stamp: 'jm 6/30/1999 15:46' prior: 21772539!
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' stamp: 'BG 12/10/2003 15:59' prior: 21773410!
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' stamp: 'BG 2/25/2001 21:36' prior: 21774149!
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' prior: 21774464!
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: 'menu messages' stamp: 'BG 12/5/2003 22:59' prior: 21775680!
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' prior: 21775829!
cancel
	"The edited information should be forgotten by the view."

	view cancel.
	hasUnsavedChanges contents: false.! !

!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' stamp: 'BG 12/10/2003 16:47' prior: 21777084!
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' stamp: 'BG 12/5/2003 22:58' prior: 21779297!
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' prior: 21779571!
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 methodsFor: 'window support' stamp: 'BG 12/5/2003 23:23'!
okToChange

  ^hasUnsavedChanges contents not
	ifFalse:
	  [PopUpMenu confirm:
		'This drawing was not saved.\Is it OK to close this window?' withCRs
	  ]
	ifTrue:
	  [true]
! !

!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 class methodsFor: 'examples' stamp: 'BG 12/5/2003 22:39' prior: 21781794!
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: 'private' stamp: 'BG 12/5/2003 23:18' prior: 21783080!
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! !

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

!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:22' prior: 21794251!
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' prior: 21794526!
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' prior: 21795193!
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' prior: 21795853!
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' prior: 21796267!
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 class methodsFor: 'accessing' stamp: 'BG 12/4/2003 12:11'!
formButtons

  ^FormButtons! !

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

!FormView class methodsFor: 'examples' stamp: 'BG 12/5/2003 14:45' prior: 21806787!
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! !

!Fraction methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49' prior: 21809325!
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: '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 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 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! !

!FractionTest methodsFor: 'testing' 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: 'testing' 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'.! !

!FrameRateMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 21814141!
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 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! !

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

!FreeTranslation class methodsFor: 'translation' stamp: 'gm 2/22/2003 18:57' prior: 21849350!
translatePanel: buttonPlayer fromTo: normalDirection
	| ow fromTM toTM fromLang toLang tt doc answer width |
	"Gather up all the info I need from the morphs in the button's owner and do the translation.  Insert the results in a TextMorph.  Use www.freeTranslation.com Refresh the banner ad.
	TextMorph with 'from' in the title is starting text.
	PopUpChoiceMorph  with 'from' in the title is the starting language.
	TextMorph with 'from' in the title is place to put the answer.
	PopUpChoiceMorph  with 'from' in the title is the target language.
		If normalDirection is false, translate the other direction."

	ow _ buttonPlayer costume ownerThatIsA: PasteUpMorph.
	ow allMorphs do: [:mm |
		(mm isTextMorph) ifTrue: [ 
			(mm knownName asString includesSubString: 'from') ifTrue: [
				 fromTM _ mm].
			(mm knownName asString includesSubString: 'to') ifTrue: [
				 toTM _ mm]].
		(mm isKindOf: PopUpChoiceMorph) ifTrue: [ 
			(mm knownName asString includesSubString: 'from') ifTrue: [
				 fromLang _ mm contents asString].
			(mm owner knownName asString includesSubString: 'from') ifTrue: [
				 fromLang _ mm contents asString].
			(mm knownName asString includesSubString: 'to') ifTrue: [
				 toLang _ mm contents asString].
			(mm owner knownName asString includesSubString: 'to') ifTrue: [
				 toLang _ mm contents asString]]].
	normalDirection ifFalse: ["switch"
		tt _ fromTM.  fromTM _ toTM.  toTM _ tt.
		tt _ fromLang.  fromLang _ toLang.  toLang _ tt].
	Cursor wait showWhile: [
		doc _ self translate: fromTM contents asString from: fromLang to: toLang.
		answer _ self extract: doc].	"pull out the translated text"
	
	width _ toTM width.
	toTM contents: answer wrappedTo: width.
	toTM changed.! !

!FreeTranslation class methodsFor: 'scamper' stamp: 'sw 9/28/2001 08:45'!
openScamperOn: currentSelection
	"Submit the string to the translation server at www.freetranslation.com.  Ask it to translate from (Preferences parameterAt: #languageTranslateFrom) to (Preferences parameterAt: #languageTranslateTo).  Display the results in a Scamper window, reusing the previous one if possible."

	| inputs scamperWindow from to | 
	currentSelection size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
	from _ Preferences parameterAt: #languageTranslateFrom ifAbsentPut: ['English'].
	to _ Preferences parameterAt: #languageTranslateTo ifAbsentPut: ['German'].
	from = to ifTrue:
			[^ self inform: 'You asked to translate from ', from, ' to ', to, '.\' withCRs,
				'Use "choose language" to set these.'].  
	inputs _ Dictionary new.
	inputs at: 'SrcText' put: (Array with: currentSelection).
	inputs at: 'Sequence' put: #('core').
	inputs at: 'Mode' put: #('html').
	inputs at: 'template' put: #('TextResult2.htm').
	inputs at: 'Language' put: (Array with: from, '/', to).
	scamperWindow _ Scamper newOrExistingOn: 'http://ets.freetranslation.com'.
	scamperWindow model submitFormWithInputs: inputs 
		url: 'http://ets.freetranslation.com:5081' asUrl
		method: 'post'.
	scamperWindow activate.
! !

!FreeTranslation class methodsFor: 'scamper' stamp: 'ads 4/1/2003 19:24' prior: 36766531!
openScamperOn: currentSelection
	"Submit the string to the translation server at www.freetranslation.com.  Ask it to translate from (Preferences parameterAt: #languageTranslateFrom) to (Preferences parameterAt: #languageTranslateTo).  Display the results in a Scamper window, reusing the previous one if possible."

	| inputs scamperWindow from to | 
	currentSelection size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
	from _ Preferences parameterAt: #languageTranslateFrom ifAbsentPut: ['English'].
	to _ Preferences parameterAt: #languageTranslateTo ifAbsentPut: ['German'].
	from = to ifTrue:
			[^ self inform: 'You asked to translate from ', from, ' to ', to, '.\' withCRs,
				'Use "choose language" to set these.'].  
	inputs _ Dictionary new.
	inputs at: 'SrcText' put: (Array with: currentSelection).
	inputs at: 'Sequence' put: #('core').
	inputs at: 'Mode' put: #('html').
	inputs at: 'template' put: #('TextResult2.htm').
	inputs at: 'Language' put: (Array with: from, '/', to).
	scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: 'http://ets.freetranslation.com'.
	scamperWindow model submitFormWithInputs: inputs 
		url: 'http://ets.freetranslation.com:5081' asUrl
		method: 'post'.
	scamperWindow activate.
! !

!FtpUrl methodsFor: 'downloading' stamp: 'mir 8/10/2001 17:45'!
downloadUrl
	"Returns a http download url for the location defined by this url."
	|  auth idx serverName |
	auth _ self authority.
	idx _ auth indexOf: $@.
	idx > 0 ifTrue:[
		serverName _ (auth copyFrom: idx+1 to: auth size).
	].
	^'http://' , serverName , self pathString! !

!FtpUrl methodsFor: 'downloading' stamp: 'mir 6/26/2001 09:47'!
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.
		(contents respondsTo: #contents) ifTrue: [ 
			"the file exists--return it"
			^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents contents ]
		ifFalse: [
			"some error"
			^nil ]. ].

	"a directory?"
	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: 'downloading' stamp: 'mir 6/27/2003 19:42' prior: 36769531!
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! !

!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
!
!FullVocabulary methodsFor: 'initialization' stamp: 'sw 9/25/2001 21:52'!
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: 'sw 9/13/2001 23:26'!
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: '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)	! !

!FullVocabulary methodsFor: 'queries' prior: 21855315!
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: 'sw 4/23/2001 14:42'!
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 classThatUnderstands: 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' prior: 36776148!
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 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 9/27/2001 03:28'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ false! !

!FunctionComponent methodsFor: 'button' stamp: 'dgd 2/22/2003 14:25' prior: 21858964!
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: 'menu' stamp: 'sw 11/27/2001 14:57'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom menu items"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu add: 'add pin' target: self selector: #addPin.
! !

!FunctionComponent methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:45' prior: 36778813!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom menu items"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu add: 'add pin' translated target: self selector: #addPin.
! !

!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 8/4/2003 10:14'!
languageClass

	^ SimplifiedChinese.
! !

!GB2312 class methodsFor: 'as yet unclassified' stamp: 'yo 10/22/2002 19:50'!
charSetSize

	^ 94 * 94.
! !

!GB2312 class methodsFor: 'as yet unclassified' stamp: 'yo 10/22/2002 19:50'!
compoundTextSequence

	^ CompoundTextSequence
! !

!GB2312 class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 10/22/2002 19:51'!
leadingChar

	^ 2.
! !

!GB2312 class methodsFor: 'accessing - encoding' 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: 'accessing - encoding' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable gb2312Table.
! !

!GB2312 class methodsFor: 'accessing - displaying' stamp: 'yo 11/23/2002 23:15'!
scanSelector

	^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:
! !

!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: 'RAA 4/25/2001 09:31'!
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 respondsTo: #binary) ifTrue: [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: 'sd 1/30/2004 15:18' prior: 36781498!
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: 'bf 5/29/2003 01:20' prior: 21862362!
nextPutImage: aForm

	| f newF |
	aForm unhibernate.
	f _ aForm colorReduced.  "minimize depth"
	f depth > 8 ifTrue: [
		"Not enough color space; do it the hard way."
		f _ f asFormOfDepth: 8].
	f depth < 8 ifTrue: [
		"writeBitData: expects depth of 8"
		newF _ f class extent: f extent depth: 8.
		(f isKindOf: ColorForm)
			ifTrue: [
				newF
					copyBits: f boundingBox
					from: f at: 0@0
					clippingBox: f boundingBox
					rule: Form over
					fillColor: nil
					map: nil.
				newF colors: f colors]
			ifFalse: [f displayOn: newF].
		f _ newF].
	(f isKindOf: ColorForm)
		ifTrue: [
			(f colorsUsed includes: Color transparent) ifTrue: [
				transparentIndex _ (f colors indexOf: Color transparent) - 1]]
		ifFalse: [transparentIndex _ nil].
	width _ f width.
	height _ f height.
	bitsPerPixel _ f depth.
	colorPalette _ f colormapIfNeededForDepth: 32.
	interlace _ false.
	self writeHeader.
	self writeBitData: f bits.
! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'nk 4/17/2004 19:44' prior: 36783241!
nextPutImage: aForm

	| f newF |
	aForm unhibernate.
	f _ aForm colorReduced.  "minimize depth"
	f depth > 8 ifTrue: [
		"Not enough color space; do it the hard way."
		f _ f asFormOfDepth: 8].
	f depth < 8 ifTrue: [
		"writeBitData: expects depth of 8"
		newF _ f class extent: f extent depth: 8.
		(f isColorForm)
			ifTrue: [
				newF
					copyBits: f boundingBox
					from: f at: 0@0
					clippingBox: f boundingBox
					rule: Form over
					fillColor: nil
					map: nil.
				newF colors: f colors]
			ifFalse: [f displayOn: newF].
		f _ newF].
	(f isColorForm)
		ifTrue: [
			(f colorsUsed includes: Color transparent) ifTrue: [
				transparentIndex _ (f colors indexOf: Color transparent) - 1]]
		ifFalse: [transparentIndex _ nil].
	width _ f width.
	height _ f height.
	bitsPerPixel _ f depth.
	colorPalette _ f colormapIfNeededForDepth: 32.
	interlace _ false.
	self writeHeader.
	self writeBitData: f bits.
! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:21' prior: 21864143!
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' stamp: 'bf 5/29/2003 01:38' prior: 21866587!
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-decoding' stamp: 'RAA 4/25/2001 09:31'!
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.
	self readWord.	"skip Image Left"
	self readWord.	"skip 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: 'mir 11/19/2003 12:19' prior: 36789016!
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: 'RAA 4/25/2001 09:30'!
readBody
	"Read the GIF blocks. Modified to return a form.  "

	| form extype block blocksize packedFields |
	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.
				self next.	"delay time 1"
				self next.	"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: [self next: blocksize]]]].
! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 14:29' prior: 36795407!
readBody
	"Read the GIF blocks. Modified to return a form.  "

	| form extype block blocksize packedFields delay1 blockSize |
	form _ nil.
	[stream atEnd] whileFalse: [
		block _ self next.
		block = Terminator ifTrue: [^ form].
		block = ImageSeparator ifTrue: [
			form isNil
				ifTrue: [form _ self readBitData]
				ifFalse: [self skipBitData].
		] ifFalse: [
			block = Extension
				ifFalse: [^ form "^ self error: 'Unknown block type'"].
			"Extension block"
			extype _ self next.	"extension type"
			extype = 16rF9 ifTrue: [  "graphics control"
				self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].
				"====
				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: [
				extype = 16rFE 
					ifTrue: [
						(blockSize _ self next) > 0
							ifTrue: [comment _ (self next: blockSize) asString]]
 					ifFalse: [ "Skip blocks"
						[(blocksize _ self next) > 0] whileTrue: [self next: blocksize]]]]]! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'KLC 1/25/2004 14:04' prior: 36796668!
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' 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: 'stream access' stamp: 'bf 5/29/2003 01:23'!
close
	"Write terminator"
	self nextPut: Terminator.
	^super close! !

!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: 'sd 9/27/2003 19:01'!
grabScreenAndSaveOnDisk  
	"GIFReaderWriter grabScreenAndSaveOnDisk"

	| form fileName |
	form _ Form fromUser.
	form bits size = 0 ifTrue: [^ self beep].
	fileName _ FileDirectory default nextNameFor: 'Squeak' extension: 'gif'.
	Utilities informUser: 'Writing ' , fileName
		during: [GIFReadWriter putForm: form onFileNamed: fileName].! !

!GIFReadWriter 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"
	^#('gif')! !

!GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29' prior: 36801947!
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! !

!GSMCodec class methodsFor: 'instance creation' stamp: 'jm 10/21/2001 10:10'!
new

	^ super new reset
! !

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

!GZipReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:32' prior: 21878981!
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 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 class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:50'!
fileIn: fullFileName
	"FileIn the contents of a gzipped file"
	| zipped unzipped |
	zipped _ self on: (FileStream readOnlyFileNamed: fullFileName).
	unzipped _ ReadStream on: (zipped contents asString).
	unzipped fileIn.! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:50'!
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 _ ReadStream on: zipped contents asString.
	cs newChangesFromStream: unzipped named: (FileDirectory localNameFor: fullFileName)
! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:35'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'gz') | (suffix = '*') 
		ifTrue: [ self services]
		ifFalse: [#()]


! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:52' prior: 36806324!
fileReaderServicesForFile: fullName suffix: suffix 
	| services |
	suffix = 'gz' | (suffix = '*')
		ifFalse: [^ #()].
	services _ OrderedCollection new.
	(fullName asLowercase endsWith: '.cs.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: 'nk 7/16/2003 15:51' prior: 36806556!
fileReaderServicesForFile: fullName suffix: suffix 
	| services |
	(suffix = 'gz') | (suffix = '*')
		ifFalse: [^ #()].
	services _ OrderedCollection new.
	(suffix = '*') | (fullName asLowercase endsWith: '.cs.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: 'hg 8/3/2000 17:45'!
uncompressedFileName: fullName
	^((fullName endsWith: '.gz') and: [self confirm: fullName , '
appears to be a compressed file.
Do you want to uncompress it?'])
		ifFalse: [fullName]
		ifTrue:[self saveContents: fullName]! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'dgd 9/21/2003 17:46' prior: 36809814!
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]! !

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

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/19/2001 23:46'!
writeFooter
	"Write some footer information for the crc"
	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: 'nk 2/19/2004 08:31' prior: 36811176!
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 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: 'nk 11/26/2002 13:44'!
fileReaderServicesForFile: fullName suffix: suffix
	"Don't offer to compress already-compressed files"
	^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' } includes: suffix) ifTrue: [ #() ] ifFalse: [ self services ]

! !

!GZipWriteStream class methodsFor: 'file list services' stamp: 'sjc 5/3/2003 21:39' prior: 36812288!
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' } includes: suffix) ifTrue: [ #() ] ifFalse: [ self services ]

! !

!GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 7/16/2003 15:52' prior: 36812603!
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 }! !

!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' prior: 21895746!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	newPagePrototype _ GeeBookPageMorph new extent: Display extent // 3 ! !

!GeeBookMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'!
includeInNewMorphMenu

	^ false! !

!GeeBookPageMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'!
includeInNewMorphMenu

	^ false! !

!GeeMailMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:50'!
descriptionForPartsBin
	^ self partName:	'GeeMail'
		categories:		#('Presentation' 'Text')
		documentation:	'A place to assemble content and associated flowing text'! !

!GeeMailMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:07'!
initialize

	self registerInFlapsRegistry.! !

!GeeMailMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:08'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(GeeMailMorph		new	'Gee-Mail'			'A place to present annotated content') 
						forFlapNamed: 'Widgets']! !

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

!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: 'RAA 5/7/2001 12:20'!
geeMail: aGeeMail

	geeMail _ aGeeMail! !

!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: '*morphic-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
! !

!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 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' prior: 21903873!
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 methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:08'!
includeInNewMorphMenu

	^ false! !

!GeePrinterPage methodsFor: '*morphic-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.

! !

!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: 'RAA 3/9/2001 10:06'!
buildFakeSlider: nameStringOrSymbol selector: aSymbol help: helpString

	| col |

	col _ self inAColumn: {
		(nameStringOrSymbol isKindOf: Symbol) 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: 'gm 2/24/2003 18:06' prior: 36820949!
buildFakeSlider: nameStringOrSymbol selector: aSymbol help: helpString 
	| col |
	col := self inAColumn: { 
						(nameStringOrSymbol isKindOf: Symbol) 
							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: 'RAA 3/8/2001 14:35'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!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/9/2001 12:50'!
doButtonProperties

	myTarget openAButtonPropertySheet.
	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: 'RAA 3/15/2001 11:52'!
initialize

	super initialize.
	self borderWidth: 4.
	self layoutInset: 4.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	thingsToRevert _ Dictionary new.
	self useRoundedCorners.
! !

!GenericPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:16' prior: 36829110!
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! !

!GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'!
scheme
	^ self schemeName.! !

!German methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:27'!
name
	"answer the receiver's name"
	^ #'Deutsch'! !

!GermanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 17:49'!
charsetClass

	^ Latin1.
! !

!GermanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 18:30'!
defaultEncodingName

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk 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].
	^ nil
! !

!GradientFillMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:15' prior: 21912830!
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: 'menu' stamp: 'dgd 8/30/2003 21:45' prior: 21914033!
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].
! !

!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: 'Morphic menu' stamp: 'dgd 10/17/2003 22:37' prior: 21919819!
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 commentStamp: '<historical>' 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.!
!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]).! !

!GrafPort methodsFor: 'accessing' stamp: 'yo 1/23/2003 17:33' prior: 21923549!
displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	((para isMemberOf: MultiNewParagraph) or: [para text string class == String]) 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: 'yo 1/23/2003 17:48'!
displayScannerForMulti: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	((para isMemberOf: MultiNewParagraph) or: [para text string class == String]) 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: 'copying' stamp: 'ar 12/30/2001 20:32'!
clippedBy: aRectangle
	^ self copy clipBy: aRectangle! !

!GrafPort methodsFor: 'copying' stamp: 'dgd 2/21/2003 22:38' prior: 21928304!
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: 'efc 6/22/2003 21:32' prior: 21926680!
frameRect: rect borderWidth: borderWidth
	"Paint a border whose rectangular area is defined by rect. The
	width of the border of each side is borderWidth."

	sourceX _ 0.
	sourceY _ 0.
	
	"for top and bottom, the following are the same"
	height _ borderWidth. 
	width _ rect width. 
	destX _ rect left.

	"top"
	destY _ rect top.
	self copyBits.

	"bottom"
	destY _ rect bottom - borderWidth.
	self copyBits.

	"for left & right, the following are the same"
	height _ rect height. 
	width _ borderWidth. 
	destY _ rect top.

	"left"
	destX _ rect left.
	self copyBits.

	"right"
	destX _ rect right - borderWidth.
	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: 'private' stamp: 'ar 9/17/2002 22:35'!
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"
	alpha = 255 ifTrue:[
		combinationRule = 30 ifTrue: [combinationRule _ Form over].
		combinationRule = 31 ifTrue: [combinationRule _ Form paint].
	] ifFalse:[
		combinationRule = Form over ifTrue: [combinationRule _ 30].
		combinationRule = Form paint ifTrue: [combinationRule _ 31].
	]! !

!GrafPort methodsFor: 'private' stamp: 'yo 6/23/2003 20:34' prior: 36837428!
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].
	]! !

!GraphMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:40' prior: 21931943!
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' prior: 21932533!
lastValue
	data isEmpty ifTrue: [^0].
	^data last! !

!GraphMorph methodsFor: 'commands' stamp: 'gk 2/23/2004 21:08' prior: 21937608!
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: 'drawing' stamp: 'dgd 2/22/2003 14:39' prior: 21933359!
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: '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' prior: 21929578!
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: 'stepping and presenter' stamp: 'dgd 2/22/2003 14:40' prior: 21934576!
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' prior: 21935018!
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 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: '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'))))! !

!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: 'sw 4/3/2001 15:40'!
initialize
	"Initialize the receiver, giving it a default graphic"

	super initialize.
	type _ #literal.
	self useForm: (ScriptingSystem formAtKey: #Menu).
! !

!GraphicTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45' prior: 36844070!
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.! !

!GraphicTile commentStamp: '<historical>' prior: 0!
A tile representing a graphic image.!
!GraphicType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ GraphicTile new typeColor: self typeColor! !

!GraphicType methodsFor: '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! !

!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: '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)	! !

!GraphicalDictionaryMenu methodsFor: 'initialization' stamp: 'sw 10/29/2001 06:30'!
initializeFor: aTarget fromDictionary: aDictionary
	"Initialize me for a target and a dictionary."

	|  imageWrapper anIndex aButton controlsWrapper asm |
	self listDirection: #topToBottom.
	self addMorphBack: (controlsWrapper _ AlignmentMorph newRow).
	self baseDictionary: aDictionary.
	target _ aTarget.
	coexistWithOriginal _ true.
	color _ Color white.
	borderColor _ Color blue darker.
	borderWidth _ 1.

	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	controlsWrapper borderWidth: 0; layoutInset: 0; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	controlsWrapper wrapCentering: #topLeft; color: Color white; vResizing: #spaceFill.
	controlsWrapper addTransparentSpacerOfSize: (18@0).
	controlsWrapper addMorphBack: (IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu'); color: Color transparent; 
			actWhen: #buttonDown;
			actionSelector: #showMenu; target: self;
			setBalloonText: 'menu').

	controlsWrapper  addTransparentSpacerOfSize: (14@0).

	aButton _ SimpleButtonMorph new target: self; borderColor: Color black.
	controlsWrapper addMorphBack: (aButton
		label: 'Prev';
		actionSelector: #downArrowHit;
		actWhen: #whilePressed;
		setBalloonText: 'show previous picture';
		yourself).
	controlsWrapper addTransparentSpacerOfSize: (15@0).
	aButton _ SimpleButtonMorph new target: self; borderColor: Color black.
	controlsWrapper addMorphBack: (aButton label: 'Next';	
		actionSelector: #upArrowHit; actWhen: #whilePressed; 
		setBalloonText: 'show next pictutre').

	self addMorphBack: controlsWrapper.
	self addTransparentSpacerOfSize: (0 @ 12).

	self addMorphBack:  (asm _ UpdatingStringMorph new contents: ' '; target: self; putSelector: #renameGraphicTo:; getSelector: #truncatedNameOfGraphic; useStringFormat).
	asm setBalloonText: 'The name of the current graphic'. 
	self addTransparentSpacerOfSize: (0 @ 12).
	self addMorphBack: (AlignmentMorph newRow height: 4; borderWidth: 0; color: Color black).
	imageWrapper _ Morph new color: Color transparent; extent: 190 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target ifNotNil: [(anIndex _ formChoices indexOf: target form ifAbsent: [nil]) ifNotNil:
		[currentIndex _ anIndex]].
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:10' prior: 36846397!
initializeFor: aTarget fromDictionary: aDictionary 
	"Initialize me for a target and a dictionary."
	| imageWrapper anIndex aButton controlsWrapper asm |
	self listDirection: #topToBottom.
	self addMorphBack: (controlsWrapper _ AlignmentMorph newRow).
	self baseDictionary: aDictionary.
	target _ aTarget.
	coexistWithOriginal _ true.
	
	self hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap.
	controlsWrapper borderWidth: 0;
		 layoutInset: 0;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 extent: 5 @ 5.
	controlsWrapper wrapCentering: #topLeft;
		 color: Color white;
		 vResizing: #spaceFill.
	controlsWrapper addTransparentSpacerOfSize: 18 @ 0.
	controlsWrapper addMorphBack: (IconicButton new borderWidth: 0;
			
			labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu');
			 color: Color transparent;
			 actWhen: #buttonDown;
			 actionSelector: #showMenu;
			 target: self;
			 setBalloonText: 'menu').
	controlsWrapper addTransparentSpacerOfSize: 14 @ 0.
	aButton _ SimpleButtonMorph new target: self;
				 borderColor: Color black.
	controlsWrapper addMorphBack: (aButton label: 'Prev';
			 actionSelector: #downArrowHit;
			 actWhen: #whilePressed;
			 setBalloonText: 'show previous picture';
			 yourself).
	controlsWrapper addTransparentSpacerOfSize: 15 @ 0.
	aButton _ SimpleButtonMorph new target: self;
				 borderColor: Color black.
	controlsWrapper addMorphBack: (aButton label: 'Next';
			 actionSelector: #upArrowHit;
			 actWhen: #whilePressed;
			 setBalloonText: 'show next pictutre').
	self addMorphBack: controlsWrapper.
	self addTransparentSpacerOfSize: 0 @ 12.
	self addMorphBack: (asm _ UpdatingStringMorph new contents: ' ';
					 target: self;
					 putSelector: #renameGraphicTo:;
					 getSelector: #truncatedNameOfGraphic;
					 useStringFormat).
	asm setBalloonText: 'The name of the current graphic'.
	self addTransparentSpacerOfSize: 0 @ 12.
	self addMorphBack: (AlignmentMorph newRow height: 4;
			 borderWidth: 0;
			 color: Color black).
	imageWrapper _ Morph new color: Color transparent;
				 extent: 190 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target
		ifNotNil: [(anIndex _ formChoices
						indexOf: target form
						ifAbsent: [])
				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 2/24/2003 16:04'!
findAgain
	"Look for the next occurrence of the search string"

	| toFind searchIndex |
	lastSearchString ifNil: [lastSearchString _ 'controls'].
	searchIndex _ currentIndex + 1.
	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']
					ifTrue:
						[self flash]]].

	currentIndex _ searchIndex.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:57' prior: 21947836!
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: 'nb 6/17/2003 12:25' prior: 21951250!
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' prior: 21951848!
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: 'ar 6/2/2001 16:54'!
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: ((SketchMorph withForm: formToEdit) position: submorphs second positionInWorld)  inBounds: bnds pasteUpMorph: aWorld paintBoxPosition: bnds topRight.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			formChoices at: currentIndex put: aForm.
			baseDictionary at: (entryNames at: currentIndex) put: aForm.
			self updateThumbnail.
			(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]] 
		ifNoBits:
			[(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]].
	
! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 10/25/2002 16:56'!
showMenu
	"Show the receiver's menu"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	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')
		('copy name'		copyName				'Copy the name of this graphic to the clipboard')
		-
		('find...'			findEntry				'Find an entry by name')).
	aMenu popUpInWorld
! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:59' prior: 36855698!
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 class methodsFor: 'example' stamp: 'sd 5/11/2003 20:53' prior: 21954203!
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: 'sd 5/11/2003 20:58'!
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 |
	aFormDictionary size isZero ifTrue: [^ self inform: 'Empty!!'].	
	inst := self new initializeFor: nil fromDictionary: aFormDictionary.
     HandMorph attach: (inst wrappedInWindowWithTitle: aLabel).
	^ inst! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:23'!
initializeFor: aTarget withForms: formList coexist: aBoolean
	" World primaryHand attachMorph: (GraphicalMenu new initializeFor: nil 
		withForms: Form allInstances coexist: true) "
	| buttons bb anIndex buttonCage imageWrapper |
	target _ aTarget.
	coexistWithOriginal _ aBoolean.
	color _ Color white.
	borderColor _ Color blue darker.
	borderWidth _ 1.
	formChoices _ formList.
	currentIndex _ 1.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	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.

	imageWrapper _ Morph new color: Color transparent; extent: 102 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target ifNotNil: [(anIndex _ formList indexOf: target form ifAbsent: [nil]) ifNotNil:
		[currentIndex _ anIndex]].
	self updateThumbnail! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'dgd 2/14/2003 19:08' prior: 36858459!
initializeFor: aTarget withForms: formList coexist: aBoolean 
	"World primaryHand attachMorph: (GraphicalMenu new  
	initializeFor: nil  
	withForms: Form allInstances coexist: true)"
	| buttons bb anIndex buttonCage imageWrapper |
	target _ aTarget.
	coexistWithOriginal _ aBoolean.

	formChoices _ formList.
	currentIndex _ 1.
	self 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.
	imageWrapper _ Morph new color: Color transparent;
				 extent: 102 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target
		ifNotNil: [(anIndex _ formList
						indexOf: target form
						ifAbsent: [])
				ifNotNil: [currentIndex _ anIndex]].
	self updateThumbnail! !

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

!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: '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 6/15/2001 18:39'!
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: SimpleClientSocket crLf.
	^ ftpEntries 
		collect:[:ftpEntry | ServerDirectory parseFTPEntry: ftpEntry]
		thenSelect: [:entry | entry notNil]! !

!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43' prior: 36864450!
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: 'mir 8/22/2001 17:16'!
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 , ': ' , SimpleClientSocket crLf.
	linkToInclude _ urlForLoading.
	HTTPClient shouldUsePluginAPI
		ifTrue: [
			self composeMailTo: recipient subject: subject body: body , (linkToInclude copyReplaceAll: '%' with: '%25')]
		ifFalse: [Preferences allowCelesteTell
			ifTrue: [FancyCelesteComposition new
				celeste: nil 
				to: recipient
				subject: subject
				initialText: body
				theLinkToInclude: linkToInclude;
				open]
			ifFalse: [self inform: 'You need to run inside a web browser to use the tell function.']]! !

!HTTPClient class methodsFor: 'utilities' stamp: 'dvf 6/15/2002 19:18' prior: 36866174!
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 , ': ' , SimpleClientSocket crLf.
	linkToInclude _ urlForLoading.
	HTTPClient shouldUsePluginAPI
		ifTrue: [
			self composeMailTo: recipient subject: subject body: body , (linkToInclude copyReplaceAll: '%' with: '%25')]
		ifFalse: [Preferences allowCelesteTell
			ifTrue: [FancyMailComposition new
				celeste: nil 
				to: recipient
				subject: subject
				initialText: body
				theLinkToInclude: linkToInclude;
				open]
			ifFalse: [self inform: 'You need to run inside a web browser to use the tell function.']]! !

!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43' prior: 36867062!
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: [Preferences allowCelesteTell
			ifTrue: [FancyMailComposition new
				celeste: nil 
				to: recipient
				subject: subject
				initialText: body
				theLinkToInclude: linkToInclude;
				open]
			ifFalse: [self inform: 'You need to run inside a web browser to use the tell function.']]! !

!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: '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: 'mir 4/2/2002 15:51'!
shouldUsePluginAPI
	"HTTPClient shouldUsePluginAPI" 

	self isRunningInBrowser
		ifFalse: [^false].
	self browserSupportsAPI
		ifFalse: [^false].
	"The Mac plugin calls do not work in full screen mode"
	^((Smalltalk platformName = 'Mac OS')
		and: [ScreenController lastScreenModeSelected]) not! !

!HTTPClient class methodsFor: 'testing' stamp: 'sd 9/30/2003 13:56' prior: 36869780!
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: '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: 'mir 2/2/2001 17:43'!
examplePostArgs
	"HTTPClient examplePostArgs"

	| args result resultStream |
	args _ Dictionary new.
	args
		at: 'arg1' put: #('val1');
		at: 'arg2' put: #('val2');
		yourself.
	resultStream _ HTTPClient httpPostDocument: 'http://www.squeaklet.com/cgi-bin/thrd.pl'  args: args.
	result _ resultStream upToEnd.
	Transcript show: result; cr; cr.
	resultStream close

! !

!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: 'mir 4/28/2001 23:36'!
httpGet: url
	| document |
	document _ self httpGetDocument: url.
	^(document isKindOf: String)
		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: 'private' stamp: 'mir 3/7/2001 14:45'!
pluginHttpPostMultipart: url args: argsDict
	| mimeBorder argsStream crLf fieldValue resultStream result |
	" do multipart/form-data encoding rather than x-www-urlencoded "

	crLf _ SimpleClientSocket 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 toText].
	"get the header of the reply"
	result _ resultStream
		ifNil: ['']
		ifNotNil: [resultStream upToEnd].
	^MIMEDocument content: result! !

!HTTPClient class methodsFor: 'private' stamp: 'mir 5/13/2003 10:43' prior: 36873680!
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 toText].
	"get the header of the reply"
	result _ resultStream
		ifNil: ['']
		ifNotNil: [resultStream upToEnd].
	^MIMEDocument content: result! !

!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: 'initialize'!
for: aUrl in: aLoader
	url _ self httpEncodeSafely: 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: 'private' stamp: 'mir 3/16/2001 13:07'!
httpEncodeSafely: aUrl
	"Encode the url but skip $/ and $:."

	| encodedStream unescaped |
	unescaped _ aUrl unescapePercents.
	encodedStream _ WriteStream on: (String new).
	
	unescaped do: [ :c |
		(c isSafeForHTTP or: [c == $/ or: [c == $:]]) ifTrue: [ encodedStream nextPut: c ] ifFalse: [
			encodedStream nextPut: $%.
			encodedStream nextPut: (c asciiValue // 16) asHexDigit.
			encodedStream nextPut: (c asciiValue \\ 16) asHexDigit.
		]
	].
	^encodedStream contents. ! !

!HTTPLoader methodsFor: 'private' stamp: 'md 11/14/2003 16:38' prior: 21978882!
removeProcess: downloadProcess
	downloads remove: downloadProcess ifAbsent: []! !

!HTTPLoader methodsFor: 'private' stamp: 'RAA 3/9/2001 08:04'!
startDownload
	| newDownloadProcess |
	
	downloads size >= self maxNrOfConnections ifTrue: [^self].
	requests size <= 0 ifTrue: [^self].

	newDownloadProcess _ [
		self flag: #httpLoader log: 'Starting download'.
		[
			self nextRequest startRetrieval
		] on: FTPConnectionException do: [ :ex | 
			Cursor normal show.
			self removeProcess: Processor activeProcess.
			self startDownload
		].
		self flag: #httpLoader log: 'Download done'.
		self removeProcess: Processor activeProcess.
		self startDownload
	] newProcess.
	downloads add: newDownloadProcess.
	newDownloadProcess resume! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 5/12/2003 18:10' prior: 36878438!
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 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 class methodsFor: 'class initialization' stamp: 'mir 3/8/2001 16:31'!
initialize
	"HTTPLoader initialize"

	MaxNrOfConnections _ 4.
	DefaultLoader ifNotNil: [
		DefaultLoader release.
		DefaultLoader _ nil]! !

!HTTPLoader class methodsFor: 'accessing' stamp: 'mir 5/1/2001 12:52'!
httpRequestClass
	^HTTPClient shouldUsePluginAPI
		ifTrue: [PluginHTTPRequest]
		ifFalse: [HTTPRequest]! !

!HTTPLoader class methodsFor: 'accessing' stamp: 'avi 4/30/2004 01:40' prior: 36880107!
httpRequestClass
	^HTTPClient shouldUsePluginAPI
		ifTrue: [PluginHTTPDownloadRequest]
		ifFalse: [HTTPDownloadRequest]! !

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

!HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 5/3/2001 12:58'!
dirListUrl
	| listURL |
	listURL _ self altUrl.
	listURL last ~= $/
		ifTrue: [listURL _ listURL , '/'].
	^ 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'! !

!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: '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: 'md 11/14/2003 16:39' prior: 21991496!
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 class methodsFor: 'class initialization' stamp: 'mir 8/23/2002 14:19'!
initialize
	"HTTPSocket initialize"

	ParamDelimiters _ ' ', CrLf.
	HTTPPort _ 80.
	HTTPProxyServer _ nil.
	HTTPBlabEmail _ ''.  "	'From: somebody@no.where', CrLf	"

	ExternalSettings registerClient: self! !

!HTTPSocket class methodsFor: 'class initialization' stamp: 'al 1/8/2004 12:21' prior: 36886851!
initialize
	"HTTPSocket initialize"

	ParamDelimiters _ ' ', CrLf.
	HTTPPort _ 80.
	HTTPProxyServer _ nil.
	HTTPBlabEmail _ ''.  "	'From: somebody@no.where', CrLf	"
	HTTPProxyCredentials _ ''.

	ExternalSettings registerClient: self! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'sw 5/23/2001 13:44'!
httpFileIn: url
	"Do a regular file-in of a file that is served from a web site.  If the file contains an EToy, then open it.  Might just be code instead.  tk 7/23/97 17:10"
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones.  The server does not have to know about the .sqo extension in order to send your file.  (We do not need a new MIME type and .sqo does not have to be registered with the server.)"
	"	HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy'	 "
	"	HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo'	 "
	"	HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy'	 "

	| doc eToyHolder |
	doc _ self httpGet: url accept: 'application/octet-stream'.
	doc class == String ifTrue:
			[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: 'sw 5/23/2001 13:44'!
httpFileInNewChangeSet: url
	"Do a regular file-in of a file that is served from a web site.  Put it into a new changeSet."
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones."
	"	HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs'	 "

	| doc |
	doc _ self httpGet: url accept: 'application/octet-stream'.
	doc class == String ifTrue:
			[self inform: 'Cannot seem to contact the web site'].
	doc reset.
	ChangeSorter newChangesFromStream: doc
				named: (url findTokens: '/') last.! !

!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: 'hg 2/12/2002 11:37'!
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 MIMI type 'application/octet-stream'."

	| document |
	document _ self httpGetDocument: url  args: args  accept: mimeType request: requestString.
	(document isKindOf: String) ifTrue: [
		"strings indicate errors"
		^ document ].

	^ (RWBinaryOrTextStream with: document content) reset
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ls 11/3/2002 14:04'!
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 _ HTTPProxyServer.
			connectToPort _ 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] ].
			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' ifFalse: [
		]
	].

{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.

	^'some other bad thing happened!!'! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'al 1/8/2004 12:44' prior: 36891397!
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 _ HTTPProxyServer.
			connectToPort _ 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"
		HTTPProxyCredentials,
		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' ifFalse: [
		]
	].

{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.

	^'some other bad thing happened!!'! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tlk 1/22/2004 21:39' prior: 36895095!
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 _ HTTPProxyServer.
			connectToPort _ 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"
		HTTPProxyCredentials,
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		self userAgentString, CrLf,
		'Host: ', serverName, 
		(port = 80 ifTrue:[''] ifFalse:[':', 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' ifFalse: [
		]
	].

{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.

	^'some other bad thing happened!!'! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:36' prior: 22004008!
httpGif: url
	"Fetch the given URL, parse it using the GIF reader, and return the resulting Form."
	"	HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif'	 "
	"	HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif'	 "

	| doc ggg |
	doc _ self httpGet: url accept: 'image/gif'.
	doc class == String ifTrue: [
		self inform: 'The server with that GIF is not responding'.
		^ ColorForm extent: 20@20 depth: 8].
	doc binary; reset.
	(ggg _ GIFReadWriter new) setStream: doc.
	^ ggg nextImage.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:37' prior: 22004623!
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: 'hg 2/11/2002 11:32'!
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]
		ifNil: [''].
	page _ page, argString.

	s _ HTTPSocket new. 
	s _ self initHTTPSocket: httpUrl wait: (self deadlineSecs: 30) ifError: [:errorString | ^errorString].
	Transcript cr; show: url; cr.
	s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		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"

	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: [
			Transcript show: 'Response: ' , s responseCode.
			Transcript show: ' redirecting to: ', newUrl; cr.
			s destroy.
			"^self httpPostDocument: newUrl  args: argsDict  accept: mimeType"
			^self httpGetDocument: newUrl accept: mimeType ] ].

	aStream _ s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'umur 6/25/2003 14:24' prior: 36903551!
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]
		ifNil: [''].
	page _ page, argString.

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

	argString first = $? ifTrue: [ argString _ argString copyFrom: 2 to: argString size].
	"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!
]style[(77 993 150 561 229 369)f1b,f1,f1cmagenta;,f1,f1cmagenta;,f1! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'md 11/14/2003 16:40' prior: 36905785!
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]
		ifNil: [''].
	page _ page, argString.

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

	argString first = $? ifTrue: [ argString _ argString copyFrom: 2 to: argString size].
	"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!
]style[(77 993 150 561 228 369)f1b,f1,f1cmagenta;,f1,f1cmagenta;,f1! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'daf 2/28/2004 18:56' prior: 36908330!
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]
		ifNil: [''].
	page _ page, argString.

	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"

	argString first = $? ifTrue: [ argString _ argString copyFrom: 2 to: argString size].
	"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!
]style[(77 693 21 303 150 561 228 369)f1b,f1,f2,f1,f1cmagenta;,f1,f1cmagenta;,f1! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ls 11/3/2002 14:04'!
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 _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'.
	"encode the arguments dictionary"
	argsStream _ WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, CrLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: 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"
		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: 'daf 2/28/2004 18:58' prior: 36913438!
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 _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'.
	"encode the arguments dictionary"
	argsStream _ WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, CrLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: 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: 'ls 11/3/2002 14:04'!
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 _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '---------SuperSwiki',Time millisecondClockValue printString,'-----'.
	contentsData _ String streamContents: [ :strm |
		strm nextPutAll: mimeBorder, CrLf.
		argsDict associationsDo: [:assoc |
			assoc value do: [ :value |
				strm
					nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"';
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: value;
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: mimeBorder;
					nextPutAll: CrLf.
			]
		].
	].

  	"make the request"	
	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"
		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: 'daf 2/28/2004 18:58' prior: 36922233!
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 _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '---------SuperSwiki',Time millisecondClockValue printString,'-----'.
	contentsData _ String streamContents: [ :strm |
		strm nextPutAll: mimeBorder, CrLf.
		argsDict associationsDo: [:assoc |
			assoc value do: [ :value |
				strm
					nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"';
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: value;
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: mimeBorder;
					nextPutAll: CrLf.
			]
		].
	].

  	"make the request"	
	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: 'ls 11/3/2002 14:04'!
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 _ HTTPProxyServer.
		port _ 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,
		'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: 'al 1/8/2004 12:50' prior: 36928032!
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 _ HTTPProxyServer.
		port _ 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: 'proxy settings' stamp: 'mir 8/23/2002 14:28'!
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].

	HTTPProxyServer _ entries at: 'host' ifAbsent: [nil].
	HTTPProxyPort _ (entries at: 'port' ifAbsent: ['80']) asInteger ifNil: [self defaultPort].
	HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: [nil])! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'nk 7/6/2003 07:30'!
httpProxyPort
	"Answer the name of my HTTP proxy server port, or nil."
	^HTTPProxyPort! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'nk 7/6/2003 07:30'!
httpProxyServer
	"Answer the name of my HTTP proxy server, or nil."
	^HTTPProxyServer! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 8/23/2002 14:29'!
proxySettingsFileName
	^'proxySettings'! !

!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: 'al 1/8/2004 12:27' prior: 22019189!
stopUsingProxyServer
	"Stop directing HTTP request through a proxy server."

	HTTPProxyServer _ nil.
	HTTPProxyPort _ 80.
	HTTPProxyCredentials _ ''
! !

!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: '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: 'ls 11/3/2002 14:05'!
initHTTPSocket: httpUrl wait: timeout ifError: aBlock
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	| serverName port serverAddr s |
	Socket initializeNetwork.

	serverName _ httpUrl authority.
	port _ httpUrl port ifNil: [self defaultPort].

	(self shouldUseProxy: serverName) ifTrue: [ 
		serverName _ HTTPProxyServer.
		port _ HTTPProxyPort].

  	"make the request"	
	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: 'nk 4/13/2002 13:00'!
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 _ (PopUpMenu labels: 'Retry\Give Up' withCRs)
				startUpWithCaption: troubleString.
			sema signal.
		].
		sema wait.
		response = 2 ifTrue: [abortActionBlock value. ^ false]].
	^ true
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'hg 2/11/2002 11:31'!
userAgentString 
	"self userAgentString"

	^'User-Agent: ',
		SystemVersion current version, '-', 
		SystemVersion current highestUpdate printString! !

!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: 'drawing' stamp: 'dgd 2/22/2003 13:46' prior: 22025747!
drawOn: aCanvas 
	"Draw this morph only if it has no target."

	target isNil ifTrue: [^super drawOn: aCanvas].
	Preferences showBoundsInHalo 
		ifTrue: 
			[aCanvas 
				frameAndFillRectangle: target boundsInWorld
				fillColor: Color transparent
				borderWidth: 1
				borderColor: Color blue]! !

!HaloMorph methodsFor: 'drawing' stamp: 'nk 6/13/2003 13:27' prior: 36937811!
drawOn: aCanvas 
	"Draw this morph only if it has no target."

	target isNil ifTrue: [^super drawOn: aCanvas].
	Preferences showBoundsInHalo 
		ifTrue: 
			[aCanvas 
				frameAndFillRectangle: self bounds
				fillColor: Color transparent
				borderWidth: 1
				borderColor: Color blue]! !

!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: '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: 'ar 8/8/2001 17:33'!
popUpFor: aMorph event: evt
	"This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame."
	| hand anEvent |
	self flag: #workAround. "We should really have some event/hand here..."
	evt isNil
		ifTrue:[	hand _ aMorph world activeHand.
				hand ifNil:[hand _ aMorph world primaryHand].
				anEvent _ hand lastEvent transformedBy: (aMorph transformedFrom: nil)]
		 ifFalse:[hand _ evt hand.
				anEvent _ evt].
	self target: aMorph.
	hand halo: self.
	hand world addMorphFront: self.
	positionOffset _ anEvent position - (aMorph point: aMorph position in: owner).
	self startStepping.
	(Preferences haloTransitions or:[self isMagicHalo]) ifTrue:[
		self magicAlpha: 0.0.
		self startSteppingSelector: #fadeInInitially.
	].! !

!HaloMorph methodsFor: 'events' stamp: 'aoy 2/17/2003 01:27' prior: 36939782!
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-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: 'geometry testing' stamp: 'dgd 2/22/2003 13:46' prior: 22026364!
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: '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 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: 'gm 2/22/2003 13:13' prior: 22058915!
addFontEmphHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseEmphasisOrAlignment
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13' prior: 22059150!
addFontSizeHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseFont
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13' prior: 22059370!
addFontStyleHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseStyle
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 11/16/2002 19:24' prior: 22060904!
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: '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/2/2001 22:18'!
openViewerForTarget: evt with: aHandle
	"Open  a viewer for my inner target"

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	innerTarget openViewerForArgument! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:19'!
tearOffTileForTarget: evt with: aHandle
	"Tear off a tile representing my inner target"

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	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: 'ar 8/8/2001 14:34'!
initialize

	super initialize.
	self color: (Color r: 0.6 g: 0.8 b: 1.0).
	growingOrRotating _ false.
	simpleMode _ Preferences  simpleHalosInForce.! !

!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:29' prior: 36946962!
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: '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' prior: 22030815!
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: 'aoy 2/17/2003 01:28' prior: 22031133!
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: 
			["adjust halo bounds if appropriate"

			submorphs size > 1 ifTrue: [self addHandles].	"recreates full set with new bounds"
			self bounds: newBounds]! !

!HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:32' prior: 36949613!
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: '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: 'private' stamp: 'ar 10/8/2001 14:34'!
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';
		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.
	self addMorph: centerHandle.
	centerHandle setCenteredBalloonText: 'Set rotation center';
			on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self;
			on: #mouseMove send: #trackCenterOfRotation:with: to: self;
			on: #mouseUp send: #setCenterOfRotation:with: to: self
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15' prior: 22034038!
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: 'ar 8/8/2001 14:45'!
addHandle: handleSpec on: eventName send: selector to: recipient
	"Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle aPoint iconName colorToUse |
	aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement.
	handle _ EllipseMorph
		newBounds: (Rectangle center: aPoint extent: HandleSize asPoint)
		color: (colorToUse _ Color colorFrom: handleSpec color).
	self addMorph: handle.
	(iconName _ handleSpec iconSymbol) ifNotNil:
		[ | form |
		form _ ScriptingSystem formAtKey: iconName.
		form ifNotNil:
			[handle addMorphCentered: (ImageMorph new
				image: form; 
				color: colorToUse makeForegroundColor;
				lock)]].
	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	self isMagicHalo ifTrue:[
		handle on: #mouseEnter send: #handleEntered to: self.
		handle on: #mouseLeave send: #handleLeft to: self].
	handle setBalloonText: (target balloonHelpTextForHandle: handle).
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15' prior: 36953908!
addHandle: handleSpec on: eventName send: selector to: recipient
	"Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle aPoint iconName colorToUse |
	aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement.
	handle _ EllipseMorph
		newBounds: (Rectangle center: aPoint extent: HandleSize asPoint)
		color: (colorToUse _ Color colorFrom: handleSpec color).
	self addMorph: handle.
	(iconName _ handleSpec iconSymbol) ifNotNil:
		[ | form |
		form _ ScriptingSystem formAtKey: iconName.
		form ifNotNil:
			[handle addMorphCentered: (ImageMorph new
				image: form; 
				color: colorToUse makeForegroundColor;
				lock)]].
	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	self isMagicHalo ifTrue:[
		handle on: #mouseEnter send: #handleEntered to: self.
		handle on: #mouseLeave send: #handleLeft to: self].
	handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15' prior: 22036160!
addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient
	"Add a handle centered at the given point with the given color, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle |
	handle _ EllipseMorph
		newBounds: (Rectangle center: aPoint extent: self handleSize asPoint)
		color: aColor.
	self addMorph: handle.
	iconName ifNotNil:
		[ | form |
		form _ ScriptingSystem formAtKey: iconName.
		form ifNotNil:
			[handle addMorphCentered: (ImageMorph new
				image: form; 
				color: aColor makeForegroundColor;
				lock)]].
	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
	^ handle
! !

!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: '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 7/20/2001 00:19'!
doGrow: evt with: growHandle
	"Called while the mouse is down in the grow handle"

	| newExtent extentToUse |
	evt hand obtainHalo: self.
	newExtent _ (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
								- target topLeft.
	evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint].
	(newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self].
	target renderedMorph setExtentFromHalo: (extentToUse _ newExtent).
	growHandle position: evt cursorPoint - (growHandle extent // 2).
	self layoutChanged.
	(self valueOfProperty: #commandInProgress) doIfNotNil:  
		[:cmd | "Update the final extent"
		cmd redoTarget: target selector: #setExtentFromHalo: argument: extentToUse]
! !

!HaloMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:21' prior: 36958926!
doGrow: evt with: growHandle
	"Called while the mouse is down in the grow handle"

	| newExtent extentToUse |
	evt hand obtainHalo: self.
	newExtent _ (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
								- target topLeft.
	evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint].
	(newExtent x = 0 or: [newExtent y = 0]) 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 selector: #setExtentFromHalo: argument: extentToUse]
! !

!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: 'md 12/12/2003 16:21' prior: 22045823!
doRot: evt with: rotHandle
	"Update the rotation of my target if it is rotatable.  Keep the relevant command object up to date."

	| degrees |
	evt hand obtainHalo: self.
	degrees _ (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees.
	degrees _ degrees - angleOffset degrees.
	degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false.
	degrees = 0.0
		ifTrue: [rotHandle color: Color lightBlue]
		ifFalse: [rotHandle color: Color blue].
	rotHandle submorphsDo:
		[:m | m color: rotHandle color makeForegroundColor].
	self removeAllHandlesBut: rotHandle.
	self showingDirectionHandles ifFalse:
		[self showDirectionHandles: true addHandles: false].
	self addDirectionHandles.

	target rotationDegrees: degrees.

	rotHandle position: evt cursorPoint - (rotHandle extent // 2).
	(self valueOfProperty: #commandInProgress) ifNotNilDo:
		[:cmd | "Update the final rotation"
		cmd redoTarget: target selector: #rotationDegrees: argument: degrees].
	self layoutChanged! !

!HaloMorph methodsFor: 'private' stamp: 'ar 8/8/2001 15:33'!
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 == nil]) ifTrue: [^ self].
	[target isFlexMorph and: [target hasNoScaleOrRotation]]
		whileTrue:
			[m _ target firstSubmorph.
			target removeFlexShell.
			target _ m].
	self isInWorld ifTrue:
		["make sure handles show in front, even if flex shell added"
		self comeToFront.
		self addHandles].
	(self valueOfProperty: #commandInProgress) doIfNotNil:
		[:cmd | self rememberCommand: cmd.
		self removeProperty: #commandInProgress] 
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 13:46' prior: 36962568!
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) doIfNotNil: 
			[:cmd | 
			self rememberCommand: cmd.
			self removeProperty: #commandInProgress]! !

!HaloMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:21' prior: 36963265!
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: 'aoy 2/15/2003 21:10' prior: 22048160!
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: 'sw 4/19/2002 23:56'!
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' trueChoice: 'Yes' falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]].

			Preferences preserveTrash
				ifTrue:
					[Preferences soundsEnabled ifTrue:
						[TrashCanMorph playDeleteSound].
					self stopStepping.
					super delete.
					target slideToTrash: evt]
				ifFalse:
					[self delete.
					target dismissViaHalo]]! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/5/2003 18:32' prior: 36965019!
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]].

			Preferences preserveTrash
				ifTrue:
					[Preferences soundsEnabled ifTrue:
						[TrashCanMorph playDeleteSound].
					self stopStepping.
					super delete.
					target slideToTrash: evt]
				ifFalse:
					[self delete.
					target dismissViaHalo]]! !

!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: '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: '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: '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: '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: 'aoy 2/17/2003 01:27' prior: 22051910!
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' prior: 22052216!
showingDirectionHandles
	^directionArrowAnchor notNil! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:11'!
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.
	(self world viewBox containsPoint: botRt)
		ifTrue: [positionOffset _ evt cursorPoint - botRt]
		ifFalse: [positionOffset _ 0@0].
	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: 'resizing';
			undoTarget: target selector: #setExtentFromHalo: argument: target extent)! !

!HaloMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:28' prior: 36968969!
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: 'resizing';
				undoTarget: target
					selector: #setExtentFromHalo:
					argument: target extent)! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 10/8/2003 19:07' prior: 36969600!
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: 'resizing' translated;
			undoTarget: target selector: #setExtentFromHalo: argument: target extent)! !

!HaloMorph methodsFor: 'private' stamp: 'di 11/28/2001 18:25'!
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: 'rotating';
			undoTarget: target selector: #rotationDegrees: argument: target rotationDegrees)

! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 8/26/2003 21:44' prior: 36970848!
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: 'rotating' translated;
			undoTarget: target selector: #rotationDegrees: argument: target rotationDegrees)

! !

!HaloMorph methodsFor: 'private' stamp: 'di 11/28/2001 18:25'!
startScale: evt with: scaleHandle
	"Initialize scaling of my target."

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle.
	target isFlexMorph ifFalse: [target addFlexShellIfNecessary].
	growingOrRotating _ true.
	positionOffset _ 0@0
! !

!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 class methodsFor: 'class initialization' stamp: 'nk 7/3/2003 19:35' prior: 22064692!
initialize
	"HaloMorph initialize"

	Preferences preferenceAt: #haloEnclosesFullBounds ifAbsent: [
		Preferences addPreference: #haloEnclosesFullBounds
			category: #halos
			default: false
			balloonHelp: 'if true, halos will enclose the full bounds of the target Morph, rather than just the bounds'
	].
  
	HandleSize _ 16! !

!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, ')'! !

!HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0!
Sets spec's for how handles are layed out in a halo.!
!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! !

!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: '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: 'cursor' stamp: 'ar 8/18/2001 00:50'!
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 == nil
		ifTrue: [temporaryCursor _ temporaryCursorOffset _ nil]
		ifFalse: [temporaryCursor _ cursorOrNil asCursorForm.
				temporaryCursorOffset _ temporaryCursor offset - hotSpotOffset].
	bounds _ self cursorBounds.
	self 
		userInitials: userInitials andPicture: (self userPicture);
		layoutChanged;
		changed
! !

!HandMorph methodsFor: 'cursor' stamp: 'dgd 2/21/2003 22:49' prior: 36974998!
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 := nil]
		ifFalse: 
			[temporaryCursor := cursorOrNil asCursorForm.
			temporaryCursorOffset := temporaryCursor offset - hotSpotOffset].
	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: 'cursor' stamp: 'NS 2/17/2001 11:01' prior: 36976381!
temporaryCursor
	^ temporaryCursor! !

!HandMorph methodsFor: 'double click support' stamp: 'jcg 9/21/2001 13:22'!
waitForClicksOrDrag: aMorph event: evt
	"Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." 
	^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: 10! !

!HandMorph methodsFor: 'double click support' stamp: 'jcg 9/21/2001 13:19'!
waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold
	"Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." 
	mouseClickState _ 
		MouseClickState new
			client: aMorph 
			click: clickAndDragSelectors first 
			dblClick: clickAndDragSelectors second 
			dblClickTime: DoubleClickTime 
			dblClickTimeout: clickAndDragSelectors third
			drag: clickAndDragSelectors fourth 
			threshold: threshold 
			event: evt.! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:25'!
drawOn: aCanvas
	| userPic |
	"Draw the hand itself (i.e., the cursor)."

	temporaryCursor == nil
		ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft]
		ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft].
	self hasUserInformation ifTrue: [
		aCanvas 
			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:43' prior: 36978955!
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: 'ar 12/30/2001 19:13'!
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 == nil 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: 'dgd 2/21/2003 22:44' prior: 36980120!
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: 'dgd 2/21/2003 22:46' prior: 22074585!
hasUserInformation
	^self userInitials notEmpty or: [self userPicture notNil]! !

!HandMorph methodsFor: 'drawing' stamp: 'nk 5/6/2003 20:55' prior: 22074731!
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."
	(savedPatch notNil
		or: [ (submorphs anySatisfy: [ :ea | ea visible ])
			or: [ temporaryCursor notNil
				or: [ self hasUserInformation ]]])
		ifTrue: [
			"using the software cursor; hide the hardware one"
			Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show].
			^ true].

	^ false
! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49' prior: 22076902!
restoreSavedPatchOn: aCanvas 
	"Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor."

	hasChanged := false.
	savedPatch ifNotNil: 
			[aCanvas drawImage: savedPatch at: savedPatch offset.
			self hasUserInformation ifTrue: [^self].	"cannot use hw cursor if so"
			submorphs notEmpty ifTrue: [^self].
			temporaryCursor ifNotNil: [^self].

			"Make the transition to using hardware cursor. Clear savedPatch and
		 report one final damage rectangle to erase the image of the software cursor."
			super invalidRect: (savedPatch offset 
						extent: savedPatch extent + self shadowOffset)
				from: self.
			Sensor currentCursor == Cursor normal ifFalse: [Cursor normal show].	"show hardware cursor"
			savedPatch := nil]! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49' prior: 22077798!
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: 'ar 2/1/2002 02:14'!
updateCacheCanvas: aCanvas
	"Update the cached image of the morphs being held by this hand."
	| subBnds rectList nPix |
	"Note: The following is an attempt to quickly get out if there's no change"
	subBnds _ Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	rectList _ damageRecorder invalidRectsFullBounds: 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 == nil or: [cacheCanvas extent ~= subBnds extent]) ifTrue: [
		cacheCanvas _ (aCanvas allocateForm: subBnds extent) getCanvas.
		cacheCanvas translateBy: subBnds origin negated
			during:[:tempCanvas| self drawSubmorphsOn: tempCanvas].
		self submorphsDo:
			[:m | (m areasRemainingToFill: subBnds) isEmpty
				ifTrue: [^ cachedCanvasHasHoles _ false]].
		nPix _ cacheCanvas form tallyPixelValues at: 1.
		"--> begin rounded corners hack <---"
		(nPix = 48 and:[submorphs size = 1 and:[submorphs first wantsRoundedCorners]])
			ifTrue:[cachedCanvasHasHoles _ false]
			ifFalse:[cachedCanvasHasHoles _ 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: 'dgd 2/21/2003 22:49' prior: 36988712!
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: 'event handling' stamp: 'RAA 8/22/2001 17:07'!
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 eventQueue ifNil: [^nil]) nextOrNilSuchThat: [ :buf |
		(buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar] 
	].
	evtBuf ifNil: [^nil].
	^self generateKeyboardEvent: evtBuf
! !

!HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43' prior: 36992064!
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 eventQueue ifNil: [^nil]) nextOrNilSuchThat: 
					[:buf | 
					buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]].
	evtBuf ifNil: [^nil].
	^self generateKeyboardEvent: evtBuf! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 3/18/2001 00:52'!
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 == nil or:[ActiveWorld == owner]) ifTrue:[^pos].
	^ActiveWorld point: pos from: owner.! !

!HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43' prior: 36993139!
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: 'mir 11/13/2002 16:17'!
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) == nil] whileFalse:[
		evt _ nil. "for unknown event types"
		type _ evtBuf at: 1.
		(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 == nil 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: 'event handling' stamp: 'dgd 2/21/2003 22:48' prior: 36994110!
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: 'ar 3/18/2001 01:47'!
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:[
	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 7/20/2003 10:02' prior: 36997057!
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 08:45'!
isCapturingGesturePoints
	^self isGenieRecognizing and: [ self giveGenieChanceToEscape not ]
! !

!HandMorph methodsFor: 'events-processing' stamp: 'nk 2/15/2004 09:01' prior: 37000930!
isCapturingGesturePoints
	^false! !

!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:10'!
compositionWindowManager

	^ self class compositionWindowManager.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'NS 2/17/2001 18:02'!
mouseFocus: aMorphOrNil
	(self prepareMouseFocusChangeFrom: mouseFocus to: aMorphOrNil)
		ifTrue: [mouseFocus _ aMorphOrNil].! !

!HandMorph methodsFor: 'focus handling' stamp: 'NS 2/17/2001 18:02' prior: 37001362!
mouseFocus: aMorphOrNil
	(self prepareMouseFocusChangeFrom: mouseFocus to: aMorphOrNil)
		ifTrue: [mouseFocus _ aMorphOrNil].! !

!HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44' prior: 37001577!
mouseFocus: aMorphOrNil
	mouseFocus _ aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:11' prior: 22085983!
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: 'dgd 2/21/2003 22:48' prior: 22086767!
newMouseFocus: aMorph event: event 
	aMorph isNil 
		ifFalse: [targetOffset := event cursorPoint - aMorph position].
	^self newMouseFocus: aMorph! !

!HandMorph methodsFor: 'geometry' stamp: 'ar 3/20/2001 20:34'!
position

	^temporaryCursor
		ifNil: [bounds topLeft]
		ifNotNil: [bounds topLeft - temporaryCursorOffset]! !

!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 12/2/2001 21:42'!
dropMorph: aMorph event: anEvent
	"Drop the given morph which was carried by the hand"
	| event dropped |
	(anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self].
	self privateRemoveMorph: aMorph.
	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 8/13/2003 11:39' prior: 37003452!
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: 'halo handling' stamp: 'RAA 2/13/2001 17:24'!
removeHaloFromClick: anEvent on: aMorph
	| halo |
	halo _ self halo ifNil:[^self].
	(halo target hasOwner: self) ifTrue:[^self].
	(halo staysUpWhenMouseIsDownIn: aMorph) ifFalse:[
		halo delete.
		self removeProperty: #halo.
	].! !

!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: '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: 'ar 3/18/2001 01:25'!
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"
	self resetGenie. "the same here"
! !

!HandMorph methodsFor: 'initialization' stamp: 'ar 3/18/2001 01:25' prior: 37008403!
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"
	self resetGenie. "the same here"
! !

!HandMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:28' prior: 37008714!
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: 'listeners' stamp: 'dgd 2/21/2003 22:48' prior: 22096618!
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: '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 2/22/2003 18:46' prior: 22101715!
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 negated].
	dragType = 2 
		ifTrue: 
			["experimental drag move"

			].
	dragType = 3 
		ifTrue: 
			["experimental drag leave"

			owner borderWidth: 0].
	^nil! !

!HandMorph methodsFor: 'private events' stamp: 'dgd 3/31/2003 18:22' prior: 37010093!
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: 'dgd 2/22/2003 18:47' prior: 22102758!
generateKeyboardEvent: evtBuf 
	"Generate the appropriate mouse event for the given raw event buffer"

	| buttons modifiers type keyValue pressType stamp |
	stamp := evtBuf second.
	stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
	keyValue := evtBuf third.
	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.
	^KeyboardEvent new 
		setType: type
		buttons: buttons
		position: self position
		keyValue: keyValue
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'yo 7/25/2003 16:56' prior: 37012293!
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: 'ar 3/16/2001 00:33'!
generateMouseEvent: evtBuf
	"Generate the appropriate mouse event for the given raw event buffer"
	| position buttons modifiers type trail stamp oldButtons evtChanged |
	(evtBuf at: 1) = (lastEventBuffer at: 1) 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 at: 2).
	stamp = 0 ifTrue:[stamp _ Time millisecondClockValue].
	position _ (evtBuf at: 3) @ (evtBuf at: 4).
	buttons _ (evtBuf at: 5).
	modifiers _ (evtBuf at: 6).
	buttons = 0 
		ifTrue:[	(lastEventBuffer at: 5) = 0
					ifTrue:[type _ #mouseMove]
					ifFalse:[type _ #mouseUp]]
		ifFalse:[	(lastEventBuffer at: 5) = 0
					ifTrue:[type _ #mouseDown]
					ifFalse:[type _ #mouseMove]].
	buttons _ buttons bitOr: (modifiers bitShift: 3).
	oldButtons _ (lastEventBuffer at: 5) bitOr: ((lastEventBuffer at: 6) bitShift: 3).
	lastEventBuffer _ evtBuf.
	type == #mouseMove ifTrue:[
		trail _ self mouseTrailFrom: evtBuf.
		^MouseMoveEvent new 
			setType: type 
			startPoint: trail first
			endPoint: trail last 
			trail: trail
			buttons: buttons
			hand: self
			stamp: stamp.
	].
	^MouseButtonEvent new 
		setType: type 
		position: position
		which: (oldButtons bitXor: buttons)
		buttons: buttons 
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'gm 2/28/2003 01:10' prior: 37013802!
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: trail first
				endPoint: trail last
				trail: trail
				buttons: buttons
				hand: self
				stamp: stamp].
	^MouseButtonEvent new 
		setType: type
		position: position
		which: (oldButtons bitXor: buttons)
		buttons: buttons
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'dgd 2/22/2003 14:58' prior: 22104643!
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 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: 'ar 3/18/2001 01:46'!
sendKeyboardEvent: 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 keyboardFocus clear:[self keyboardFocus: nil]! !

!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: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:06'!
autoFocusRectangleBoundsFor: aMorph
	^aMorph bounds! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:15'!
disableGenieFocus
! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:47'!
enableGenie
	self error: 'Genie is not available for this hand'.! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:44'!
focusStartEvent
	^nil! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:06'!
genieGestureProcessor
	^nil! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:45'!
isGenieAvailable
	"Answer whether the Genie gesture recognizer is available for this hand"
	^false! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:46'!
isGenieEnabled
	"Answer whether the Genie gesture recognizer is enabled for this hand"
	^false! !

!HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:46'!
isGenieFocused
	"Answer whether the Genie gesture recognizer is auto-focused for this hand"
	^false! !

!HandMorph methodsFor: 'multilingual' stamp: 'yo 9/26/2003 22:11'!
clearKeyboardInterpreter

	keyboardInterpreter _ nil.
! !

!HandMorph methodsFor: 'multilingual' stamp: 'yo 9/26/2003 11:51'!
keyboardInterpreter

	keyboardInterpreter ifNil: [keyboardInterpreter _ Smalltalk systemLanguage defaultInputInterpreter].
	^ keyboardInterpreter.
! !

!HandMorph class methodsFor: 'accessing' stamp: 'yo 11/24/2003 06:23'!
compositionWindowManager

	CompositionWindowManager ifNotNil: [^ CompositionWindowManager].
	(Smalltalk platformName = 'Win32') ifTrue: [
		^ CompositionWindowManager _ ImmWin32 new.
	].
	((Smalltalk platformName = 'unix') and: [(Smalltalk getSystemAttribute: 1005) = 'X11']) ifTrue: [
		^ CompositionWindowManager _ ImmX11 new.
	].

	^ CompositionWindowManager _ ImmAbstractPlatform new.
! !

!HandMorph class methodsFor: 'class initialization' stamp: 'di 2/20/2001 00:44'!
initialize
	"HandMorph initialize"

	PasteBuffer _ nil.
	DoubleClickTime _ 350.
	NormalCursor _ ColorForm mappingWhiteToTransparentFrom: Cursor normal.
! !

!HandMorph class methodsFor: 'class initialization' stamp: 'kfr 7/13/2003 14:15' prior: 37021256!
initialize
	"HandMorph initialize"

	PasteBuffer _ nil.
	DoubleClickTime _ 350.
	NormalCursor _ CursorWithMask normal asCursorForm.
! !

!HandMorph class methodsFor: 'utilities' stamp: 'nk 7/20/2003 10:03' prior: 22108921!
showEvents: aBool
	"HandMorph showEvents: true"
	"HandMorph showEvents: false"
	ShowEvents _ aBool.
	aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].! !

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

!HandMorphForReplay methodsFor: 'event handling' stamp: 'dgd 2/22/2003 13:25' prior: 22109803!
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]! !

!HandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:30' prior: 22112427!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 8 @ 8.
	! !

!HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15' prior: 22112939!
stepTime
	"Update every hundredth of a second."
	^ 10
! !

!HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'!
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]] ! !

!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.!
!HashTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
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 ! !

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

!HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0!
I am a simple test case to check that HashTester works correctly!
!HeadMorph methodsFor: 'furnitures' stamp: 'dgd 3/7/2003 14:31' prior: 22117870!
addRandomFurnitures

	self perform: #(#yourself #addBeret #addHighHat #addAfroHair #addShortHair #addSpikyHair ) atRandom.
	self perform: #(#yourself #yourself #addShortMustache ) 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: 'dgd 3/7/2003 14:32' prior: 22114277!
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! !

!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' prior: 22121517!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	degrees _ 90.0.
	magnitude _ 1.0.
	
	self extent: 160 @ 160! !

!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' prior: 22123570!
mouseMove: evt

	self mouseDown: evt! !

!Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'!
isHeap

	^ true! !

!Heap methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:05' prior: 22127205!
= anObject

	^ self == anObject
		ifTrue: [true]
		ifFalse: [anObject isHeap
			ifTrue: [sortBlock = anObject sortBlock and: [super = anObject]]
			ifFalse: [super = anObject]]! !

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

!HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 6/15/2003 13:40' prior: 22138650!
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 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.
					authority := authority copyFrom: 1 to: lastColonIndex - 1]].

	"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: $:]].

	"get the path"
	path := self privateParsePath: remainder relativeTo: #() .! !

!HierarchicalUrl methodsFor: 'parsing' stamp: 'mu 12/24/2003 16:03' prior: 37028276!
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 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']].

	"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: $:]].

	"get the path"
	path := self privateParsePath: remainder relativeTo: #() .! !

!HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 6/15/2003 13:40' prior: 22140392!
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: 'ls 6/15/2003 13:27' prior: 22142408!
toText
	| ans |
	ans _ WriteStream on: String new.
	ans nextPutAll: self schemeName.
	ans nextPutAll: '://'.
	self username ifNotNil: [
		ans nextPutAll: self username.
		self password ifNotNil: [
			ans nextPutAll: ':'.
			ans nextPutAll: self password ].
		ans nextPutAll: '@' ].
	ans nextPutAll: self authority.
	port ifNotNil: [ans nextPut: $:; print: port].
	path do: [ :pathElem |
		ans nextPut: $/.
		ans nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		ans nextPut: $?.
		ans nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		ans nextPut: $#.
		ans nextPutAll: self fragment encodeForHTTP. ].
	
	^ans contents! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'!
password
	"http://user:pword@foo.com' asUrl password"
	^password! !

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

!HierarchyBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'!
defaultBrowserTitle
	^ 'Hierarchy Browser'! !

!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: 'class list' stamp: 'sw 3/24/2002 01:55'!
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 class methodsFor: 'as yet unclassified' stamp: 'dew 9/15/2001 16:19'!
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"! !

!HttpUrl methodsFor: 'downloading' stamp: 'ar 3/18/2001 00:54'!
askNamePassword
	"Authorization is required by the host site.  Ask the user for a userName and password.  Encode them and store under this realm.  Return false if the user wants to give up."

	| user password |
	(self confirm: 'Host ', self toText, '
wants a different user and password.  Type them now?' orCancel: [false])
		ifFalse: [^ false].
	"Note: When Scamper is converted to run under MVC, we'll have to pass in topView in order to decide which FillInTheBlank to call."
	user _ FillInTheBlank request: 'User account name?' initialAnswer: '' 
				centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint - (50@0).
	password _ FillInTheBlank requestPassword: 'Password?'.
	Passwords at: realm put: (Authorizer new encode: user password: password).
	^ true! !

!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 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
!
!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/10/2003 14:06'!
addTemp: tempName

	self addTemps: {tempName}! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/10/2003 14:06' prior: 37037892!
addTemp: tempName

	self addTemps: {tempName}! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:07'!
addTemps: tempKeys

	| otherKeys i |
	otherKeys _ ir otherTempKeys.
	i _ ir numArgs + otherKeys size.
	tempKeys do: [:key |
		tempMap at: key put: (i _ i + 1)].
	ir otherTempKeys: otherKeys, tempKeys.
! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:07' prior: 37038140!
addTemps: tempKeys

	| otherKeys i |
	otherKeys _ ir otherTempKeys.
	i _ ir numArgs + otherKeys size.
	tempKeys do: [:key |
		tempMap at: key put: (i _ i + 1)].
	ir otherTempKeys: otherKeys, tempKeys.
! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/10/2003 14:10'!
primitiveNode: primNode

	ir primitiveNode: primNode! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/10/2003 14:10' prior: 37038700!
primitiveNode: primNode

	ir primitiveNode: primNode! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:12'!
rargs: tempKeys

	tempKeys withIndexDo: [:key :i |
		tempMap at: key put: i - 1].
	ir rargKeys: tempKeys.
! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:12' prior: 37038962!
rargs: tempKeys

	tempKeys withIndexDo: [:key :i |
		tempMap at: key put: i - 1].
	ir rargKeys: tempKeys.
! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:06'!
thisContext: tempKey

	tempMap at: tempKey put: -1! !

!IRBuilder methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:06' prior: 37039332!
thisContext: tempKey

	tempMap at: tempKey put: -1! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/11/2003 10:58'!
getField: instVarIndex
	"Receiver must be on top"

	self pushLiteral: instVarIndex.
	self send: #getInstVar:.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/11/2003 10:58' prior: 37039592!
getField: instVarIndex
	"Receiver must be on top"

	self pushLiteral: instVarIndex.
	self send: #getInstVar:.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:25'!
jumpAheadTarget: labelSymbol
	"Pop latest jumpAheadTo: with this labelSymbol and have it point to this new instruction sequence"

	| jumpInstr |
	self startNewSequence.
	jumpInstr _ (jumpAheadStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast.
	jumpInstr destination: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:25' prior: 37039974!
jumpAheadTarget: labelSymbol
	"Pop latest jumpAheadTo: with this labelSymbol and have it point to this new instruction sequence"

	| jumpInstr |
	self startNewSequence.
	jumpInstr _ (jumpAheadStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast.
	jumpInstr destination: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44'!
jumpAheadTo: labelSymbol
	"Jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This is and its corresponding target is only good for one use.  Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	"jumpAheadTarget: label will pop this and replace destination with its basic block"
	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (self add: IRJump new).
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44' prior: 37040820!
jumpAheadTo: labelSymbol
	"Jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This is and its corresponding target is only good for one use.  Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	"jumpAheadTarget: label will pop this and replace destination with its basic block"
	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (self add: IRJump new).
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44'!
jumpAheadTo: labelSymbol if: boolean
	"Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This and its corresponding target is only good for one use.  Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	| instr |
	"jumpAheadTarget: label will pop this and replace destination with its basic block"
	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (instr _ self add: (IRJumpIf new boolean: boolean)).
	self startNewSequence.
	instr otherwise: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44' prior: 37042044!
jumpAheadTo: labelSymbol if: boolean
	"Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self.  This and its corresponding target is only good for one use.  Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."

	| instr |
	"jumpAheadTarget: label will pop this and replace destination with its basic block"
	(jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: (instr _ self add: (IRJumpIf new boolean: boolean)).
	self startNewSequence.
	instr otherwise: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44'!
jumpBackTarget: labelSymbol
	"Remember this basic block for a future jumpBackTo: labelSymbol.  Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name."

	self startNewSequence.
	(jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44' prior: 37043466!
jumpBackTarget: labelSymbol
	"Remember this basic block for a future jumpBackTo: labelSymbol.  Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name."

	self startNewSequence.
	(jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
		addLast: currentSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:25'!
jumpBackTo: labelSymbol
	"Pop last remembered position with this label and write an unconditional jump to it"

	| sequence |
	sequence _ (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast.
	self add: (IRJump new destination: sequence).
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:25' prior: 37044308!
jumpBackTo: labelSymbol
	"Pop last remembered position with this label and write an unconditional jump to it"

	| sequence |
	sequence _ (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast.
	self add: (IRJump new destination: sequence).
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'!
popTop

	self add: IRInstruction popTop! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09' prior: 37045140!
popTop

	self add: IRInstruction popTop! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'!
pushDup

	self add: IRInstruction pushDup! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09' prior: 37045380!
pushDup

	self add: IRInstruction pushDup! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'!
pushLiteral: object

	self add: (IRInstruction pushLiteral: object)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09' prior: 37045624!
pushLiteral: object

	self add: (IRInstruction pushLiteral: object)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:52'!
pushReceiver

	self add: (IRInstruction pushTemp: 0)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:52' prior: 37045920!
pushReceiver

	self add: (IRInstruction pushTemp: 0)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/17/2003 11:06'!
pushTemp: key

	| index |
	index _ tempMap at: key.
	self add: (IRInstruction pushTemp: index)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/17/2003 11:06' prior: 37046186!
pushTemp: key

	| index |
	index _ tempMap at: key.
	self add: (IRInstruction pushTemp: index)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:52'!
pushThisContext

	self add: (IRInstruction pushTemp: -1)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:52' prior: 37046536!
pushThisContext

	self add: (IRInstruction pushTemp: -1)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/15/2003 01:55'!
remoteReturn

	self add: IRInstruction remoteReturn.
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/15/2003 01:55' prior: 37046810!
remoteReturn

	self add: IRInstruction remoteReturn.
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/15/2003 01:55'!
returnTop

	self add: IRInstruction returnTop.
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/15/2003 01:55' prior: 37047126!
returnTop

	self add: IRInstruction returnTop.
	self startNewSequence.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'!
send: selector

	self add: (IRInstruction send: selector)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09' prior: 37047430!
send: selector

	self add: (IRInstruction send: selector)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'!
send: selector toSuperOf: behavior

	self add: (IRInstruction send: selector toSuperOf: behavior)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09' prior: 37047706!
send: selector toSuperOf: behavior

	self add: (IRInstruction send: selector toSuperOf: behavior)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 15:03'!
setField: instVarIndex
	"receiver must be on top with new field value underneath"

	self pushLiteral: instVarIndex.
	self send: #storeIn:instVar:.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 15:03' prior: 37048062!
setField: instVarIndex
	"receiver must be on top with new field value underneath"

	self pushLiteral: instVarIndex.
	self send: #storeIn:instVar:.
! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/17/2003 11:06'!
storeTemp: key

	| index |
	index _ tempMap at: key.
	self add: (IRInstruction storeTemp: index)! !

!IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/17/2003 11:06' prior: 37048518!
storeTemp: key

	| index |
	index _ tempMap at: key.
	self add: (IRInstruction storeTemp: index)! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/13/2003 13:20'!
add: instr

	"Associate instr with current parse node or byte range"
	instr sourceNode: self sourceNode.
	instr bytecodeIndex: self sourceByteIndex.
	^ currentSequence add: instr! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/13/2003 13:20' prior: 37048867!
add: instr

	"Associate instr with current parse node or byte range"
	instr sourceNode: self sourceNode.
	instr bytecodeIndex: self sourceByteIndex.
	^ currentSequence add: instr! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/17/2003 11:06'!
initialize

	ir _ IRMethod new.
	tempMap _ Dictionary new.
	jumpAheadStacks _ IdentityDictionary new.
	jumpBackTargetStacks _ IdentityDictionary new.
	sourceMapNodes _ OrderedCollection new.  "stack"

	"Leave an empty sequence up front (guaranteed not to be in loop)"
	ir startSequence: (IRSequence new orderNumber: 0).
	currentSequence _ IRSequence new orderNumber: 1.
	ir startSequence add: (IRJump new destination: currentSequence).
! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/17/2003 11:06' prior: 37049375!
initialize

	ir _ IRMethod new.
	tempMap _ Dictionary new.
	jumpAheadStacks _ IdentityDictionary new.
	jumpBackTargetStacks _ IdentityDictionary new.
	sourceMapNodes _ OrderedCollection new.  "stack"

	"Leave an empty sequence up front (guaranteed not to be in loop)"
	ir startSequence: (IRSequence new orderNumber: 0).
	currentSequence _ IRSequence new orderNumber: 1.
	ir startSequence add: (IRJump new destination: currentSequence).
! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/10/2003 17:45'!
startNewSequence
	"End current instruction sequence and start a new sequence to add instructions to.  If ending block just falls through to new block then add an explicit jump to it so they stay linked"

	| newSequence |
	currentSequence isEmpty ifTrue: [^ self].  "block is still empty, continue using it"
	newSequence _ IRSequence new
		orderNumber: currentSequence orderNumber + 1.
	currentSequence last isJumpOrReturn ifFalse: [
		self add: (IRJump new destination: newSequence)].
	currentSequence _ newSequence.
! !

!IRBuilder methodsFor: 'private' stamp: 'ajh 3/10/2003 17:45' prior: 37050399!
startNewSequence
	"End current instruction sequence and start a new sequence to add instructions to.  If ending block just falls through to new block then add an explicit jump to it so they stay linked"

	| newSequence |
	currentSequence isEmpty ifTrue: [^ self].  "block is still empty, continue using it"
	newSequence _ IRSequence new
		orderNumber: currentSequence orderNumber + 1.
	currentSequence last isJumpOrReturn ifFalse: [
		self add: (IRJump new destination: newSequence)].
	currentSequence _ newSequence.
! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:17'!
mapToByteIndex: index
	"decompiling"

	sourceMapByteIndex _ index! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:17' prior: 37051585!
mapToByteIndex: index
	"decompiling"

	sourceMapByteIndex _ index! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:45'!
mapToNode: object
	"new instructions will be associated with object"

	sourceMapNodes addLast: object! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:45' prior: 37051867!
mapToNode: object
	"new instructions will be associated with object"

	sourceMapNodes addLast: object! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:25'!
popMap

	sourceMapNodes removeLast! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:25' prior: 37052221!
popMap

	sourceMapNodes removeLast! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:19'!
sourceByteIndex
	"decompiling"

	^ sourceMapByteIndex! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:19' prior: 37052441!
sourceByteIndex
	"decompiling"

	^ sourceMapByteIndex! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 21:03'!
sourceNode

	^ sourceMapNodes isEmpty
		ifTrue: [nil]
		ifFalse: [sourceMapNodes last]! !

!IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 21:03' prior: 37052699!
sourceNode

	^ sourceMapNodes isEmpty
		ifTrue: [nil]
		ifFalse: [sourceMapNodes last]! !

!IRBuilder methodsFor: 'results' stamp: 'ajh 3/10/2003 15:51'!
ir

	^ ir! !

!IRBuilder methodsFor: 'results' stamp: 'ajh 3/10/2003 15:51' prior: 37053023!
ir

	^ ir! !

!IRBuilder methodsFor: 'decompiling' stamp: 'ajh 6/22/2003 14:44'!
addJumpBackTarget: label to: sequence

	(jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new])
		addLast: sequence! !

!IRBuilder methodsFor: 'decompiling' stamp: 'ajh 6/22/2003 14:44' prior: 37053197!
addJumpBackTarget: label to: sequence

	(jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new])
		addLast: sequence! !

!IRBuilder methodsFor: 'decompiling' stamp: 'ajh 3/21/2003 01:48'!
testJumpAheadTarget: label

	jumpAheadStacks at: label ifPresent: [:stack |
		[stack isEmpty] whileFalse: [self jumpAheadTarget: label]
	]! !

!IRBuilder methodsFor: 'decompiling' stamp: 'ajh 3/21/2003 01:48' prior: 37053615!
testJumpAheadTarget: label

	jumpAheadStacks at: label ifPresent: [:stack |
		[stack isEmpty] whileFalse: [self jumpAheadTarget: label]
	]! !

!IRBuilder commentStamp: 'ajh 5/23/2003 11:03' prior: 0!
I provide a simple interface for constructing an IRMethod.  For example, to create an ir method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in BytecodeGenerator), do:

	IRBuilder new
		rargs: #(self a);		"receiver and args names"
		addTemps: #(z);		"extra temps (not used here)"
		pushTemp: #self;
		getField: 1;
		pushTemp: #a;
		send: #>;
		jumpAheadTo: #else if: false;
		pushLiteral: 'yes';
		returnTop;
		jumpAheadTarget: #else;
		pushLiteral: 'no';
		returnTop;
		ir

Sending #compiledMethod to an ir method will generate its compiledMethod.  Sending #methodNode to it will decompile to its parse tree.
!
!IRBuilder class methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 17:56'!
new

	^ super new initialize! !

!IRBuilder class methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 17:56' prior: 37054773!
new

	^ super new initialize! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:49'!
addTemps: anArray 
	self addInstruction: #addTemps! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:27'!
blockReturnTop
	self addInstruction: #blockReturnTop.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:29'!
createBlock: size
	self addInstruction: #createBlock! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 6/3/2003 10:07'!
doDup
	self addInstruction: #doDup.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:50'!
doPop
	self addInstruction: #doPop.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:49'!
getField: aSmallInteger 
	self addInstruction: #getField.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:30'!
jumpAheadTarget: labelSymbol
	self addInstruction: #jumpAheadTarget:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:31'!
jumpAheadTo: labelSymbol
	self addInstruction: #jumpAheadTo:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:31'!
jumpAheadTo: labelSymbol if: boolean
	self addInstruction: #jumpAheadTo:if.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:31'!
jumpBackTarget: labelSymbol
	self addInstruction: #jumpBackTarget:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:32'!
jumpBackTo: labelSymbol
	self addInstruction: #jumpBackTo:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:32'!
jumpOverBlockTo: labelSymbol
	self addInstruction: #jumpOverBlockTo:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:32'!
localReturnTop
	self addInstruction: #localReturnTop.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:32'!
popTemp
	self addInstruction: #popTemp.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:33'!
pushLiteral: obj
	self addInstruction: #pushLiteral:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:33'!
pushTemp: tempKey
	self addInstruction: #pushTemp:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:33'!
pushThisContext
	self addInstruction: #pushThisContext.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:48'!
rargs: anArray 
	self addInstruction: #rargs.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:33'!
remoteReturn
	self addInstruction: #remoteReturn.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 7/14/2003 18:25'!
returnTop
	self addInstruction: #returnTop.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:34'!
send: selector
	self addInstruction: #send.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:34'!
send: selector toSuperOf: behavior
	self addInstruction: #send:toSuperOf:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:34'!
setField: instVarIndex
	self addInstruction: #setField::.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 6/9/2004 16:29' prior: 37057865!
setField: instVarIndex
	self addInstruction: #setField:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/19/2003 19:35'!
storeTemp: tempKey
	self addInstruction: #storeTemp:.! !

!IRBuilderMock methodsFor: 'instructions' stamp: 'md 5/23/2003 12:11'!
tempVarAt: aString 
	self addInstruction: #tempVarAt! !

!IRBuilderMock methodsFor: 'as yet unclassified' stamp: 'md 7/6/2003 19:10'!
includes: tt
	^true.! !

!IRBuilderMock methodsFor: 'as yet unclassified' stamp: 'md 7/14/2003 18:25'!
ir
	^self! !

!IRBuilderMock methodsFor: 'as yet unclassified' stamp: 'md 10/28/2003 16:12'!
popTop
	self addInstruction: #popTop.! !

!IRBuilderMock methodsFor: 'as yet unclassified' stamp: 'md 7/6/2003 19:10'!
tempNames
	^self! !

!IRBuilderMock methodsFor: 'private' stamp: 'md 5/19/2003 19:28'!
addInstruction: aSymbol
	instructions add: aSymbol.! !

!IRBuilderMock methodsFor: 'printing' stamp: 'md 5/19/2003 19:40'!
printInstructions
	^String streamContents: [:stream | self printInstructionsOn: stream]. ! !

!IRBuilderMock methodsFor: 'printing' stamp: 'md 5/19/2003 19:52'!
printInstructionsOn: aStream
	instructions do: [:each | aStream nextPutAll: each. aStream nextPutAll: ' ']. ! !

!IRBuilderMock methodsFor: 'printing' stamp: 'md 5/19/2003 19:51'!
printString
	^String streamContents: [:stream | self printInstructionsOn: stream]. ! !

!IRBuilderMock methodsFor: 'initializing' stamp: 'md 5/19/2003 19:43'!
initialize
	instructions := OrderedCollection new.! !

!IRBuilderMock class methodsFor: 'instance creation' stamp: 'md 5/19/2003 19:37'!
new
	^super new initialize.! !

!IRBuilderMockTest methodsFor: 'initialize-release' stamp: 'md 7/14/2003 18:22'!
setUp
	builder _ IRBuilderMock new! !

!IRBuilderMockTest methodsFor: 'testing' stamp: 'md 5/19/2003 19:56'!
testBlockReturnTop
	builder blockReturnTop.
	self assert: (builder printString = 'blockReturnTop ').! !

!IRBuilderMockTest methodsFor: 'testing' stamp: 'md 5/19/2003 19:56'!
testExample

	| expected |

	builder
		rargs: #(self otherPoint);		"receiver and args declarations"
		addTemps: #(z);					"temp declariations"
		pushTemp: #self;
		getField: 1;
		storeTemp: #z;						"z _ x."
		pushTemp: #otherPoint;
		send: #x;
		pushTemp: #self;
		setField: 1;						"x _ otherPoint x"
		doPop;
		pushTemp: #otherPoint;
		pushTemp: #z;
		send: #setX:;						"otherPoint setX: z"
		doPop;
		pushTemp: #z;
		pushTemp: #self;
		getField: 1;
		send: #=;						"z = x"
		jumpAheadTo: #notEqual if: false;
		pushLiteral: 'equal';				"ifTrue: ['equal']"
		jumpAheadTo: #end;
		jumpAheadTarget: #notEqual;
		pushLiteral: 'not equal';			"ifFalse: ['not equal']"
		jumpAheadTarget: #end;
		localReturnTop;
		yourself.

      expected := 'rargs addTemps pushTemp: getField storeTemp: pushTemp: send pushTemp: setField:: doPop pushTemp: pushTemp: send doPop pushTemp: pushTemp: getField send jumpAheadTo:if pushLiteral: jumpAheadTo: jumpAheadTarget: pushLiteral: jumpAheadTarget: localReturnTop '.
	self assert: ((builder printString) = expected).! !

!IRBuilderMockTest methodsFor: 'testing' stamp: 'md 7/14/2003 18:26'!
testExampleNew

	| expected |

	builder
		rargs: #(self a);		"receiver and args names"
		addTemps: #(z);		"extra temps (not used here)"
		pushTemp: #self;
		getField: 1;
		pushTemp: #a;
		send: #>;
		jumpAheadTo: #else if: false;
		pushLiteral: 'yes';
		returnTop;
		jumpAheadTarget: #else;
		pushLiteral: 'no';
		returnTop;
		ir.

      expected :=  'rargs addTemps pushTemp: getField pushTemp: send jumpAheadTo:if pushLiteral: returnTop jumpAheadTarget: pushLiteral: returnTop '.
	self assert: ((builder printString) = expected).! !

!IRBuilderMockTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class InstructionBuilderMock. 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!
!IRBuilderTest methodsFor: 'initialize-release' stamp: 'md 7/14/2003 18:28'!
setUp
	builder := IRBuilder new.! !

!IRBuilderTest methodsFor: 'examples' stamp: 'md 3/22/2003 17:38'!
exampleBlock1
	^ [1] value.
! !

!IRBuilderTest methodsFor: 'examples' stamp: 'md 3/22/2003 17:42'!
exampleBlock2
	^ [1].
! !

!IRBuilderTest methodsFor: 'examples' stamp: 'md 3/21/2003 11:24'!
exampleReturn1
	^1.
! !

!IRBuilderTest methodsFor: 'todo - oldstyleblocks' stamp: 'md 7/14/2003 18:30'!
TODOtestBlock1

	| aInstructionBuilder aCompiledMethod   |
	aInstructionBuilder := builder
		rargs: #(self);		"receiver and args declarations"
		pushThisContext; 
		pushLiteral: 0;
		send: #blockCopy:;
		jumpOverBlockTo: #jmp;
		pushLiteral: 1;
		blockReturnTop;
		jumpAheadTarget: #jmp;
	     send: #value;			
		returnTop;
		yourself.

	aCompiledMethod := aInstructionBuilder compiledMethodWith: #().
	self should: [aCompiledMethod isKindOf: CompiledMethod].
     self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = self exampleBlock1].! !

!IRBuilderTest methodsFor: 'todo - oldstyleblocks' stamp: 'md 7/14/2003 18:29'!
TODOtestBlock2

	| aInstructionBuilder aCompiledMethod  result |
	aInstructionBuilder := builder
		rargs: #(self);		"receiver and args declarations"
		pushThisContext; 
		pushLiteral: 0;
		send: #blockCopy:;
		jumpOverBlockTo: #jmp;
		pushLiteral: 1;
		blockReturnTop;
		jumpAheadTarget: #jmp;	
		localReturnTop;
		yourself.

	aCompiledMethod := aInstructionBuilder compiledMethodWith: #().
	self should: [aCompiledMethod isKindOf: CompiledMethod].
	result := (aCompiledMethod valueWithReceiver: nil arguments: #() ).
	self should: [result isKindOf: BlockContext].
     self should: [result value = 1].! !

!IRBuilderTest methodsFor: 'testing' stamp: 'md 7/14/2003 18:37'!
testExample
	self shouldnt:[builder
		rargs: #(self otherPoint);		"receiver and args declarations"
		addTemps: #(z);					"temp declariations"
		pushTemp: #self;
		getField: 1;
		storeTemp: #z;						"z _ x."
		pushTemp: #otherPoint;
		send: #x;
		pushTemp: #self;
		setField: 1;						"x _ otherPoint x"
		popTop;
		pushTemp: #otherPoint;
		pushTemp: #z;
		send: #setX:;						"otherPoint setX: z"
		popTop;
		pushTemp: #z;
		pushTemp: #self;
		getField: 1;
		send: #=;						"z = x"
		jumpAheadTo: #notEqual if: false;
		pushLiteral: 'equal';				"ifTrue: ['equal']"
		jumpAheadTo: #end;
		jumpAheadTarget: #notEqual;
		pushLiteral: 'not equal';			"ifFalse: ['not equal']"
		jumpAheadTarget: #end;
		returnTop;
		ir ] raise: Error.! !

!IRBuilderTest methodsFor: 'testing' stamp: 'md 7/14/2003 18:35'!
testReturn1

	| iRMethod aCompiledMethod |
	iRMethod := builder
		rargs: #(self);		"receiver and args declarations"
		pushLiteral: 1;				
		returnTop;
		ir.

	aCompiledMethod := iRMethod compiledMethod.

	self should: [aCompiledMethod isKindOf: CompiledMethod].
     self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = self exampleReturn1].! !

!IRBuilderTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class InstructionBuilder. 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!
!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43'!
constant

	^ constant! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43' prior: 37065516!
constant

	^ constant! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43'!
constant: object

	constant _ object! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43' prior: 37065736!
constant: object

	constant _ object! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:46'!
executeOn: interpreter

	^ interpreter pushLiteral: constant! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:46' prior: 37065986!
executeOn: interpreter

	^ interpreter pushLiteral: constant! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 16:12'!
isConstant: valueTest

	^ valueTest value: constant! !

!IRConstant methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 16:12' prior: 37066284!
isConstant: valueTest

	^ valueTest value: constant! !

!IRConstant commentStamp: 'ajh 3/24/2003 23:56' prior: 0!
Instruction "pushLiteral: object"!
!IRDup methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:46'!
executeOn: interpreter

	^ interpreter pushDup! !

!IRDup methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:46' prior: 37066652!
executeOn: interpreter

	^ interpreter pushDup! !

!IRDup commentStamp: 'ajh 3/24/2003 23:56' prior: 0!
Instruction "pushDup"!
!IRInstruction methodsFor: 'accessing' stamp: 'ajh 3/6/2003 14:32'!
executeOn: interpreter
	"Send approriate message to interpreter"

	self subclassResponsibility! !

!IRInstruction methodsFor: 'accessing' stamp: 'ajh 3/6/2003 14:32' prior: 37066985!
executeOn: interpreter
	"Send approriate message to interpreter"

	self subclassResponsibility! !

!IRInstruction methodsFor: 'accessing' stamp: 'ajh 3/6/2003 14:32'!
successorSequences
	"sent to last instruction in sequence which is expected to be a jump and return instruction"

	^ #()! !

!IRInstruction methodsFor: 'accessing' stamp: 'ajh 3/6/2003 14:32' prior: 37067335!
successorSequences
	"sent to last instruction in sequence which is expected to be a jump and return instruction"

	^ #()! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:12'!
isConstant: valueTest

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:12' prior: 37067736!
isConstant: valueTest

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:19'!
isGoto
	"is unconditional jump"

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:19' prior: 37067958!
isGoto
	"is unconditional jump"

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:21'!
isIf

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:21' prior: 37068200!
isIf

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:22'!
isJump
	"goto or if"

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:22' prior: 37068388!
isJump
	"goto or if"

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:13'!
isJumpOrReturn

	^ self isJump or: [self isReturn]! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:13' prior: 37068608!
isJumpOrReturn

	^ self isJump or: [self isReturn]! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:09'!
isReturn

	^ false! !

!IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:09' prior: 37068868!
isReturn

	^ false! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:07'!
bytecodeIndex

	^ bytecodeIndex! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:07' prior: 37069064!
bytecodeIndex

	^ bytecodeIndex! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:14'!
bytecodeIndex: index

	bytecodeIndex _ index! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:14' prior: 37069286!
bytecodeIndex: index

	bytecodeIndex _ index! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32'!
sourceNode

	^ sourceNode
	! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32' prior: 37069533!
sourceNode

	^ sourceNode
	! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32'!
sourceNode: parseNode

	sourceNode _ parseNode
	! !

!IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32' prior: 37069745!
sourceNode: parseNode

	sourceNode _ parseNode
	! !

!IRInstruction commentStamp: 'ajh 3/24/2003 23:38' prior: 0!
I am an instruction in the IR (intermediate representation) language.  The IR serves as the intermediary between the Smalltalk language and the bytecode language.  It is easier to optimize and translate to/from this language than it is to optimize/translate directly from Smalltalk to bytecodes.  The IR is generic and simple consisting of just twelve instructions.  They are:

	goto: labelNum
	if: boolean goto: labelNum1 otherwise: labelNum2
	label: labelNum
	popTop
	pushDup
	pushLiteral: object
	pushTemp: tempIndex
	remoteReturn
	returnTop
	send: selector
	send: selector toSuperOf: behavior
	storeTemp: tempIndex

Each instruction is reified as an instance of one of my eight subclasses and grouped by basic block (IRSequence) into an IRMethod.  IRInterpreter visits each instruction in a IRMethod responding to the above instruction messages sent to it.
!
!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07'!
goto: seq

	^ IRJump new
		destination: seq! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07' prior: 37070940!
goto: seq

	^ IRJump new
		destination: seq! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07'!
if: bool goto: seq1 otherwise: seq2

	^ IRJumpIf new
		boolean: bool;
		destination: seq1;
		otherwise: seq2! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07' prior: 37071218!
if: bool goto: seq1 otherwise: seq2

	^ IRJumpIf new
		boolean: bool;
		destination: seq1;
		otherwise: seq2! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07'!
popTop

	^ IRPop new! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:07' prior: 37071626!
popTop

	^ IRPop new! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
pushDup

	^ IRDup new! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37071858!
pushDup

	^ IRDup new! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
pushLiteral: object

	^ IRConstant new
		constant: object! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37072092!
pushLiteral: object

	^ IRConstant new
		constant: object! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/12/2003 12:16'!
pushTemp: index

	^ IRTemp new
		number: index;
		isStore: false! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/12/2003 12:16' prior: 37072398!
pushTemp: index

	^ IRTemp new
		number: index;
		isStore: false! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
remoteReturn

	^ IRReturn new
		isRemote: true! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37072718!
remoteReturn

	^ IRReturn new
		isRemote: true! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
returnTop

	^ IRReturn new
		isRemote: false! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37073002!
returnTop

	^ IRReturn new
		isRemote: false! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
send: selector

	^ IRSend new
		selector: selector! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37073282!
send: selector

	^ IRSend new
		selector: selector! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'!
send: selector toSuperOf: behavior

	^ IRSend new
		selector: selector;
		superOf: behavior! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08' prior: 37073574!
send: selector toSuperOf: behavior

	^ IRSend new
		selector: selector;
		superOf: behavior! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/12/2003 12:16'!
storeTemp: index

	^ IRTemp new
		number: index;
		isStore: true! !

!IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/12/2003 12:16' prior: 37073948!
storeTemp: index

	^ IRTemp new
		number: index;
		isStore: true! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:26'!
goto: seqNum! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:26' prior: 37074256!
goto: seqNum! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:26'!
if: bool goto: seqNum1 otherwise: seqNum2! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:26' prior: 37074448!
if: bool goto: seqNum1 otherwise: seqNum2! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:25'!
label: seqNum! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 13:25' prior: 37074698!
label: seqNum! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 14:11'!
popTop! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 14:11' prior: 37074892!
popTop! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 14:12'!
pushDup! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 14:12' prior: 37075072!
pushDup! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:08'!
pushLiteral: object! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:08' prior: 37075254!
pushLiteral: object! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:09'!
pushTemp: index! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:09' prior: 37075460!
pushTemp: index! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:10'!
remoteReturn! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:10' prior: 37075658!
remoteReturn! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:08'!
returnTop! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:08' prior: 37075850!
returnTop! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11'!
send: selector! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11' prior: 37076036!
send: selector! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11'!
send: selector toSuperOf: behavior! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11' prior: 37076232!
send: selector toSuperOf: behavior! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11'!
storeTemp: index! !

!IRInterpreter methodsFor: 'instructions' stamp: 'ajh 3/2/2003 16:11' prior: 37076468!
storeTemp: index! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 12:33'!
interpret: ir

	self interpretAll: ir allSequences! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 12:33' prior: 37076665!
interpret: ir

	self interpretAll: ir allSequences! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/10/2003 23:30'!
interpretAll: irSequences

	irSequences do: [:seq | self interpretSequence: seq]! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/10/2003 23:30' prior: 37076928!
interpretAll: irSequences

	irSequences do: [:seq | self interpretSequence: seq]! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/6/2003 15:31'!
interpretInstruction: irInstruction

	irInstruction executeOn: self! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/6/2003 15:31' prior: 37077251!
interpretInstruction: irInstruction

	irInstruction executeOn: self! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 13:20'!
interpretSequence: instructionSequence

	self label: instructionSequence orderNumber.
	instructionSequence do: [:instr | self interpretInstruction: instr].
! !

!IRInterpreter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 13:20' prior: 37077547!
interpretSequence: instructionSequence

	self label: instructionSequence orderNumber.
	instructionSequence do: [:instr | self interpretInstruction: instr].
! !

!IRInterpreter commentStamp: 'ajh 3/24/2003 23:55' prior: 0!
I visit each IRInstruction in an IRMethod in order.  Each instruction sends its instruction message to me upon being visited.  See my 'instructions' method category for complete list of instructions.  Subclasses should override them.!
!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:08'!
destination

	^ destination! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:08' prior: 37078321!
destination

	^ destination! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:08'!
destination: sequence

	destination _ sequence! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:08' prior: 37078545!
destination: sequence

	destination _ sequence! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47'!
executeOn: interpreter

	^ interpreter goto: destination orderNumber! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47' prior: 37078807!
executeOn: interpreter

	^ interpreter goto: destination orderNumber! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:19'!
isGoto
	"is unconditional jump"

	^ true! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:19' prior: 37079113!
isGoto
	"is unconditional jump"

	^ true! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:22'!
isJump
	"goto or if"

	^ true! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:22' prior: 37079363!
isJump
	"goto or if"

	^ true! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:02'!
successorSequences

	^ {destination}! !

!IRJump methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:02' prior: 37079591!
successorSequences

	^ {destination}! !

!IRJump commentStamp: 'ajh 3/24/2003 23:56' prior: 0!
Instruction "goto: labelNum"!
!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43'!
boolean

	^ boolean! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43' prior: 37079919!
boolean

	^ boolean! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43'!
boolean: bool

	boolean _ bool! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43' prior: 37080131!
boolean: bool

	boolean _ bool! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47'!
executeOn: interpreter

	^ interpreter if: boolean goto: destination orderNumber otherwise: otherwise orderNumber! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47' prior: 37080365!
executeOn: interpreter

	^ interpreter if: boolean goto: destination orderNumber otherwise: otherwise orderNumber! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:19'!
isGoto
	"is unconditional jump"

	^ false! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:19' prior: 37080765!
isGoto
	"is unconditional jump"

	^ false! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:21'!
isIf

	^ true! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:21' prior: 37081021!
isIf

	^ true! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43'!
otherwise

	^ otherwise! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:43' prior: 37081221!
otherwise

	^ otherwise! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44'!
otherwise: sequence

	otherwise _ sequence! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44' prior: 37081441!
otherwise: sequence

	otherwise _ sequence! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:02'!
successorSequences

	^ {destination. otherwise}! !

!IRJumpIf methodsFor: 'as yet unclassified' stamp: 'ajh 3/11/2003 00:02' prior: 37081699!
successorSequences

	^ {destination. otherwise}! !

!IRJumpIf commentStamp: 'ajh 3/24/2003 23:56' prior: 0!
Instruction "if: boolean goto: labelNum1 otherwise: labelNum2"!
!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:07'!
initialize

	primitiveNode _ PrimitiveNode null.
	rargKeys _ #(self).
	otherTempKeys _ #().
! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:07' prior: 37082078!
initialize

	primitiveNode _ PrimitiveNode null.
	rargKeys _ #(self).
	otherTempKeys _ #().
! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:04'!
otherTempKeys: tempKeys

	otherTempKeys _ tempKeys! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:04' prior: 37082418!
otherTempKeys: tempKeys

	otherTempKeys _ tempKeys! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/10/2003 23:08'!
primitiveNode: aPrimitiveNode

	primitiveNode _ aPrimitiveNode! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/10/2003 23:08' prior: 37082674!
primitiveNode: aPrimitiveNode

	primitiveNode _ aPrimitiveNode! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:12'!
rargKeys: tempKeys

	rargKeys _ tempKeys! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/17/2003 11:12' prior: 37082954!
rargKeys: tempKeys

	rargKeys _ tempKeys! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/10/2003 17:52'!
startSequence: irSequence

	startSequence _ irSequence! !

!IRMethod methodsFor: 'initialize' stamp: 'ajh 3/10/2003 17:52' prior: 37083190!
startSequence: irSequence

	startSequence _ irSequence! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/9/2003 15:35'!
allSequences

	^ startSequence withAllSuccessors! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/9/2003 15:35' prior: 37083452!
allSequences

	^ startSequence withAllSuccessors! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:11'!
numArgs

	^ rargKeys size - 1! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:11' prior: 37083701!
numArgs

	^ rargKeys size - 1! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:07'!
otherTempKeys

	^ otherTempKeys! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:07' prior: 37083913!
otherTempKeys

	^ otherTempKeys! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/10/2003 18:10'!
primitiveNode

	^ primitiveNode! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/10/2003 18:10' prior: 37084129!
primitiveNode

	^ primitiveNode! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:13'!
rargKeys

	^ rargKeys! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:13' prior: 37084345!
rargKeys

	^ rargKeys! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/10/2003 17:53'!
startSequence

	^ startSequence! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/10/2003 17:53' prior: 37084541!
startSequence

	^ startSequence! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:07'!
tempKeys

	^ rargKeys allButFirst, otherTempKeys! !

!IRMethod methodsFor: 'accessing' stamp: 'ajh 3/17/2003 11:07' prior: 37084757!
tempKeys

	^ rargKeys allButFirst, otherTempKeys! !

!IRMethod methodsFor: 'printing' stamp: 'ajh 3/9/2003 15:53'!
longPrintOn: stream

	IRPrinter new
		indent: 0;
		stream: stream;
		interpret: self! !

!IRMethod methodsFor: 'printing' stamp: 'ajh 3/9/2003 15:53' prior: 37085005!
longPrintOn: stream

	IRPrinter new
		indent: 0;
		stream: stream;
		interpret: self! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45'!
absorbConstantConditionalJumps

	startSequence absorbConstantConditionalJumps: IdentitySet new! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45' prior: 37085326!
absorbConstantConditionalJumps

	startSequence absorbConstantConditionalJumps: IdentitySet new! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45'!
absorbJumpsToSingleInstrs

	startSequence absorbJumpToSingleInstr: IdentitySet new! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45' prior: 37085670!
absorbJumpsToSingleInstrs

	startSequence absorbJumpToSingleInstr: IdentitySet new! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/18/2003 19:05'!
optimize

	self removeEmptyStart.
	self absorbJumpsToSingleInstrs.  "do before next to get in right form"
	self absorbConstantConditionalJumps.
	self absorbJumpsToSingleInstrs.  "do again since new opportunities may have arised after last step" 
! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/18/2003 19:05' prior: 37085990!
optimize

	self removeEmptyStart.
	self absorbJumpsToSingleInstrs.  "do before next to get in right form"
	self absorbConstantConditionalJumps.
	self absorbJumpsToSingleInstrs.  "do again since new opportunities may have arised after last step" 
! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/18/2003 19:25'!
removeEmptyStart

	startSequence size = 1 ifTrue: [
		"startSeq is just unconditional jump, forget it"
		startSequence _ startSequence last destination].
! !

!IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/18/2003 19:25' prior: 37086638!
removeEmptyStart

	startSequence size = 1 ifTrue: [
		"startSeq is just unconditional jump, forget it"
		startSequence _ startSequence last destination].
! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/10/2003 15:55'!
compiledMethod

	^ compiledMethod ifNil: [self compiledMethodWith: #(0)]! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/10/2003 15:55' prior: 37087103!
compiledMethod

	^ compiledMethod ifNil: [self compiledMethodWith: #(0)]! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/15/2003 02:02'!
compiledMethodWith: trailer

	^ compiledMethod _ IRTranslator new
		interpret: self;
		compiledMethodWith: trailer! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/15/2003 02:02' prior: 37087405!
compiledMethodWith: trailer

	^ compiledMethod _ IRTranslator new
		interpret: self;
		compiledMethodWith: trailer! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/10/2003 15:54'!
privCompiledMethod: aCompiledMethod

	compiledMethod _ aCompiledMethod! !

!IRMethod methodsFor: 'translating' stamp: 'ajh 3/10/2003 15:54' prior: 37087791!
privCompiledMethod: aCompiledMethod

	compiledMethod _ aCompiledMethod! !

!IRMethod methodsFor: 'mapping' stamp: 'ajh 3/19/2003 13:38'!
sourceMap
	"Return a mapping from bytecode pcs to source code ranges"

	| start map |
	"Besides getting start position, make sure bytecodeIndices are filled in"
	start _ self compiledMethod initialPC - 1.  
	map _ OrderedCollection new.
	self allSequences do: [:seq |
		seq do: [:instr |  | node |
			((node _ instr sourceNode) notNil and: 
			 [node debugHighlightStart notNil and:
			  [node debugHighlightStop notNil and:
			   [instr bytecodeIndex notNil]]]) ifTrue: [
				map add:
					instr bytecodeIndex + start
						-> (node debugHighlightStart to: node debugHighlightStop)]
		]
	].
	^ map! !

!IRMethod methodsFor: 'mapping' stamp: 'ajh 3/19/2003 13:38' prior: 37088085!
sourceMap
	"Return a mapping from bytecode pcs to source code ranges"

	| start map |
	"Besides getting start position, make sure bytecodeIndices are filled in"
	start _ self compiledMethod initialPC - 1.  
	map _ OrderedCollection new.
	self allSequences do: [:seq |
		seq do: [:instr |  | node |
			((node _ instr sourceNode) notNil and: 
			 [node debugHighlightStart notNil and:
			  [node debugHighlightStop notNil and:
			   [instr bytecodeIndex notNil]]]) ifTrue: [
				map add:
					instr bytecodeIndex + start
						-> (node debugHighlightStart to: node debugHighlightStop)]
		]
	].
	^ map! !

!IRMethod commentStamp: 'ajh 5/23/2003 11:08' prior: 0!
I am a method in the IR (intermediate representation) language consisting of IRInstructions grouped by IRSequence (basic block).  The IRSequences form a control graph (therefore I only have to hold onto the starting sequence).  #compiledMethod will convert me to a CompiledMethod.  #methodNode will convert me back to a parse tree.
!
!IRMethod class methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:17'!
new

	^ super new initialize! !

!IRMethod class methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 23:17' prior: 37089839!
new

	^ super new initialize! !

!IRPop methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47'!
executeOn: interpreter

	^ interpreter popTop! !

!IRPop methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:47' prior: 37090072!
executeOn: interpreter

	^ interpreter popTop! !

!IRPop commentStamp: 'ajh 3/24/2003 23:57' prior: 0!
Instruction "popTop"!
!IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:49'!
indent: tabs

	indent _ tabs! !

!IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:49' prior: 37090399!
indent: tabs

	indent _ tabs! !

!IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:50'!
stream: stringWriteStream

	stream _ stringWriteStream! !

!IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:50' prior: 37090611!
stream: stringWriteStream

	stream _ stringWriteStream! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:41'!
goto: seqNum

	stream nextPutAll: 'goto: '.
	seqNum printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:41' prior: 37090877!
goto: seqNum

	stream nextPutAll: 'goto: '.
	seqNum printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'!
if: bool goto: seqNum1 otherwise: seqNum2

	stream nextPutAll: 'if: '.
	bool printOn: stream.
	stream nextPutAll: ' goto: '.
	seqNum1 printOn: stream.
	stream nextPutAll: ' else: '.
	seqNum2 printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42' prior: 37091175!
if: bool goto: seqNum1 otherwise: seqNum2

	stream nextPutAll: 'if: '.
	bool printOn: stream.
	stream nextPutAll: ' goto: '.
	seqNum1 printOn: stream.
	stream nextPutAll: ' else: '.
	seqNum2 printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/11/2003 00:36'!
label: seqNum

	"add tab and cr since this does not get called within interpretInstruction:"
	stream cr.  "extra cr just to space out sequences"
	indent timesRepeat: [stream tab].
	stream nextPutAll: 'label: '.
	seqNum printOn: stream.
	stream cr.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/11/2003 00:36' prior: 37091752!
label: seqNum

	"add tab and cr since this does not get called within interpretInstruction:"
	stream cr.  "extra cr just to space out sequences"
	indent timesRepeat: [stream tab].
	stream nextPutAll: 'label: '.
	seqNum printOn: stream.
	stream cr.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'!
popTop

	stream nextPutAll: 'popTop'! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42' prior: 37092409!
popTop

	stream nextPutAll: 'popTop'! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'!
pushDup

	stream nextPutAll: 'pushDup'! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42' prior: 37092641!
pushDup

	stream nextPutAll: 'pushDup'! !

!IRPrinter methodsFor: 'instructions' stamp: 'md 11/21/2003 12:16'!
pushLiteral: object

	stream nextPutAll: 'pushLiteral: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.

	((object isBlockClosure) or: [object isCompiledMethod])
		ifTrue: [
			IRPrinter new
				indent: indent + 1;
				stream: stream;
				interpret: object method ir removeEmptyStart].
! !

!IRPrinter methodsFor: 'instructions' stamp: 'md 11/21/2003 12:16' prior: 37092878!
pushLiteral: object

	stream nextPutAll: 'pushLiteral: '.
	object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
	object printOn: stream.

	((object isBlockClosure) or: [object isCompiledMethod])
		ifTrue: [
			IRPrinter new
				indent: indent + 1;
				stream: stream;
				interpret: object method ir removeEmptyStart].
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:12'!
pushTemp: index

	stream nextPutAll: 'pushTemp: '.
	index printOn: stream.
	index = 0 ifTrue: [stream nextPutAll: ' "receiver"'].
	index = -1 ifTrue: [stream nextPutAll: ' "thisContext"'].
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/10/2003 14:12' prior: 37093708!
pushTemp: index

	stream nextPutAll: 'pushTemp: '.
	index printOn: stream.
	index = 0 ifTrue: [stream nextPutAll: ' "receiver"'].
	index = -1 ifTrue: [stream nextPutAll: ' "thisContext"'].
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:43'!
remoteReturn

	stream nextPutAll: 'remoteReturn'.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:43' prior: 37094247!
remoteReturn

	stream nextPutAll: 'remoteReturn'.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:43'!
returnTop

	stream nextPutAll: 'returnTop'.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:43' prior: 37094507!
returnTop

	stream nextPutAll: 'returnTop'.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44'!
send: selector

	stream nextPutAll: 'send: '.
	selector printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44' prior: 37094755!
send: selector

	stream nextPutAll: 'send: '.
	selector printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44'!
send: selector toSuperOf: behavior

	stream nextPutAll: 'send: '.
	selector printOn: stream.
	stream nextPutAll: ' toSuperOf: '.
	behavior printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44' prior: 37095061!
send: selector toSuperOf: behavior

	stream nextPutAll: 'send: '.
	selector printOn: stream.
	stream nextPutAll: ' toSuperOf: '.
	behavior printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44'!
storeTemp: index

	stream nextPutAll: 'storeTemp: '.
	index printOn: stream.
! !

!IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44' prior: 37095533!
storeTemp: index

	stream nextPutAll: 'storeTemp: '.
	index printOn: stream.
! !

!IRPrinter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 15:48'!
interpretInstruction: irInstruction

	indent timesRepeat: [stream tab].
	super interpretInstruction: irInstruction.
	stream cr.
! !

!IRPrinter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 15:48' prior: 37095844!
interpretInstruction: irInstruction

	indent timesRepeat: [stream tab].
	super interpretInstruction: irInstruction.
	stream cr.
! !

!IRPrinter commentStamp: 'ajh 3/25/2003 00:22' prior: 0!
I interpret IRMethod instructions and write them out to a print stream.!
!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:48'!
executeOn: interpreter

	^ isRemote
		ifTrue: [interpreter remoteReturn]
		ifFalse: [interpreter returnTop]! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:48' prior: 37096394!
executeOn: interpreter

	^ isRemote
		ifTrue: [interpreter remoteReturn]
		ifFalse: [interpreter returnTop]! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44'!
isRemote

	^ isRemote! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44' prior: 37096782!
isRemote

	^ isRemote! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44'!
isRemote: boolean

	isRemote _ boolean! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44' prior: 37096998!
isRemote: boolean

	isRemote _ boolean! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 16:10'!
isReturn

	^ true! !

!IRReturn methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 16:10' prior: 37097248!
isReturn

	^ true! !

!IRReturn commentStamp: 'ajh 3/24/2003 23:57' prior: 0!
Instruction "returnTop" or "remoteReturn"!
!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:48'!
executeOn: interpreter

	^ superOf
		ifNil: [interpreter send: selector]
		ifNotNil: [interpreter send: selector toSuperOf: superOf]! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:48' prior: 37097553!
executeOn: interpreter

	^ superOf
		ifNil: [interpreter send: selector]
		ifNotNil: [interpreter send: selector toSuperOf: superOf]! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44'!
selector

	^ selector! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44' prior: 37097987!
selector

	^ selector! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44'!
selector: symbol

	selector _ symbol! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:44' prior: 37098199!
selector: symbol

	selector _ symbol! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45'!
superOf

	^ superOf! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45' prior: 37098441!
superOf

	^ superOf! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45'!
superOf: behavior

	superOf _ behavior! !

!IRSend methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45' prior: 37098649!
superOf: behavior

	superOf _ behavior! !

!IRSend commentStamp: 'ajh 3/24/2003 23:57' prior: 0!
Instruction "send: selector" or "send: selector toSuperOf: behavior"!
!IRSequence methodsFor: 'comparing' stamp: 'ajh 3/11/2003 00:29'!
= other
	"Override collection equal with identity equal"

	^ self == other! !

!IRSequence methodsFor: 'comparing' stamp: 'ajh 3/11/2003 00:29' prior: 37099013!
= other
	"Override collection equal with identity equal"

	^ self == other! !

!IRSequence methodsFor: 'comparing' stamp: 'ajh 6/18/2002 15:09'!
hash

	^ self identityHash! !

!IRSequence methodsFor: 'comparing' stamp: 'ajh 6/18/2002 15:09' prior: 37099319!
hash

	^ self identityHash! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/19/2003 22:22'!
nextSequence

	| sequences i |
	sequences _ self withAllSuccessors.
	i _ sequences findFirst: [:seq | seq orderNumber = self orderNumber].
	(i = 0 or: [i = sequences size]) ifTrue: [^ nil].
	^ sequences at: i + 1! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/19/2003 22:22' prior: 37099539!
nextSequence

	| sequences i |
	sequences _ self withAllSuccessors.
	i _ sequences findFirst: [:seq | seq orderNumber = self orderNumber].
	(i = 0 or: [i = sequences size]) ifTrue: [^ nil].
	^ sequences at: i + 1! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/19/2003 01:24'!
successorSequences

	self isEmpty ifTrue: [^ #()].
	^ self last successorSequences! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/19/2003 01:24' prior: 37100141!
successorSequences

	self isEmpty ifTrue: [^ #()].
	^ self last successorSequences! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 9/26/2002 16:14'!
withAllSuccessors
	"Return me and all my successors sorted by sequence orderNumber"

	| list |
	list _ OrderedCollection new: 20.
	self withAllSuccessorsDo: [:seq | list add: seq].
	^ list asSortedCollection: [:x :y | x orderNumber <= y orderNumber]! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 9/26/2002 16:14' prior: 37100483!
withAllSuccessors
	"Return me and all my successors sorted by sequence orderNumber"

	| list |
	list _ OrderedCollection new: 20.
	self withAllSuccessorsDo: [:seq | list add: seq].
	^ list asSortedCollection: [:x :y | x orderNumber <= y orderNumber]! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 7/18/2002 01:37'!
withAllSuccessorsDo: block
	"Iterate over me and all my successors only once"

	self withAllSuccessorsDo: block alreadySeen: IdentitySet new! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 7/18/2002 01:37' prior: 37101159!
withAllSuccessorsDo: block
	"Iterate over me and all my successors only once"

	self withAllSuccessorsDo: block alreadySeen: IdentitySet new! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/6/2003 01:31'!
withAllSuccessorsDo: block alreadySeen: set
	"Iterate over me and all my successors only once"

	(set includes: self) ifTrue: [^ self].
	set add: self.
	block value: self.
	self successorSequences do: [:seq |
		seq ifNotNil: [seq withAllSuccessorsDo: block alreadySeen: set]].
! !

!IRSequence methodsFor: 'successor sequences' stamp: 'ajh 3/6/2003 01:31' prior: 37101616!
withAllSuccessorsDo: block alreadySeen: set
	"Iterate over me and all my successors only once"

	(set includes: self) ifTrue: [^ self].
	set add: self.
	block value: self.
	self successorSequences do: [:seq |
		seq ifNotNil: [seq withAllSuccessorsDo: block alreadySeen: set]].
! !

!IRSequence methodsFor: 'optimizing' stamp: 'ajh 3/13/2003 00:26'!
absorbConstantConditionalJumps: alreadySeen
	"Collapse sequences that look like:
			[if] goto s1
			...
		 s1:	pushConst: true/false
			goto s2
		 s2:	if true/false goto s3 else s4
	into:
			[if] goto s3/s4

	These sequences are produced by and:/or: messages"

	| seq bool if |
	(alreadySeen includes: self) ifTrue: [^ self].
	alreadySeen add: self.

	[(seq _ self successorSequences) size > 0  "not return"
	  and: [(seq _ seq first "destination") size = 2
	   and: [(seq first isConstant: [:obj | (bool _ obj) isKindOf: Boolean])
	    and: [seq last isGoto
	     and: [(if _ seq last destination first) isIf]]]]
	] whileTrue: [ "absorb"
		self last destination: (bool == if boolean
			ifTrue: [if destination]
			ifFalse: [if otherwise]).
	].

	self successorSequences do: [:instrs | instrs absorbConstantConditionalJumps: alreadySeen].
! !

!IRSequence methodsFor: 'optimizing' stamp: 'ajh 3/13/2003 00:26' prior: 37102338!
absorbConstantConditionalJumps: alreadySeen
	"Collapse sequences that look like:
			[if] goto s1
			...
		 s1:	pushConst: true/false
			goto s2
		 s2:	if true/false goto s3 else s4
	into:
			[if] goto s3/s4

	These sequences are produced by and:/or: messages"

	| seq bool if |
	(alreadySeen includes: self) ifTrue: [^ self].
	alreadySeen add: self.

	[(seq _ self successorSequences) size > 0  "not return"
	  and: [(seq _ seq first "destination") size = 2
	   and: [(seq first isConstant: [:obj | (bool _ obj) isKindOf: Boolean])
	    and: [seq last isGoto
	     and: [(if _ seq last destination first) isIf]]]]
	] whileTrue: [ "absorb"
		self last destination: (bool == if boolean
			ifTrue: [if destination]
			ifFalse: [if otherwise]).
	].

	self successorSequences do: [:instrs | instrs absorbConstantConditionalJumps: alreadySeen].
! !

!IRSequence methodsFor: 'optimizing' stamp: 'ajh 3/20/2003 00:10'!
absorbJumpToSingleInstr: alreadySeen
	"Collapse jumps to single return instructions into caller"

	| seqs seq |
	(alreadySeen includes: self) ifTrue: [^ self].
	alreadySeen add: self.

	[ (seqs _ self successorSequences) size = 1  "unconditional jump..." 
	   and: [(seq _ seqs first) size = 1  "...to single instruction..."
	    and: [seq successorSequences size < 2]]  "...but don't collapse conditional jumps so their otherwiseSequences can stay right after them"
	] whileTrue: [ "replace goto with single instruction"
		self removeLast.
		seq do: [:instr | self add: instr copy].
	].

	seqs do: [:instrs | instrs absorbJumpToSingleInstr: alreadySeen].
! !

!IRSequence methodsFor: 'optimizing' stamp: 'ajh 3/20/2003 00:10' prior: 37104176!
absorbJumpToSingleInstr: alreadySeen
	"Collapse jumps to single return instructions into caller"

	| seqs seq |
	(alreadySeen includes: self) ifTrue: [^ self].
	alreadySeen add: self.

	[ (seqs _ self successorSequences) size = 1  "unconditional jump..." 
	   and: [(seq _ seqs first) size = 1  "...to single instruction..."
	    and: [seq successorSequences size < 2]]  "...but don't collapse conditional jumps so their otherwiseSequences can stay right after them"
	] whileTrue: [ "replace goto with single instruction"
		self removeLast.
		seq do: [:instr | self add: instr copy].
	].

	seqs do: [:instrs | instrs absorbJumpToSingleInstr: alreadySeen].
! !

!IRSequence methodsFor: 'printing' stamp: 'ajh 3/11/2003 00:57'!
longPrintOn: stream

	[IRPrinter new
		indent: 0;
		stream: stream;
		interpretSequence: self
	] onDNU: #orderNumber do: [:ex | ex resume: ex receiver]! !

!IRSequence methodsFor: 'printing' stamp: 'ajh 3/11/2003 00:57' prior: 37105646!
longPrintOn: stream

	[IRPrinter new
		indent: 0;
		stream: stream;
		interpretSequence: self
	] onDNU: #orderNumber do: [:ex | ex resume: ex receiver]! !

!IRSequence methodsFor: 'printing' stamp: 'ajh 3/11/2003 00:25'!
printOn: stream

	stream nextPutAll: 'an '.
	self class printOn: stream.
	stream space.
	stream nextPut: $(.
	self orderNumber printOn: stream.
	stream nextPut: $).
! !

!IRSequence methodsFor: 'printing' stamp: 'ajh 3/11/2003 00:25' prior: 37106104!
printOn: stream

	stream nextPutAll: 'an '.
	self class printOn: stream.
	stream space.
	stream nextPut: $(.
	self orderNumber printOn: stream.
	stream nextPut: $).
! !

!IRSequence methodsFor: 'manipulating' stamp: 'ajh 3/19/2003 22:25'!
splitAfter: instruction

	| newSeq instr next |
	next _ self nextSequence.
	next _ next
		ifNil: [self orderNumber + 1]
		ifNotNil: [(next orderNumber + self orderNumber) / 2].
	newSeq _ IRSequence new orderNumber: next.
	instr _ instruction.
	[(instr _ instr nextLink) isNil] whileFalse: [newSeq add: instr].
	instruction nextLink: nil.
	lastLink _ instruction.
	self add: (IRJump new destination: newSeq).
	^ newSeq! !

!IRSequence methodsFor: 'manipulating' stamp: 'ajh 3/19/2003 22:25' prior: 37106594!
splitAfter: instruction

	| newSeq instr next |
	next _ self nextSequence.
	next _ next
		ifNil: [self orderNumber + 1]
		ifNotNil: [(next orderNumber + self orderNumber) / 2].
	newSeq _ IRSequence new orderNumber: next.
	instr _ instruction.
	[(instr _ instr nextLink) isNil] whileFalse: [newSeq add: instr].
	instruction nextLink: nil.
	lastLink _ instruction.
	self add: (IRJump new destination: newSeq).
	^ newSeq! !

!IRSequence methodsFor: 'initializing' stamp: 'ajh 7/18/2002 01:23'!
orderNumber: n
	"Sequences are sorted by this number"

	orderNumber _ n! !

!IRSequence methodsFor: 'initializing' stamp: 'ajh 7/18/2002 01:23' prior: 37107592!
orderNumber: n
	"Sequences are sorted by this number"

	orderNumber _ n! !

!IRSequence methodsFor: 'accessing' stamp: 'ajh 7/18/2002 01:23'!
orderNumber
	"Sequences are sorted by this number"

	^ orderNumber! !

!IRSequence methodsFor: 'accessing' stamp: 'ajh 7/18/2002 01:23' prior: 37107895!
orderNumber
	"Sequences are sorted by this number"

	^ orderNumber! !

!IRSequence commentStamp: 'ajh 3/14/2003 00:33' prior: 0!
I hold a sequence of IRInstructions where only the last instruction jumps or returns, the rest are guaranteed to execute in order (ie. a basic block).!
!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:18'!
executeOn: interpreter

	^ isStore
		ifTrue: [interpreter storeTemp: number]
		ifFalse: [interpreter pushTemp: number]! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:18' prior: 37108401!
executeOn: interpreter

	^ isStore
		ifTrue: [interpreter storeTemp: number]
		ifFalse: [interpreter pushTemp: number]! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45'!
isStore

	^ isStore! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45' prior: 37108807!
isStore

	^ isStore! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45'!
isStore: boolean

	isStore _ boolean! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/10/2003 00:45' prior: 37109015!
isStore: boolean

	isStore _ boolean! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:17'!
number

	^ number! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:17' prior: 37109257!
number

	^ number! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:16'!
number: n

	number _ n! !

!IRTemp methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:16' prior: 37109461!
number: n

	number _ n! !

!IRTemp commentStamp: 'ajh 3/24/2003 23:58' prior: 0!
Instruction "pushTemp: tempIndex" or "storeTemp: tempIndex"!
!IRTranslator methodsFor: 'initialize' stamp: 'ajh 3/9/2003 22:02'!
initialize

	gen _ BytecodeGenerator new.
! !

!IRTranslator methodsFor: 'initialize' stamp: 'ajh 3/9/2003 22:02' prior: 37109786!
initialize

	gen _ BytecodeGenerator new.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:09'!
goto: seqNum

	self doPending.
	gen goto: seqNum.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:09' prior: 37110034!
goto: seqNum

	self doPending.
	gen goto: seqNum.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:09'!
if: bool goto: seqNum1 otherwise: seqNum2

	self doPending.
	gen if: bool goto: seqNum1 otherwise: seqNum2.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:09' prior: 37110300!
if: bool goto: seqNum1 otherwise: seqNum2

	self doPending.
	gen if: bool goto: seqNum1 otherwise: seqNum2.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:10'!
label: seqNum

	pending _ OrderedCollection new.
	gen label: seqNum.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:10' prior: 37110682!
label: seqNum

	pending _ OrderedCollection new.
	gen label: seqNum.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:35'!
popTop

	"if last was storeTemp or storeInstVar then convert to storePopTemp or storePopInstVar"
	#storeTemp: == self pendingSelector ifTrue: [
		^ self pendingSelector: #storePopTemp:].
	#storeInstVar: == self pendingSelector ifTrue: [
		^ self pendingSelector: #storePopInstVar:].

	"otherwise do normal pop"
	self doPending.
	gen popTop.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:35' prior: 37110986!
popTop

	"if last was storeTemp or storeInstVar then convert to storePopTemp or storePopInstVar"
	#storeTemp: == self pendingSelector ifTrue: [
		^ self pendingSelector: #storePopTemp:].
	#storeInstVar: == self pendingSelector ifTrue: [
		^ self pendingSelector: #storePopInstVar:].

	"otherwise do normal pop"
	self doPending.
	gen popTop.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:10'!
pushDup

	self doPending.
	gen pushDup.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:10' prior: 37111834!
pushDup

	self doPending.
	gen pushDup.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/12/2003 11:58'!
pushLiteral: object

	self addPending: (Message selector: #pushLiteral: argument: object)! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/12/2003 11:58' prior: 37112081!
pushLiteral: object

	self addPending: (Message selector: #pushLiteral: argument: object)! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 23:39'!
pushTemp: index

	index = 0 ifTrue: [
		^ self addPending: (Message selector: #pushReceiver)].
	(self pendingMatches: {
		[:m | m selector == #storePopTemp: and: [m argument = index]]}
	) ifTrue: [
		^ self pendingSelector: #storeTemp:].
	self doPending.
	index = -1 ifTrue: [^ gen pushThisContext].
	gen pushTemp: index.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 23:39' prior: 37112426!
pushTemp: index

	index = 0 ifTrue: [
		^ self addPending: (Message selector: #pushReceiver)].
	(self pendingMatches: {
		[:m | m selector == #storePopTemp: and: [m argument = index]]}
	) ifTrue: [
		^ self pendingSelector: #storeTemp:].
	self doPending.
	index = -1 ifTrue: [^ gen pushThisContext].
	gen pushTemp: index.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:12'!
remoteReturn

	self doPending.
	gen remoteReturn.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:12' prior: 37113236!
remoteReturn

	self doPending.
	gen remoteReturn.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/10/2003 16:27'!
returnTop

	#pushReceiver == self pendingSelector ifTrue: [
		self pendingSelector: #returnReceiver.
		^ self doPending
	].
	#pushLiteral: == self pendingSelector ifTrue: [
		self pendingSelector: #returnConstant:.
		^ self doPending
	].
	#pushInstVar: == self pendingSelector ifTrue: [
		self pendingSelector: #returnInstVar:.
		^ self doPending
	].
	self doPending.
	gen returnTop.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/10/2003 16:27' prior: 37113503!
returnTop

	#pushReceiver == self pendingSelector ifTrue: [
		self pendingSelector: #returnReceiver.
		^ self doPending
	].
	#pushLiteral: == self pendingSelector ifTrue: [
		self pendingSelector: #returnConstant:.
		^ self doPending
	].
	#pushInstVar: == self pendingSelector ifTrue: [
		self pendingSelector: #returnInstVar:.
		^ self doPending
	].
	self doPending.
	gen returnTop.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 04:26'!
send: selector

	"If get/set inst var, access it directly"
	| index |
	((#(getInstVar: #storeIn:instVar:) identityIncludes: selector) and:
	 [self pendingMatches: {
		[:m | m selector == #pushReceiver].
		[:m | m selector == #pushLiteral: and: [m argument isInteger]]}]
	) ifTrue: [
		index _ self popPending argument.
		self popPending.  "pop pushReceiver"
		self addPending: (Message
			selector: (selector == #getInstVar:
				ifTrue: [#pushInstVar:] ifFalse: [#storeInstVar:])
			argument: index).
		(self pendingMatches: {
			[:m | m selector == #storePopInstVar: and: [m argument = index]].
			[:m | m selector == #pushInstVar: and: [m argument = index]]}
		) ifTrue: [
			self popPending.
			self pendingSelector: #storeInstVar:.
		].
		^ self
	].

	"otherwise do normal send"
	self doPending.
	gen send: selector.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 04:26' prior: 37114439!
send: selector

	"If get/set inst var, access it directly"
	| index |
	((#(getInstVar: #storeIn:instVar:) identityIncludes: selector) and:
	 [self pendingMatches: {
		[:m | m selector == #pushReceiver].
		[:m | m selector == #pushLiteral: and: [m argument isInteger]]}]
	) ifTrue: [
		index _ self popPending argument.
		self popPending.  "pop pushReceiver"
		self addPending: (Message
			selector: (selector == #getInstVar:
				ifTrue: [#pushInstVar:] ifFalse: [#storeInstVar:])
			argument: index).
		(self pendingMatches: {
			[:m | m selector == #storePopInstVar: and: [m argument = index]].
			[:m | m selector == #pushInstVar: and: [m argument = index]]}
		) ifTrue: [
			self popPending.
			self pendingSelector: #storeInstVar:.
		].
		^ self
	].

	"otherwise do normal send"
	self doPending.
	gen send: selector.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:14'!
send: selector toSuperOf: behavior

	self doPending.
	gen send: selector toSuperOf: behavior.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 22:14' prior: 37116248!
send: selector toSuperOf: behavior

	self doPending.
	gen send: selector toSuperOf: behavior.
! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/12/2003 11:58'!
storeTemp: index

	self addPending: (Message selector: #storeTemp: argument: index)! !

!IRTranslator methodsFor: 'instructions' stamp: 'ajh 3/12/2003 11:58' prior: 37116603!
storeTemp: index

	self addPending: (Message selector: #storeTemp: argument: index)! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/15/2003 02:02'!
interpret: ir

	ir optimize.
	gen primitiveNode: ir primitiveNode.
	gen numArgs: ir numArgs.
	super interpret: ir.
! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/15/2003 02:02' prior: 37116934!
interpret: ir

	ir optimize.
	gen primitiveNode: ir primitiveNode.
	gen numArgs: ir numArgs.
	super interpret: ir.
! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/13/2003 18:07'!
interpretAll: irSequences

	irSequences withIndexDo: [:seq :i | seq orderNumber: i].
	super interpretAll: irSequences.
! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/13/2003 18:07' prior: 37117326!
interpretAll: irSequences

	irSequences withIndexDo: [:seq :i | seq orderNumber: i].
	super interpretAll: irSequences.
! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/13/2003 04:50'!
interpretInstruction: irInstruction

	currentInstr _ irInstruction.
	super interpretInstruction: irInstruction.
! !

!IRTranslator methodsFor: 'interpret' stamp: 'ajh 3/13/2003 04:50' prior: 37117726!
interpretInstruction: irInstruction

	currentInstr _ irInstruction.
	super interpretInstruction: irInstruction.
! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 14:54'!
addPending: message

	pending addLast: currentInstr -> message! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 14:54' prior: 37118115!
addPending: message

	pending addLast: currentInstr -> message! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 3/13/2003 04:49'!
doPending
	"execute pending instructions"

	| assoc |
	[pending isEmpty] whileFalse: [
		assoc _ pending removeFirst.
		gen mapBytesTo: assoc key "instr".
		assoc value "message" sendTo: gen.
	].
	gen mapBytesTo: currentInstr.
! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 3/13/2003 04:49' prior: 37118407!
doPending
	"execute pending instructions"

	| assoc |
	[pending isEmpty] whileFalse: [
		assoc _ pending removeFirst.
		gen mapBytesTo: assoc key "instr".
		assoc value "message" sendTo: gen.
	].
	gen mapBytesTo: currentInstr.
! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/5/2003 12:41'!
pendingMatches: blocks
	"Return true if each message at end of pending list satisfies its corresponding block.  The number of elements tested equals the number of blocks.  If not enough elements return false"

	| messages i |
	messages _ pending collect: [:assoc | assoc value].
	blocks size > messages size ifTrue: [^ false].
	i _ messages size - blocks size.
	blocks do: [:b |
		(b value: (messages at: (i _ i + 1))) ifFalse: [^ false].
	].
	^ true! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/5/2003 12:41' prior: 37119028!
pendingMatches: blocks
	"Return true if each message at end of pending list satisfies its corresponding block.  The number of elements tested equals the number of blocks.  If not enough elements return false"

	| messages i |
	messages _ pending collect: [:assoc | assoc value].
	blocks size > messages size ifTrue: [^ false].
	i _ messages size - blocks size.
	blocks do: [:b |
		(b value: (messages at: (i _ i + 1))) ifFalse: [^ false].
	].
	^ true! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06'!
pendingSelector

	pending isEmpty ifTrue: [^ nil].
	^ pending last value "message" selector! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06' prior: 37120095!
pendingSelector

	pending isEmpty ifTrue: [^ nil].
	^ pending last value "message" selector! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06'!
pendingSelector: selector

	pending last value "message" setSelector: selector! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06' prior: 37120445!
pendingSelector: selector

	pending last value "message" setSelector: selector! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 14:27'!
popPending

	^ pending removeLast value "message"! !

!IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 14:27' prior: 37120769!
popPending

	^ pending removeLast value "message"! !

!IRTranslator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28'!
compiledMethodWith: trailer

	^ gen compiledMethodWith: trailer! !

!IRTranslator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28' prior: 37121030!
compiledMethodWith: trailer

	^ gen compiledMethodWith: trailer! !

!IRTranslator commentStamp: 'ajh 3/25/2003 00:26' prior: 0!
I interpret IRMethod instructions, sending the appropriate bytecode messages to my BytecodeGenerator (gen).  I hold some messages back in pending awaiting certain sequences of them that can be consolidated into single bytecode instructions, otherwise the pending messages are executed in order as if they were executed when they first appeared.!
!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: '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 8/12/2001 17:01'!
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 imageForm.
	^ self initializeWithThumbnail: aThumbnail withLabel: aLabel andSend: aSelector to: aReceiver 	! !

!IconicButton methodsFor: 'initialization' stamp: 'ar 12/18/2001 21:22'!
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"

	| labeledItem  |
	labeledItem _ AlignmentMorph newColumn beTransparent.
	labeledItem borderWidth: 0.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (BorderedStringMorph contents: aLabel font: (StrikeFont familyName: 'ComicBold' size: 15)).
	self
		beTransparent;
		labelGraphic: labeledItem imageForm;
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

!IconicButton methodsFor: 'initialization' stamp: 'nk 9/7/2003 08:44' prior: 37123345!
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"

	| labeledItem  |
	labeledItem _ AlignmentMorph newColumn beTransparent.
	labeledItem borderWidth: 0.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (BorderedStringMorph contents: aLabel font: (StrikeFont familyName: 'ComicBold' size: 15)).
	self
		beTransparent;
		labelGraphic: (labeledItem imageForm asFormOfDepth: 16);
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

!IconicButton methodsFor: 'initialization' stamp: 'dgd 11/26/2003 15:26' prior: 37124297!
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"

	| labeledItem  |
	labeledItem _ AlignmentMorph newColumn beTransparent.
	labeledItem borderWidth: 0.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (BorderedStringMorph contents: aLabel font: (StrikeFont familyName: Preferences standardEToysFont familyName size: 15)).
	self
		beTransparent;
		labelGraphic: (labeledItem imageForm asFormOfDepth: 16);
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

!IconicButton methodsFor: 'initialization' stamp: 'dew 8/4/2004 23:53' prior: 37125272!
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"

	| labeledItem |
	labeledItem _ AlignmentMorph newColumn beTransparent.
	labeledItem borderWidth: 0.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (BorderedStringMorph contents: aLabel font: (StrikeFont familyName: Preferences standardBalloonHelpFont familyName size: 13)).  "Use a non-TT font. TT fonts look bad in thumbnail form."
	self
		beTransparent;
		labelGraphic: (labeledItem imageForm asFormOfDepth: 16);
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

!IconicButton methodsFor: 'initialization' stamp: 'dew 8/4/2004 23:53' prior: 37126274!
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"

	| labeledItem |
	labeledItem _ AlignmentMorph newColumn beTransparent.
	labeledItem borderWidth: 0.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (BorderedStringMorph contents: aLabel font: (StrikeFont familyName: Preferences standardBalloonHelpFont familyName size: 13)).  "Use a non-TT font. TT fonts look bad in thumbnail form."
	self
		beTransparent;
		labelGraphic: (labeledItem imageForm asFormOfDepth: 16);
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

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

!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 methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'!
contentsClass
	^IdentityDictionary! !

!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!
!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
!
!IdentitySkipList methodsFor: 'element comparison' stamp: 'LC 6/18/2001 20:28'!
is: element1 equalTo: element2
	^ element1 == element2! !

!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!
!IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'!
offset
	^0@0! !

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

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

!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: 'aoy 2/17/2003 01:17' prior: 22333309!
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' prior: 22333557!
isOpaque
	"Return true if the receiver is marked as being completely opaque"
	^ self
		valueOfProperty: #isOpaque
		ifAbsent: [false]! !

!ImageMorph methodsFor: 'drawing' stamp: 'ar 12/12/2001 01:09'!
drawOn: aCanvas
	| style |
	(style _ self borderStyle) ifNotNil:[
		style frameRectangle: bounds on: aCanvas.
	].
	self isOpaque
		ifTrue:[aCanvas drawImage: image at: self innerBounds origin]
		ifFalse:[aCanvas paintImage: image at: self innerBounds origin]! !

!ImageMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:46' prior: 22336397!
opacityString
	^ (self isOpaque
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'opaque' translated! !

!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: '*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 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 class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:09' prior: 22336949!
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: 'parts bin' stamp: 'tk 11/16/2001 12:12'!
descriptionForPartsBin
	^ self partName:	'Image'
		categories:		#('Graphics' ' Basic 2 ')
		documentation:	'A non-editable picture.  If you use the Paint palette to make a picture, you can edit it afterwards.'! !

!ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18' prior: 22342121!
close
	
	stream close! !

!ImageReadWriter methodsFor: 'private' stamp: 'sd 1/30/2004 15:18' prior: 22345785!
on: aStream
	(stream _ aStream) reset.
	stream binary.
	"Note that 'reset' makes a file be text.  Must do this after."! !

!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: 'ar 6/16/2002 17:34'!
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 respondsTo: #close) ifTrue: [ aBinaryStream close ].
			^self error: 'image format not recognized'].
	reader _ readerClass new on: aBinaryStream reset.
	Cursor read showWhile: [
		form _ reader nextImage.
		reader close].
	^ form
! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'sd 1/30/2004 15:18' prior: 37136707!
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' 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 6/16/2002 17:33'!
understandsImageFormat: aStream
	^(self new on: aStream) understandsImageFormat! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'yo 11/11/2002 17:30' prior: 22361280!
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 allInstances, MultiSymbol allInstances.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"
	(newRoots _ self rootsIncludingPlayers) ifNotNil: [
		arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
	"Creation of the segment happens here"
	self copyFromRoots: arrayOfRoots sizeHint: 0.
	segSize _ segment size.
	[(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods pointed at from outside"
	[(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods, blocks from outPointers"
	"classes of receivers of blocks"
	list _ self compactClassesArray.
	outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	"Zap sender of a homeContext. Can't send live stacks out."
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 15:31'!
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.

	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 _ PopUpMenu
				confirm: 
'Some block(s) which reference instance variables 
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?' 
				trueChoice: 'keep going' 
				falseChoice: 'stop and take a look'.
			goodToGo ifFalse: [
				naughtyBlocks inspect.
				self error: 'Here are the bad blocks'].
		].
	].
	"Creation of the segment happens here"

	"try using one-quarter of memory 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: 'yo 3/31/2003 12:09' prior: 37139850!
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, MultiSymbol 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 _ PopUpMenu
				confirm: 
'Some block(s) which reference instance variables 
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?' 
				trueChoice: 'keep going' 
				falseChoice: 'stop and take a look'.
			goodToGo ifFalse: [
				naughtyBlocks inspect.
				self error: 'Here are the bad blocks'].
		].
	].
	"Creation of the segment happens here"

	"try using one-quarter of memory 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 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: 'sd 5/11/2003 17:12' prior: 22367655!
install
	"This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment."

	| newRoots |
	state = #onFile ifTrue: [self readFromFile].
	state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols.
		endMarker _ segment nextObject. 	"for enumeration of objects"
		endMarker == 0 ifTrue: [endMarker _ 'End' clone]].
	(state = #active) | (state = #imported) ifFalse: [self errorWrongState].
	newRoots _ self loadSegmentFrom: segment outPointers: outPointers.
	state = #imported 
		ifTrue: ["just came in from exported file"
			arrayOfRoots _ newRoots]
		ifFalse: [
			arrayOfRoots elementsForwardIdentityTo: newRoots].
	state _ #inactive.
	self beepPrimitive.	"Don't use Squeak sound here. <- was the old comment of self beep."
	"I converted self beep as self beepPrimitive to avoid to use the sound system - sd 11/May/03" 
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'md 10/22/2003 16:24' prior: 37148655!
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.	"Don't use Squeak sound here. <- was the old comment of self beep."
	"I converted self beep as Beeper beepPrimitive to avoid to use the sound system - sd 11/May/03" 
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'gk 2/24/2004 23:53' prior: 37149701!
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: 'ar 2/22/2001 10:45'!
writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"



	| fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
	zipper _ [
		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: 'testing' stamp: 'gm 2/15/2003 14:56' prior: 22393963!
findRogueRootsAllMorphs: rootArray 
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) assemble all objects should be in seg:  morph tree, presenter, scripts, player classes, metaclasses.  Put in a Set.
2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."

	| inSeg testRoots scriptEditors pointIn wld xRoots |
	Smalltalk garbageCollect.
	inSeg := IdentitySet new: 200.
	arrayOfRoots := rootArray.
	(testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray].
	testRoots do: 
			[:obj | 
			(obj isKindOf: Project) 
				ifTrue: 
					[inSeg add: obj.
					wld := obj world.
					inSeg add: wld presenter].
			(obj isKindOf: Presenter) ifTrue: [inSeg add: obj]].
	xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)].
	xRoots do: 
			[:obj | 
			"root is a project"

			obj isMorph 
				ifTrue: 
					[obj allMorphs do: 
							[:mm | 
							inSeg add: mm.
							mm player ifNotNil: [inSeg add: mm player]].
					obj isWorldMorph ifTrue: [inSeg add: obj presenter]]].
	inSeg do: 
			[:obj | 
			(obj isKindOf: Player) 
				ifTrue: 
					[scriptEditors := obj class tileScriptNames 
								collect: [:nn | obj scriptEditorFor: nn].
					scriptEditors do: [:se | inSeg addAll: se allMorphs]]].
	testRoots do: [:each | inSeg remove: each ifAbsent: []].
	"want them to be pointed at from outside"
	pointIn := IdentitySet new: 400.
	inSeg do: [:ob | pointIn addAll: (Smalltalk pointersTo: ob except: inSeg)].
	testRoots do: [:each | pointIn remove: each ifAbsent: []].
	pointIn remove: inSeg array ifAbsent: [].
	pointIn remove: pointIn array ifAbsent: [].
	inSeg do: 
			[:obj | 
			(obj 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 isKindOf: Player) 
				ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]].
	"*** presenter playerlist"
	self halt: 'Examine local variables pointIn and inSeg'.
	^pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'gm 2/22/2003 18:36' prior: 22398168!
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: 'fileIn/Out' stamp: 'tk 10/21/2002 15:34'!
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 |

	self flag: #bobconv.	

	RecentlyRenamedClasses _ nil.		"in case old data hanging around"
	mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers.
		"Dictionary of just the ones that change shape.  Substitute them in outPointers."
	ccFixups _ self remapCompactClasses: mapFakeClassesToReal 
				refStrm: smartRefStream.
	ccFixups ifFalse: [^ self error: 'A class in the file is not compatible'].
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers.
		"Can't use install.  Not ready for rehashSets"
	mapFakeClassesToReal isEmpty ifFalse: [
		self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
	].
	receiverClasses _ self restoreEndianness.		"rehash sets"
	smartRefStream checkFatalReshape: receiverClasses.

	"Classes in this segment."
	arrayOfRoots do: [:importedObject | 
		importedObject class class == Metaclass ifTrue: [self declare: importedObject]].
	arrayOfRoots do: [:importedObject | 
		(importedObject isKindOf: 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: 'yo 8/5/2003 19:13' prior: 37159635!
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 m |

	self flag: #bobconv.	

	RecentlyRenamedClasses _ nil.		"in case old data hanging around"
	mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers.
		"Dictionary of just the ones that change shape.  Substitute them in outPointers."
	ccFixups _ self remapCompactClasses: mapFakeClassesToReal 
				refStrm: smartRefStream.
	ccFixups ifFalse: [^ self error: 'A class in the file is not compatible'].
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers.
		"Can't use install.  Not ready for rehashSets"
	mapFakeClassesToReal isEmpty ifFalse: [
		self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
	].
	arrayOfRoots do: [:importedObject |
		(importedObject isKindOf: MultiString) ifTrue: [
			importedObject mutateJISX0208StringToUnicode.
			importedObject class = MultiSymbol ifTrue: [
				"self halt."
				MultiSymbol hasInternedALoadedSymbol: importedObject ifTrue: [:multiSymbol |
					multiSymbol == importedObject ifFalse: [
						multiSymbol becomeForward: importedObject.
					].
				].
			].
		].
	].
	Smalltalk garbageCollect.
	MultiSymbol rehash.

	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"

	MultiSymbol allInstances do: [:each | 
		m _ MultiSymbol intern: each asString.
		each == m ifFalse: [
			"For a project from older m17n image, this is necessary."
			"self halt."
			m becomeForward: each.
		].
	].
! !

!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 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 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: '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: '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: '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: '*SMBase-export' stamp: 'gk 11/7/2003 00:21'!
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 methodsFor: '*SMBase-export' stamp: 'gk 11/7/2003 00:21' prior: 37177936!
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 commentStamp: '<historical>' prior: 0!
I represent a segment of Squeak address space.  I am created from an array of root objects.  After storing, my segment contains a binary encoding of every object accessible from my roots but not otherwise accessible from anywhere else in the system.  My segment contains outward pointers that are indices into my table of outPointers.
	When a segment is written out onto a file, it goes in a folder called <image name>_segs.  If your image is called "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the image whenever your move, copy, or rename it.
	Whenever a Class is in arrayOfRoots, its class (aClass class) must also be in the arrayOfRoots.
	There are two kinds of image segments.  Normal image segments are a piece of a specific Squeak image, and can only be read back into that image.  The image holds the array of outPointers that are necessary to turn the bits in the file into objects.
	To put out a normal segment that holds a Project (not the current project), execute (Project named: 'xxx') storeSegment.

	The second kind of image segment is an Export Segment.  It can be read into a different Squeak image.  It does not have stay with your Squeak image.  To create one:
(ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class))
		writeForExport: 'myFile.extSeg'.
To create one for a project:
	(Project named: 'Play With Me - 3') exportSegment.
To read it into another image:  Select 'myFile.extSeg' in a FileList, Menu 'load as project'.  It will install its classes automatically.  If you need to see the roots array, it is temporarily stored in (SmartRefStream scannedObject).

arrayOfRoots	The objects that head the tree we will trace.
segment			The WordArray of raw bits of all objects in the tree.
outPointers		Oops of all objects outside the segment pointed to from inside.
state			(see below)
segmentName	Its basic name.  Often the name of a Project.
fileName		The local name of the file.  'Foo-23.seg'
endMarker		An object located in memory somewhere after a segment that has 
		just been brought in.  To enumerate the objects in the segment, start at 
		the segment and go to this object.
userRootCnt		number of roots submitted by caller.  Extras are added in preparation for saving.

state that an ImageSegment may exist in...

#activeCopy			(has been 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 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: 'fileIn/Out' stamp: 'sd 9/30/2003 14:02' prior: 22433191!
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: 'sd 11/16/2003 14:17' prior: 22435789!
startUp
	| choice |
	"Minimal thing to assure that a .segs folder is present"

(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
	(FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) 
		ifFalse: [
			choice _ (PopUpMenu labels: 'Create folder\Quit without saving' withCRs)
				startUpWithCaption: 
					'The folder with segments for this image is missing.\' withCRs,
					self folder, '\If you have moved or renamed the image file,\' withCRs,
					'please Quit and rename the segments folder in the same way'.
			choice = 1 ifTrue: [FileDirectory default createDirectory: self folder].
			choice = 2 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]]

	! !

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

!ImmAbstractPlatform methodsFor: 'all' stamp: 'yo 11/7/2002 17:43'!
keyboardFocusForAMorph: aMorph

	"do nothing"
! !

!ImmWin32 methodsFor: 'all' stamp: 'yo 11/30/2003 16:06'!
keyboardFocusForAMorph: aMorph

	| left top pos |
	aMorph ifNil: [^ self].
	[
		pos _ aMorph prefereredKeyboardPosition.
		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
! !

!ImmX11 methodsFor: 'as yet unclassified' stamp: 'yo 11/24/2003 06:21'!
keyboardFocusForAMorph: aMorph

	| left top pos |
	aMorph ifNil: [^ self].
	[
		pos _ aMorph prefereredKeyboardPosition.
		left _ (pos x min: Display width max: 0) asInteger.
		top _ (pos y min: Display height max: 0) asInteger
			 + (aMorph textStyle lineGrid).
		self setCompositionWindowPositionX: left y: top
	] 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
! !

!Imports methodsFor: 'initialize' stamp: 'sd 5/11/2003 18:17'!
initialize

	imports := Dictionary new.! !

!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 20:36'!
images
	"returns all the imported images"

	^ imports values

	! !

!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 21:51'!
importImage: anImage named: aName 
	
	imports at: aName 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 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 class methodsFor: 'instance creation' stamp: 'sd 5/11/2003 18:16'!
default

	default isNil
		ifTrue: [ default := self new].
	^ default! !

!Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:38' prior: 37191995!
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! !

!InMidstOfFileinNotification methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 17:07'!
defaultAction

	self resume: false! !

!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: 'bf 2/9/2004 10:55'!
userString
	"Add leading tabs to my userString"
	^ (String new: indentLevel withAll: Character tab), super userString
! !

!IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'md 11/14/2003 16:43' prior: 22442633!
acceptDroppingMorph: toDrop event: evt
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self clearDropHighlighting.! !

!IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 16:49' prior: 37193196!
acceptDroppingMorph: toDrop event: evt
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self highlightForDrop: false.! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:25'!
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.
	hasToggle
		ifTrue: [hLineLeft := myBounds right - 3]
		ifFalse: [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: 'nk 3/8/2004 11:41'!
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.
	hasToggle
		ifTrue: [vLineTop := myCenter y + 5]
		ifFalse: [vLineTop := myCenter y].
	self nextSibling hasToggle
		ifTrue: [vLineBottom := nextSibBounds top + 2 ]
		ifFalse: [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: 'ar 12/31/2001 02:37'!
drawOn: aCanvas

	| tRect sRect columnRect columnScanner columnData columnLeft colorToUse |

	tRect := self toggleRectangle.
	sRect := bounds withLeft: tRect right + 3.
	self drawToggleOn: aCanvas in: tRect.
	colorToUse _ complexContents preferredColor ifNil: [color].
	(container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
		aCanvas 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 7/10/2002 11:53' prior: 37196293!
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].
	(container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
		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' prior: 22444141!
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: 'initialization' stamp: 'nop 2/10/2001 15:06'!
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.
! !

!IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 22445441!
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-container protocol' stamp: 'ar 3/17/2001 17:38'!
openPath: anArray

	anArray isEmpty ifTrue: [^container setSelectedMorph: nil].
	self withSiblingsDo: [:each | 
		(each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [
			each isExpanded ifFalse: [
				each toggleExpandedState.
				container adjustSubmorphPositions.
			].
			each changed.
			anArray size = 1 ifTrue: [
				^container setSelectedMorph: each
			].
			each firstChild ifNil: [^container setSelectedMorph: nil].
			^each firstChild openPath: anArray allButFirst.
		].
	].
	^container setSelectedMorph: nil

! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'tpr 11/27/2003 14:15' prior: 37199776!
openPath: anArray

	anArray isEmpty ifTrue: [^container setSelectedMorph: nil].
	self withSiblingsDo: [:each | 
		(anArray first isNil or: [each complexContents asString = anArray first]) ifTrue: [
			each isExpanded ifFalse: [
				each toggleExpandedState.
				container adjustSubmorphPositions.
			].
			each changed.
			anArray size = 1 ifTrue: [
				^container setSelectedMorph: each
			].
			each firstChild ifNil: [^container setSelectedMorph: nil].
			^each firstChild openPath: anArray allButFirst.
		].
	].
	^container setSelectedMorph: nil

! !

!IndentingListItemMorph 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.!
!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' prior: 22471514!
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: 'dgd 2/22/2003 13:25' prior: 22474451!
requiredWidth
	submorphs isEmpty ifTrue: [^self basicWidth].
	^(submorphs detectSum: [:m | m width]) + (submorphs size * padding)! !

!IndexTabs methodsFor: 'layout' stamp: 'dgd 2/22/2003 13:25' prior: 22475368!
widthImposedByOwner
	((owner isNil or: [owner isWorldOrHandMorph]) 
		or: [owner submorphs size < 2]) ifTrue: [^self basicWidth].
	^owner submorphs second width! !

!InfiniteForm methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'!
asColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:34'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the real display message, but it doesn't get used until the new
	display protocol is installed."
	| targetBox patternBox bb |
	(patternForm isKindOf: Form) ifFalse:
		[^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm].

	"Do it iteratively"
	targetBox _ aDisplayMedium boundingBox intersect: clipRectangle.
	patternBox _ patternForm boundingBox.
	bb _ BitBlt current destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm
		combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0
		extent: patternBox extent clipRect: clipRectangle.
	bb colorMap:
		(patternForm 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' prior: 37203294!
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: 'ar 5/14/2001 23:35'!
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 isKindOf: Form) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox _ aPort clipRect.
	patternBox _ patternForm boundingBox.
	savedMap _ aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form paint;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm 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' prior: 37205474!
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: 'ar 5/14/2001 23:35'!
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 isKindOf: Form) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox _ aPort clipRect.
	patternBox _ patternForm boundingBox.
	savedMap _ aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form paint;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm 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: 'nk 4/17/2004 19:48' prior: 37207910!
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! !

!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: 'accessing' stamp: 'nk 3/7/2004 18:45' prior: 22493501!
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: 'private' stamp: 'ar 5/2/2001 18:11'!
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 |
	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.
	self perform: (BlockTypes at: blockType+1).
	"Note: if bit position hasn't advanced then nothing has been decoded."
	bp = self bitPosition 
		ifTrue:[^self primitiveFailed].
	^self next! !

!InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18' prior: 37211098!
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: '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"! !

!InfoStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 22513945!
initialize
"initialize the state of the receiver"
	super initialize.
""
	stepTime _ 1000.
	block _ [Time now]! !

!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: 'ar 2/14/2001 00:00'!
peekPosition
	^self cursorPoint! !

!InputSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:45' prior: 22529436!
shutDown
	InterruptWatcherProcess ifNotNil: [
		InterruptWatcherProcess terminate.
		InterruptWatcherProcess _ nil ].! !

!InputSensor methodsFor: 'keyboard' stamp: 'yo 8/18/2003 23:36' prior: 22515863!
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: 'modifier keys' stamp: 'sw 5/23/2001 13:46'!
macOptionKeyPressed
	"Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific."

	Preferences macOptionKeyAllowed ifFalse: [self notifyWithLabel: 'Portability note:
InputSensor>>macOptionKeyPressed is not portable.
Please use InputSensor>>yellowButtonPressed instead!!'].
	^ self primMouseButtons anyMask: 32! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 7/12/2000 09:31'!
anyButtonPressed
	"Answer whether a mouse button is being pressed."
	^ self mouseButtons > 0! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24' prior: 37215315!
anyButtonPressed
	"Answer whether at least one mouse button is currently being pressed."

	^ self primMouseButtons anyMask: 7
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 7/12/2000 09:31'!
blueButtonPressed
	"Answer whether only the blue mouse button is being pressed. 
	This is the third mouse button or cmd+click on the Mac."
	^ self mouseButtons = 1! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24' prior: 37215683!
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 7/12/2000 09:31'!
mouseButtons
	"Answer the result of primMouseButtons, but swap the mouse  
	buttons if Preferences swapMouseButtons is set.
	Mask off just the lower 3 buttons (just the mouse buttons)"
	^ (ButtonDecodeTable at: self primMouseButtons + 1)
		bitAnd: 7! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24' prior: 37216177!
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' stamp: 'nk 3/17/2004 07:02' prior: 22518627!
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 7/12/2000 09:31'!
redButtonPressed
	"Answer true if the red mouse button is being pressed. This is 
	the first mouse button."
	^ self mouseButtons = 4! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:16' prior: 37217111!
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' prior: 22518992!
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' prior: 22519271!
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' stamp: 'nk 3/17/2004 07:25' prior: 22519850!
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 7/12/2000 09:32'!
yellowButtonPressed
	"Answer whether only the yellow mouse button is being pressed. 
	This is the second mouse button or option+click on the Mac."
	^ self mouseButtons = 2! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:05' prior: 37218608!
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: 'user interrupts' stamp: 'nk 4/12/2004 19:36'!
eventTicklerProcess
	"Answer my event tickler process, if any"
	^nil! !

!InputSensor methodsFor: 'user interrupts' stamp: 'nk 6/21/2004 10:41' prior: 22522008!
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: 'gk 2/23/2004 20:51' prior: 22522892!
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: 'user interrupts' stamp: 'gk 2/23/2004 20:51' prior: 37219766!
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 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 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: '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: 'nk 7/11/2002 07:41'!
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 ] ].
! !

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

!InputSensor class methodsFor: 'preference change notification' stamp: 'nk 7/11/2002 07:32'!
duplicateControlAndAltKeysChanged
	"The Preference for duplicateControlAndAltKeys has changed."
	(Preferences
		valueOfFlag: #swapControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting swapControlAndAltKeys preference'.
			(Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
		].
	self installKeyDecodeTable.
! !

!InputSensor class methodsFor: 'preference change notification' stamp: 'nk 7/11/2002 07:32'!
swapControlAndAltKeysChanged
	"The Preference for swapControlAndAltKeys has changed."
	(Preferences
		valueOfFlag: #duplicateControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting duplicateControlAndAltKeys preference'.
			(Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
		].
	self installKeyDecodeTable.
! !

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

!InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0!
see BorderedMorph!
!Inspector methodsFor: 'accessing' stamp: 'ajh 2/3/2003 19:19' prior: 22531775!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	| c |
	c _ anObject inspectorClass.
	(self class ~= c and: [self class format = c format]) ifTrue: [
		self primitiveChangeClassTo: c basicNew].
	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''! !

!Inspector methodsFor: 'accessing' stamp: 'hg 10/14/2001 16:20'!
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: 'hmm 7/12/2001 20:35'!
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: 'menu commands' stamp: 'tk 10/18/2002 17:13'!
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: 'sw 3/20/2001 12:20'!
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: 'dew 2/13/2001 01:31'!
chasePointers
	| saved |
	self selectionIndex == 0 ifTrue: [^ self changed: #flash].
	saved _ self object.
	[self object: nil.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: saved]
		ifFalse: [self inspectPointers]]
		ensure: [self object: saved]! !

!Inspector methodsFor: 'menu commands' stamp: 'nk 7/24/2003 10:11' prior: 37228236!
chasePointers
	| saved |
	self selectionIndex == 0 ifTrue: [^ self changed: #flash].
	saved _ self object.
	[self object: nil.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: saved]
		ifFalse: [self objectReferencesToSelection]]
		ensure: [self object: saved]! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 3/28/2003 18:29' prior: 22539122!
classVarRefs
	"Request a browser of methods that store into a chosen instance variable"

	| aClass |
	(aClass _ self classOfSelection) ifNotNil:
		[SystemNavigation new browseClassVarRefs: aClass].
! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14' prior: 37228964!
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 3/28/2003 16:50' prior: 22539932!
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.
	SystemNavigation new browseAllStoresInto: sel from: aClass! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14' prior: 37229540!
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: 'dew 9/19/2001 01: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)
		-
		('browse full (b)'					browseMethodFull)
		('browse class'						browseClass)
		('browse hierarchy'					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: 'rhi 5/27/2004 17:00' prior: 37230515!
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)
		-
		('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 10/18/2002 16:52'!
inspectElement
	| sel selSize countString count |
	"Create and schedule an Inspector on an element of the receiver's model's currently selected collection."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	((sel _ self selection) isKindOf: SequenceableCollection) ifFalse:
		[(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement].
		^ sel inspect].
	(selSize _ sel size) == 1 ifTrue: [^ sel first inspect].
	selSize <= 15 ifTrue:
		[count _ (SelectionMenu selections: (1 to: selSize) asArray) startUpWithCaption: 'which element?'.
		count ifNil: [^ self] ifNotNil: [^ (sel at: count) inspect]].

	countString _ FillInTheBlank request: 'Which element? (1 - ', selSize printString, ')' initialAnswer: '1'.
	countString isEmptyOrNil ifTrue: [^ self].
	count _ Integer readFrom: (ReadStream on: countString).
	(count > 0 and: [count <= selSize])
		ifTrue:
			[(sel  at: count) inspect]
		ifFalse:
			[self beep]! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 6/5/2003 13:34' prior: 37233232!
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)].
		count _ PopUpMenu withCaption: 'which element?' chooseFrom: nameStrs.
		count = 0 ifTrue: [^ self].
		^ (sel at: count) inspect].

	countString _ FillInTheBlank 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: [self beep]! !

!Inspector methodsFor: 'menu commands' stamp: 'md 10/22/2003 16:10' prior: 37234247!
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)].
		count _ PopUpMenu withCaption: 'which element?' chooseFrom: nameStrs.
		count = 0 ifTrue: [^ self].
		^ (sel at: count) inspect].

	countString _ FillInTheBlank 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: 'yo 3/9/2004 11:04' prior: 37235357!
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 _ PopUpMenu withCaption: 'which element?' chooseFrom: nameStrs.
		count = 0 ifTrue: [^ self].
		^ (sel at: count) inspect].

	countString _ FillInTheBlank 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: 'sw 3/7/2001 12:36'!
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 == $c ifTrue: [^ self copyName].
	aChar == $p ifTrue: [^ self browseFullProtocol].
	aChar == $N ifTrue: [^ self browseClassRefs].
	aChar == $v ifTrue: [^ self viewerForValue].

	^ self arrowKey: aChar from: view! !

!Inspector methodsFor: 'menu commands' stamp: 'rhi 5/27/2004 17:09' prior: 37237610!
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' prior: 22544391!
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 3/28/2003 16:51' prior: 22544800!
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.
	SystemNavigation new  browseAllAccessesTo: sel from: aClass! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14' prior: 37239255!
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: 'sw 12/11/2000 15:52'!
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: 'sw 12/11/2000 15:52'!
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! !

!InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'!
interpretNextInstructionUsing: aScanner 
	
	bingo _ false.
	aScanner interpretNextInstructionFor: self.
	^bingo! !

!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}
].!
!InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'!
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: '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! !

!InstVarRefLocatorTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:42'!
testExample1
	| method |

	method := self class compiledMethodAt: #example1.
	self assert: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:42'!
testExample2
	| method |

	method := self class compiledMethodAt: #example2.
	self deny: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'testing' 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 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!
!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: 'sw 3/20/2001 12:16'!
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: 'sw 8/3/2001 18:38'!
windowWithLabel: aLabel
	"Answer a SystemWindow associated with the receiver, with appropriate border characteristics"

	| window |
	"The first branch below provides a pretty nice effect -- a large draggable border when active, a minimal border when not -- but the problem is that we often rely on the title bar to convey useful information.  For the moment, whether the titled or nontitled variant is used is governed by the hard-coded preference named 'suppressWindowTitlesInInstanceBrowsers'"

	Preferences suppressWindowTitlesInInstanceBrowsers
		ifTrue:
			[(window _ SystemWindow newWithoutLabel) model: self.
			window setProperty: #borderWidthWhenActive toValue: 8.
			window setProperty: #borderWidthWhenInactive toValue: 1.
			window borderWidth: 8]
		ifFalse:
			[(window _ SystemWindow labelled: aLabel) model: self].
	^ window
! !

!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: 'sw 11/21/2001 14:36'!
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 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.'! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16833620!
blockReturnTop
	"Return Top Of Stack bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16833776!
doDup
	"Duplicate Top Of Stack bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16833926!
doPop
	"Remove Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16834072!
jump: offset
	"Unconditional Jump bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16834225!
jump: offset if: condition 
	"Conditional Jump bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16834391!
methodReturnConstant: value 
	"Return Constant bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02' prior: 16834556!
methodReturnReceiver
	"Return Self bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16834709!
methodReturnTop
	"Return Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16834865!
popIntoLiteralVariable: anAssociation 
	"Remove Top Of Stack And Store Into Literal Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16835076!
popIntoReceiverVariable: offset 
	"Remove Top Of Stack And Store Into Instance Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16835284!
popIntoTemporaryVariable: offset 
	"Remove Top Of Stack And Store Into Temporary Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16835494!
pushActiveContext
	"Push Active Context On Top Of Its Own Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16835676!
pushConstant: value
	"Push Constant, value, on Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16835854!
pushLiteralVariable: anAssociation
	"Push Contents Of anAssociation On Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16836056!
pushReceiver
	"Push Active Context's Receiver on Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03' prior: 16836236!
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' prior: 16836490!
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' prior: 16836731!
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' prior: 16837189!
storeIntoLiteralVariable: anAssociation 
	"Store Top Of Stack Into Literal Variable Of Method bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04' prior: 16837401!
storeIntoReceiverVariable: offset 
	"Store Top Of Stack Into Instance Variable Of Method bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04' prior: 16837608!
storeIntoTemporaryVariable: offset 
	"Store Top Of Stack Into Temporary Variable Of Method bytecode."
! !

!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. !
!InstructionClientTest methodsFor: 'testing' 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.
			].
	].
! !

!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!
!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' prior: 22556008!
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' stamp: 'md 4/8/2003 12:14' prior: 22556608!
doPop
	"Print the Remove Top Of Stack bytecode."

	self print: 'pop'! !

!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13' prior: 22556737!
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' prior: 22556905!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

	self print: 
		(condition
			ifTrue: ['jumpTrue: ']
			ifFalse: ['jumpFalse: '])
			, (scanner pc + offset) printString! !

!InstructionPrinter methodsFor: 'printing' stamp: 'md 4/8/2003 12:47' prior: 22560705!
print: instruction 
	"Append to the receiver a description of the bytecode, instruction." 

	| code |
	stream print: oldPC; space.
	stream nextPut: $<.
	oldPC to: scanner pc - 1 do: 
		[:i | 
		code _ (method at: i) radix: 16.
		stream nextPut: 
			(code size < 5
				ifTrue: [$0]
				ifFalse: [code at: 4]).
		stream nextPut: code last; space].
	stream skip: -1.
	stream nextPut: $>.
	stream space.
	stream nextPutAll: instruction.
	stream cr.
	oldPC _ scanner pc.
	"(InstructionPrinter compiledMethodAt: #print:) symbolic."
! !

!InstructionPrinter methodsFor: 'printing' stamp: 'ajh 6/27/2003 22:26' prior: 37254136!
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 < 5
				ifTrue: [$0]
				ifFalse: [code at: 4]).
		stream nextPut: code last; space].
	stream skip: -1.
	stream nextPut: $>.
	stream space.
	stream nextPutAll: instruction.
	stream cr.
	oldPC _ scanner pc.
	"(InstructionPrinter compiledMethodAt: #print:) symbolic."
! !

!InstructionPrinter methodsFor: 'printing' stamp: 'ajh 6/27/2003 22:26' prior: 22558456!
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 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 class methodsFor: 'printing' stamp: 'md 4/8/2003 11:19'!
on: aMethod
	^self new method: aMethod.
	! !

!InstructionPrinterTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:28'!
example1
	| ff|
	(1 < 2) ifTrue: [tt ifNotNil: [ff _ 'hallo']].
	^ ff.! !

!InstructionPrinterTest methodsFor: 'testing' 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.
			].
! !

!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!
!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' stamp: 'ajh 8/13/2002 17:32'!
willJustPop

	^ (self method at: pc) = Encoder popCode! !

!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: 'decoding' stamp: 'ajh 7/29/2001 20:45'!
atEnd

	^ pc > self method endPC! !

!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' 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 5/30/2003 01:34'!
previousPc

	| currentPc dummy prevPc |
	currentPc _ pc.
	pc _ self method initialPC.
	dummy _ Message catcher.
	[pc = currentPc] whileFalse: [
		prevPc _ pc.
		self interpretNextInstructionFor: dummy.
	].
	^ prevPc! !

!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:29' prior: 37259096!
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' 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: 'private' stamp: 'ajh 8/1/2001 02:57'!
pc: n

	pc _ n! !

!Integer methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49' prior: 22574203!
// 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: 'truncation and round off' stamp: 'ar 12/25/2001 16:03'!
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].
	^ self atRandom: Collection randomForPicking! !

!Integer methodsFor: 'truncation and round off' stamp: 'lr 11/4/2003 12:14' prior: 37260837!
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: '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: 'yo 8/30/2002 16:32' prior: 22587555!
asCharacter
	"Answer the Character whose value is the receiver."

	self > 255
		ifTrue: [^ MultiCharacter value: self]
		ifFalse: [^ Character value: 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: '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: '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: 'gk 11/26/2003 10:26' prior: 22591302!
printOn: 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"
	
	| current letters digits quo i |
	self < 0 ifTrue: [
		aStream nextPut: $-.
		^self negated printOn: aStream base: base].
	digits _ '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'.
	base = 10 ifFalse: [aStream print: base; nextPut: $r].
	current _ self.
	i _ self digitLength * 8.
	letters _ String new: i.
	[current < base] whileFalse: 
		[quo _ current quo: base.
		letters at: i put: (digits at: (current - (quo * base)) + 1).
		i _ i - 1.
		current _ quo].
	letters at: i put: (digits at: current + 1).
	aStream nextPutAll: (letters copyFrom: i to: letters size)! !

!Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'!
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: 'RAH 4/25/2000 19:49'!
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: 'RAH 4/25/2000 19:49'!
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 printStringBase: baseInteger.
			self negative
				ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)]
				ifFalse: [^ '10r' , tempString]].
	^ self printStringBase: baseInteger! !

!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 class methodsFor: 'instance creation' stamp: 'bf 2/2/2004 00:23' prior: 22605125!
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: '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: 'ar 10/6/2001 19:33'!
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 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]]].! !

!Integer class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	#Numeric.
	"add 200/01/19 For <number> protocol support."
	^ 1! !

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

!IntegerDigitLogicTest methodsFor: 'running' 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: 'running' 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: 'running' 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: 'running' 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: 'running' 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: 'running' 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].
! !

!IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:34'!
testBenchFib
	self should: [0 benchFib = 1].
	self should: [1 benchFib = 1].
	self should: [2 benchFib = 3].
	! !

!IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:34'!
testBenchmark
	self shouldnt: [0 benchmark ] raise: Error.
	! !

!IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:32'!
testTinyBenchmarks
	self shouldnt: [0 tinyBenchmarks] raise: Error.! !

!IntegerTest methodsFor: 'testing - bitLogic' stamp: 'md 3/17/2003 15:27'!
testBitLogic  
	"This little suite of tests is designed to verify correct operation of most
	of Squeak's bit manipulation code, including two's complement
	representation of negative values.  It was written in a hurry and
	is probably lacking several important checks."

	"Shift 1 bit left then right and test for 1"
	| n |
	1 to: 100 do: [:i | self should: [((1 bitShift: i) bitShift: i negated) = 1]].

	"Shift -1 left then right and test for 1"
	1 to: 100 do: [:i | self should: [((-1 bitShift: i) bitShift: i negated) = -1]].

	"And a single bit with -1 and test for same value"
	1 to: 100 do: [:i | self should: [((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)]].

	"Verify that (n bitAnd: n negated) = n for single bits"
	1 to: 100 do: [:i | self should: [n _ 1 bitShift: i. (n bitAnd: n negated) = n]].

	"Verify that n negated = (n complemented + 1) for single bits"
	1 to: 100 do: [:i | self should:[n _ 1 bitShift: i.
				n negated = ((n bitXor: -1) + 1)]].

	"Verify that (n + n complemented) = -1 for single bits"
	1 to: 100 do: [:i | self should: [n _ 1 bitShift: i.
				(n + (n bitXor: -1)) = -1]].

	"Verify that n negated = (n complemented +1) for single bits"
	1 to: 100 do: [:i | self should: [n _ 1 bitShift: i.
				n negated = ((n bitXor: -1) + 1)]].

	self should: [(-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE].! !

!IntegerTest methodsFor: 'testing - bitLogic' stamp: 'md 3/17/2003 15:10'!
testTwoComplementRightShift
	| large small |
	small _ 2 << 16.
	large _ 2 << 32.
	
	self should: [(small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1)
		== ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))].
		
     self should: [ (small bitShift: -1) ~= (small + 1 bitShift: -1)
		== ((large bitShift: -1) ~= (large + 1 bitShift: -1))].! !

!IntegerTest methodsFor: 'testing - testing' stamp: 'md 4/21/2003 16:17'!
testEven
	
	self deny: (1073741825 even).
	self assert: (1073741824  even).
	! !

!IntegerTest methodsFor: 'testing - testing' stamp: 'md 4/21/2003 16:14'!
testIsInteger
	self assert: (0 isInteger).
	! !

!IntegerTest methodsFor: 'testing - testing' 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: 'testing - instance creation' stamp: 'md 3/25/2003 23:14'!
testNew
	self should: [Integer new] raise: TestResult error. ! !

!IntegerTest methodsFor: 'testing - Class Methods' stamp: 'md 4/21/2003 16:12'!
testPrimesUpTo
	|primes|

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

!IntegerTest methodsFor: 'testing' stamp: 'BG 2/8/2004 22:49'!
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 hex.
  hexString := hexString copyFrom:4 to: hexString size.
  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: 'testing' stamp: 'BG 2/8/2004 22:49'!
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) hex.
  hexString := hexString copyFrom:4 to: hexString size.
  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: 'testing' stamp: 'BG 2/8/2004 22: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) hex.
  hexString := hexString copyFrom:4 to: hexString size.
  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: 'testing - math' 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 ! !

!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' prior: 22616980!
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! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'RAA 2/4/2001 16:08'!
addButtons

	| marginPt i sz data images pageNumber f m b1 b2 dot arrowWidth arrowCenter vertices arrowHeight nameMorph |

	self changeNoLayout.
	self hResizing: #rigid.
	self vResizing: #rigid.
	marginPt _ 4@4.
	i _ self currentIndex.
	sz _ self myThumbnailSize.
	arrowWidth _ 14.
	arrowHeight _ 17.
	data _ {
		{i - 1. 'Previous:'. #previousPage. #rightCenter. arrowWidth negated. 'Prev'}.
		{i + 1. 'Next:'. #nextPage. #leftCenter. arrowWidth. '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 - (0@arrowHeight).
				arrowCenter + (0@arrowHeight).
				arrowCenter + (tuple fifth @ 0).
			}.
			f getCanvas
				drawPolygon: vertices 
				color: Color orange 
				borderWidth: 0 
				borderColor: Color transparent.
			m _ ImageMorph new image: f.
			m setBalloonText: tuple second,' ',(listOfPages at: pageNumber) first.
			m addMouseUpActionWith: (
				MessageSend receiver: self selector: tuple third
			).
		] ifFalse: [
			f _ (Form extent: sz depth: 16) fillColor: Color lightGray.
			m _ ImageMorph new image: f.
		].
		m
	].
	b1 _ images first.
	b2 _ images second.
	dot _ EllipseMorph new extent: 16@16; color: Color orange lighter; borderWidth: 0.
	self addMorph: (b1 position: self position + marginPt).
	self addMorph: (b2 position: b1 topRight + (marginPt x @ 0)).
	self extent: (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;
		align: nameMorph bottomLeft with: self bottomLeft.

! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 15:41' prior: 37284315!
addButtons

	| marginPt i sz data images pageNumber f m b1 b2 dot arrowWidth arrowCenter vertices arrowHeight nameMorph |

	self changeNoLayout.
	self hResizing: #rigid.
	self vResizing: #rigid.
	marginPt _ 4@4.
	i _ self currentIndex.
	sz _ self myThumbnailSize.
	arrowWidth _ 14.
	arrowHeight _ 17.
	data _ {
		{i - 1. 'Previous:'. #previousPage. #rightCenter. arrowWidth negated. 'Prev'}.
		{i + 1. 'Next:'. #nextPage. #leftCenter. arrowWidth. '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 - (0@arrowHeight).
				arrowCenter + (0@arrowHeight).
				arrowCenter + (tuple fifth @ 0).
			}.
			f getCanvas
				drawPolygon: vertices 
				color: Color orange 
				borderWidth: 0 
				borderColor: Color transparent.
			m _ ImageMorph new image: f.
			m setBalloonText: tuple second 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: 16@16; color: Color orange lighter; borderWidth: 0.
	self addMorph: (b1 position: self position + marginPt).
	self addMorph: (b2 position: b1 topRight + (marginPt x @ 0)).
	self extent: (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;
		align: nameMorph bottomLeft with: self bottomLeft.

! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 11/29/2003 17:35' prior: 37286562!
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 2/16/2003 14:15'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ (Color
		r: 0.27
		g: 0.634
		b: 0.365)
		alpha: 0.25! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 10/26/2003 19:06' prior: 37291276!
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' prior: 22623697!
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: 'navigation' stamp: 'RAA 3/5/2001 21:27'!
destroyThread

	(self confirm: 'Destroy thread <',threadName,'> ?') ifFalse: [^self].
	self class knownThreads removeKey: threadName ifAbsent: [].
	self delete! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 9/19/2003 15:30' prior: 37292086!
destroyThread

	(self confirm: ('Destroy thread <{1}> ?' translated format:{threadName})) ifFalse: [^self].
	self class knownThreads removeKey: threadName ifAbsent: [].
	self delete! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/3/2004 16:58' prior: 37292352!
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 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: 'RAA 8/15/2001 12:00'!
insertNewProjectActionFor: newProj

	| me |

	me _ CurrentProjectRefactoring currentProjectName.
	listOfPages withIndexDo: [ :each :index |
		each first = me ifTrue: [
			listOfPages add: {newProj name} afterIndex: index.
			^self switchToThread: threadName.
		].
	].
	listOfPages add: {newProj name} afterIndex: listOfPages size.
	^self switchToThread: threadName
		
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 3/5/2001 21:29'!
jumpWithinThread

	| aMenu me weHaveOthers myIndex |

	me _ CurrentProjectRefactoring currentProjectName.
	aMenu _ MenuMorph new defaultTarget: self.
	weHaveOthers _ false.
	myIndex _ self currentIndex.
	listOfPages withIndexDo: [ :each :index |
		index = myIndex ifTrue: [
			aMenu add: 'you are here' action: #yourself.
			aMenu lastSubmorph color: Color red.
		] ifFalse: [
			weHaveOthers _ true.
			aMenu add: 'jump to <',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'].
	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 9/19/2003 15:33' prior: 37294270!
jumpWithinThread

	| aMenu me weHaveOthers myIndex |

	me _ CurrentProjectRefactoring currentProjectName.
	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: 'RAA 3/22/2001 12:59'!
moreCommands

	| allThreads aMenu others target |

	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	others _ (allThreads keys reject: [ :each | each = threadName]) asSortedCollection.
	others do: [ :each |
		aMenu add: 'switch to <',each,'>' selector: #switchToThread: argument: each.
	].
	aMenu 
		add: 'switch to recent projects' action: #getRecentThread;
		addLine;
		add: 'create a new thread' action: #threadOfNoProjects;
		add: 'edit this thread' action: #editThisThread;
		add: 'create thread of all projects' action: #threadOfAllProjects;
		addLine;
		add: 'First project in thread' action: #firstPage;
		add: 'Last project in thread' action: #lastPage.
	(target _ self currentIndex + 2) > listOfPages size ifFalse: [
		aMenu 
			add: 'skip over next project (',(listOfPages at: target - 1) first,')' 
			action: #skipOverNext
	].
	aMenu
		add: 'jump within this thread' action: #jumpWithinThread;
		add: 'insert new project' action: #insertNewProject;
		addLine;
		add: 'simply close this navigator' action: #delete;
		add: 'destroy this thread' action: #destroyThread.

	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 9/19/2003 15:36' prior: 37296124!
moreCommands

	| allThreads aMenu others target |

	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	others _ (allThreads keys reject: [ :each | each = threadName]) asSortedCollection.
	others do: [ :each |
		aMenu add: ('switch to <{1}>' translated format:{each}) selector: #switchToThread: argument: each.
	].
	aMenu 
		add: 'switch to recent projects' translated action: #getRecentThread;
		addLine;
		add: 'create a new thread' translated action: #threadOfNoProjects;
		add: 'edit this thread' translated action: #editThisThread;
		add: 'create thread of all projects' translated action: #threadOfAllProjects;
		addLine;
		add: 'First project in thread' translated action: #firstPage;
		add: 'Last project in thread' translated action: #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
		add: 'jump within this thread' translated action: #jumpWithinThread;
		add: 'insert new project' translated action: #insertNewProject;
		addLine;
		add: 'simply close this navigator' translated action: #delete;
		add: 'destroy this thread' translated action: #destroyThread.

	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/3/2004 17:21' prior: 37297412!
moreCommands
	"Put up a menu of options"

	| allThreads aMenu others target |
	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'navigation' translated.
	aMenu addStayUpItem.
	self flag: #deferred.  "Probably don't want that stay-up item, not least because the navigation-keystroke stuff is not dynamically handled"
	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' 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 4/4/2004 21:33' prior: 37298851!
moreCommands
	"Put up a menu of options"

	| allThreads aMenu others target |
	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'navigation' translated.
	aMenu addStayUpItem.
	self flag: #deferred.  "Probably don't want that stay-up item, not least because the navigation-keystroke stuff is not dynamically handled"
	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: 'RAA 2/4/2001 16:16'!
myThumbnailSize

	^52@39! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 11/29/2003 17:36' prior: 37302505!
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: 'RAA 3/5/2001 21:16'!
skipOverNext
	
	| target |

	(target _ self currentIndex + 2) > listOfPages size ifTrue: [^1 beep].
	currentIndex _ target.
	self loadPageWithProgress.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25' prior: 37303525!
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 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: 'RAA 2/24/2001 13:15'!
threadOfNoProjects

	| nameList nav |

	nameList _ { {CurrentProjectRefactoring currentProjectName} }.
	nav _ self class basicNew.
	nav
		listOfPages: nameList;
		threadName: '' index: nil;
		initialize.
	nav editThisThread.
! !

!InternalThreadNavigationMorph methodsFor: 'sorting' stamp: 'RAA 2/4/2001 16:12'!
acceptSortedContentsFrom: aHolder
	"Update my page list from the given page sorter."

	| nameOfThisProject cachedData proj |

	threadName isEmpty ifTrue: [threadName _ 'I need a name'].
	threadName _ FillInTheBlank 
		request: 'Name this thread.' 
		initialAnswer: threadName.
	threadName isEmptyOrNil ifTrue: [^self].
	listOfPages _ OrderedCollection new.
	aHolder submorphs doWithIndex: [:m :i |
		(nameOfThisProject _ m valueOfProperty: #nameOfThisProject) ifNotNil: [
			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: 'dgd 9/19/2003 15:27' prior: 37305360!
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: 'piano rolls' stamp: 'JW 5/17/2001 08:05'!
triggerActionFromPianoRoll

	| proj |

	WorldState addDeferredUIMessage: [
		(self currentIndex >= listOfPages size)
			ifTrue: [1 beep]
			ifFalse: [
				currentIndex _ self currentIndex + 1.
				proj _ Project named: ((listOfPages at: currentIndex) at: 1).
				proj world setProperty: #letTheMusicPlay toValue: true.
				proj enter.
			].
	]! !

!InternalThreadNavigationMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:13' prior: 37308521!
triggerActionFromPianoRoll
	| proj |
	WorldState addDeferredUIMessage: 
			[self currentIndex >= listOfPages size 
				ifTrue: [1 beep]
				ifFalse: 
					[currentIndex := self currentIndex + 1.
					proj := Project named: ((listOfPages at: currentIndex) first).
					proj world setProperty: #letTheMusicPlay toValue: true.
					proj enter]]! !

!InternalThreadNavigationMorph methodsFor: 'piano rolls' stamp: 'md 10/22/2003 15:25' prior: 37308972!
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: 'private' stamp: 'RAA 2/24/2001 13:14'!
currentIndex

	| currentName |

	currentName _ CurrentProjectRefactoring currentProjectName.
	listOfPages withIndexDo: [ :each :index |
		(each first = currentName and: [preferredIndex = index]) ifTrue: [^currentIndex _ index]
	].
	listOfPages withIndexDo: [ :each :index |
		each first = currentName ifTrue: [^currentIndex _ index]
	].
	^currentIndex ifNil: [1]
! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dgd 10/26/2003 19:37' prior: 37309855!
currentIndex

	| currentName |

	currentName _ CurrentProjectRefactoring currentProjectName.
	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 2/24/2001 22:18'!
loadPageWithProgress

	| projectInfo projectName |

	projectInfo _ listOfPages at: currentIndex.
	projectName _ projectInfo at: 1.
	loadedProject _ Project named: projectName.
	self class know: listOfPages as: threadName.
	WorldState addDeferredUIMessage: [
		InternalThreadNavigationMorph openThreadNamed: threadName atIndex: currentIndex
	] fixTemps.

	loadedProject ifNil: [
		ComplexProgressIndicator new 
			targetMorph: self;
			historyCategory: 'project loading';
			withProgressDo: [
				[
					loadedProject _ CurrentProjectRefactoring 
							currentFromMyServerLoad: projectName
				] 
					on: ProjectViewOpenNotification
					do: [ :ex | ex resume: false]		
						"we probably don't want a project view morph in this case"
			].
	].
	loadedProject ifNil: [
		^self inform: 'I cannot find that project'
	].
	self delete.

	loadedProject enter.
! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 14:13' prior: 37310826!
loadPageWithProgress
	| projectInfo projectName |
	projectInfo := listOfPages at: currentIndex.
	projectName := projectInfo first.
	loadedProject := Project named: projectName.
	self class know: listOfPages as: threadName.
	WorldState 
		addDeferredUIMessage: 
			[InternalThreadNavigationMorph openThreadNamed: threadName
				atIndex: currentIndex] 
					fixTemps.
	loadedProject ifNil: 
			[(ComplexProgressIndicator new)
				targetMorph: self;
				historyCategory: 'project loading';
				withProgressDo: 
						[
						[loadedProject := CurrentProjectRefactoring 
									currentFromMyServerLoad: projectName] 
								on: ProjectViewOpenNotification
								do: 
									[:ex | 
									ex resume: false
									"we probably don't want a project view morph in this case"]]].
	loadedProject ifNil: [^self inform: 'I cannot find that project'].
	self delete.
	loadedProject enter! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dgd 10/8/2003 19:09' prior: 37311786!
loadPageWithProgress

	| projectInfo projectName |

	projectInfo _ listOfPages at: currentIndex.
	projectName _ projectInfo first.
	loadedProject _ Project named: projectName.
	self class know: listOfPages as: threadName.
	WorldState addDeferredUIMessage: [
		InternalThreadNavigationMorph openThreadNamed: threadName atIndex: currentIndex
	] fixTemps.

	loadedProject ifNil: [
		ComplexProgressIndicator new 
			targetMorph: self;
			historyCategory: 'project loading' translated;
			withProgressDo: [
				[
					loadedProject _ CurrentProjectRefactoring 
							currentFromMyServerLoad: projectName
				] 
					on: ProjectViewOpenNotification
					do: [ :ex | ex resume: false]		
						"we probably don't want a project view morph in this case"
			].
	].
	loadedProject ifNil: [
		^self inform: 'I cannot find that project' translated
	].
	self delete.

	loadedProject enter.
! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'sw 3/3/2004 17:03' prior: 37312775!
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 _ CurrentProjectRefactoring 
							currentFromMyServerLoad: projectName
				] 
					on: ProjectViewOpenNotification
					do: [ :ex | ex resume: false]		
						"we probably don't want a project view morph in this case"
			].
	].
	loadedProject ifNil: [
		^self inform: 'I cannot find that project' translated
	].
	self delete.

	loadedProject enter.
! !

!InternalThreadNavigationMorph methodsFor: 'accessing' stamp: 'dgd 11/29/2003 17:35'!
sizeRatio
	"answer the size ratio for the receiver"
	
	^ Preferences standardMenuFont height / 12! !

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

!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: '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: 'sorter' stamp: 'RAA 5/10/2001 17:04'!
sorterFormForProject: aProject sized: ignored

	^(ProjectViewMorph on: aProject) imageForm scaledToSize: 80@60.
! !

!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: 'comparing' stamp: 'rhi 8/14/2003 10:08' prior: 23689811!
= 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: '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: 'testing' stamp: 'rhi 8/12/2003 09:52'!
isInterval

	^ true! !

!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 class methodsFor: 'instance creation' stamp: 'md 1/14/2004 11:42' prior: 23694291!
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
"! !

!IntervalTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'sd 12/23/2001 16:16'!
testExtent

	self assert: (Interval from: 10 to: 100) extent = 90! !

!IntervalTest methodsFor: 'testing' 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: 'testing' stamp: 'sd 2/21/2004 13:46'!
testOtherNewFrom
	"self run: #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: 'testing' stamp: 'md 6/6/2003 15:02'!
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)! !

!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 methodsFor: 'exceptionInstantiator' stamp: 'ar 5/30/2001 20:49'!
pathName: badPathName
	^self new pathName: badPathName! !

!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.
!
!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: 'miscellaneous' stamp: 'ls 7/10/2003 17:42'!
returnTwelve
	"this method is tweaked by testFlagInCompiledMethod"
	^12! !

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

! !

!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.!
!JISX0208 class methodsFor: 'as yet unclassified' stamp: 'yo 9/2/2002 16:47'!
charSetSize

	^ 94 * 94.
! !

!JISX0208 class methodsFor: 'as yet unclassified' stamp: 'yo 9/2/2002 16:49'!
compoundTextSequence

	^ CompoundTextSequence.
! !

!JISX0208 class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 9/2/2002 17:38'!
leadingChar

	^ 1.
! !

!JISX0208 class methodsFor: 'as yet unclassified' stamp: 'yo 9/4/2002 22:52'!
printingDirection

	^ #right.
! !

!JISX0208 class methodsFor: 'accessing - displaying' stamp: 'yo 3/13/2003 11:57'!
scanSelector

	^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern:
! !

!JISX0208 class methodsFor: 'accessing - encoding' 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: 'accessing - encoding' 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: 'accessing - encoding' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable jisx0208Table.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 09:24'!
charAtKuten: anInteger

	| a b |
	a _ anInteger \\ 100.
	b _ anInteger // 100.
	(a > 94) | (b > 94) ifTrue: [
		self error: 'character code is not valid'.
	].
	^ MultiCharacter leadingChar: self leadingChar code: ((b - 1) * 94) + a - 1.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 10:45'!
languageClass

	^ Japanese.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 09:09'!
stringFromKutenArray: anArray

	| s |
	s _ MultiString new: anArray size.
	1 to: anArray size do: [:i |
		s at: i put: (self charAtKuten: (anArray at: i)).
	].
	^s.
! !

!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: '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 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>
!
!JPEGMovieFile methodsFor: 'initialization' stamp: 'jm 11/15/2001 08:13'!
initialize

	file _ nil.
	frameOffsets _ #().
	currentFrameIndex _ 1.
! !

!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: 'jm 2/11/2002 13:30'!
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: '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: 'jm 11/20/2001 11:02'!
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: 'jm 11/15/2001 08:10'!
videoSetFrame: newIndex stream: ignored
	"Set the index of the current frame."

	currentFrameIndex _ (newIndex asInteger max: 1) min: (frameOffsets size - 1).
! !

!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: '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: 'jm 11/16/2001 17:01'!
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: 'jm 11/27/2001 10:23'!
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 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 class methodsFor: 'testing' stamp: 'jm 11/15/2001 14:56'!
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'
! !

!JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'jm 1/25/2002 20:46'!
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: 'jm 12/13/2001 09:38'!
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: 'jm 12/13/2001 09:39'!
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 soundtracks' stamp: 'jm 12/13/2001 21:03'!
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: 'jm 12/13/2001 21:03'!
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: 'movie creation-private' stamp: 'jm 1/25/2002 21:08'!
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: 'jm 2/3/2002 10:14'!
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: 'jm 11/25/2001 14:20'!
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: 'jm 11/25/2001 14:23'!
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: 'jm 11/17/2001 08:01'!
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: 'jm 11/25/2001 16:55'!
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
! !

!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 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 class methodsFor: 'class initialization' stamp: 'ar 3/4/2001 18:32'!
initialize
	"JPEGReadStream initialize"
	MaxBits _ 16.! !

!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: '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: '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: '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: 'mir 6/12/2001 11:28'!
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 hex , ' 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: '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: '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: '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: '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: 'private' stamp: 'ar 3/4/2001 17:34'!
on: aStream
	super on: aStream.
	stream _ JPEGReadStream on: stream upToEnd.! !

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

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

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/25/2001 20:23'!
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.
	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: 'jmv 12/7/2001 17:13'!
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 respondsTo: #close) ifTrue: [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: 'sd 1/30/2004 15:19' prior: 37382914!
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: 'jm 11/25/2001 20:24'!
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.
	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 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 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 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')! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 8/14/2003 15:40'!
beCurrentNaturalLanguage

	super beCurrentNaturalLanguage.
	Preferences restoreDefaultFontsForJapanese.
! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 10/4/2003 16:04'!
flapTabTextFor: aString in: aFlapTab

	^ aString.
! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 11/12/2002 11:09'!
removeFonts
! !

!JapaneseEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 22:38'!
charsetClass

	^ UnicodeJapanese.
! !

!JapaneseEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 4/2/2003 07:32'!
defaultEncodingName

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^ 'utf-8' copy].
	(#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) ifTrue: [^ 'shift-jis' copy].
	(#('unix') includes: platformName) ifTrue: [^ 'euc-jp' copy].
	^ nil
! !

!JapaneseEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 11/24/2003 06:24'!
defaultInputInterpreter

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^ NoInputInterpreter new].
	platformName = 'Win32' ifTrue: [^ WinShiftJISInputInterpreter new].
	platformName = 'Mac OS'
		ifTrue: [('10*' match: Smalltalk osVersion)
				ifTrue: [^ MacUnicodeInputInterpreter new]
				ifFalse: [^ MacShiftJISInputInterpreter new]].
	((platformName = 'unix') and: [(Smalltalk getSystemAttribute: 1005) = 'X11']) ifTrue: [
		^ UnixEUCJPInputInterpreter new].
	^ NoInputInterpreter new.
! !

!JapaneseEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 12/1/2003 14:25'!
setClipboardInterpreterClass

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE'])
		ifTrue: [clipboardInterpreter _ NoConversionClipboardInterpreter. ^ self].
	platformName = 'Win32'
		ifTrue: [clipboardInterpreter _ WinShiftJISClipboardInterpreter. ^ self].
	platformName = 'Mac OS'
		ifTrue: [clipboardInterpreter _ MacShiftJISClipboardInterpreter. ^ self].
	((platformName = 'unix') and: [(Smalltalk getSystemAttribute: 1005) = 'X11'])
		ifTrue: [clipboardInterpreter _ UnixEUCJPClipboardInterpreter. ^ self].
	clipboardInterpreter _ NoConversionClipboardInterpreter.
! !

!JoystickMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:50' prior: 23736209!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'set X range' translated action: #setXRange.
	aCustomMenu add: 'set Y range' translated action: #setYRange.
	autoCenter
		ifTrue: [aCustomMenu add: 'turn auto-center off' translated action: #toggleAutoCenter]
		ifFalse: [aCustomMenu add: 'turn auto-center on' translated action: #toggleAutoCenter].
	realJoystickIndex
		ifNil: [aCustomMenu add: 'track real joystick' translated action: #trackRealJoystick]
		ifNotNil: [aCustomMenu add: 'stop tracking joystick' translated action: #stopTrackingJoystick].
! !

!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: 'je 1/6/2002 02:14' prior: 23736019!
stepTime
	^ realJoystickIndex
		ifNil:
			[super stepTime]
		ifNotNil:
			[0]  "fast as we can to track actual joystick"
! !

!JoystickMorph methodsFor: 'stepping and presenter' stamp: 'laza 6/8/2003 11:53' prior: 37396849!
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 commentStamp: 'kfr 10/27/2003 16:25' prior: 0!
A widget that simulates a joystick. Mosly used in etoy scripting.!
!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: 'sw 9/26/2001 04: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."

	^ #((joystick (
(slot amount 'The amount of displacement' Number readOnly Player getAmount unused unused)
(slot angle 'The angular displacement' Number readOnly Player getAngle  unused  unused)
(slot leftRight  'The horizontal displacement' Number  readOnly Player getLeftRight  unused  unused)
(slot upDown 'The vertical displacement' Number  readOnly Player getUpDown unused unused))))


! !

!JoystickMorph class methodsFor: '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] ! !

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

!KSX1001 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 10:46'!
languageClass

	^ Korean.
! !

!KSX1001 class methodsFor: 'as yet unclassified' stamp: 'yo 10/22/2002 19:47'!
charSetSize

	^ 94 * 94.
! !

!KSX1001 class methodsFor: 'as yet unclassified' stamp: 'yo 10/22/2002 19:47'!
compoundTextSequence

	^ CompoundTextSequence.
! !

!KSX1001 class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 10/22/2002 19:49'!
leadingChar

	^ 3.
! !

!KSX1001 class methodsFor: 'accessing - encoding' 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: 'accessing - encoding' stamp: 'yo 11/24/2002 22:38'!
scanSelector

	^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:
! !

!KSX1001 class methodsFor: 'accessing - encoding' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable ksx1001Table.
! !

!KeyboardEvent methodsFor: 'printing' stamp: 'nk 7/20/2003 10:13' prior: 23745494!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: type; nextPutAll: ' '''.
	self controlKeyPressed ifTrue: [ aStream nextPutAll: 'Ctrl-' ].
	self commandKeyPressed ifTrue: [ aStream nextPutAll: 'Cmd-' ].
	(buttons anyMask: 32) ifTrue: [ aStream nextPutAll: 'Opt-' ].
	self controlKeyPressed ifTrue: [
		aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter.
	] ifFalse: [
		aStream nextPut: self keyCharacter.
	].
	aStream nextPut: $'.
	aStream nextPut: $].! !

!KeyboardEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 18:53' prior: 23746719!
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! !

!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 methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 16:24'!
new



	^ (self basicNew) initialize; yourself.

! !

!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'mrm 7/1/2001 04:32'!
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'; actionSelector: #buildChord:).
	button _ SimpleButtonMorph new target: self;
		borderColor: #raised; borderWidth: 2; color: color.
	playRow addMorphBack: (button label: '          rest          '; actionSelector: #emitRest).
	button _ SimpleButtonMorph new target: self;
		borderColor: #raised; borderWidth: 2; color: color.
	playRow addMorphBack: (button label: 'del'; 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';
				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';
				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';
				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';
				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';
				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';
				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';
				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';
				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';
				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';
				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';
				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';
				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: 'dgd 2/14/2003 20:55' prior: 23751761!
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: 'simple keyboard' stamp: 'ar 3/17/2001 14:27'!
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]).
! !

!KidNavigationMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2003 18:39' prior: 23758541!
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: 'nk 7/12/2003 08:46' prior: 23758912!
fontForButtons

	^Preferences standardEToysFont! !

!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' prior: 23759182!
initialize
	"initialize the state of the receiver"
	| |
	super initialize.
	""
	self layoutInset: 12.

	self removeAllMorphs.
	self addButtons! !

!Kiswahili methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:27'!
name
	"answer the receiver's name"
	^ #'Kiswahili'! !

!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: 'dgd 3/7/2003 14:35' prior: 23781564!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom.
	! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'dew 6/30/2003 01:11' prior: 37410734!
initialize
	super initialize.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'nk 5/18/2003 13:14' prior: 23781756!
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.

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

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

!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 class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 20:18' prior: 23870147!
initialize
	"
	KlattSynthesizer initialize
	"
	Epsilon _ 1.0e-04.
! !

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 15:30'!
charsetClass

	^ UnicodeKorean.
! !

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 18:29'!
defaultEncodingName

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk 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].
	^ nil
! !

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

!Language methodsFor: 'accessing' stamp: 'dgd 8/27/2003 17:31'!
debug 
	"answer the receiver's debug flag"
	^ debug! !

!Language methodsFor: 'accessing' stamp: 'dgd 8/27/2003 17:31'!
debug: aBoolean 
	"set the receiver's debug flag"
	debug := aBoolean! !

!Language methodsFor: 'accessing' stamp: 'dgd 8/24/2003 17:56'!
name
	"answer the receiver's name"
	self subclassResponsibility! !

!Language methodsFor: 'accessing' stamp: 'dgd 8/27/2003 17:30'!
switchDebug
	"switch the receiver's debug flag"
	self debug: self debug not! !

!Language methodsFor: 'accessing' stamp: 'dgd 8/24/2003 19:11'!
translations
	"answer the receiver's collection of translations"
	^ translations! !

!Language methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:10'!
untranslated
	"answer the receiver's collection of untranslated phrases"
	^untranslated! !

!Language methodsFor: 'accessing - phrases' stamp: 'dgd 8/25/2003 20:07'!
phrase: phraseString translation: translationString 
	"set the receiver's translation for phraseString"
	| oldUntranslatedSize |
	translations at: phraseString put: translationString.
	self changed: #translations.

	oldUntranslatedSize := untranslated size.
	untranslated
		remove: phraseString
		ifAbsent: [].
	oldUntranslatedSize = untranslated size
		ifFalse: [self changed: #untranslated]! !

!Language methodsFor: 'accessing - phrases' stamp: 'dgd 8/27/2003 17:04'!
rawTranslationFor: phraseString 
	"answer the receiver's translation for phraseString ignoring the debug flag"
	^ translations
		at: phraseString
		ifAbsent: [| oldUntranslatedSize | 
			oldUntranslatedSize := untranslated size.
			untranslated add: phraseString.
			oldUntranslatedSize = untranslated size
				ifFalse: [self changed: #untranslated].
			phraseString]! !

!Language methodsFor: 'accessing - phrases' stamp: 'dgd 8/26/2003 11:32'!
removeTranslationFor: phraseString 
	"answer the receiver's translation for phraseString"
	translations
		removeKey: phraseString
		ifAbsent: [].
	self changed: #translations.! !

!Language methodsFor: 'accessing - phrases' stamp: 'jm 9/2/2003 12:01'!
removeUntranslated: phraseString 
	"remove phraseString from unstranslated set"
	| oldUntranslatedSize |
	oldUntranslatedSize := untranslated size.
	untranslated remove: phraseString ifAbsent:[^self].
	oldUntranslatedSize = untranslated size
		ifFalse: [self changed: #untranslated]! !

!Language methodsFor: 'accessing - phrases' stamp: 'dgd 8/27/2003 16:31'!
translationFor: phraseString 
	"answer the receiver's translation for phraseString"
	| oldUntranslatedSize |
	translations
		at: phraseString
		ifPresent: [:translation | ^ debug
				ifTrue: [translation , ' (' , phraseString , ')']
				ifFalse: [translation]].

	oldUntranslatedSize := untranslated size.
	untranslated add: phraseString.
	oldUntranslatedSize = untranslated size
		ifFalse: [self changed: #untranslated].
	^ phraseString! !

!Language methodsFor: 'checking' stamp: 'dgd 9/28/2003 16:47'!
check
	"check the translations and answer a collection with the results"
	| results counter phrasesCount |
	results := OrderedCollection new.
	phrasesCount := translations size + untranslated size.
	counter := 0.

	translations
		keysAndValuesDo: [:phrase :translation | 
			| result | 
			result := self checkPhrase: phrase translation: 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! !

!Language methodsFor: 'checking' stamp: 'dgd 9/28/2003 16:57'!
checkPhrase: phraseString translation: translationString 
	"check the translation an aswer a string with a comment or a  
	nil meaning no-comments"
	((phraseString beginsWith: ' ')
			and: [(translationString beginsWith: ' ') not])
		ifTrue: [^ 'The original phrase begins with a blank and the translation don''t.' translated].

	((phraseString endsWith: ' ')
			and: [(translationString endsWith: ' ') not])
		ifTrue: [^ 'The original phrase ends with a blank and the translation don''t.' translated].

	(phraseString onlyLetters notEmpty
			and: [phraseString onlyLetters first isUppercase]
			and: [translationString onlyLetters notEmpty]
			and: [translationString onlyLetters first isUppercase not])
		ifTrue: [^ 'The original phrase begins with uppercase and the translation don''t.' translated].

	(phraseString onlyLetters notEmpty
			and: [phraseString onlyLetters first isLowercase]
			and: [translationString onlyLetters notEmpty]
			and: [translationString onlyLetters first isLowercase not])
		ifTrue: [^ 'The original phrase begins with lowercase and the translation don''t.' translated].

	phraseString = translationString
		ifTrue: [^ 'original and translation are the same'].
	" 
	(self isPhraseUsed: phraseString)  
	ifFalse: [^ 'The original phrase seems to be unused.'  
	translated]."

	^ nil! !

!Language methodsFor: 'checking' stamp: 'dgd 9/28/2003 16:54'!
checkUntranslatedPhrase: phraseString 
	"check the phrase an aswer a string with a comment or a nil  
	meaning no-comments"

	(translations includes: phraseString)
		ifTrue: [^ 'possible double-translation' translated].

	^ nil! !

!Language methodsFor: 'checking' stamp: 'dgd 9/6/2003 19:12'!
isPhraseUsed: phraseString 
	"answer whatever the phraseString is used on any method"
	" 
	| methods |  
	methods := Smalltalk  
	allSelectNoDoits: [:method |  
	method  
	hasLiteralSuchThat: [:lit |  
	lit class == String  
	and: [lit includesSubstring: phraseString caseSensitive:  
	true]]].  
	 
	^ methods notEmpty  
	"
	Smalltalk
		allBehaviorsDo: [:class | 
			class
				selectorsDo: [:selector |
					selector ~~ #DoIt
						ifTrue: [
							((class compiledMethodAt: selector)
									hasLiteralSuchThat: [:literal |
										literal class == String
											and: [literal = phraseString ]])
								ifTrue: [^ true]]]].

	^ false! !

!Language methodsFor: 'file operations' stamp: 'dgd 8/31/2003 20:28'!
loadFromFileNamed: fileNameString 
	"save the receiver's translations to a file named fileNameString"
	| stream loadedDictionary |
	stream := ReferenceStream fileNamed: fileNameString.
	loadedDictionary := stream next.
	stream close.

	self initializeTranslations.
	self initializeUntranslated.
	self processExternalObject: loadedDictionary! !

!Language methodsFor: 'file operations' stamp: 'dgd 8/31/2003 20:24'!
mergeFromFileNamed: fileNameString 
	"save the receiver's translations to a file named fileNameString"
	| stream loadedDictionary |
	stream := ReferenceStream fileNamed: fileNameString.
	loadedDictionary := stream next.
	stream close.

	self processExternalObject: loadedDictionary.! !

!Language methodsFor: 'file operations' stamp: 'dgd 8/31/2003 20:25'!
mergeFromStream: aStream 
	"save the receiver's translations to a file named aStream"
	| stream loadedDictionary |
	stream := ReferenceStream on: aStream.
	loadedDictionary := stream next.
	stream close.

	self processExternalObject: loadedDictionary ! !

!Language methodsFor: 'file operations' stamp: 'dgd 8/31/2003 20:41'!
processExternalObject: aDictionaryOrArray 
	"pivate - process the external object"
	| loadedDictionary loadedSet |
	(aDictionaryOrArray isKindOf: Dictionary)
		ifTrue: ["old format without untranslated collection"
			loadedDictionary := aDictionaryOrArray.
			loadedSet := Set new]
		ifFalse: ["new format -> {translations. untranslated}"
			loadedDictionary := aDictionaryOrArray first.
			loadedSet := aDictionaryOrArray second].

	loadedSet
		do: [:each | self rawTranslationFor: each].
	loadedDictionary
		keysAndValuesDo: [:key :value | self phrase: key translation: value]! !

!Language methodsFor: 'file operations' stamp: 'dgd 8/31/2003 20:28'!
saveToFileNamed: fileNameString 
	"save the receiver's translations to a file named fileNameString"
	| stream |
	stream := ReferenceStream fileNamed: fileNameString.
	stream nextPut: {translations. untranslated}.
	stream close! !

!Language methodsFor: 'initialization' stamp: 'dgd 8/28/2003 09:44'!
initialize
	"initialize the receiver"
	debug := false.

	self initializeTranslations.
	self initializeUntranslated! !

!Language methodsFor: 'initialization' stamp: 'dgd 8/24/2003 18:15'!
initializeTranslations
	"initialize the receiver's translations dictionary"
	translations := Dictionary new! !

!Language methodsFor: 'initialization' stamp: 'dgd 8/24/2003 18:16'!
initializeUntranslated
	"initialize the receiver's untranslated collection"
	untranslated := Set new! !

!Language methodsFor: 'printing' stamp: 'dgd 8/24/2003 18:06'!
printOn: aStream 
	"Append to the argument, aStream, a sequence of characters  
	that identifies the receiver."
	aStream nextPutAll: 'Language: ';
		 nextPutAll: self name! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/16/2003 21:52'!
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! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/19/2003 13:50'!
printHeaderReportOn: aStream 
	"append to aStream a header report of the receiver with swiki  
	format"
	aStream nextPutAll: '!!!!';
		
		nextPutAll: ('Language: {1}' translated format: {self name});
		 cr.

	aStream nextPutAll: '- ';
		
		nextPutAll: ('{1} translated phrases' translated format: {translations size});
		 cr.

	aStream nextPutAll: '- ';
		
		nextPutAll: ('{1} untranslated phrases' translated format: {untranslated size});
		 cr.

	aStream cr; cr! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/19/2003 13:47'!
printReportOn: aStream 
	"append to aStream a report of the receiver with swiki format"
	self printHeaderReportOn: aStream.
	self printUntranslatedReportOn: aStream.
	self printTranslationsReportOn: aStream! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/19/2003 13:50'!
printTranslationsReportOn: aStream 
	"append to aStream a report of the receiver's translations"
	| originalPhrases |
	aStream nextPutAll: '!!';
		 nextPutAll: 'translations' translated;
		 cr.

	originalPhrases := translations keys asSortedCollection.

	originalPhrases
		do: [:each | 
			aStream
				nextPutAll: ('|{1}|{2}|' format: {self asHtml: each. self
							asHtml: (translations at: each)});
				 cr].

	aStream cr; cr! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/19/2003 13:50'!
printUntranslatedReportOn: aStream 
	"append to aStream a report of the receiver's translations"
	aStream nextPutAll: '!!';
		 nextPutAll: 'not translated' translated;
		 cr.

	untranslated asSortedCollection
		do: [:each | 
			aStream
				nextPutAll: ('|{1}|' format: {self asHtml: each});
				 cr].

	aStream cr; cr! !

!Language methodsFor: 'reporting' stamp: 'dgd 9/16/2003 20:30'!
reportString
	"answer a string with a report of the receiver"
	| stream |
	stream := String new writeStream.
	self printReportOn: stream.
	^ stream contents! !

!Language methodsFor: 'user interface' stamp: 'dgd 8/24/2003 19:16'!
defaultBackgroundColor
	"answer the receiver's defaultBackgroundColor for views"
	^ Color cyan! !

!Language class methodsFor: 'accessing - instances' stamp: 'dgd 8/24/2003 18:00'!
clearAllInstances
	"clear the receiver instance and the subclasses ones"
	self withAllSubclasses
		do: [:each | each clearInstance]! !

!Language class methodsFor: 'accessing - instances' stamp: 'dgd 8/24/2003 18:00'!
clearInstance
	"clear the receiver instance"
	instance := nil! !

!Language class methodsFor: 'accessing - instances' stamp: 'dgd 8/24/2003 18:23'!
instance
	"answer an instance of the receiver"
	^ instance
		ifNil: [instance := self newInstance]! !

!Language class methodsFor: 'accessing - instances' stamp: 'dgd 8/24/2003 17:54'!
newInstance
	"private - answer a new instance of the receiver"
	^ super new initialize! !

!Language class methodsFor: 'accessing - languages' stamp: 'dgd 9/24/2003 18:31'!
availableLanguageSymbols
	"answer a collection of available languages in the image"
	^ (self availableLanguages
		collect: [:each | each name]) asSortedCollection! !

!Language class methodsFor: 'accessing - languages' stamp: 'dgd 9/24/2003 18:07'!
availableLanguages
	"answer a collection of available languages in the image"
	^ self allSubclasses
		select: [:each | each includesSelector: #name]
		thenCollect: [:each | each instance]! !

!Language class methodsFor: 'accessing - languages' stamp: 'dgd 8/24/2003 18:32'!
defaultLanguage
	"answer the default language"
	^ Language languageNamed: Project current naturalLanguage ifNone: [English instance]! !

!Language class methodsFor: 'accessing - languages' stamp: 'dgd 8/24/2003 18:04'!
languageNamed: aString
	"answer the instance of the language named aString"
	^ Language availableLanguages detect:[:each | each name = aString]! !

!Language class methodsFor: 'accessing - languages' stamp: 'dgd 8/24/2003 18:32'!
languageNamed: aString ifNone: aBlock
	"answer the instance of the language named aString"
	^ Language availableLanguages
		detect: [:each | each name = aString]
		ifNone: aBlock! !

!Language class methodsFor: 'applying' stamp: 'dgd 9/24/2003 18:51'!
applyTranslations
	"private - try to apply the translations as much as possible all  
	over the image"
	Cursor wait
		showWhile: [
	self recreateFlaps.
	ParagraphEditor initializeTextEditorMenus.
	Utilities emptyScrapsBook]! !

!Language class methodsFor: 'applying' stamp: 'dgd 2/26/2004 18:36' prior: 37430015!
applyTranslations
	"private - try to apply the translations as much as possible all  
	over the image"
	Cursor wait
		showWhile: [""
			ActiveWorld allTileScriptingElements
				do: [:viewerOrScriptor | viewerOrScriptor setNaturalLanguageTo: Language defaultLanguage name].
			self recreateFlaps.
			ParagraphEditor initializeTextEditorMenus.
			Utilities emptyScrapsBook]! !

!Language class methodsFor: 'applying' stamp: 'nk 5/1/2004 16:52' prior: 37430328!
applyTranslations
	"private - try to apply the translations as much as possible all  
	over the image"
	Cursor wait
		showWhile: [""
			ActiveWorld allTileScriptingElements
				do: [:viewerOrScriptor | viewerOrScriptor setNaturalLanguageTo: Language defaultLanguage name].
			self recreateFlaps.
			ParagraphEditor initializeTextEditorMenus.
			Utilities emptyScrapsBook.
			MenuIcons initializeTranslations.]! !

!Language class methodsFor: 'applying' stamp: 'dgd 9/24/2003 18:51'!
recreateFlaps
	Flaps disableGlobalFlaps: false.
	Flaps enableGlobalFlaps.
	(Project current isFlapIDEnabled: 'Navigator' translated)
		ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated]! !

!Language class methodsFor: 'class initialization' stamp: 'dgd 10/4/2003 14:21'!
initialize
	"initialize the receiver"
	" 
	Language initialize.
	"
	FileList registerFileReader: self! !

!Language class methodsFor: 'file-list services' stamp: 'dgd 10/31/2003 09:23'!
fileReaderServicesForFile: fullName suffix: suffix 
	"Answer the file services associated with given file"
	^ (suffix = 'translation') | (suffix = '*')
		ifTrue: [{self serviceMergeLanguageTranslations}]
		ifFalse: [#()]! !

!Language class methodsFor: 'file-list services' stamp: 'dgd 10/4/2003 14:50'!
mergeTranslationFileNamed: fileFullNameString 
	"merge the translation in the file named fileFullNameString"
	| stream |
	stream := FileStream oldFileNamed: fileFullNameString.
	self mergeFromStream: stream named: stream localName sansPeriodSuffix.
	stream close
! !

!Language class methodsFor: 'file-list services' stamp: 'dgd 10/4/2003 14:34'!
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'! !

!Language class methodsFor: 'file-list services' stamp: 'dgd 10/4/2003 14:24'!
services
	"Answer potential file services associated with this class"
	^ {self serviceMergeLanguageTranslations}! !

!Language class methodsFor: 'instance creation' stamp: 'dgd 8/24/2003 17:54'!
new
	"answer an instance of the receiver"
	^ self error: 'use #instance to get the default instance of the receiver'! !

!Language class methodsFor: 'merging' stamp: 'dgd 8/29/2003 21:07'!
mergeFromStream: aStream named: fileNameString 
	"merge the translation in aStream named fileNameString"
	| targetLanguage |
	targetLanguage := self availableLanguages
				detect: [:each | 
					each class name = fileNameString
						or: [each name = fileNameString]]
				ifNone: [
					Transcript
						show: ('invalid language: {1}' translated format: {fileNameString});
						 cr.
					^ self].

	targetLanguage mergeFromStream: aStream ! !

!LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 8/14/2003 15:39'!
beCurrentNaturalLanguage

! !

!LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 8/11/2003 21:23'!
flapTabTextFor: aString

	^ aString asTranslatedWording.
! !

!LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 8/11/2003 21:25'!
flapTabTextFor: aString in: aFlapTab

	^ aString asTranslatedWording.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 17:49'!
charsetClass

	^ Latin1.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 14:43'!
defaultClipboardInterpreter

	clipboardInterpreter ifNil: [self setClipboardInterpreterClass].
	^ clipboardInterpreter new.

! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 10/24/2002 11:56'!
defaultEncodingName

	self subclassResponsibility
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 21:47'!
defaultInputInterpreter

	| platformName osVersion |
	platformName _ Smalltalk platformName.
	osVersion _ Smalltalk getSystemAttribute: 1002.
	^ MacRomanInputInterpreter new.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:06'!
defaultSystemConverter

	defaultSystemConverter ifNil: [self setDefaultSystemConverterClass].
	^ defaultSystemConverter new.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 15:50'!
initialize
"
	self initialize
"
	Smalltalk addToStartUpList: self.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:24'!
setClipboardInterpreterClass

	clipboardInterpreter _ MacRomanClipboardInterpreter.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 14:40'!
setDefaultSystemConverterClass

	| encodingName cl |
	encodingName _ self defaultEncodingName.
	encodingName ifNil: [^ defaultSystemConverter _ MacRomanTextConverter].

	cl _ TextConverter defaultConverterClassForEncoding: encodingName.
	cl ifNotNil: [^ defaultSystemConverter _ cl].
	^ defaultSystemConverter _ MacRomanTextConverter.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 15:43'!
setInputInterpreterClass

	inputInterpreter _ NoInputInterpreter.

! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 13:55'!
startUp

	clipboardInterpreter _ nil.
	inputInterpreter _ nil.
	defaultSystemConverter _ nil.
	Clipboard clearInterpreters.
	HandMorph startUp.
! !

!LanguageEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 13:55' prior: 37436046!
startUp

	clipboardInterpreter _ nil.
	inputInterpreter _ nil.
	defaultSystemConverter _ nil.
	Clipboard clearInterpreters.
	HandMorph startUp.
! !

!LargePositiveInteger methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'!
hash

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

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

!LargePositiveIntegerTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'md 3/17/2003 15:17'!
testMultDicAddSub
	| n f f1 |
	
	n _ 100.
	f _ 100 factorial.
	f1 _ f*(n+1).
	n timesRepeat: [f1 _ f1 - f].
	self should: [f1 = f]. 

	n timesRepeat: [f1 _ f1 + f].
	self should: [f1 // f = (n+1)]. 
	self should: [f1 negated = (Number readFrom: '-' , f1 printString)].! !

!LargePositiveIntegerTest methodsFor: 'as yet unclassified' stamp: 'md 3/17/2003 15:19'!
testNormalize

	"Check normalization and conversion to/from SmallInts"

	self should: [(SmallInteger maxVal + 1 - 1) == SmallInteger maxVal].
	self should: [(SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3)].
	self should: [(SmallInteger minVal - 1 + 1) == SmallInteger minVal].
	self should: [(SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3)].! !

!Latin1 class methodsFor: 'class initialization' 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 18:09'!
charSetSize

	^ 256.

	"^ 94 + 96"
! !

!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: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: '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: 'displaying' stamp: 'yo 8/18/2003 17:32'!
printingDirection

	^ #right.
! !

!Latin1 class methodsFor: 'displaying' stamp: 'yo 8/18/2003 17:32'!
scanSelector

	^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:
! !

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

!LayoutCell methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:09' prior: 23993145!
size
	| n cell |
	n := 0.
	cell := self.
	[cell isNil] whileFalse: 
			[n := n + 1.
			cell := cell nextCell].
	^n! !

!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 class methodsFor: 'as yet unclassified' stamp: 'ar 2/5/2002 00:07'!
fractions: fractionsOrNil
	^self fractions: fractionsOrNil offsets: nil! !

!LayoutFrame class methodsFor: 'as yet unclassified' stamp: 'ar 2/5/2002 20:06'!
offsets: offsetsOrNil
	^self fractions: nil offsets: offsetsOrNil! !

!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 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: 'ls 6/22/2001 22:47'!
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 changed.! !

!LazyListMorph methodsFor: 'list management' stamp: 'sps 3/9/2004 17:06' prior: 37443056!
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: '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: 'ls 10/11/2003 13:12'!
display: item  atRow: row on: canvas
	"display the given item at row row"
	| drawBounds |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds.
	canvas text: item bounds: drawBounds font: font color: (self colorForRow: row).! !

!LazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:17' prior: 37445517!
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: '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: 'ls 10/21/2001 20:57'!
item: index
	"return the index-th item, using the 'listItems' cache"
	(index between: 1 and: listItems size)
		ifFalse: [ "there should have been an update, but there wasn't!!"  ^self getListItem: index].
	(listItems at: index) ifNil: [ 
		listItems at: index put: (self getListItem: index). ].
	^listItems at: index! !

!LazyListMorph methodsFor: 'scroll range' stamp: 'sps 3/23/2004 16:07'!
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 -- if the list is less then 30 items, we grab them all. If not, we grab currently visible ones, until we've checked itemsToCheck of them, then take the max width out of that 'sampling', then double it. If you know a better way, please chime in."

	| maxW count itemsToCheck item |

	itemsToCheck _ 30.
	maxW _ 0. 
	count _ 0.
	listItems do: 
		[ :each |
			each ifNotNil: 
				[maxW _ maxW max: (self font widthOfStringOrText: each contents)]].
				
	(count < itemsToCheck) ifTrue:
		[1 to: listItems size do: 
			[:i | (listItems at: i) ifNil: 
							[item _ self item: i.
							maxW _ maxW max: (self font widthOfStringOrText: item contents).
							((count _ count + 1) > itemsToCheck) ifTrue:[ ^maxW * 2]]]].
	
	^maxW 
! !

!LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:18' prior: 37449688!
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 -- if the list is less then 30 items, we grab them all. If not, we grab currently visible ones, until we've checked itemsToCheck of them, then take the max width out of that 'sampling', then double it. If you know a better way, please chime in."

	| maxW count itemsToCheck item |

	itemsToCheck _ 30.
	maxW _ 0. 
	count _ 0.
	listItems do: 
		[ :each |
			each ifNotNil: 
				[maxW _ maxW max: (self widthToDisplayItem: each contents)]].
				
	(count < itemsToCheck) ifTrue:
		[1 to: listItems size do: 
			[:i | (listItems at: i) ifNil: 
							[item _ self item: i.
							maxW _ maxW max: (self widthToDisplayItem: item contents).
							((count _ count + 1) > itemsToCheck) ifTrue:[ ^maxW * 2]]]].
	
	^maxW 
! !

!LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:17'!
widthToDisplayItem: item
	^self font widthOfStringOrText: item
	! !

!LazyListMorph commentStamp: 'ls 10/11/2003 13:10' 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.!
!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: 'kfr 5/26/2000 20:12'!
initialize

	super initialize.
	color _ Color green.
	highlighted _ false.
	char _ 0.! !

!LedCharacterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:55' prior: 37454624!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	highlighted _ false.
	char _ 0! !

!LedCharacterMorph commentStamp: '<historical>' prior: 0!
char 36 is SPACE!
!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! !

!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: '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' prior: 24008854!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	highlighted _ false.
	digit _ 0 ! !

!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' prior: 24012402!
color: aColor 
	"set the receiver's color and the submorphs color"
	super color: aColor.
	self
		submorphsDo: [:m | m color: aColor]! !

!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: 'initialization' stamp: 'dgd 3/7/2003 14:36'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color green! !

!LedMorph methodsFor: 'initialization' stamp: 'di 3/8/2001 23:44'!
initialize

	super initialize.
	flashing _ false.
	flash _ false.
	self scrollInit.
	self digits: 2.
	self value: 0.
	self color: Color green.
! !

!LedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36' prior: 37463390!
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: '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 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.

!
!LedTimerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36' prior: 24015340!
initialize
"initialize the state of the receiver"
	super initialize.
""
	counting _ false.
	startSeconds _ Time totalSeconds! !

!Lexicon methodsFor: 'initialization' stamp: 'sw 12/18/2000 16:12'!
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: 'sw 10/12/2001 21:36'!
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 
		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.
	self reformulateCategoryList.
	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: 'hmm 3/3/2004 22:17' prior: 37466253!
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: 'sw 1/30/2001 22:24'!
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: 'sw 12/18/2000 23:19'!
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: 'basic operation' stamp: 'sw 3/20/2001 16:06'!
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: 'sw 12/5/2000 15:50'!
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: [^ self beep].
	messageIndex _ messageList indexOf: detectedItem.
	self messageListIndex: messageIndex! !

!Lexicon methodsFor: 'basic operation' stamp: 'nb 6/17/2003 12:25' prior: 37473401!
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: 'tk 9/14/2001 16:32'!
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: [
		editSelection _ #newMessage.
		self contentsChanged].
	(newSelector _ self selectedMessageName) ifNotNil: 
		[self updateSelectorsVisitedfrom: current to: newSelector]! !

!Lexicon methodsFor: 'basic operation' stamp: 'nk 2/14/2004 15:10' prior: 37474501!
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: 'sw 3/20/2001 12:13'!
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: 'sw 5/25/2001 01:34'!
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: 'sw 12/12/2000 19:37'!
categoryListIndex
	"Answer the index of the currently-selected item in in the category list"

	^ categoryListIndex ifNil: [categoryListIndex _ 1]! !

!Lexicon methodsFor: 'category list' stamp: 'sw 3/20/2001 20:19'!
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: 'sw 12/1/2000 23:01'!
chooseCategory: aCategory
	"Choose the category of the given name, if there is one"

	self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ self beep])! !

!Lexicon methodsFor: 'category list' stamp: 'nb 6/17/2003 12:25' prior: 37479068!
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: 'sw 12/28/2000 13:46'!
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: 'sw 12/11/2000 14:47'!
reformulateCategoryList
	"Reformulate the category list"

	categoryList _ nil.
	self categoryListIndex: 0.
	self changed: #categoryList.
	self contentsChanged! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/11/2000 14:52'!
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: 'RAA 5/28/2001 13:38'!
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.
	(Smalltalk allCallsOn: poolAssoc) do: [ :elem |
		(nonMeta isKindOf: elem actualClass) ifTrue: [
			aList add: elem methodSymbol
		]
	].
	^ aList! !

!Lexicon methodsFor: 'category list' stamp: 'sd 4/29/2003 12:15' prior: 37480983!
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: 'sw 12/11/2000 14:52'!
showCategoriesPane
	"Show the categories pane instead of the search pane"

	| aPane |
	(aPane _ self searchPane) ifNil: [^ self beep].
	self containingWindow replacePane: aPane with: self newCategoryPane.
	categoryList _ nil.
	self changed: #categoryList.
	self changed: #messageList! !

!Lexicon methodsFor: 'category list' stamp: 'nb 6/17/2003 12:25' prior: 37482213!
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: 'control buttons' stamp: 'sw 7/23/2002 12:56'!
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: 'sw 7/23/2002 12:51'!
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: 'sw 2/26/2002 12:06'!
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: 'sw 3/20/2001 19:47'!
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: 'history' stamp: 'sw 12/14/2000 14:35'!
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: 'sw 12/14/2000 14:35'!
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: 'sw 12/5/2000 16: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: 'sw 3/19/2001 10:58'!
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: 'sw 12/5/2000 16: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: 'limit class' stamp: 'sw 3/19/2001 06:41'!
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: 'sw 2/6/2002 19:20'!
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:
			[Object class]
		ifFalse:
			[Object].
	[limitClass superclass ~~ oneTooFar]
		whileTrue: [limitClass _ limitClass superclass].
	^ limitClass! !

!Lexicon methodsFor: 'limit class' stamp: 'cmm 3/26/2003 22:33' prior: 37490881!
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: 'sw 12/13/2000 06:49'!
limitClass: aClass
	"Set the most generic class to show as indicated"

	limitClass _ aClass! !

!Lexicon methodsFor: 'limit class' stamp: 'sw 3/20/2001 13:07'!
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: 'sw 1/12/2001 00:17'!
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: '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: 'sw 3/20/2001 10:17'!
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 _ PopUpMenu withCaption:
'Caution!!  This would be
accepted into class ', aClass name, '.
Is that okay?' chooseFrom: 
	{'okay, no problem'. 
	'cancel - let me reconsider'. 
	'compile into ', targetClass name, ' instead'.
	'compile into a new uniclass'}.
			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: 'menu commands' stamp: 'sw 11/21/2001 11:01'!
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: 'sw 3/20/2001 22:23'!
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: 'sw 10/8/2001 14:33'!
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: 'new-window queries' stamp: 'sw 4/4/2001 00:14'!
browseClassVarRefs
	"Let the search pertain to the target class regardless of selection"

	targetClass theNonMetaClass browseClassVarRefs! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 3/28/2003 18:28' prior: 37497662!
browseClassVarRefs
	"Let the search pertain to the target class regardless of selection"

	SystemNavigation new browseClassVarRefs: targetClass theNonMetaClass ! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12' prior: 37497891!
browseClassVarRefs
	"Let the search pertain to the target class regardless of selection"

	self systemNavigation  browseClassVarRefs: targetClass theNonMetaClass ! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sw 12/15/2000 12:29'!
browseInstVarDefs
	"Let the search pertain to the target class regardless of selection"

	targetClass browseInstVarDefs! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/16/2003 19:43' prior: 37498382!
browseInstVarDefs
	"Let the search pertain to the target class regardless of selection"

	 self systemNavigation browseInstVarDefs: targetClass! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sw 12/15/2000 12:29'!
browseInstVarRefs
	"Let the search pertain to the target class regardless of selection"

	targetClass browseInstVarRefs! !

!Lexicon methodsFor: 'new-window queries' prior: 37498813!
browseInstVarRefs
	"Let the search pertain to the target class regardless of selection"
	SystemNavigation new browseInstVarRefs: targetClass! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12' prior: 37498996!
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: 'sw 3/20/2001 18:55'!
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: 'sw 4/12/2001 00:42'!
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: 'sw 3/20/2001 19:00'!
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: 'sw 4/12/2001 00:46'!
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 allSelectorsUnderstood 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: 'NS 12/12/2003 15:58' prior: 37500409!
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: 'sw 4/12/2001 00:50'!
obtainNewSearchString
	"Put up a box allowing the user to enter a fresh search string"

	| fragment |
	
	fragment _ FillInTheBlank 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: 'sw 3/20/2001 12:13'!
selectorsMatching
	"Anwer a list of selectors in the receiver that match the current search string"

	| fragment aList |
	fragment _ self lastSearchString asLowercase.
	aList _ targetClass allSelectorsUnderstood select:
		[:aSelector | (aSelector includesSubstring: fragment caseSensitive: false) and:
			[currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]].

	^ aList asSortedArray! !

!Lexicon methodsFor: 'search' stamp: 'NS 12/12/2003 15:59' prior: 37502360!
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: 'sw 3/20/2001 18:56'!
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 allSelectorsUnderstood 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:
		[^ self beep].
	self initListFrom: aList asSortedArray highlighting: targetClass.
	messageListIndex _  messageListIndex min: messageList size.
	self changed: #messageList
! !

!Lexicon methodsFor: 'search' stamp: 'nb 6/17/2003 12:25' prior: 37503401!
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 allSelectorsUnderstood 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: 'NS 12/12/2003 15:59' prior: 37504264!
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: 'sw 12/18/2000 16:40'!
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: [^ self beep].
	self containingWindow replacePane: aPane with: self newSearchPane.
	categoryList _ nil.
	self changed: #categoryList.
	self changed: #messageList! !

!Lexicon methodsFor: 'search' stamp: 'nb 6/17/2003 12:25' prior: 37505970!
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: 'sw 12/14/2000 17:38'!
categoryOfSelector: aSelector
	"Answer the name of the defining category for aSelector, or nil if none"

	| classDefiningSelector |
	classDefiningSelector _ targetClass classThatUnderstands: 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' prior: 37507401!
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: 'sw 3/20/2001 12:12'!
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].
	Smalltalk 
		showMenuOf: messages
		withFirstItem: selector
		ifChosenDo: [:sel | aBlock value: sel]! !

!Lexicon methodsFor: 'selection' stamp: 'nk 7/11/2003 06:55' prior: 37508385!
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: 'sw 3/19/2001 12:14'!
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: 'sw 12/14/2000 13:48'!
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: 'sw 5/22/2001 18:20'!
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: 'nk 6/19/2004 16:46' prior: 37512255!
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 decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

		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: 'sw 1/26/2001 19:42'!
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: 'RAA 5/28/2001 13:38'!
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.
	(Smalltalk 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: [^ self beep].
	self okToChange ifFalse: [^ self].
	chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp.
	chosen isEmptyOrNil ifFalse:
			[self displaySelector: chosen]! !

!Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:15' prior: 37514647!
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: [^ self beep].
	self okToChange
		ifFalse: [^ self].
	chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp.
	chosen isEmptyOrNil
		ifFalse: [self displaySelector: chosen]! !

!Lexicon methodsFor: 'senders' stamp: 'md 10/22/2003 16:15' prior: 37515441!
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: 'RAA 5/28/2001 13:38'!
selectorsSendingSelectedSelector
	"Assumes lastSendersSearchSelector is already set"

	| selectorSet sel cl |

	autoSelectString _ (self lastSendersSearchSelector upTo: $:) asString.
	selectorSet _ Set new.
	(Smalltalk 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: 'sd 4/29/2003 12:16' prior: 37517067!
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: 'RAA 5/28/2001 13:38'!
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 _ FillInTheBlank 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.
	(Smalltalk 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: 'senders' stamp: 'sd 4/29/2003 12:16' prior: 37518405!
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 _ FillInTheBlank 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: 'sw 12/11/2000 14:46'!
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: 'sw 12/19/2000 18: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: 'sw 9/6/2001 15:06'!
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'.
	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: 'sw 1/26/2001 19:37'!
useVocabulary: aVocabulary
	"Set up the receiver to use the given vocabulary"

	currentVocabulary _ aVocabulary! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 18:59'!
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: 'sw 11/21/2001 11:00'!
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 allSelectorsUnderstood 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: 'NS 12/12/2003 15:58' prior: 37525264!
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: 'sw 3/20/2001 12:11'!
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:
					[self beep.  "Smalltalk 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: 'sd 5/11/2003 17:03' prior: 37527658!
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:
					[self 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: 'md 10/22/2003 16:14' prior: 37528534!
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: 'sw 3/20/2001 12:13'!
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:
			[self beep]! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'nb 6/17/2003 12:25' prior: 37530297!
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: 'sw 3/20/2001 12:11'!
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 ifNotNil: [self targetObject class] ifNil: [targetClass].
	aList _ OrderedCollection new.
	Smalltalk changes methodChanges associationsDo:
		[:classChgAssoc |
			classChgAssoc value associationsDo:
				[:methodChgAssoc |
					(methodChgAssoc value == #change or: [methodChgAssoc value == #add])  ifTrue:
						[(aClass _ targetedClass classThatUnderstands: methodChgAssoc key) ifNotNil:
							[(aClass name = classChgAssoc key) ifTrue:
								[aList add: methodChgAssoc key]]]]].
	^ aList! !

!Lexicon methodsFor: 'within-tool queries' prior: 37531285!
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.
	Smalltalk changes 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 5/23/2003 14:38' prior: 37532061!
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: 'sw 3/20/2001 20:22'!
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 ~~ #DoIt ifTrue:
					[aList add: sel]]].
	^ aList! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:14'!
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 ~~ #DoIt ifTrue:
					[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: 'sw 4/4/2001 00:15'!
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: 'sw 3/20/2001 20:21'!
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: 'sw 3/20/2001 20:16'!
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: 'sw 11/21/2001 11:19'!
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: 'sw 11/21/2001 10:46'!
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 _ FillInTheBlank request: 'whose initials? ' initialAnswer: Utilities authorInitials.
	initials isEmptyOrNil ifTrue: [^ self].
	self showMethodsWithInitials: initials


! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:44'!
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: 'sw 3/20/2001 20:16'!
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: '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: 'sw 3/20/2001 16:42'!
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: '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: '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: 'tiles' stamp: 'tk 9/17/2001 13:42'!
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: [^ self 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: 'tiles' stamp: 'nb 6/17/2003 12:25' prior: 37539941!
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: 'tiles' stamp: 'tk 9/14/2001 18:05'!
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 classThatUnderstands: 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: [nil].
	codePane ifNotNil: [codePane hideScrollBar].
	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: [nil]].
	tileScriptor owner clipSubmorphs: true.
	tileScriptor extent: codePane extent.! !

!Lexicon methodsFor: 'tiles' prior: 37541165!
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 hideScrollBar].
	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: 'tiles' stamp: 'nk 4/28/2004 10:15' prior: 37542627!
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: '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: '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 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: 'controls' stamp: 'sw 7/23/2002 12:55'!
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.
	Preferences alternativeWindowLook ifTrue:
		[buttons color: Color transparent.
		buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised]].
	divider _ BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:
		[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 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 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.'! !

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

!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: 'tk 11/16/2001 12:13'!
descriptionForPartsBin
	^ self partName:	'Line'
		categories:		#('Graphics' ' Basic 2 ')
		documentation:	'A straight line.  Shift-click to get handles and move the ends.'! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'!
direction
	^end - start! !

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

!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: '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: 'enumerating' stamp: 'ajh 8/6/2002 16:39'!
species

	^ Array! !

!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: 'dgd 2/14/2003 20:18' prior: 24048603!
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! !

!ListComponent methodsFor: 'components' stamp: 'gm 2/27/2003 23:19' prior: 24054190!
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: 'model access' stamp: 'ls 5/17/2001 23:07' prior: 24053625!
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]! !

!ListViewLine methodsFor: 'thumbnail' stamp: 'sw 10/6/2002 02:00'!
morphRepresented
	"Answer the morph that I actually represent"

	^ objectRepresented! !

!LiteralList methodsFor: 'adding' stamp: 'ajh 3/6/2003 18:00'!
addLast: object
	"Only add if not already in list"

	(equalitySet includes: object) ifTrue: [^ object].
	equalitySet add: object.
	super addLast: object.
	^ object
! !

!LiteralList methodsFor: 'adding' stamp: 'ajh 3/6/2003 18:00' prior: 37555138!
addLast: object
	"Only add if not already in list"

	(equalitySet includes: object) ifTrue: [^ object].
	equalitySet add: object.
	super addLast: object.
	^ object
! !

!LiteralList methodsFor: 'private' stamp: 'ajh 1/21/2003 12:21'!
setCollection: anArray

	super setCollection: anArray.
	equalitySet _ LiteralSet new: anArray size.
! !

!LiteralList methodsFor: 'private' stamp: 'ajh 1/21/2003 12:21' prior: 37555620!
setCollection: anArray

	super setCollection: anArray.
	equalitySet _ LiteralSet new: anArray size.
! !

!LiteralList methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:21'!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock

	start to: self size do:
		[:index | ((self at: index) literalEqual: anElement) ifTrue: [^ index]].
	^ exceptionBlock value! !

!LiteralList methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:21' prior: 37555978!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock

	start to: self size do:
		[:index | ((self at: index) literalEqual: anElement) ifTrue: [^ index]].
	^ exceptionBlock value! !

!LiteralList commentStamp: 'ajh 3/25/2003 00:31' prior: 0!
Holds a unique ordered collection of literals!
!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: '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: '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) 
	].	! !

!LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 12/9/2001 16:03'!
add: newObject
	"Include newObject as one of the receiver's elements.  If equivalent is already present don't add and return equivalent object"

	| 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]
		ifNotNil: [array at: index]! !

!LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 12/9/2001 16:03' prior: 37557712!
add: newObject
	"Include newObject as one of the receiver's elements.  If equivalent is already present don't add and return equivalent object"

	| 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]
		ifNotNil: [array at: index]! !

!LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 2/2/2002 19:16'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!LiteralSet methodsFor: 'as yet unclassified' stamp: 'ajh 2/2/2002 19:16' prior: 37558681!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil
					or: [element literalEqual: anObject])
					ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!LiteralSet commentStamp: 'ajh 3/25/2003 00:33' prior: 0!
Holds a unique set of literals.  Literal objects are equal if they are #= plus they are the same class.  This set uses this rule for finding elements.

Example:
	Set new add: 'anthony'; add: #anthony; size  "= 1"
	LiteralSet new add: 'anthony'; add: #anthony; size  "= 2"
!
!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/16/2001 12:12'!
emitLoad: stack on: strm
	splNode ifNil:[^super emitLoad: stack on: strm].
	code < 256
		ifTrue: [strm nextPut: 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: 'ar 8/21/2001 13:21'!
sizeForStore: encoder
	| index |
	(key isVariableBinding and:[key isSpecialWriteBinding]) 
		ifFalse:[^super sizeForStore: encoder].
	code < 0 ifTrue:[
		index _ self index.
		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: 'ar 8/21/2001 13:21'!
sizeForStorePop: encoder
	| index |
	(key isVariableBinding and:[key isSpecialWriteBinding]) 
		ifFalse:[^super sizeForStorePop: encoder].
	code < 0 ifTrue:[
		index _ self index.
		code _ self code: index type: LdLitType].
	splNode _ encoder encodeSelector: #value:.
	^(splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder) + 1! !

!LoginFailedException methodsFor: 'exceptionDescription' stamp: 'mir 2/15/2002 13:10'!
isResumable
	"Resumable so we can give the user another chance to login"

	^true! !

!LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0!
Exception for signaling login failures of protocol clients.
!
!LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'!
name

	^ self key isString
		ifTrue: [self key]
		ifFalse: [self key printString]! !

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

!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: 'ar 8/16/2001 11:54'!
recompileBindingsAnnouncing: aBool
	"Make the receiver (a global read-write binding) be a read-only binding"
	aBool ifTrue:[
		Utilities informUserDuring:[:bar|
			(Smalltalk allCallsOn: self) do:[:mref| 
				bar value: 'Recompiling ', mref asStringOrText.
				mref actualClass recompile: mref methodSymbol].
		].
	] ifFalse:[
		(Smalltalk allCallsOn: self) do:[:mref| 
			mref actualClass recompile: mref methodSymbol].
	].! !

!LookupKey methodsFor: 'bindings' stamp: 'sd 4/29/2003 12:17' prior: 37564338!
recompileBindingsAnnouncing: aBool 
	"Make the receiver (a global read-write binding) be a read-only binding"
	aBool
		ifTrue: [Utilities
				informUserDuring: [:bar | (SystemNavigation new allCallsOn: self)
						do: [:mref | 
							bar value: 'Recompiling ' , mref asStringOrText.
							mref actualClass recompile: mref methodSymbol]]]
		ifFalse: [(SystemNavigation new allCallsOn: self)
				do: [:mref | mref actualClass recompile: mref methodSymbol]]! !

!LookupKey methodsFor: 'bindings' stamp: 'dvf 8/23/2003 11:50' prior: 37564846!
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]]! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'zz 3/2/2004 08:18' prior: 24096973!
samples
	"For compatibility with SampledSound. Just return my left channel (which is the only channel if I am mono)."

	^ leftSamples
! !

!LoopedSampledSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:36'!
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 ~= (Smalltalk endianness = #big).
	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: 'file i/o' stamp: 'sd 9/30/2003 13:41' prior: 37566171!
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"
! !

!MCPTest methodsFor: 'Testing - geometry' stamp: 'dgd 2/14/2003 10:13'!
defaultBounds
	"the default bounds for morphs"
	^ 0 @ 0 corner: 50 @ 40 ! !

!MCPTest methodsFor: 'Testing - geometry' stamp: 'dgd 2/14/2003 10:13'!
defaultTop
	"the default top for morphs"
	^ self defaultBounds top ! !

!MCPTest methodsFor: 'Testing - geometry' 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! !

!MCPTest methodsFor: 'Testing' 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: 'Testing' 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.! !

!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' prior: 24113090!
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' prior: 24114472!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'set channel' translated action: #setChannel:.
	aCustomMenu add: 'set controller' translated action: #setController:.
! !

!MIDIPianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:55' prior: 24152802!
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' prior: 24152244!
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].
! !

!MIDIScore methodsFor: 'ambient track' stamp: 'md 12/12/2003 16:21' prior: 24162503!
eventMorphsDo: aBlock
	"Evaluate aBlock for all morphs related to the ambient events."

	ambientTrack == nil ifTrue: [^ self].
	ambientTrack do: [:evt | evt morph ifNotNilDo: aBlock].
! !

!MIMEDocument methodsFor: 'accessing' stamp: 'ar 8/23/2001 22:38'!
contents
	"Compatibility with stream protocol"
	^self content! !

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

!MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ': '.
	aStream nextPutAll: self asHeaderValue! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'!
parameterAt: aParameter put: value
	parameters at: aParameter put: value! !

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

!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 commentStamp: '<historical>' prior: 0!
For local files, we do not read the entire contents unless we absolutely have to.!
!MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'!
contentType: aString contentStream: aStream
	^(self contentType: aString content: nil) contentStream: aStream! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 11/16/2001 16:40'!
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: 'jm 11/16/2001 16:29'!
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].
	mpegFile hasVideo
		ifTrue: [^ ((mpegFile videoGetFrame: 0) asFloat / (mpegFile videoFrames: 0)) min: 1.0].
	soundTrack ifNotNil: [^ soundTrack soundPosition].
	^ 0.0
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'mu 6/25/2003 02:41' prior: 37577999!
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: 'jm 12/16/2001 12:34'!
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: 'jm 6/3/2001 14:34'!
repeat
	"Answer the repeat flag."

	repeat ifNil: [repeat _ false].
	^ repeat
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 6/3/2001 14:33'!
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: '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: 'jm 6/13/2001 16:12'!
volume: aNumber
	"Set the sound playback volume to the given level, between 0.0 and 1.0."

	volume _ aNumber asFloat.
	volume < 0.0 ifTrue: [volume _ 0.0].
	volume > 1.0 ifTrue: [volume _ 1.0].
	soundTrack ifNotNil: [soundTrack volume: volume].
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jdl 3/28/2003 09:41' prior: 37582211!
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: 'jm 4/6/2001 08:31'!
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: 'jm 11/13/2001 07:36'!
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: 'jm 3/21/2001 16:25'!
setFrameRate
	"Ask the user to specify the desired frame rate."

	| rateString |
	rateString _ FillInTheBlank
		request: 'Desired frames per second?'
		initialAnswer: desiredFrameRate printString.
	rateString size = 0 ifTrue: [^ self].
	desiredFrameRate _ rateString asNumber asFloat.
	desiredFrameRate <= 0.1 ifTrue: [desiredFrameRate _ 0.1].
! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'jdl 3/28/2003 09:26' prior: 37583971!
setFrameRate
	"Ask the user to specify the desired frame rate."

	| rateString |
	rateString := FillInTheBlank request: 'Desired frames per second?'
				initialAnswer: desiredFrameRate printString.
	rateString isEmpty ifTrue: [^self].
	desiredFrameRate := rateString asNumber asFloat.
	desiredFrameRate := desiredFrameRate max: 0.1! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'dgd 10/8/2003 19:10' prior: 37584407!
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: 'jm 11/21/2001 17:56'!
startPlaying
	"Start playing the movie at the current position."

	| frameIndex |
	self stopPlaying.
	self mpegFileIsOpen ifFalse: [^ self].
	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: 'mu 6/25/2003 02:42' prior: 37585248!
startPlaying
	"Start playing the movie at the current position."

	| frameIndex |
	self stopPlaying.
	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: 'jm 6/3/2001 14:30'!
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: 'jm 11/13/2001 08:45'!
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: 'jm 2/21/2001 21:51'!
closeFile
	"Close my MPEG file, if any."

	mpegFile ifNotNil: [
		mpegFile closeFile.
		mpegFile _ nil.
		frameBuffer _ nil].
	self changed.
! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 22:09' prior: 37590866!
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: 'jm 3/22/2001 12:42'!
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: 'jm 11/17/2001 09:48'!
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: ', 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: ', 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: 'gm 2/27/2003 23:50' prior: 37591803!
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: ' , 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: ' , mpegFileName.
					^false]].
	mpegFile fileHandle ifNil: [^false].

	"initialize soundTrack"
	soundTrack := mpegFile hasAudio 
		ifTrue: [mpegFile audioPlayerForChannel: 1]
		ifFalse: [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: 'dgd 3/7/2004 19:07' prior: 37593161!
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: 'jm 11/26/2001 08:26'!
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: 'jm 11/20/2001 15:00'!
initialize

	super initialize.
	super extent: 250@0.
	frameBuffer _ nil.
	mpegFile _ nil.
	running _ false.	
	desiredFrameRate _ 10.0.
	allowFrameDropping _ true.
	repeat _ false.
	soundTrack _ nil.
	volume _ 0.5.
! !

!MPEGDisplayMorph methodsFor: 'initialization' stamp: 'dgd 3/8/2004 23:05' prior: 37597435!
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: 'jm 12/14/2001 15:34'!
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: 'jm 12/17/2001 08:15'!
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?'.
	jpegFileName size = 0 ifTrue: [^ self].
	(jpegFileName asLowercase endsWith: '.jmv') ifFalse: [
		jpegFileName _ jpegFileName, '.jmv'].

	result _ FillInTheBlank request: 'Quality level (1 to 100)?'.
	q _ result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100].

	result _ FillInTheBlank request: 'Frame rate?'.
	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: 'dgd 2/21/2003 22:59' prior: 37599019!
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?'.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?'.
	q := result ifNil: [50]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	result := FillInTheBlank request: 'Frame rate?'.
	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: 'jm 12/17/2001 08:15'!
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?'.
	jpegFileName size = 0 ifTrue: [^ self].
	(jpegFileName asLowercase endsWith: '.jmv') ifFalse: [
		jpegFileName _ jpegFileName, '.jmv'].

	result _ FillInTheBlank request: 'Quality level (1 to 100)?'.
	q _ result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100].

	JPEGMovieFile convertMPEGFileNamed: mpegFileName toJPEGMovieNamed: jpegFileName quality: q.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 22:59' prior: 37601092!
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?'.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?'.
	q := result ifNil: [50]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	JPEGMovieFile 
		convertMPEGFileNamed: mpegFileName
		toJPEGMovieNamed: jpegFileName
		quality: q! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'jm 12/17/2001 08:15'!
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?'.
	jpegFileName size = 0 ifTrue: [^ self].
	(jpegFileName asLowercase endsWith: '.jmv') ifFalse: [
		jpegFileName _ jpegFileName, '.jmv'].

	result _ FillInTheBlank request: 'Quality level (1 to 100)?'.
	q _ result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100].

	JPEGMovieFile
		convertSqueakMovieNamed: squeakMovieFileName
		toJPEGMovieNamed: jpegFileName
		quality: q.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:00' prior: 37602805!
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?'.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?'.
	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: 'jm 12/13/2001 20:46'!
invokeMenu
	"Invoke a menu of additonal functions."

	| aMenu |
	aMenu _ CustomMenu new.
	repeat
		ifTrue: [aMenu add: 'turn off repeat (now on)' action: #toggleRepeat]
		ifFalse: [aMenu add: 'turn on repeat (now off)' action: #toggleRepeat].
	aMenu addList:	#(
		-
		('set frame rate'							setFrameRate)
		-
		('create JPEG movie from MPEG'				createJPEGfromMPEG)
		('create JPEG movie from SqueakMovie'		createJPEGfromSqueakMovie)
		('create JPEG movie from folder of frames'	createJPEGfromFolderOfFrames)
		-
	).
	(mpegFile isKindOf: JPEGMovieFile) ifTrue: [
		mpegFile hasAudio
			ifTrue: [aMenu add: 'remove all soundtracks' action: #removeAllSoundtracks]
			ifFalse: [aMenu add: 'add soundtrack' action: #addSoundtrack]].

	aMenu invokeOn: self defaultSelection: nil.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 9/19/2003 12:17' prior: 37604922!
invokeMenu
	"Invoke a menu of additonal functions."

	| aMenu |
	aMenu _ CustomMenu new.
	repeat
		ifTrue: [aMenu add: 'turn off repeat (now on)' translated action: #toggleRepeat]
		ifFalse: [aMenu add: 'turn on repeat (now off)' translated action: #toggleRepeat].
	aMenu 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: [
		mpegFile hasAudio
			ifTrue: [aMenu add: 'remove all soundtracks' translated action: #removeAllSoundtracks]
			ifFalse: [aMenu add: 'add soundtrack' translated action: #addSoundtrack]].

	aMenu invokeOn: self defaultSelection: nil.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 21:05' prior: 37605785!
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: 'jm 12/13/2001 08:55'!
toggleRepeat
	"Toggle the repeat flag."

	repeat _ repeat not.
! !

!MPEGDisplayMorph methodsFor: 'other' stamp: 'jm 12/14/2001 15:11'!
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.
	framesToAdvance _ desiredFrame - currentFrame.
	framesToAdvance <= 0 ifTrue: [^ self].
	(allowFrameDropping and: [framesToAdvance > 1]) ifTrue: [
		mpegFile videoDropFrames: framesToAdvance - 1 stream: 0].
	self nextFrame.
! !

!MPEGDisplayMorph methodsFor: 'other' stamp: 'jm 11/14/2001 11:58'!
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: 'jm 11/21/2001 16:58'!
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
! !

!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.
!
!MPEGFile methodsFor: 'access' stamp: 'JMM 11/10/2000 00:26'!
endianness
	^endianness isNil ifTrue: [endianness _ Smalltalk endianness] ifFalse: [endianness]! !

!MPEGFile methodsFor: 'access' stamp: 'sd 9/30/2003 13:41' prior: 37616282!
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: 'JMM 9/29/2000 19:28'!
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 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: 'dgd 2/16/2004 14:19'!
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: 'JMM 9/20/2000 02:05'!
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 9/20/2000 01:57'!
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 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 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: 'jm 11/16/2001 07:53'!
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: 'JMM 11/21/2000 13:15'!
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 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 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: 'instance creation' stamp: 'JMM 9/18/2000 03:27'!
openFile: aPath
	^self new initialize openFile: aPath.! !

!MPEGFile class methodsFor: 'testing' stamp: 'JMM 9/18/2000 14:28'!
isFileValidMPEG: path
	^self primFileValidMPEG: path! !

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

!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: '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: '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: '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: '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,f3c150048000,f3! !

!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: '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: 'initialization' stamp: 'dgd 3/7/2003 14:39'!
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: 'jm 6/3/2001 23:43'!
initialize

	super initialize.
	self color: (Color gray: 0.9).  "old color"
	self fillStyle: self moviePlayerFillStyle.
	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.  "make minimum size"
! !

!MPEGMoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:40' prior: 37641975!
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: 'private' stamp: 'jm 12/13/2001 08:59'!
addButtonRow

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap; color: Color transparent.
	r addMorphBack: (self buttonName: 'Open' action: #openMPEGFile).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Menu' action: #invokeMenu).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Rewind' action: #rewindMovie).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Play' action: #startPlaying).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' action: #stopPlaying).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: '<' action: #previousFrame).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: '>' action: #nextFrame).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 9/19/2003 12:12' prior: 37643559!
addButtonRow

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap; color: Color transparent.
	r addMorphBack: (self buttonName: 'Open' translated action: #openMPEGFile).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Rewind' translated action: #rewindMovie).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Play' translated action: #startPlaying).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' translated action: #stopPlaying).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: '<' action: #previousFrame).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: '>' action: #nextFrame).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:40' prior: 37644703!
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: 'jm 6/3/2001 23:52'!
addPositionSlider

	| 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;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'start ').
	r addMorphBack: positionSlider.
	r addMorphBack: (StringMorph contents: ' end').
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 9/19/2003 12:19' prior: 37647339!
addPositionSlider

	| 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;
		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: 'dgd 3/8/2004 20:40' prior: 37647983!
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: 'jm 6/3/2001 23:53'!
addVolumeSlider

	| levelSlider r |
	levelSlider _ 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;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '  soft ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' loud').
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 9/19/2003 12:19' prior: 37649357!
addVolumeSlider

	| levelSlider r |
	levelSlider _ 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;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '  soft ' translated).
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' loud' translated).
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 2/15/2004 20:04' prior: 37650002!
addVolumeSlider

	| 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;
		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:40' prior: 37650669!
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: 'jm 6/3/2001 23:41'!
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: 'jm 6/3/2001 23:42'!
buttonName: aString action: aSymbol

	^ SimpleButtonMorph new
		target: moviePlayer;
		label: aString;
		actionSelector: aSymbol;
		color: (Color gray: 0.8);  "old color"
		fillStyle: self buttonFillStyle;
		borderWidth: 0;
		borderColor: #raised.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/7/2004 19:22' prior: 37652542!
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: 'nk 11/21/2002 10:41'!
quit
	moviePlayer stopPlaying.
	self delete.! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:39' prior: 37653435!
quit
	"quit the receiver"
	self delete! !

!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 class methodsFor: 'class initialization' stamp: 'bkv 11/21/2002 11:19'!
initialize 
    "MPEGMoviePlayerMorph initialize."

    FileList registerFileReader: self.! !

!MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:40' prior: 37654133!
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: 'asm 4/11/2003 12:36'!
unload
	"Unload the receiver from global registries"

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

!MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'ads 7/30/2003 16:07' prior: 37654923!
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: 'bkv 11/21/2002 11:18'!
fileReaderServicesForFile: fullName suffix: suffix 

	|  selectedServices |
	selectedServices _ OrderedCollection new.
	((MPEGPlayer registeredVideoFileSuffixes includes: suffix ) or: [ MPEGPlayer registeredAudioFileSuffixes includes: suffix ] )
		ifTrue: [ ^self services ].
	^ selectedServices! !

!MPEGMoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54' prior: 37655444!
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: 'bkv 11/21/2002 12:02'!
services 

     ^OrderedCollection with: self servicePlayInMPEGPlayer
! !

!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: 'nk 11/21/2002 10:19'!
playFile: aFileName

     | wrapper |
     
     wrapper _ self openOn: aFileName.
     wrapper moviePlayer startPlaying. 
     "wrapper openInWindow."
	wrapper openInWorld.
     ^wrapper! !

!MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'bkv 11/21/2002 11:47'!
serviceOpenInMPEGPlayer
	"Answer a service for opening in a MPEG player"

	^ SimpleServiceEntry
		provider: self
		label: 'open in MPEG player'
		selector: #openOn: 
		description: 'open in 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: 'dgd 2/15/2004 22:08'!
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."

	^ #(
	(playing
		(
			(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 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:)
		)
	))! !

!MPEGMoviePlayerMorph class methodsFor: 'scripting' stamp: 'dgd 3/8/2004 21:44' prior: 37657473!
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."

	^ #(
	(playing
		(
			(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 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:)
		)
	))! !

!MPEGMoviePlayerMorph class methodsFor: '*Tools-FileList-registering' stamp: 'nk 11/21/2002 10:22'!
openOn: aFileName

     | wrapper |
     
     wrapper _ self new initialize addQuitButton.
     wrapper moviePlayer openFileNamed: aFileName. 
     ^wrapper! !

!MPEGMoviePlayerMorph class methodsFor: '*Tools-FileList-registering' stamp: 'dgd 3/8/2004 20:37' prior: 37659686!
openOn: fileNameString 
	"open a new instance of the receiver on a file named 
	fileNameString "
	| wrapper |
	wrapper := self new.
	wrapper moviePlayer openFileNamed: fileNameString.
	^ wrapper! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'!
audioPlayerProcess
	^audioPlayerProcess ! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:39'!
audioPlayerProcess: aProcess
	audioPlayerProcess _ aProcess! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'!
clockBias
	^clockBias! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'!
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: 'JMM 9/20/2000 18:33'!
errorForSoundStart: aValueInMilliseconds
	errorForSoundStart _ aValueInMilliseconds
! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/19/2000 11:52'!
external
	[external hasVideo] on: Error do: 
		[(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: 'JMM 9/20/2000 13:37'!
form: aForm
	form _ aForm! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:39'!
frameRate
	^frameRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:36'!
frameRate: aRate
	frameRate _ aRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:04'!
lastDelay
	^lastDelay! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:03'!
lastDelay: aNumber
	lastDelay _ aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:20'!
morph
	^morph! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:20'!
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: 'JMM 9/20/2000 13:59'!
noSound: flag
	noSound _ flag! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:59'!
playerProcessPriority
	^playerProcessPriority! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:59'!
playerProcessPriority: aNumber
	playerProcessPriority _ aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:34'!
sampleRate
	^sampleRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:36'!
sampleRate: aRate
	sampleRate _ aRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:01'!
soundQueue
	^soundQueue! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:01'!
soundQueue: aQueue
	soundQueue _ aQueue! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:38'!
startTime
	^startTime! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:38'!
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: 'JMM 9/20/2000 14:02'!
timeCheck: aNumber
	timeCheck _ aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:58'!
videoPlayerProcess
	^videoPlayerProcess ! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:58'!
videoPlayerProcess: aProcess
	videoPlayerProcess _ aProcess! !

!MPEGPlayer methodsFor: 'access' stamp: 'kfr 11/9/2000 21:21'!
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: 'kfr 11/9/2000 22:26'!
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: 'JMM 11/19/2000 18:03'!
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: 'JMM 11/19/2000 18:02'!
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: 'JMM 11/8/2000 15:30'!
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: 'JMM 11/8/2000 10:13'!
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: 'JMM 11/8/2000 14:28'!
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: 'kfr 11/9/2000 21:19'!
initialize: aPath

	(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: 'JMM 11/13/2000 19:35'!
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: 'JMM 11/13/2000 19:35'!
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: 'JMM 11/13/2000 19:37'!
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: 'JMM 11/8/2000 10:25'!
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: 'JMM 11/19/2000 12:47'!
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: 'jm 12/17/2001 09:36'!
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 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 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 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! !

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

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

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

!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: 'sw 12/17/2001 16:50'!
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 |
	self flag: #bob.		"is <aPoint> global or local?"
	self flag: #arNote.	"<aPoint> is local to aWorld"
	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.
	^ mvcSelection
! !

!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:38' prior: 24203905!
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: 'project' stamp: 'di 11/16/2001 09:42'!
project
	^ Project current! !

!MVCWiWPasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:38' prior: 24202208!
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! !

!MacFileDirectory methodsFor: 'file operations' stamp: 'nk 11/23/2002 04:53'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmptyOrNil ifTrue: [^ pathName].
	(self class isAbsolute: path) ifTrue: [^ path].
	^ pathName = ''			"Root dir?"
		ifTrue: [ path]
		ifFalse: [pathName , ':' , path]! !

!MacFileDirectory methodsFor: 'file operations' stamp: 'nk 3/13/2003 09:01' prior: 37692285!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmptyOrNil ifTrue: [^ pathName].
	(self class isAbsolute: path) ifTrue: [^ path].
	pathName = ''			"Root dir?"
		ifTrue: [ ^path].
	^(path first = $:)
		ifTrue: [ pathName, path ]
		ifFalse: [pathName , ':' , path]! !

!MacFileDirectory methodsFor: 'as yet unclassified' stamp: 'hmm 3/25/2004 21:57'!
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 class methodsFor: 'platform specific'!
isActiveDirectoryClass
	^ super isActiveDirectoryClass
		and: [(Smalltalk getSystemAttribute: 1201) isNil
				or: [(Smalltalk getSystemAttribute: 1201) asNumber <= 31]]! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06' prior: 37694507!
isActiveDirectoryClass
	^ super isActiveDirectoryClass
		and: [(SmalltalkImage current getSystemAttribute: 1201) isNil
				or: [(SmalltalkImage current getSystemAttribute: 1201) asNumber <= 31]]! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'!
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: '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: $: ]! !

!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: 'md 1/13/2004 17:54'!
testMacFileFullPathFor
	"(self run: #testMacFileFullPathFor)"
	Smalltalk 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: 'md 1/13/2004 17:53'!
testMacIsAbsolute
	"(self selector: #testMacIsAbsolute) run"
	
	
	self deny: (MacFileDirectory isAbsolute: 'Volumes').
	self assert: (MacFileDirectory isAbsolute: 'Volumes:Data:Stef').
	self assert: (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')).
! !

!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'JMM 12/5/2001 22:23'!
isActiveDirectoryClass
	"Ok, lets see if we support HFS Plus file names, the long ones"

	^ (self pathNameDelimiter = self primPathNameDelimiter) and: [(Smalltalk getSystemAttribute: 1201) notNil and: [(Smalltalk getSystemAttribute: 1201) asNumber > 31]]! !

!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06' prior: 37697957!
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! !

!MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:22'!
fromSystemClipboard: aString

	^ aString squeakToIso.
! !

!MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:23'!
toSystemClipboard: aString

	| result |
	aString isOctetString ifTrue: [^ aString asOctetString isoToSqueak].

	result _ WriteStream on: (String new: aString size).
	aString do: [:each | each value < 256 ifTrue: [result nextPut: each isoToSqueak]].
	^ result contents.
! !

!MacRomanInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 21:19'!
nextCharFrom: sensor firstEvt: evtBuf



	| keyValue |

	keyValue := evtBuf third.

	^ keyValue asCharacter squeakToIso.

! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 22:20'!
currentCharSize

	^ 1.
! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/4/2003 12:33'!
leadingChar

	^ 0.
! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 21:19'!
nextFromStream: aStream 
	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	^ character1 squeakToIso.
! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 21:17'!
nextPut: aCharacter toStream: aStream 

	aStream isBinary ifTrue: [
		aCharacter class == Character ifTrue: [
			aStream basicNextPut: aCharacter isoToSqueak.
			^ aStream.
		].
		aCharacter class == MultiCharacter ifTrue: [
			aStream nextInt32Put: aCharacter value.
			^ aStream.
		].
	].
	aStream basicNextPut: aCharacter isoToSqueak.
! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 22:15'!
restoreStateOf: aStream with: aConverterState

	aStream position: aConverterState.
! !

!MacRomanTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 22:15'!
saveStateOf: aStream

	^ aStream position.
! !

!MacRomanTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 8/4/2003 12:33'!
encodingNames 

	^ #('mac-roman' ) copy
! !

!MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 8/16/2003 00:21'!
fromSystemClipboard: aString
	^ aString convertFromSystemString! !

!MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 8/16/2003 00:24'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToSystemString .
! !

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

!MacUnicodeInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 9/26/2003 11:51'!
nextCharFrom: sensor firstEvt: evtBuf

	| keyValue |
	keyValue := evtBuf third.
	keyValue < 256 ifTrue: [^ Character value: keyValue].
	^ Smalltalk systemLanguage charsetClass charFromUnicode: keyValue.
! !

!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: '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: 'dgd 2/14/2003 21:40' prior: 24220691!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	trackPointer _ true.
	magnification _ 2.

	lastPos _ self sourcePoint.
	self extent: 128 @ 128! !

!MagnifierMorph methodsFor: 'initialization' stamp: 'nk 3/6/2004 10:47' prior: 37703350!
initialize
	"initialize the state of the receiver"
	super initialize.

	trackPointer _ true.
	showPointer _ false.
	magnification _ 2.

	self extent: 128 @ 128! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'sw 6/25/2001 11:43'!
magnifiedForm
	"Answer the magnified form"

	| srcRect form exclusion |
	lastPos _ self sourcePoint.
	srcRect _ self sourceRectFrom: lastPos.
	((srcRect intersects: self bounds) and: [RecursionLock == nil])
		ifTrue: [RecursionLock _ self.
				self isRound
					ifTrue: [exclusion _ owner]
					ifFalse: [exclusion _ self].
				form _ self 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"
	^ form magnify: form boundingBox
		by: magnification
		smoothing: (magnification isInteger ifTrue: [1] ifFalse: [2])! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'dgd 2/21/2003 23:07' prior: 37703847!
magnifiedForm
	"Answer the magnified form"

	| srcRect form exclusion |
	lastPos := self sourcePoint.
	srcRect := self sourceRectFrom: lastPos.
	((srcRect intersects: self bounds) and: [RecursionLock isNil]) 
		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"
	^form 
		magnify: form boundingBox
		by: magnification
		smoothing: (magnification isInteger ifTrue: [1] ifFalse: [2])! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'nk 3/6/2004 10:47' prior: 37704619!
magnifiedForm
	"Answer the magnified form"
	| srcRect form exclusion magnified |
	srcRect := self sourceRectFrom: self sourcePoint.
	(RecursionLock isNil and: [ 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"
	showPointer
		ifTrue: [magnified
				reverse: (magnified center - (2 @ 2) extent: 4 @ 4)
				fillColor: Color white].
	^ magnified! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'nk 3/17/2004 11:34' prior: 37705400!
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: 'menu' stamp: 'dgd 8/30/2003 21:50' prior: 24222541!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu
		addLine;
		add: 'magnification...' translated action: #chooseMagnification;
		addUpdating: #trackingPointerString action: #toggleTrackingPointer;
		addUpdating: #toggleRoundString action: #toggleRoundness.! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/6/2004 10:15' prior: 37707397!
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: 'dgd 2/21/2003 23:07' prior: 24222925!
chooseMagnification
	| result |
	result := (SelectionMenu selections: #(1.5 2 4 8)) 
				startUpWithCaption: 'Choose magnification
(currently ' 
						, magnification printString , ')'.
	(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: 'dgd 10/8/2003 19:13' prior: 37708287!
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: 'md 11/16/2003 15:14' prior: 37708755!
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: 'nk 3/17/2004 11:34'!
showPointer
	^showPointer ifNil: [ showPointer _ false ].! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/6/2004 10:15'!
showingPointerString
	^ (showPointer
		ifTrue: ['stop showing pointer']
		ifFalse: ['start showing pointer']) translated! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:34' prior: 37709792!
showingPointerString
	^ (self showPointer
		ifTrue: ['stop showing pointer']
		ifFalse: ['start showing pointer']) translated! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/6/2004 10:15'!
toggleShowingPointer
	showPointer _ showPointer not! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:35' prior: 37710190!
toggleShowingPointer
	self showPointer: self showPointer not! !

!MagnifierMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:51' prior: 24223939!
trackingPointerString
	^ (trackPointer
		ifTrue: ['stop tracking pointer']
		ifFalse: ['start tracking pointer']) translated! !

!MagnifierMorph methodsFor: 'round view' stamp: 'dgd 8/30/2003 21:51' prior: 24225930!
toggleRoundString
	^ (self isRound
		ifTrue: ['be square']
		ifFalse: ['be round'])  translated! !

!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 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: 'sw 8/10/2001 22:21'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'RoundGlass'
		categoryList: #(Useful)
		documentation: 'A round magnifying glass'
		globalReceiverSymbol: #MagnifierMorph
		nativitySelector: #newRound}! !

!MagnifierMorph class methodsFor: 'parts bin' stamp: 'nk 3/6/2004 10:27' prior: 37712464!
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 }! !

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

!Magnitude commentStamp: '<historical>' prior: 0!
Magnitude has methods for dealing with linearly ordered collections.

Subclasses represent dates, times, and numbers.

Example for interval-testing (answers a Boolean):
	7 between: 5 and: 10 

No instance-variables.
!
!MailAddressParserTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:48'!
setUp
	"I am the method in which your test is initialized. 
If you have ressources to build, put them here."! !

!MailAddressParserTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:48'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !

!MailAddressParserTest methodsFor: 'testing' stamp: 'md 3/17/2003 15:54'!
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 should:	[(MailAddressParser addressesIn: testString) =  correctAnswer].! !

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

!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: 'access' stamp: 'bf 3/9/2000 18:02'!
messageText
	"return the current text"
	^messageText isoToSqueak! !

!MailComposition methodsFor: 'access' stamp: 'bf 3/9/2000 18:26'!
messageText: aText
	"change the current text"
	messageText _ aText squeakToIso.
	self changed: #messageText.
	^true! !

!MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'!
smtpServer
	^MailSender smtpServer! !

!MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'!
submit
	| message |
	"submit the message"
	textEditor
		ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
	message := MailMessage from: messageText asString.
	self breakLinesInMessage: message.
	SMTPSocket 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: 'access' stamp: 'mir 5/12/2003 16:04' prior: 37719789!
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: 'ls 10/16/1998 09:11'!
open
	"open an interface"
	Smalltalk isMorphic
		ifTrue: [ self openInMorphic ]
		ifFalse: [ self openInMVC ]! !

!MailComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:17'!
openInMVC
	| textView sendButton  |

	mvcWindow _ StandardSystemView new
		label: 'Mister Postman';
		minimumSize: 400@250;
		model: self.

	textView _ PluggableTextView
		on: self
		text: #messageText
		accept: #messageText:.
	textEditor _ textView controller.

	sendButton _ PluggableButtonView 
		on: self
		getState: nil
		action: #submit.
	sendButton label: 'Send'.
	sendButton borderWidth: 1.

	sendButton window: (1@1 extent: 398@38).
	mvcWindow addSubView: sendButton.

	textView window: (0@40 corner: 400@250).
	mvcWindow addSubView: textView below: sendButton.

	mvcWindow controller open.

		
! !

!MailComposition methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:20'!
openInMorphic
	"open an interface for sending a mail message with the given initial 
	text "
	| textMorph buttonsList sendButton attachmentButton |
	morphicWindow _ SystemWindow labelled: 'Mister Postman'.
	morphicWindow model: self.
	textEditor _ textMorph _ PluggableTextMorph
						on: self
						text: #messageText
						accept: #messageText:.
	morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1).
	buttonsList _ AlignmentMorph newRow.
	sendButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #submit.
	sendButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'send message';
		setBalloonText: 'add this to the queue of messages to be sent';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: sendButton.
	
	attachmentButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #addAttachment.
	attachmentButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'add attachment';
		setBalloonText: 'Send a file with the message';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: attachmentButton.
	
	morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1).
	morphicWindow openInMVC! !

!MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'!
sendMailMessage: aMailMessage
	self messageText: aMailMessage text! !

!MailComposition commentStamp: '<historical>' prior: 0!
a message being composed.  When finished, it will be submitted via a Celeste.!
!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 ! !

!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: '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: 'parsing' stamp: 'mdr 3/15/2001 18:46'!
fieldsFrom: aStream do: aBlock
	"Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body."

	| savedLine line s |
	savedLine _ MailDB readStringLineFrom: aStream.
	[aStream atEnd] whileFalse: [
		line _ savedLine.
		(line isEmpty) ifTrue: [^self].  "quit when we hit a blank line"
		[savedLine _ MailDB readStringLineFrom: aStream.
		 (savedLine size > 0) and: [savedLine first isSeparator]] whileTrue: [
			"lines starting with white space are continuation lines"
			s _ ReadStream on: savedLine.
			s skipSeparators.
			line _ line, ' ', s upToEnd].
		self reportField: line withBlanksTrimmed to: aBlock].

	"process final header line of a body-less message"
	(savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock].
! !

!MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43' prior: 37728294!
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: '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' 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: 'ads 3/29/2003 18:05' prior: 24284655!
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' and: [Smalltalk includesKey: #HtmlParser])
		ifTrue: [^(HtmlParser parse: (ReadStream on: body content)) formattedText].

	"check for an embedded message"
	self body contentType = 'message/rfc822' ifTrue: [
		^(MailMessage from: self body content) formattedText ].

	"nothing special--just return the text"
	^body content.

! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'nk 7/6/2003 07:18' prior: 37732223!
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: 'ads 9/6/2003 11:58' prior: 37733900!
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 isoToSqueak.

! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 3/19/2001 09:56'!
cleanedHeader
	"Reply with a cleaned up version email header.  First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded"

	| new priorityFields omittedFields |

	new _ WriteStream on: (String new: text size).

	priorityFields _ #('Date' 'From' 'Subject' 'To' 'Cc').
	omittedFields _ MailMessage omittedHeaderFields.

	"Show the priority fields first, in the order given in priorityFields"
	priorityFields do: [ :pField |
		"We don't check whether the priority field is in the omitted list!!"
		self headerFieldsNamed: pField do:
			[: fValue | new nextPutAll: pField, ': ', fValue; cr]].

	"Show the rest of the fields, omitting the uninteresting ones and ones we have already shown"
	omittedFields _ omittedFields, priorityFields.
	self fieldsFrom: (ReadStream on: text) do:
		[: fName : fValue |
		((fName beginsWith: 'x-') or:
			[omittedFields anySatisfy: [: omitted | fName sameAs: omitted]])
				ifFalse: [new nextPutAll: fName, ': ', fValue; cr]].

	^new contents! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 10/24/2001 18:14' prior: 37737317!
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 isoToSqueak; 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' stamp: 'RAA 2/16/2001 07:40'!
fieldsAsMimeHeader
	"return the entire header in proper MIME format"

	self halt.		"This no longer appears to be used and since, as a result of recent changes, it references an undeclared variable <subject>, I have commented out the code to clean up the inspection of undeclared vars"

"---
	| strm |
	strm _ WriteStream on: (String new: 100).
	self fields associationsDo: [:e | strm nextPutAll: e key;
		 nextPutAll: ': ';
		 nextPutAll: (e key = 'subject' ifTrue: [subject] ifFalse: [e value asHeaderValue]);
		 cr]. 
	^ strm contents
---"! !

!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: 'ls 2/10/2001 13:54'!
regenerateBodyFromParts
	"regenerate the message body from the multiple parts"
	| bodyText |

	bodyText := String streamContents: [ :str |
		str cr.
		parts do: [ :part |
			str
				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: 'bkv 6/23/2003 14:17' prior: 37740830!
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: '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 2/10/2001 16:36'!
save
	"save the part to a file"
	| fileName file |
	fileName _ self name
				ifNil: ['attachment' , Utilities dateTimeSuffix].
	(fileName includes: $.) ifFalse: [
		self body isJpeg
			ifTrue: [fileName _ fileName , '.jpg'].
		self body isGif ifTrue: [fileName _ fileName, '.gif']. ].
	fileName _ FillInTheBlank request: 'File name for save?' initialAnswer: fileName.
	fileName isEmpty
		ifTrue: [^ nil].
	file _ FileStream newFileNamed: fileName.
	file nextPutAll: self bodyText.
	file close! !

!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: '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 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 class methodsFor: 'instance creation' stamp: 'ls 2/10/2001 12:30'!
empty
	"return a message with no text and no header"
	^super new initialize! !

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

!MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 01:31'!
isSmtpServerSet
	^ SmtpServer notNil and: [SmtpServer notEmpty]
! !

!MailSender class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 17:55'!
sendMessage: aMailMessage

	self preferred ifNotNil: [self preferred sendMailMessage: aMailMessage]! !

!MailSender class methodsFor: 'as yet unclassified' stamp: 'ads 5/11/2003 21:11' prior: 37753190!
sendMessage: aMailMessage

	self default ifNotNil: [self default sendMailMessage: aMailMessage]! !

!MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 01:34'!
setSmtpServer
	"Set the SMTP server used to send outgoing messages via"
	SmtpServer ifNil: [SmtpServer _ ''].
	SmtpServer _ FillInTheBlank
		request: 'What is your mail server for outgoing mail?'
		initialAnswer: SmtpServer.
! !

!MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 00:49'!
setUserName
	"Change the user's email name for use in composing messages."

	(UserName isNil) ifTrue: [UserName _ ''].
	UserName _ FillInTheBlank
		request: 'What is your email address?\(This is the address other people will reply to you)' withCRs
		initialAnswer: UserName isoToSqueak.
	UserName ifNotNil: [UserName _ UserName squeakToIso]! !

!MailSender class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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! !

!MailtoUrl methodsFor: 'downloading' stamp: 'sw 5/23/2001 13:49'!
activate
	"Activate a Celeste window for the receiver"

	(Smalltalk includesKey: #Celeste)
		ifFalse: [^ self inform: 'no mail reader present'].
	^ CelesteComposition
		openForCeleste: Celeste current
		initialText: self composeText! !

!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 00:47' prior: 37754883!
activate
	"Activate a Celeste window for the receiver"

	MailSender sendMessage: (MailMessage from: self composeText)! !

!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 01:00' prior: 24299349!
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].! !

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

!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: '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: '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 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)! !

!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: 'dgd 2/16/2003 20:51' prior: 24332168!
visible: aBoolean 
	"set the 'visible' attribute of the receiver to aBoolean"
	self hasExtension
		ifFalse: [aBoolean
				ifTrue: [^ self]].
	self assureExtension visible: aBoolean! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 6/12/2001 06:02'!
innerAngle
	^(transform a11 @ transform a21) degrees! !

!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 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 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 06:03'!
heading: newHeading
	"Set the receiver's heading (in eToy terms)"
	self rotateBy: ((newHeading - 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: 'initialization' stamp: 'mdr 12/19/2001 19:08'!
initialize
	super initialize.
	transform _ MatrixTransform2x3 identity.
! !

!MatrixTransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38' prior: 37785110!
initialize
"initialize the state of the receiver"
	super initialize.
""
	transform _ MatrixTransform2x3 identity! !

!MatrixTransformMorph methodsFor: 'menus' stamp: 'jcg 11/1/2001 13:03'!
setRotationCenterFrom: aPoint

	super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint)
! !

!MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'!
privateFullMoveBy: delta
	self privateMoveBy: delta.
	transform offset: transform offset + delta.! !

!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.!
!MczInstaller methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 1/20/2004 11:13' prior: 37786151!
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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/17/2004 02:53' prior: 37786841!
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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/17/2004 03:26' prior: 37788077!
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: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58'!
extractPackageName
	^ (self parseMember: 'package') at: #name.
	! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58' prior: 37789053!
extractPackageName
	^ (self parseMember: 'package') at: #name.
	! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:17'!
extractVersionInfo
	^ self extractInfoFrom: (self parseMember: 'version')! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:17' prior: 37789363!
extractVersionInfo
	^ self extractInfoFrom: (self parseMember: 'version')! !

!MczInstaller methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/17/2004 02:56' prior: 37789691!
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: 'as yet unclassified' stamp: 'avi 9/17/2003 22:58'!
installMember: member
	 self useNewChangeSetDuring:
		[member contentStream text fileInAnnouncing: 'loading ', member fileName]! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2003 22:58' prior: 37790449!
installMember: member
	 self useNewChangeSetDuring:
		[member contentStream text fileInAnnouncing: 'loading ', member fileName]! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58'!
parseMember: fileName
	| tokens |
	tokens _ (self scanner scanTokens: (zip contentsOf: fileName)) first.
	^ self associate: tokens! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58' prior: 37790885!
parseMember: fileName
	| tokens |
	tokens _ (self scanner scanTokens: (zip contentsOf: fileName)) first.
	^ self associate: tokens! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:18'!
recordVersionInfo
	Versions 
		at: self extractPackageName 
		put: self extractVersionInfo! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:18' prior: 37791326!
recordVersionInfo
	Versions 
		at: self extractPackageName 
		put: self extractVersionInfo! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:04'!
scanner
	^ Scanner new! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:04' prior: 37791687!
scanner
	^ Scanner new! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:55'!
stream: aStream
	stream _ aStream! !

!MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:55' prior: 37791913!
stream: aStream
	stream _ aStream! !

!MczInstaller methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bf 2/9/2004 13:56' prior: 37792159!
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: 'as yet unclassified' 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 methodsFor: 'as yet unclassified' stamp: 'bf 2/9/2004 15:00' prior: 37793301!
versions: aVersionList anySatisfy: aDependencyID
	^ aVersionList anySatisfy: [:version | 
			aDependencyID = (version at: #id)
				or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:49'!
extension
	^ 'mcz'! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:49' prior: 37793881!
extension
	^ 'mcz'! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:53'!
fileReaderServicesForFile: fileName suffix: suffix
	^ Array with: self serviceLoadVersion! !

!MczInstaller class methodsFor: 'services' stamp: 'nk 6/8/2004 17:29' prior: 37794087!
fileReaderServicesForFile: fileName suffix: suffix
	^({ self extension. '*' } includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()].
! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:53' prior: 37794268!
fileReaderServicesForFile: fileName suffix: suffix
	^ Array with: self serviceLoadVersion! !

!MczInstaller class methodsFor: 'services' stamp: 'ab 8/8/2003 18:02'!
initialize
	Versions _ Dictionary new.
	Smalltalk at: #MCReader ifAbsent: [FileList registerFileReader: self]! !

!MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:51' prior: 37794668!
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: 'cwp 8/7/2003 18:54' prior: 37795008!
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: 'cwp 8/7/2003 18:53' prior: 37795463!
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: 'services' stamp: 'ab 8/8/2003 18:01' prior: 37795918!
services
	^ Array with: self serviceLoadVersion! !

!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 18:13' prior: 37796183!
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: 'installing' stamp: 'cwp 8/7/2003 17:56' prior: 37796537!
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: 'instance creation' stamp: 'cwp 8/7/2003 17:56' prior: 37796818!
on: aStream
	^ self new stream: aStream! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 1/19/2004 13:13'!
clearVersionInfo
	Versions _ Dictionary new! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 1/19/2004 13:13' prior: 37797079!
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: 'cwp 8/11/2003 23:49' prior: 37797343!
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! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 2/17/2004 02:49' prior: 37798414!
versionInfo
	^ Versions! !

!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 methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:16'!
appearanceIcon
	"answer a form to be used as icon"
	^ Icons
		at: #appearance
		ifAbsentPut: [ (Form
	extent: 16@14
	depth: 32
	fromArray: #( 0 0 0 4289169776 4289229125 4290082107 4289822288 4291467620 4292060268 4291137109 4289884214 4286929978 4287789670 0 0 0 0 0 4289230930 4290607675 4293577121 4290039534 4291094270 4290240510 4293655806 4294900984 4294829532 4294365358 4289951807 4286405700 0 0 0 4289229124 4292781405 4294901478 4294901495 4282427646 4281185790 4280328446 4290693582 4294877034 4294885266 4294878589 4294897880 4292320092 4285748543 0 0 4291461941 4289033536 4286797872 4291728209 4287549648 4283748081 4283416547 4293450161 4294869536 4294873638 4294472469 4294760617 4294897341 4290869554 0 4290475827 4291728455 4286275662 4288907635 4286270506 4294891655 4294436006 4294892951 4294892950 4294887798 4294493045 4294424929 4294823310 4294896331 4294887044 4286269986 4292321612 4294303367 4289687854 4289226794 4291201593 4294825339 4294890359 4294889072 4294888045 4294887791 4294886764 4294884959 4294884651 4294896469 4294886190 4289025555 4292580149 4294899597 4294894454 4294890086 4294890084 4294887001 4294885202 4294884172 4294883143 4294882115 4294880831 4294879034 4294884370 4294897203 4294820113 4290404369 4286732340 4292645166 4294886481 4294889819 4294886221 4294883393 4294881594 4294880049 4294878506 4294877220 4294875422 4294874137 4294285348 4293959983 4294872847 4290205704 0 4286801746 4286271530 4291394337 4294883392 4294882363 4294879535 4294877992 4294876444 4294807313 4294872077 4291332110 4290302101 4291222190 4292643344 4288824841 0 0 0 4286275917 4289749270 4294880046 4294877992 4294875677 4294744619 4293962089 4294875444 4286484227 4280542776 4280610882 4285238276 4286857244 0 0 0 0 4286341967 4291653651 4294877984 4294741525 4291723672 4292396798 4292056799 4290345992 4283095577 4282835744 4287392000 0 0 0 0 0 0 4286336294 4294807570 4294873615 4289944488 4289625598 4288567285 4293813261 4294869250 4294342916 4285872146 0 0 0 0 0 0 0 4287777553 4293950213 4294015780 4293237122 4293293883 4294866944 4293945344 4286790669 0 0 0 0 0 0 0 0 0 4285680687 4286858001 4287907080 4288563720 4287119627 4285023274 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37799049!
appearanceIcon
^ Icons
		at: #appearanceIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 4294967295 4294914610 1261581055 4294967295 4294967078 623850055 1262304536 553648127 4294914607 1412644660 1442878037 789774335 4280635289 328705 963542642 2571702015 4282131736 1176307975 1432640097 1586838527 993792806 224354447 2407892317 1603437837 1247750183 1015843973 2340717698 1989375523 1318556043 2340714370 2004316529 2140372782 407732874 2172024433 1532717146 1752262444 4279898433 2172025179 1751672644 976899103 4294967059 744184680 1532783892 33756182 4294967295 322984808 1129334839 101063935 4294967295 4279068775 757801555 1666714879 4294967295 4294909784 1498567000 1461059583 4294967295 4294967053 371085598 184549375 4294967295 4294967295 169221642 4294967295)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.129 0.646 1.0) #(0.129 0.905 0.223) #(0.129 0.968 0.258) #(0.16 0.71 1.0) #(0.258 0.678 1.0) #(0.258 0.905 0.129) #(0.289 0.741 0.905) #(0.289 0.87 0.094) #(0.321 0.807 0.968) #(0.419 0.258 0.16) #(0.419 0.548 0.0) #(0.451 0.223 0.063) #(0.451 0.289 0.16) #(0.451 0.321 0.223) #(0.482 0.289 0.129) #(0.482 0.289 0.16) #(0.482 0.321 0.16) #(0.482 0.353 0.258) #(0.482 0.388 0.289) #(0.482 0.548 0.0) #(0.517 0.223 0.031) #(0.517 0.258 0.063) #(0.517 0.258 0.094) #(0.517 0.353 0.192) #(0.517 0.353 0.223) #(0.517 0.388 0.321) #(0.548 0.258 0.031) #(0.548 0.419 0.0) #(0.548 0.839 0.839) #(0.58 0.258 0.031) #(0.58 0.289 0.063) #(0.58 0.482 0.388) #(0.611 0.289 0.031) #(0.611 0.321 0.968) #(0.646 0.258 0.031) #(0.646 0.321 0.063) #(0.646 0.451 0.258) #(0.646 0.548 0.451) #(0.678 0.419 0.16) #(0.678 0.451 0.16) #(0.678 0.451 0.258) #(0.678 0.482 0.321) #(0.678 0.482 1.0) #(0.71 0.353 0.031) #(0.71 0.353 0.678) #(0.71 0.388 0.063) #(0.71 0.451 0.192) #(0.71 0.451 0.223) #(0.71 0.482 0.223) #(0.71 0.482 0.321) #(0.71 0.807 0.936) #(0.71 0.87 1.0) #(0.741 0.388 0.063) #(0.741 0.451 0.192) #(0.741 0.482 0.031) #(0.741 0.482 0.223) #(0.741 0.807 0.807) #(0.741 0.839 0.58) #(0.776 0.482 0.192) #(0.776 0.548 0.223) #(0.776 0.548 0.321) #(0.776 0.87 0.678) #(0.776 0.905 1.0) #(0.807 0.451 0.063) #(0.807 0.482 0.129) #(0.807 0.517 0.192) #(0.807 0.517 0.611) #(0.807 0.548 0.031) #(0.807 0.58 0.258) #(0.807 0.58 0.321) #(0.807 0.611 0.388) #(0.839 0.58 0.87) #(0.839 0.611 0.353) #(0.839 0.646 0.289) #(0.839 0.646 0.419) #(0.87 0.548 0.063) #(0.87 0.58 0.16) #(0.87 0.58 0.192) #(0.87 0.646 0.353) #(0.87 0.776 1.0) #(0.905 0.451 0.223) #(0.905 0.611 0.517) #(0.936 0.388 0.031) #(0.936 0.807 0.646) #(0.936 0.87 0.71) #(0.936 1.0 1.0) #(0.968 0.419 0.0) #(0.968 0.482 0.0) #(0.968 0.482 0.129) #(0.968 0.611 0.129) #(0.968 0.646 0.16) #(0.968 0.678 0.419) #(0.968 0.741 0.388) #(0.968 0.839 0.678) #(0.968 0.87 0.517) #(0.968 0.905 0.646) #(1.0 0.451 0.063) #(1.0 0.482 0.0) #(1.0 0.517 0.0) #(1.0 0.517 0.129) #(1.0 0.548 0.031) #(1.0 0.548 0.063) #(1.0 0.58 0.031) #(1.0 0.58 0.063) #(1.0 0.58 0.094) #(1.0 0.58 0.129) #(1.0 0.611 0.094) #(1.0 0.611 0.16) #(1.0 0.611 0.192) #(1.0 0.611 0.419) #(1.0 0.646 0.129) #(1.0 0.646 0.16) #(1.0 0.646 0.223) #(1.0 0.646 0.482) #(1.0 0.678 0.16) #(1.0 0.678 0.192) #(1.0 0.678 0.223) #(1.0 0.71 0.223) #(1.0 0.71 0.258) #(1.0 0.741 0.063) #(1.0 0.741 0.16) #(1.0 0.741 0.258) #(1.0 0.741 0.289) #(1.0 0.741 0.321) #(1.0 0.741 0.353) #(1.0 0.741 0.58) #(1.0 0.776 0.063) #(1.0 0.776 0.16) #(1.0 0.776 0.289) #(1.0 0.776 0.321) #(1.0 0.776 0.353) #(1.0 0.776 0.419) #(1.0 0.776 0.451) #(1.0 0.776 0.517) #(1.0 0.807 0.419) #(1.0 0.807 0.451) #(1.0 0.807 0.548) #(1.0 0.839 0.353) #(1.0 0.839 0.388) #(1.0 0.839 0.451) #(1.0 0.839 0.482) #(1.0 0.87 0.517) #(1.0 0.87 0.58) #(1.0 0.87 0.678) #(1.0 0.905 0.451) #(1.0 0.905 0.87) #(1.0 0.936 0.192) #(1.0 0.936 0.321) #(1.0 0.936 0.741) #(1.0 0.936 0.807) #(1.0 0.968 0.548) #(1.0 0.968 0.87) #(1.0 1.0 0.905) #(1.0 1.0 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( )  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'!
backAndForthIcon
^ Icons
		at: #backAndForthIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1583242846 1577189890 33686110 1583242846 1583242754 34081804 202115074 39738974 1583219208 202116108 202116108 134372958 1577191430 201656588 202114314 151519838 1577192460 173803788 202136581 168362590 34081802 1549535498 202136668 84543746 34343429 1549534556 1549556828 1543834114 34211164 1549556828 1549556828 1549536257 39607388 1549556828 1549556828 1549556737 34233436 1543832837 89939036 1549535745 34343516 1549535497 151608412 1544162306 1577192458 1549535500 202136668 168559198 1577191436 173803788 202136586 201851486 1583219208 202116108 201721356 134372958 1583242754 34081804 202115074 39738974 1583242846 4278321666 33686110 1583242846)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 18:52'!
backIcon
	"answer a form to be used as icon"
	^ Icons
		at: #back
		ifAbsentPut: [ (Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 0 0 0 0 0 4283067445 4278803462 4286939742 0 0 0 0 0 0 0 0 0 0 0 0 4283723068 4278549253 4278619142 4286414681 0 0 0 0 0 0 0 0 0 0 0 4284247873 4279203086 4287488397 4280850982 4286677083 0 0 0 0 0 0 0 0 0 0 4284379459 4278808072 4288864162 4294508280 4280915751 4286545754 0 0 0 0 0 0 0 0 0 4284970313 4279069963 4288011157 4294901502 4293852910 4280063772 4281229857 4282411566 4282346028 4282346028 4282346028 4282346028 4282215467 4283724604 0 4286545754 4279134731 4287158152 4294901502 4294770428 4293983472 4286960773 4285185130 4285316460 4285316716 4285316716 4285316716 4285447790 4284792676 4279203855 4286808157 4280052246 4284598881 4291163845 4290571964 4290375097 4290637501 4291819215 4291688909 4291426505 4291426505 4291426505 4291426505 4291754446 4290443706 4280453408 4279656464 4279938586 4283028553 4281321007 4280599332 4280599332 4281255470 4283617618 4285914485 4286899076 4286767746 4286701953 4286701953 4286898820 4286112632 4279796502 4279656720 4278232064 4278237696 4278235648 4278235904 4278235904 4278235648 4278235648 4279089933 4280731430 4281912889 4282175293 4282175293 4282241086 4281848376 4279075084 4286808157 4279527694 4278235136 4278239488 4278237952 4278237952 4278237952 4278238720 4278239232 4278239488 4278371586 4278633990 4278634246 4278634246 4278569733 4278551044 0 4286545754 4278807302 4278237440 4278241280 4278240000 4278240512 4278237184 4278232576 4278232320 4278232320 4278232320 4278232320 4278232320 4278233344 4278219264 0 0 4284970569 4278481156 4278632454 4278832905 4278767112 4278556932 4281231137 4282412078 4282346540 4282346540 4282346540 4282346540 4282215467 4283723836 0 0 0 4284379715 4278743815 4279748631 4280080412 4279342864 4286545754 0 0 0 0 0 0 0 0 0 0 0 4284248129 4279073037 4281127724 4280131612 4286677083 0 0 0 0 0 0 0 0 0 0 0 0 4283723324 4279600405 4280458018 4286414937 0 0 0 0 0 0 0 0 0 0 0 0 0 4283067445 4279197453 4286939742 0 0 0 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37811954!
backIcon
^ Icons
		at: #backIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 538976288 537002498 33686048 538976288 538976258 34081804 202115074 35659808 538968584 202116108 202116108 134357024 537004038 201655561 202116108 201851424 537005068 168123401 202116108 202113568 34081802 89938953 202116108 202116098 34343429 1549556828 1549556828 84216834 34211164 1549556828 1549556828 1543833857 33905756 1549556828 1549556828 1543833857 34145628 1543832837 89939036 84216065 34343173 1549556745 151587081 151389186 537005065 89938953 202116102 100925984 537004044 151346185 202116102 101188128 538968584 201918729 201721348 134357024 538976258 34081804 202115074 35659808 538976288 537002498 33686048 538976288)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #( ) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'nk 3/9/2004 11:27'!
blankIcon
	^ Icons
		at: #blankIcon
		ifAbsentPut: [ Form
				extent: 16 @ 16
				depth: 8 ] ! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:41'!
cancelIcon
	"answer a form to be used as icon"
	^ Icons
		at: #cancel
		ifAbsentPut: [ (Form
	extent: 16@13
	depth: 32
	fromArray: #( 4281204736 4291297280 4292297539 4292569963 4292436064 4291297280 0 0 0 4278386688 4291690496 4292569963 4292569963 4291297280 4290248704 0 0 4288086016 4291432207 4292172378 4293036939 4293354596 4285988864 0 0 4291297280 4293563026 4292638583 4291570732 4292214784 4279631872 0 0 0 4291297280 4291297280 4290838528 4291834418 4293743957 4278387716 4283903791 4292957011 4291237655 4291297280 4291690496 4284350464 0 0 0 0 4279435264 4292214784 4291297280 4291624960 4292764258 4291797152 4294224811 4291834418 4291231744 4292214784 4289855488 0 0 0 0 0 0 4284153856 4292214784 4291690496 4291759887 4292228148 4291568676 4291231744 4292214784 4292673536 4278517760 0 0 0 0 0 0 0 4289003520 4292214784 4291624960 4291624960 4291624960 4292149248 4292673536 4280418304 0 0 0 0 0 0 0 0 4291428352 4291690496 4292149248 4292608000 4292608000 4292608000 4292673536 4282318848 0 0 0 0 0 0 0 4285071360 4292884279 4291759887 4292214784 4293198595 4292673536 4292608000 4292554543 4293198595 4278714368 0 0 0 0 0 4279566336 4292683559 4292228148 4290838528 4292673536 4288937984 4293198595 4292214784 4292087567 4292887620 4291297280 0 0 0 0 0 4292153360 4292297539 4290838528 4292214784 4292214784 0 4283695104 4292673536 4291690496 4292683559 4292884279 4284809216 0 0 0 4287102976 4290710283 4291690496 4291297280 4292673536 4281794560 0 0 4292214784 4291690496 4292214784 4291759887 4292214784 4279304192 0 4280483840 4293198595 4292214784 4292214784 4292673536 4288806912 0 0 0 4281073664 4292214784 4292214784 4292214784 4292214784 4292214784 0 4279631872 4279369728 4279369728 4279369728 4279762944 0 0 0 0 0 4279697408 4279369728 4279369728 4279369728 4279828480 4278386688)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37819410!
cancelIcon
^ Icons
		at: #cancelIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447663 791551247 190733918 1583223839 978802495 1060514107 419978846 1578179663 1415001600 3552809 1377306974 1578448975 909522432 3552822 691604062 287324214 909522432 3552822 910693895 322450998 909522432 3552822 909517061 305415734 1161184512 3552822 690562052 255017795 1128477440 3552809 690562052 271139394 1111631168 3552051 859971842 236864066 1111634772 1396851266 1111627014 1578054466 1111634723 759317058 1110639710 1577784644 1145251905 4932420 1141637982 1583220758 893798231 1464419893 218193502 1583242761 169552695 925243140 56516190 1583242846 1577518340 67241566 1583242846)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:07'!
copyIcon
	"answer a form to be used as icon"
	^ Icons
		at: #copy
		ifAbsentPut: [ (Form
	extent: 15@16
	depth: 32
	fromArray: #( 4288270844 4291226876 4291226876 4291161084 4291161084 4291161084 4291095548 4291029756 4290964219 4289250782 4288777855 0 0 0 0 4290764540 4294967295 4294901503 4294835966 4294835710 4294770174 4294704381 4294573053 4294507517 4293915896 4287476696 0 0 0 0 4290764540 4294901503 4294835966 4294573051 4294375416 4294309623 4294243831 4294178038 4293981174 4293324018 4288988907 0 0 0 0 4290764028 4294835966 4294770174 4290698232 4290501627 4290764540 4290764540 4290764540 4290764028 4290698492 4290698492 4290632700 4290501627 4288261829 0 4290698492 4294770174 4294704382 4290697975 4294441980 4294967295 4294901503 4294835967 4294835710 4294770174 4294704381 4294573309 4294507517 4293521654 4286881466 4290632956 4294704381 4294573309 4290632183 4294441468 4294901503 4294835966 4294835710 4294770174 4294704381 4294573053 4294507517 4294375932 4293718775 4289187056 4290632699 4294573053 4294507517 4290435319 4294375932 4294835966 4294770174 4294770174 4294704381 4294573053 4294507004 4294375932 4293915896 4293390070 4288989934 4290501627 4294507004 4294375932 4290369782 4294375932 4294770174 4294704382 4294704381 4294573053 4294441468 4294375676 4294113019 4293390069 4293192948 4288792301 4290435835 4294375676 4294178555 4289909235 4294310139 4294704382 4294573309 4294507517 4294441468 4294310140 4294112761 4293390069 4293127156 4292930035 4288529643 4290304249 4293915897 4293324277 4289580784 4294244347 4294573053 4294507517 4294441468 4294310140 4293981689 4293324277 4293127156 4292863986 4292601328 4288332265 4289975799 4293324277 4293127156 4289383663 4294178555 4294507516 4294375932 4294310139 4293784568 4293258485 4293061363 4292863986 4292535792 4292338414 4288069350 4289055728 4293061364 4292863986 4289186542 4294113017 4294375676 4294178555 4293586934 4293192948 4292995827 4292798194 4292535536 4292272878 4292009965 4287806180 4286231533 4288660972 4288463851 4286165225 4293916153 4294113017 4293390069 4293192948 4292995571 4292667122 4292469999 4292207086 4291944172 4291681259 4287477731 0 0 0 4287008151 4293653239 4293390069 4293127156 4292930035 4292666864 4292404207 4292207086 4291878636 4291615467 4291287017 4287214816 0 0 0 4286942614 4292667122 4293061620 4292863986 4292601328 4292403951 4292141293 4291812588 4291549674 4291221481 4290958566 4286951902 0 0 0 4286942357 4291681516 4292010222 4291813100 4291615723 4291418602 4291155689 4290893030 4290695397 4290367203 4290104290 4286491610)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37826460!
copyIcon
^ Icons
		at: #copyIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 186325787 454761243 454043945 690563369 402653184 0 2360874 690563369 402653184 639968549 622923050 690563369 402653208 404232216 404232216 403253545 402653207 654311424 0 2294825 402653207 654311424 0 656609066 402663191 654311424 2565926 555814186 405218836 654311424 656877089 555813418 405020946 637534247 656810273 538970666 337715473 637544231 606150944 538839082 253829134 640099874 555819040 505219114 34212354 606478625 555753246 488376106 707406338 589373729 538910237 471467818 690563330 539041824 522066972 437847338 690563330 252641794 33686018 33685802 690563370 707406378 707406378 707406378)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.678 0.87) #(0.482 0.71 0.936) #(0.517 0.548 0.58) #(0.517 0.611 0.741) #(0.517 0.71 0.87) #(0.548 0.71 0.87) #(0.548 0.71 0.905) #(0.58 0.741 0.905) #(0.611 0.678 0.776) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.548 0.482) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.646 0.807 0.968) #(0.678 0.776 0.87) #(0.678 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.807 0.905) #(0.71 0.839 0.968) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.87 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:11'!
cutIcon
	"answer a form to be used as icon"
	^ Icons
		at: #cut
		ifAbsentPut: [ (Form
	extent: 14@16
	depth: 32
	fromArray: #( 4288270844 4291226876 4291226876 4291226876 4291161340 4291161084 4291161084 4291095548 4291095548 4291029756 4291029755 4289846011 4287272869 0 4290764540 4294967295 4294967295 4294901503 4294901503 4294835966 4294770174 4294770174 4294704382 4294573309 4294573053 4294507005 4290303731 4286484644 4290764540 4294901759 4294901503 4294835967 4294835966 4294770174 4294770174 4294704381 4294573309 4294507517 4294441468 4294244347 4293718775 4287740902 4290764540 4294901503 4294835967 4294808989 4294770174 4294770174 4294704381 4294573053 4294507517 4294441468 4294480796 4293850104 4293586934 4289121263 4290764028 4294835966 4294733434 4294457931 4294664815 4294704381 4294573053 4294507517 4294441468 4294533486 4294457931 4294142069 4293324277 4288924142 4290698492 4294835710 4294756301 4294522439 4294459216 4294664814 4294507517 4294441468 4294533486 4294459216 4294456646 4293573573 4293127156 4288792301 4290698492 4294770174 4294704382 4294690508 4294522439 4294459216 4294533486 4294467950 4294459216 4294456646 4293507781 4293061620 4292930035 4288529643 4290632956 4294704381 4294573053 4294507517 4294493644 4294458187 4294461784 4294461784 4294392394 4293507781 4293061363 4292863986 4292667120 4288398058 4290632699 4294573053 4294507517 4294441468 4294375676 4294399587 4294531942 4294531942 4294071137 4292995827 4292863986 4292601328 4292469743 4288200935 4290501627 4294507517 4294441468 4294375676 4294207346 4294466918 4294264916 4294264916 4294466918 4293681775 4292601328 4292404207 4292207086 4288003814 4290435835 4294441468 4294375676 4294076530 4294468201 4294200407 4293179844 4293114051 4294134870 4294468201 4293288302 4292141294 4291878636 4287806180 4290370041 4294310140 4293947515 4294468202 4294200407 4293114308 4292930035 4292667122 4292785602 4294134871 4294468202 4292961908 4291681259 4287543523 4290238712 4293915897 4293376965 4293869131 4293114308 4292863986 4292666864 4292469999 4292272878 4292325824 4293737546 4291931325 4291418345 4287346145 4289975799 4293324277 4293192948 4292995827 4292863986 4292601328 4292404207 4292272622 4292009965 4291812588 4291615467 4291287273 4291089895 4287149024 4289252594 4293127156 4292995571 4292798450 4292535792 4292404207 4292207086 4291944429 4291747051 4291549674 4291287017 4291089895 4290826725 4286886366 4288924143 4292930035 4292798194 4292535536 4292338415 4292141293 4291878636 4291681259 4291484138 4291221481 4291024102 4290761189 4290498276 4286688732)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37834014!
cutIcon
^ Icons
		at: #cutIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 169285399 387389207 387389207 251935804 321990961 825307441 825307440 823263548 321990969 825307441 825309481 2623293 321992755 925970737 825701166 2559037 321993266 876032305 926167590 589499453 321990970 842282807 875701795 589499197 321990961 976434485 707142435 589498685 321990961 824981046 740500259 505350461 321990961 758524715 908402462 505284669 321990958 925573666 725032988 505153341 321990455 723657503 489371425 505087805 321987108 572465950 471475225 504890941 254357760 2302750 505290270 504890685 237187363 522133020 454563861 336855869 235670540 202115337 117901061 83951933 238894397 1027423549 1027423549 1027423549)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.58 0.646) #(0.517 0.678 0.87) #(0.517 0.71 0.87) #(0.548 0.58 0.646) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.611 0.776 0.905) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.839 0.968) #(0.71 0.87 1.0) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.839 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.87 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.678 0.741) #(0.839 0.71 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.71 0.776) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.388 0.419) #(0.905 0.388 0.451) #(0.905 0.741 0.776) #(0.905 0.936 0.968) #(0.936 0.223 0.289) #(0.936 0.388 0.419) #(0.936 0.741 0.776) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.223 0.289) #(0.968 0.289 0.321) #(0.968 0.321 0.388) #(0.968 0.388 0.451) #(0.968 0.419 0.451) #(0.968 0.451 0.482) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.192 0.258) #(1.0 0.223 0.289) #(1.0 0.223 0.321) #(1.0 0.289 0.353) #(1.0 0.353 0.388) #(1.0 0.388 0.419) #(1.0 0.419 0.482) #(1.0 0.58 0.611) #(1.0 0.776 0.807) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:54'!
deleteIcon
	"answer a form to be used as icon"
	^ Icons
		at: #delete
		ifAbsentPut: [ Form
	extent: 14@16
	depth: 32
	fromArray: #( 4288270844 4291226876 4291226876 4291226876 4291161340 4291161084 4291161084 4291095548 4291095548 4291029756 4291029755 4289846011 4287272869 0 4290764540 4294967295 4294967295 4294901503 4294901503 4294835966 4294770174 4294770174 4294704382 4294573309 4294573053 4294507005 4290303731 4286484644 4290764540 4294901759 4294901503 4294835967 4294835966 4294770174 4294770174 4294704381 4294573309 4294507517 4294441468 4294244347 4293718775 4287740902 4290764540 4294901503 4294835967 4294808989 4294770174 4294770174 4294704381 4294573053 4294507517 4294441468 4294480796 4293850104 4293586934 4289121263 4290764028 4294835966 4294733434 4294457931 4294664815 4294704381 4294573053 4294507517 4294441468 4294533486 4294457931 4294142069 4293324277 4288924142 4290698492 4294835710 4294756301 4294522439 4294459216 4294664814 4294507517 4294441468 4294533486 4294459216 4294456646 4293573573 4293127156 4288792301 4290698492 4294770174 4294704382 4294690508 4294522439 4294459216 4294533486 4294467950 4294459216 4294456646 4293507781 4293061620 4292930035 4288529643 4290632956 4294704381 4294573053 4294507517 4294493644 4294458187 4294461784 4294461784 4294392394 4293507781 4293061363 4292863986 4292667120 4288398058 4290632699 4294573053 4294507517 4294441468 4294375676 4294399587 4294531942 4294531942 4294071137 4292995827 4292863986 4292601328 4292469743 4288200935 4290501627 4294507517 4294441468 4294375676 4294207346 4294466918 4294264916 4294264916 4294466918 4293681775 4292601328 4292404207 4292207086 4288003814 4290435835 4294441468 4294375676 4294076530 4294468201 4294200407 4293179844 4293114051 4294134870 4294468201 4293288302 4292141294 4291878636 4287806180 4290370041 4294310140 4293947515 4294468202 4294200407 4293114308 4292930035 4292667122 4292785602 4294134871 4294468202 4292961908 4291681259 4287543523 4290238712 4293915897 4293376965 4293869131 4293114308 4292863986 4292666864 4292469999 4292272878 4292325824 4293737546 4291931325 4291418345 4287346145 4289975799 4293324277 4293192948 4292995827 4292863986 4292601328 4292404207 4292272622 4292009965 4291812588 4291615467 4291287273 4291089895 4287149024 4289252594 4293127156 4292995571 4292798450 4292535792 4292404207 4292207086 4291944429 4291747051 4291549674 4291287017 4291089895 4290826725 4286886366 4288924143 4292930035 4292798194 4292535536 4292338415 4292141293 4291878636 4291681259 4291484138 4291221481 4291024102 4290761189 4290498276 4286688732)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37841698!
deleteIcon
^ Icons
		at: #deleteIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 169285399 387389207 387389207 251935804 321990961 825307441 825307440 823263548 321990969 825307441 825309481 2623293 321992755 925970737 825701166 2559037 321993266 876032305 926167590 589499453 321990970 842282807 875701795 589499197 321990961 976434485 707142435 589498685 321990961 824981046 740500259 505350461 321990961 758524715 908402462 505284669 321990958 925573666 725032988 505153341 321990455 723657503 489371425 505087805 321987108 572465950 471475225 504890941 254357760 2302750 505290270 504890685 237187363 522133020 454563861 336855869 235670540 202115337 117901061 83951933 238894397 1027423549 1027423549 1027423549)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.58 0.646) #(0.517 0.678 0.87) #(0.517 0.71 0.87) #(0.548 0.58 0.646) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.611 0.776 0.905) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.839 0.968) #(0.71 0.87 1.0) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.839 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.87 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.678 0.741) #(0.839 0.71 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.71 0.776) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.388 0.419) #(0.905 0.388 0.451) #(0.905 0.741 0.776) #(0.905 0.936 0.968) #(0.936 0.223 0.289) #(0.936 0.388 0.419) #(0.936 0.741 0.776) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.223 0.289) #(0.968 0.289 0.321) #(0.968 0.321 0.388) #(0.968 0.388 0.451) #(0.968 0.419 0.451) #(0.968 0.451 0.482) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.192 0.258) #(1.0 0.223 0.289) #(1.0 0.223 0.321) #(1.0 0.289 0.353) #(1.0 0.353 0.388) #(1.0 0.388 0.419) #(1.0 0.419 0.482) #(1.0 0.58 0.611) #(1.0 0.776 0.807) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:44'!
doItIcon
	"answer a form to be used as icon"
	^ Icons
		at: #doIt
		ifAbsentPut: [ (Form
	extent: 14@16
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 4279768832 4292334872 4287006269 4280492824 0 0 0 0 0 0 0 0 4278453249 4289634304 4294967173 4294966710 4294964609 4294962201 4294961408 4288385024 0 0 0 0 0 4284306944 4294966869 4294966675 4294961992 4294699031 4294962201 4294172424 4286411776 4279110912 0 0 0 4282399744 4294964542 4294967204 4294964093 4294961459 4294699031 4294699031 4288385024 4279571200 0 0 0 4281215488 4294502162 4294966675 4294964878 4294962004 4294895656 4294501398 4289042441 4280755456 0 0 0 0 4293318145 4294967041 4294964769 4294896425 4294896425 4294830632 4294830632 4294896188 4289109288 4280097809 0 0 0 0 4278453248 4282794240 4290160896 4294962450 4294966557 4294896425 4294962480 4294896196 4294964609 4294965638 4294961408 4288978230 4281479462 0 0 0 0 0 4280360704 4290818326 4294962480 4294896425 4294895651 4294699031 4294962450 4293318145 4285490944 0 0 0 0 0 4286608912 4294965067 4294895656 4294896425 4294962201 4291542272 4283320320 4278453248 0 0 0 0 4281610240 4294966065 4294967194 4294963035 4294896425 4288450064 4280886784 0 0 0 0 0 0 4292528640 4294967054 4294962480 4294896425 4294830632 4294896188 4294963035 4287070262 4283979064 0 0 0 0 0 4278518784 4284307200 4291476494 4294502162 4294895656 4294896425 4294895656 4294896425 4294965248 4293910016 4286280192 0 0 0 0 0 4278387456 4294041617 4294962480 4294896425 4294699031 4291739648 4285096448 4279637248 0 0 0 0 0 4281873408 4294967054 4294964769 4292594432 4286872832 4280426240 4278255616 0 0 0 0 0 0 4289239808 4294965248 4289832192 4281873408 4278453248 0 0 0 0 0 0 0 0 4285293312 4283386368 4278453248 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37849392!
doItIcon
^ Icons
		at: #doItIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1229539657 1229539657 235144196 68030025 1229539657 1229539585 524502844 791489806 1229539657 1225658690 1144335919 705954377 1229539598 238634555 841887258 50612553 1225656876 1144862257 739968782 1229539657 237518392 825307441 857474318 1229539657 1224806177 775958834 876364589 487344457 1229539598 235282994 825241134 672352585 1229539598 238107185 825172752 21580105 1225657153 1162164017 420023881 1229539657 237453106 741421363 924258830 1229539657 1224806692 741093681 825310761 340347209 1229539585 724709678 622002958 1229539657 1225592127 942085638 17058121 1229539657 222182944 218173001 1229539657 1229539657 219152654 1229539657 1229539657 1229539657)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.031 0.031 0.0) #(0.063 0.063 0.0) #(0.094 0.063 0.0) #(0.094 0.094 0.063) #(0.129 0.094 0.0) #(0.129 0.129 0.0) #(0.129 0.129 0.094) #(0.16 0.129 0.0) #(0.16 0.16 0.0) #(0.192 0.192 0.0) #(0.192 0.192 0.129) #(0.223 0.192 0.0) #(0.258 0.223 0.0) #(0.258 0.258 0.0) #(0.289 0.289 0.0) #(0.353 0.321 0.0) #(0.353 0.321 0.223) #(0.419 0.388 0.0) #(0.482 0.451 0.0) #(0.517 0.451 0.063) #(0.517 0.482 0.0) #(0.517 0.517 0.192) #(0.517 0.517 0.223) #(0.611 0.548 0.063) #(0.611 0.58 0.0) #(0.646 0.611 0.031) #(0.646 0.611 0.16) #(0.646 0.611 0.192) #(0.678 0.611 0.0) #(0.678 0.646 0.0) #(0.71 0.646 0.0) #(0.71 0.678 0.0) #(0.776 0.71 0.063) #(0.807 0.741 0.0) #(0.807 0.741 0.031) #(0.807 0.776 0.0) #(0.839 0.839 0.094) #(0.87 0.807 0.0) #(0.905 0.839 0.0) #(0.936 0.87 0.0) #(0.968 0.87 0.031) #(0.968 0.905 0.063) #(1.0 0.905 0.063) #(1.0 0.936 0.0) #(1.0 0.936 0.063) #(1.0 0.936 0.094) #(1.0 0.936 0.129) #(1.0 0.936 0.16) #(1.0 0.936 0.192) #(1.0 0.936 0.223) #(1.0 0.936 0.258) #(1.0 0.936 0.289) #(1.0 0.936 0.321) #(1.0 0.936 0.353) #(1.0 0.968 0.129) #(1.0 0.968 0.223) #(1.0 0.968 0.289) #(1.0 0.968 0.482) #(1.0 0.968 0.517) #(1.0 0.968 0.548) #(1.0 1.0 0.0) #(1.0 1.0 0.031) #(1.0 1.0 0.094) #(1.0 1.0 0.192) #(1.0 1.0 0.321) #(1.0 1.0 0.517) #(1.0 1.0 0.58) #(1.0 1.0 0.611) #(1.0 1.0 0.646) #(1.0 1.0 0.71) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:17'!
findIcon
	"answer a form to be used as icon"
	^ Icons
		at: #find
		ifAbsentPut: [ (Form
	extent: 12@12
	depth: 32
	fromArray: #( 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4292272882 4289053924 4278190081 0 0 0 0 0 0 0 0 4278190081 4289053924 4286292698 4278190081 0 0 4278190081 4278190081 0 0 0 0 4289243304 4278190081 4278190081 0 0 4278190081 4292272882 4289447398 4278190081 0 0 0 0 0 0 0 0 4278190081 4289053924 4286292698 4278190081 0 0 0 4278190081 4278190081 4278190081 4278190081 0 0 4278190081 4278190081 0 0 0 4278190081 4291747311 4290696170 4289842151 4289053924 4278190081 0 0 0 0 0 0 4278190081 4290696170 4289842151 4289053924 4288265441 4287345885 4278190081 0 0 4278190081 4278190081 0 4278190081 4289842151 4289053924 4288265441 4287345885 4286426073 4278190081 0 4278190081 4292272882 4289053924 4278190081 4278190081 4289053924 4288265441 4287345885 4286426073 4285506261 4278190081 0 4278190081 4289053924 4286292698 4278190081 4278190081 4288265441 4287345885 4286426073 4285506261 4284520913 4278190081 0 0 4281088591 4278190081 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37856239!
findIcon
^ Icons
		at: #findIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 286331153 286331153 286331153 286331153 285278481 286331153 286331153 286331153 17762561 286331137 17895697 286331153 17368321 286327055 151064849 286331153 285278481 286327049 83955985 286331153 286331153 286331137 17895697 286331153 286331153 286331153 286331153 16847121 286327041 16847121 286331137 252248337 285278222 218890513 286331137 151322897 285281805 201918209 286331153 16847121 285281548 151521025 286331153 286331153 285281289 134678017 286331153 286331153 285280520 117834753 286331137 17895697 285280263 100926209 286327055 151064849 286327041 16843025 286327049 83955985 286331153 286331153 286331138 17895697)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.16 0.223 0.289) #(0.388 0.611 0.839) #(0.419 0.646 0.839) #(0.482 0.646 0.87) #(0.482 0.678 0.87) #(0.548 0.71 0.87) #(0.611 0.741 0.905) #(0.646 0.776 0.905) #(0.678 0.678 0.678) #(0.678 0.776 0.905) #(0.71 0.807 0.905) #(0.741 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.905 0.968) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 18:54'!
forwardIcon
	"answer a form to be used as icon"
	^ Icons
		at: #forward
		ifAbsentPut: [ (Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 4286939742 4278803462 4283067445 0 0 0 0 0 0 0 0 0 0 0 0 0 4286414681 4278619142 4278549253 4283723068 0 0 0 0 0 0 0 0 0 0 0 0 4286677083 4280850982 4287488397 4279203086 4284247873 0 0 0 0 0 0 0 0 0 0 0 4286545754 4280915751 4294508280 4288864162 4278808072 4284379459 0 0 0 4283725116 4282215467 4282346028 4282346028 4282346028 4282346028 4282411566 4281229857 4280063772 4293852910 4294901502 4288011157 4279069963 4284970313 0 0 4279203855 4284792932 4285447790 4285316716 4285316716 4285316716 4285316460 4285185130 4286960773 4293983472 4294770428 4294901502 4287158152 4279134731 4286545754 0 4280453408 4290443706 4291754446 4291426505 4291426505 4291426505 4291426505 4291688909 4291819215 4290637501 4290375097 4290571964 4291163845 4284598881 4280052246 4286808157 4279796502 4286112632 4286898820 4286701953 4286701953 4286767746 4286899076 4285914485 4283617618 4281255470 4280599332 4280599332 4281321007 4283028553 4279938586 4279656464 4279075084 4281848376 4282241086 4282175293 4282175293 4281912889 4280731430 4279089933 4278235648 4278235648 4278235904 4278235904 4278235648 4278237696 4278232064 4279656720 4278551044 4278569733 4278634246 4278634246 4278633990 4278371586 4278239488 4278239232 4278238720 4278237952 4278237952 4278237952 4278239488 4278235136 4279527694 4286808157 4278219264 4278233344 4278232320 4278232320 4278232320 4278232320 4278232320 4278232576 4278237184 4278240512 4278240000 4278241280 4278237440 4278807302 4286545754 0 4283723836 4282215467 4282346540 4282346540 4282346540 4282346540 4282412078 4281231137 4278556932 4278767112 4278832905 4278632454 4278481156 4284970569 0 0 0 0 0 0 0 0 0 4286545754 4279342864 4280080412 4279748631 4278743815 4284379715 0 0 0 0 0 0 0 0 0 0 4286677083 4280131612 4281127724 4279073037 4284248129 0 0 0 0 0 0 0 0 0 0 0 4286414937 4280458018 4279600405 4283723324 0 0 0 0 0 0 0 0 0 0 0 0 4286939742 4279197453 4283067445 0 0 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37862251!
forwardIcon
^ Icons
		at: #forwardIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 555819297 553779714 33686049 555819297 555819266 34081804 202115074 35725601 555811336 202116108 202116108 134357281 553781254 202116108 151323916 151519777 553782284 202116108 157047813 201916961 34081798 101058054 157047900 84674818 34343429 1543832837 1549556828 1543834626 34211164 1549556828 1549556828 1549534465 39607388 1549556828 1549556828 1549556737 34233436 1543832837 89939036 1543833857 34343177 151587081 157047900 84478978 553782284 202116108 157047813 151781921 553781260 202116108 157025545 201851425 555811336 202116108 201918732 134357281 555819266 34081804 202115074 35725601 555819297 553779714 33686049 555819297)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #( ) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:14'!
helpIcon
	"answer a form to be used as icon"
	^ Icons
		at: #help
		ifAbsentPut: [ Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 0 0 0 0 4289539622 4289923849 4289988102 4289857030 4289268745 4288818726 0 0 0 0 0 0 0 0 4289670694 4290838785 4292359220 4293682790 4293620595 4293554545 4293420903 4291705403 4289398278 4288228902 0 0 0 0 0 4289798171 4291824909 4294345346 4294818233 4294231236 4294434012 4294434269 4294899960 4294891736 4294217358 4290584865 4287766555 0 0 0 4289670951 4291693066 4294737277 4294615971 4294031287 4294634218 4294901502 4294901502 4294901502 4294833396 4294887881 4294743188 4290255900 4287704871 0 0 4290707456 4294267474 4294870919 4293888136 4294901502 4294900474 4294880171 4294875031 4294824401 4294835966 4294894563 4294872975 4294009442 4288283652 0 4289604901 4292284689 4294860639 4294859868 4293959840 4294901502 4294881456 4294858840 4294790477 4293685617 4294638844 4294901502 4294723913 4294718516 4290512904 4287376677 4289858313 4293596694 4294853957 4294851131 4294728796 4294874774 4294857555 4294849587 4293078574 4293638328 4294901502 4294619312 4293853698 4293853184 4292345856 4287040265 4289855488 4293988882 4294844962 4294844191 4294843934 4294843934 4294843420 4293865263 4293969606 4294835966 4294830826 4293926430 4293656576 4293853184 4292935680 4286775296 4289658880 4294182149 4294838537 4294838537 4294838537 4294838280 4294181892 4293632160 4294901502 4294756809 4293925916 4293656576 4293656576 4293853184 4293066752 4286644224 4289268489 4293525504 4294836224 4294836224 4294770688 4294770688 4292938764 4294437610 4294900988 4294386724 4294180864 4294246400 4294246400 4294443008 4292673536 4286515977 4288818469 4291887104 4294836224 4294836224 4294770688 4294770688 4294246914 4294878886 4294876830 4294770688 4294770688 4294770688 4294770688 4294836224 4290314240 4286655781 0 4289593344 4294247428 4294837509 4294837252 4294837252 4294180864 4292627018 4293613656 4294837252 4294837252 4294837252 4294837509 4293919748 4287037440 0 0 4288229159 4290642948 4294775057 4294840593 4294839051 4293276466 4294308080 4294834424 4294853186 4294838794 4294840593 4294775057 4289135620 4286394151 0 0 0 4287701019 4290447368 4294253596 4294844705 4294717231 4294884283 4294885054 4294850360 4294844705 4293991452 4289136648 4285866011 0 0 0 0 0 4287704614 4288283652 4290843154 4293402656 4293997620 4293932084 4293205791 4290253330 4287038468 4286459430 0 0 0 0 0 0 0 0 4287376934 4287040779 4286841346 4286710274 4286516491 4286721574 0 0 0 0 0)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37869552!
helpIcon
^ Icons
		at: #helpIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447663 791551247 190733918 1583223839 978796095 1062687035 419978846 1578179663 1413307392 23896 1377306974 1578448976 805306453 1381564503 1362692702 287329870 1006655054 1278148608 1279792647 321538890 1314016584 657588310 690561285 305415749 1162167596 1040210997 690562052 255017795 1128477489 5780777 690562052 271139394 1111631168 3552051 859971842 236864066 1111634772 1396851266 1111627014 1578054466 1111634723 759317058 1110639710 1577784644 1145251905 4932420 1141637982 1583220758 893798231 1464419893 218193502 1583242761 169552695 925243140 56516190 1583242846 1577518340 67241566 1583242846)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:02'!
inspectIcon
	"answer a form to be used as icon"
	^ Icons
		at: #inspect
		ifAbsentPut: [Form
		extent: 15 @ 15
		depth: 32
		fromArray: #(0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4291283919 4293324531 4292405234 4291615719 4289444808 4278190081 0 0 0 0 0 0 0 4278190081 4293324531 4293456119 4292405234 4291945200 4290959852 4289514727 4289054950 4278190081 0 0 0 0 0 4278190081 4291283919 4293456119 4292667891 4291748335 4290171625 4289514727 4289514727 4289514727 4288263886 4278190081 0 0 0 0 4278190081 4293257966 4292405234 4291748335 4289514727 4289054950 4289054950 4288923620 4288923620 4288923620 4278190081 0 0 0 0 4278190081 4291945200 4291485422 4289514727 4289054950 4288463845 4288463845 4288463845 4288463845 4288923620 4278190081 0 0 0 0 4278190081 4291090405 4290171625 4289054950 4288463845 4288463845 4288463845 4288135398 4288135398 4288135398 4278190081 0 0 0 0 4278190081 4288656582 4288923620 4288463845 4288463845 4288135398 4287806948 4288135398 4287806948 4287213006 4278190081 0 0 0 0 0 4278190081 4288463070 4288463845 4288135398 4287806948 4287544294 4287544294 4287280095 4278190081 0 0 0 0 0 0 0 4278190081 4287213006 4287806948 4287544294 4287280865 4286622160 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 0 4278190081 4287518507 4287456581 4278190081 0 0 0 0 0 0 0 0 0 0 0 4278190081 4287585846 4294029435 4287329891 4278190081 0 0 0 0 0 0 0 0 0 0 0 4278190081 4287390788 4293634933 4286342996 4278190081 0 0 0 0 0 0 0 0 0 0 0 4278190081 4286339131 4284764738 4278190081 0 0 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4294901760 )
		offset: 0 @ 0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37877313!
inspectIcon
^ Icons
		at: #inspectIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 656877313 16843009 656877351 656877351 656867609 589306902 19343143 656877351 654385957 538909463 352397095 656877351 18425121 504895255 386990375 656877351 19013662 387257620 336462119 656877351 18816279 353571603 235536679 656877351 18487317 320017166 236388647 656877351 17830931 319753742 236388647 656877351 654381587 252579086 402719271 656877351 656867594 235738903 16908545 656877351 656877313 16843009 33621512 19343143 656877351 656877351 654379046 134293287 656877351 656877351 656867591 638124327 656877351 656877351 656877313 136578049 656877351 656877351 656877351 16974337 656877351 656877351 656877351 654377255)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.388 0.321 0.258) #(0.482 0.353 0.223) #(0.482 0.388 0.321) #(0.517 0.678 0.839) #(0.548 0.321 0.16) #(0.548 0.353 0.192) #(0.548 0.388 0.258) #(0.548 0.451 0.388) #(0.548 0.678 0.807) #(0.548 0.71 0.87) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.58 0.776 0.905) #(0.611 0.71 0.776) #(0.611 0.71 0.807) #(0.611 0.776 0.87) #(0.611 0.776 0.905) #(0.646 0.776 0.905) #(0.646 0.807 0.905) #(0.678 0.741 0.807) #(0.678 0.807 0.905) #(0.71 0.839 0.936) #(0.776 0.807 0.807) #(0.776 0.839 0.905) #(0.776 0.87 0.936) #(0.807 0.87 0.905) #(0.807 0.87 0.936) #(0.807 0.905 0.936) #(0.839 0.905 0.968) #(0.87 0.905 0.968) #(0.87 0.936 0.968) #(0.905 0.936 0.936) #(0.905 0.936 0.968) #(0.936 0.678 0.451) #(0.936 0.968 0.968) #(0.968 0.71 0.482) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 18:02'!
morphsIcon
	"answer a form to be used as icon"
	^ Icons
		at: #morphs
		ifAbsentPut: [ Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 0 4279900693 4286348346 4286019384 4278255873 0 0 0 0 0 4281944942 4279441698 0 0 0 0 4289372704 4294962505 4294965433 4294966462 4294964520 4283320832 0 0 0 4280693842 4287213015 4287605985 4279837496 0 0 4279900435 4294897927 4294831202 4294831961 4294831961 4294964074 4294966791 0 0 4280562771 4287147998 4286160590 4287213015 4287871204 4280694355 0 4286611514 4294964520 4294833203 4294767410 4294831401 4294962993 4294966303 4282136320 4281811540 4287345393 4287871204 4288923879 4289516010 4289252844 4288793086 4280825941 4285821228 4294965025 4294833203 4294833466 4294767410 4294962999 4294966303 4282071040 4279834136 4287413759 4290833151 4291556606 4291556606 4291622399 4289188607 4278256388 4278650628 4294966791 4294965304 4294899259 4294962999 4294897194 4294967056 0 0 4279637531 4287675384 4291622399 4293722111 4291622399 4278716686 0 0 4281280512 4294967065 4294967065 4294966303 4294967056 4281610496 0 0 0 4280095000 4288399355 4291489535 4278914837 0 0 0 0 0 4282596608 4282531328 0 0 0 0 0 0 4278913806 4279049515 0 0 0 0 0 0 4279900709 4278519567 0 0 0 0 0 4280752409 4279373072 4279439122 4280097053 0 0 0 0 0 4285237697 4281816715 0 0 0 0 4281073664 4293288802 4294558400 4294359221 4291297280 4280951072 0 0 0 4281347626 4284845517 4285240530 4279768858 0 0 0 4292280320 4293288802 4292299081 4292299081 4291840329 4289789952 0 0 0 4286620118 4288134376 4287871204 4282606746 0 0 4285726720 4293726481 4292610827 4292673536 4291559424 4291301392 4290314240 4282526764 0 4279178011 4289648383 4290833151 4289977080 4287675384 4279637536 0 4290314240 4293066752 4292673536 4292673536 4292214784 4291297280 4290641920 4284427051 0 4288003050 4291754239 4292606975 4292606975 4290306556 4285501886 0 0 4294181121 4293066752 4293001216 4291624960 4291297280 4289200128 0 4278849043 4291622399 4293132287 4293722111 4293132287 4291622399 4290043388 4280624427 0 4286447616 4292280320 4292739072 4292280320 4291624960 4280749582 0 4280693314 4283260533 4283391341 4283259501 4283391341 4283391341 4282799986 4282009177 0 0 4281532673 4280942849 4281008385 4280352768 0 0)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37884002!
morphsIcon
^ Icons
		at: #morphsIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 4294926691 1677721599 4294967098 989855743 4284899437 1835401215 4294916662 942014463 1667457633 1634232831 4282005299 909846015 1667589734 1583311711 976829247 1162100773 1667524199 1717529439 976898895 1330594085 4285099111 1600061439 4282006863 1515136511 4294929259 1811939327 4294916670 1311113215 4294967077 637534207 4294967098 637534207 4294967077 637534207 4294913577 690946047 4294967077 637534207 4281227101 1548495359 4294911274 757465087 777082706 1381123921 4294911292 992346111 1230591059 1280134217 4280632907 1211966975 1230394195 1363954761 4280635477 1430924543 4284175958 1280066303 625956954 1481590821 4281422163 1363945983 625956952 1481590821 4294967116 1291845631)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.031 0.031 0.031) #(0.031 0.031 0.063) #(0.031 0.063 0.094) #(0.031 0.094 0.16) #(0.063 0.031 0.063) #(0.063 0.063 0.094) #(0.063 0.063 0.129) #(0.063 0.094 0.129) #(0.094 0.063 0.094) #(0.094 0.094 0.063) #(0.094 0.094 0.094) #(0.094 0.094 0.129) #(0.094 0.129 0.223) #(0.129 0.0 0.0) #(0.129 0.031 0.031) #(0.129 0.094 0.094) #(0.129 0.129 0.16) #(0.129 0.192 0.258) #(0.129 0.192 0.321) #(0.16 0.0 0.0) #(0.16 0.129 0.129) #(0.16 0.16 0.0) #(0.16 0.223 0.321) #(0.192 0.0 0.0) #(0.192 0.16 0.16) #(0.192 0.192 0.0) #(0.192 0.258 0.321) #(0.192 0.321 0.548) #(0.223 0.192 0.0) #(0.223 0.223 0.0) #(0.223 0.258 0.353) #(0.223 0.289 0.419) #(0.258 0.16 0.16) #(0.258 0.223 0.0) #(0.258 0.321 0.451) #(0.258 0.388 0.611) #(0.289 0.289 0.0) #(0.289 0.353 0.419) #(0.289 0.353 0.451) #(0.353 0.16 0.16) #(0.388 0.548 0.807) #(0.419 0.548 0.776) #(0.419 0.58 0.741) #(0.419 0.58 0.839) #(0.451 0.0 0.0) #(0.451 0.451 0.16) #(0.451 0.451 0.223) #(0.482 0.0 0.0) #(0.482 0.482 0.223) #(0.482 0.611 0.807) #(0.517 0.517 0.223) #(0.517 0.646 0.839) #(0.548 0.678 0.839) #(0.548 0.678 0.87) #(0.548 0.678 0.905) #(0.548 0.71 0.968) #(0.548 0.741 1.0) #(0.58 0.741 0.905) #(0.58 0.741 0.936) #(0.58 0.741 1.0) #(0.611 0.776 1.0) #(0.646 0.807 0.905) #(0.646 0.807 1.0) #(0.646 0.839 1.0) #(0.678 0.0 0.0) #(0.678 0.646 0.129) #(0.678 0.807 0.936) #(0.678 0.839 0.936) #(0.678 0.839 1.0) #(0.71 0.0 0.0) #(0.71 0.87 1.0) #(0.741 0.0 0.0) #(0.741 0.905 1.0) #(0.776 0.936 1.0) #(0.807 0.0 0.0) #(0.807 0.063 0.063) #(0.807 0.936 1.0) #(0.807 0.968 1.0) #(0.807 1.0 1.0) #(0.839 0.0 0.0) #(0.839 0.289 0.289) #(0.87 0.0 0.0) #(0.87 0.031 0.031) #(0.87 1.0 1.0) #(0.905 0.0 0.0) #(0.905 0.388 0.388) #(0.905 1.0 1.0) #(0.936 0.063 0.063) #(0.936 1.0 1.0) #(0.968 0.0 0.0) #(0.968 0.741 0.71) #(1.0 0.776 0.776) #(1.0 0.936 0.16) #(1.0 0.936 0.192) #(1.0 0.936 0.289) #(1.0 0.936 0.353) #(1.0 0.936 0.388) #(1.0 0.968 0.0) #(1.0 0.968 0.129) #(1.0 0.968 0.16) #(1.0 0.968 0.192) #(1.0 0.968 0.223) #(1.0 0.968 0.419) #(1.0 1.0 0.0) #(1.0 1.0 0.063) #(1.0 1.0 0.094) #(1.0 1.0 0.223) #(1.0 1.0 0.741) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( )  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:58'!
newIcon
	"answer a form to be used as icon"
	^ Icons
		at: #new
		ifAbsentPut: [Form
	extent: 14@15
	depth: 32
	fromArray: #( 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 4278190081 4294375933 4294375933 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4278190081 0 0 4278190081 4294375933 4294375933 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4294310140 4278190081 0 4294415388 4278190081 4294415388 4294967040 4294415388 4293718520 4294415388 4293718520 4293718520 4293718520 4293718520 4293718520 4278190081 4294415388 4294967040 4294811648 4294957312 4294967040 4294957312 4294811648 4294967040 4294415388 4292929779 4292929779 4292929779 4292929779 4278190081 4294967295 4294811648 4294967040 4294953216 4294967235 4294953216 4294967040 4294811648 4292403952 4292403952 4292403952 4292403952 4292403952 4278190081 4294415388 4294957312 4294953216 4294967235 4294967235 4294967235 4294953216 4294957312 4294415388 4291812076 4291812076 4291812076 4291812076 4278190081 4294967040 4294967040 4294967235 4294967235 4294967235 4294967235 4294967235 4294967040 4294967040 4291549419 4291220970 4291220713 4291220713 4278190081 4294415388 4294957312 4294953216 4294967235 4294967235 4294967235 4294953216 4294957312 4294415388 4291549419 4291549419 4291549419 4291549419 4278190081 4294967295 4294415388 4294967040 4294953216 4294967235 4294953216 4294967040 4294811648 4292206831 4292403952 4292403952 4292403952 4292272624 4278190081 4294415388 4294967040 4294415388 4294811648 4294967040 4294811648 4294415388 4294967040 4294415388 4292929779 4292995315 4292469745 4292995315 4278190081 4293848813 4294415388 4278190081 4294415388 4294967040 4294415388 4293455608 4294415388 4293718521 4293455607 4293455607 4293455607 4293455607 4278190081 0 0 4278190081 4294112764 4294112763 4294112763 4294112763 4294112763 4294112763 4294113020 4294112763 4294112763 4294112763 4278190081 0 0 4278190081 4293718777 4293718777 4293718520 4293718520 4293718520 4293718520 4293718520 4293718520 4293718520 4293718520 4278190081 0 0 4278190081 4281479730 4280427042 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280427042)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:50' prior: 37891560!
newIcon
^ Icons
		at: #newIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 421075227 454761242 437918232 404232217 421075227 269488144 269484048 269490199 421075227 269488144 269484048 269490199 420354318 336465166 403505165 218961943 236196115 336793876 236453897 151590935 420549650 353506321 403179528 134748183 236130837 353702419 236455173 84219927 336860437 353703188 337118212 67377175 236130837 353702419 236455173 84219927 420353042 353506321 386402312 134682647 236195345 336662036 236388361 134813719 420354062 336467982 386596875 185276439 421075223 404229912 252641295 252647447 421075224 218959117 218959117 218961943 421075224 404232216 404232216 404232215 421075225 387389207 387389207 387389207)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.129 0.129 0.129) #(0.192 0.192 0.192) #(0.776 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.905 0.936) #(0.839 0.905 0.968) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.936 0.936) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.58 0.094) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.646 0.0) #(1.0 0.807 0.0) #(1.0 0.87 0.0) #(1.0 1.0 0.0) #(1.0 1.0 0.776) #(0.0 0.0 0.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #( ) #(0.345 0.529 0.603) #(0.47 0.721 0.823) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:42'!
okIcon
	"answer a form to be used as icon"
	^ Icons
		at: #ok
		ifAbsentPut: [ (Form
	extent: 14@13
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 4280494885 4281243983 0 0 0 0 0 0 0 0 0 0 0 4280896308 4288013220 4278234158 0 0 0 0 0 0 0 0 0 0 4281095737 4281509462 4278493479 4278228005 0 0 0 0 0 0 0 0 0 4281688130 4282628192 4278231328 4278493479 4278452225 0 4281420601 4281509462 4278200576 0 0 0 0 4281689668 4283022949 4278298918 4278234158 4278191872 0 4280297251 4279477564 4289389236 4278214656 0 0 0 4280969528 4282692712 4278298918 4278235439 4278192128 0 0 4278212374 4278234402 4279809075 4278231328 0 0 4280706618 4283022949 4278236197 4278234158 4278196227 0 0 0 4278210831 4278237731 4279156015 4282834031 0 4286221696 4284729979 4278236197 4278235439 4278196739 0 0 0 0 4278208269 4278306857 4278242856 4284670076 4291755482 4288013220 4278234402 4278235439 4278199304 0 0 0 0 0 4278269718 4278239018 4278240548 4279225909 4279354676 4278237977 4278235439 4278200585 0 0 0 0 0 0 4278657040 4278237225 4278239018 4278242599 4278239018 4278237751 4278199048 0 0 0 0 0 0 0 4278387972 4278231328 4278239018 4278306857 4278237751 4278196483 0 0 0 0 0 0 0 0 0 4278194944 4278221857 4278229557 4278193664 0 0 0 0 0 0 0 0 0)
	offset: 0@0)
]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37898788!
okIcon
^ Icons
		at: #okIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 908273718 909522486 909522486 909522486 624104246 909522486 909522486 909522470 722538294 909522486 909522486 909519405 286327094 909519147 120993334 908734226 318846518 908205876 221656630 657199637 37107254 906760737 288765476 789844740 909522486 906696477 775303728 336921654 909522486 906632220 825570066 352663094 909522486 906565658 505419285 137770550 909522486 906369048 454564101 909522486 909522486 906039576 471401526 909522486 909522486 909509390 268580406 909522486 909522486 909522467 590755382 909522486 909522486)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.0 0.031 0.0) #(0.0 0.063 0.0) #(0.0 0.094 0.0) #(0.0 0.129 0.031) #(0.0 0.129 0.063) #(0.0 0.16 0.0) #(0.0 0.16 0.031) #(0.0 0.192 0.063) #(0.0 0.258 0.031) #(0.0 0.321 0.031) #(0.0 0.321 0.063) #(0.0 0.388 0.0) #(0.0 0.482 0.129) #(0.0 0.58 0.129) #(0.0 0.611 0.192) #(0.0 0.646 0.129) #(0.0 0.678 0.129) #(0.0 0.678 0.16) #(0.0 0.71 0.129) #(0.0 0.71 0.16) #(0.0 0.741 0.094) #(0.0 0.741 0.129) #(0.0 0.741 0.16) #(0.0 0.741 0.192) #(0.0 0.776 0.129) #(0.0 0.807 0.129) #(0.0 0.807 0.16) #(0.031 0.741 0.16) #(0.031 0.807 0.192) #(0.063 0.646 0.223) #(0.063 0.776 0.192) #(0.094 0.71 0.192) #(0.129 0.129 0.129) #(0.129 0.16 0.129) #(0.129 0.388 0.223) #(0.16 0.289 0.192) #(0.16 0.321 0.223) #(0.16 0.419 0.223) #(0.16 0.611 0.289) #(0.192 0.289 0.223) #(0.192 0.388 0.258) #(0.192 0.646 0.321) #(0.258 0.71 0.419) #(0.258 0.741 0.388) #(0.258 0.87 0.419) #(0.289 0.741 0.388) #(0.388 0.807 0.482) #(0.388 0.905 0.482) #(0.482 0.548 0.517) #(0.58 0.905 0.646) #(0.678 0.905 0.71) #(0.807 1.0 0.87) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:07'!
openIcon
	"answer a form to be used as icon"
	^ Icons
		at: #open
		ifAbsentPut: [ (Form
	extent: 16@15
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 4288842363 4286347163 4285428404 4288645244 0 0 0 0 0 0 0 0 0 0 0 4287791492 4286677171 4291349230 4292401910 4285689241 0 0 0 0 4283131820 4285236925 4284776636 4284710844 4282670503 4288908410 4287004053 4288257747 4293322490 4293980158 4293585148 4287796945 4287265666 0 0 0 4282218204 4289850108 4288535292 4287747580 4285178604 4285102528 4291546859 4294769918 4293980414 4293125114 4293124602 4292532982 4284705196 4287790973 0 0 4282874839 4291099902 4289127420 4287280106 4288127449 4293914618 4294901502 4294375166 4293717246 4293256698 4292861687 4290889969 4286483154 4284703113 4288251003 4288251003 4282612183 4290902782 4287475429 4290624737 4294901502 4294901502 4294901502 4294901502 4294834174 4294637054 4285040346 4282016981 4283727070 4281686469 4282736052 4281089440 4282480343 4291165694 4286887407 4284646617 4287080942 4286751464 4286488549 4286290405 4286289636 4283330515 4281229271 4283141880 4282025470 4282354942 4280177122 4280233634 4282349012 4291428094 4282549220 4283990750 4288592884 4288003830 4286887156 4285900529 4284717552 4284059633 4284062462 4281105406 4280578556 4279651815 4278194611 4282861711 4282282451 4290310398 4281165015 4292208892 4291486199 4291885821 4288731902 4285640957 4283272956 4281366010 4280114165 4279189471 4278459587 4279047084 4278719144 0 4282414804 4286232820 4283794660 4292738814 4288205047 4286889466 4284719870 4282351098 4280639217 4279190507 4278396373 4278195907 4278194104 4279112877 4279837342 0 4282415060 4283008479 4288003054 4289850366 4286236414 4283996920 4283601660 4282087928 4280178928 4278464737 4278198229 4278197197 4278194880 4278586798 4281612178 0 4280637902 4282809825 4289778679 4290898942 4289123838 4287478268 4286424566 4285306353 4283199973 4281621469 4281291477 4281157576 4280695997 4279247534 4283583881 0 4278859967 4284517603 4294901246 4294901502 4294901246 4294308348 4293584630 4292795119 4292334314 4291545315 4290690268 4289966293 4289571281 4281551024 0 0 4278660536 4289249007 4294901502 4294901502 4294901502 4294901502 4294505978 4293453040 4292400102 4291347677 4290295250 4289571273 4288782788 4280102558 0 0 4278791603 4281293771 4282016462 4281819086 4281818570 4281489864 4281225665 4280896443 4280566964 4280171951 4279973544 4279709860 4279315104 4281940622 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37905055!
openIcon
^ Icons
		at: #openIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 2661195422 2661195422 2052805237 2661195422 2661195422 2661195374 1670288984 2661195422 1045712204 947544694 2560334447 1772002974 864319859 1465093632 2627246230 1265475230 998997611 1889140892 2593691273 1548383348 998992519 0 2644333873 1143683360 982214222 1701076574 1564419650 892737814 848313671 2003986265 1346914600 521339703 847783826 2408807770 1110317582 84609950 979387799 2020102452 504301572 34280606 977367428 1632192052 436864774 67185054 490505098 2087477078 1076700193 454050718 490505098 2087477078 1076700193 454050718 223281152 10262933 2441971330 2150276766 159449088 40345 2492237183 2065014430 203763756 741090082 471340818 288333470)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.031 0.678) #(0.0 0.031 0.741) #(0.0 0.063 0.71) #(0.0 0.063 0.776) #(0.0 0.094 0.776) #(0.0 0.094 0.807) #(0.0 0.094 0.839) #(0.0 0.129 0.839) #(0.0 0.16 0.741) #(0.0 0.192 0.905) #(0.031 0.063 0.678) #(0.031 0.16 0.71) #(0.031 0.223 0.741) #(0.031 0.223 0.87) #(0.031 0.258 0.936) #(0.063 0.129 0.678) #(0.063 0.16 0.646) #(0.063 0.192 0.646) #(0.063 0.289 0.905) #(0.094 0.129 0.611) #(0.094 0.16 0.611) #(0.094 0.16 0.646) #(0.094 0.192 0.678) #(0.094 0.223 0.678) #(0.094 0.321 0.905) #(0.094 0.353 0.968) #(0.129 0.223 0.741) #(0.129 0.258 0.71) #(0.129 0.353 0.807) #(0.129 0.353 0.968) #(0.129 0.451 1.0) #(0.16 0.223 0.646) #(0.16 0.258 0.807) #(0.16 0.289 0.741) #(0.16 0.321 0.776) #(0.16 0.321 0.839) #(0.16 0.353 0.807) #(0.16 0.353 0.839) #(0.16 0.388 0.839) #(0.16 0.482 1.0) #(0.192 0.192 0.58) #(0.192 0.289 0.71) #(0.192 0.353 0.776) #(0.192 0.353 0.807) #(0.192 0.353 0.87) #(0.192 0.451 1.0) #(0.223 0.223 0.548) #(0.223 0.388 0.807) #(0.223 0.388 0.839) #(0.223 0.451 0.839) #(0.223 0.451 0.87) #(0.223 0.482 1.0) #(0.223 0.517 1.0) #(0.223 0.548 1.0) #(0.258 0.289 0.548) #(0.258 0.353 0.646) #(0.258 0.353 0.71) #(0.258 0.451 0.839) #(0.258 0.482 0.839) #(0.258 0.482 0.905) #(0.258 0.517 0.905) #(0.289 0.388 0.678) #(0.289 0.419 0.839) #(0.289 0.451 0.905) #(0.289 0.517 0.87) #(0.289 0.548 1.0) #(0.321 0.289 0.548) #(0.321 0.482 0.87) #(0.321 0.517 0.905) #(0.321 0.58 1.0) #(0.353 0.517 0.87) #(0.353 0.548 0.968) #(0.353 0.611 1.0) #(0.388 0.388 0.548) #(0.388 0.419 0.678) #(0.388 0.482 0.741) #(0.388 0.517 0.741) #(0.388 0.517 0.87) #(0.388 0.548 0.905) #(0.388 0.611 0.968) #(0.388 0.646 1.0) #(0.419 0.451 0.71) #(0.419 0.482 0.776) #(0.419 0.517 0.741) #(0.419 0.517 0.87) #(0.419 0.58 0.968) #(0.419 0.646 0.936) #(0.451 0.419 0.611) #(0.451 0.646 0.968) #(0.451 0.71 1.0) #(0.482 0.451 0.611) #(0.482 0.548 0.839) #(0.482 0.58 0.905) #(0.482 0.611 0.905) #(0.482 0.646 0.968) #(0.482 0.741 0.968) #(0.482 0.776 1.0) #(0.517 0.482 0.58) #(0.517 0.517 0.71) #(0.517 0.646 0.936) #(0.517 0.678 0.936) #(0.517 0.71 0.936) #(0.517 0.71 0.968) #(0.517 0.741 1.0) #(0.548 0.482 0.517) #(0.548 0.678 0.905) #(0.548 0.71 0.936) #(0.548 0.741 1.0) #(0.58 0.482 0.482) #(0.58 0.517 0.517) #(0.58 0.58 0.839) #(0.58 0.646 0.87) #(0.58 0.741 0.936) #(0.58 0.741 0.968) #(0.58 0.839 1.0) #(0.611 0.517 0.482) #(0.611 0.548 0.482) #(0.611 0.611 0.839) #(0.611 0.741 0.968) #(0.611 0.839 0.968) #(0.611 0.87 1.0) #(0.646 0.548 0.482) #(0.646 0.646 0.776) #(0.646 0.839 1.0) #(0.646 0.87 1.0) #(0.646 0.905 1.0) #(0.678 0.678 0.807) #(0.678 0.678 0.839) #(0.678 0.741 0.936) #(0.71 0.71 0.839) #(0.71 0.839 0.968) #(0.71 0.936 1.0) #(0.741 0.71 0.839) #(0.741 0.741 0.87) #(0.741 0.741 0.905) #(0.741 0.968 1.0) #(0.776 0.807 0.968) #(0.776 0.936 1.0) #(0.776 1.0 1.0) #(0.807 0.776 0.87) #(0.807 0.807 0.905) #(0.807 0.807 0.936) #(0.807 0.905 0.968) #(0.807 1.0 1.0) #(0.839 0.839 0.936) #(0.839 0.936 1.0) #(0.839 1.0 1.0) #(0.87 0.839 0.905) #(0.87 0.87 0.936) #(0.87 0.87 0.968) #(0.87 1.0 1.0) #(0.905 0.905 1.0) #(0.936 0.905 0.968) #(0.936 0.936 1.0) #(0.968 0.936 1.0) #(0.968 0.968 1.0) #(1.0 0.968 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:09'!
pasteIcon
	"answer a form to be used as icon"
	^ Icons
		at: #paste
		ifAbsentPut: [ (Form
	extent: 15@16
	depth: 32
	fromArray: #( 0 0 0 0 0 4289107077 4291547086 4289503123 0 0 0 0 0 0 0 4293818659 4294941516 4294941256 4294940737 4292448348 4292142057 4292601837 4291811804 4292256118 4294935827 4294935311 4294935052 4294536455 4289563760 0 4294943061 4294967035 4294965739 4291940551 4290760663 4290826455 4290234320 4290496461 4291021773 4290951586 4294951747 4294950973 4294940182 4290675287 0 4294943576 4294965741 4294964182 4294958217 4294956403 4294955373 4294954855 4294954337 4294953819 4294952789 4294950726 4294942484 4294935297 4290675287 0 4294943319 4294964443 4294959256 4294957187 4294956670 4294956151 4290893017 4290764540 4290764540 4290764540 4290764540 4290698492 4290698492 4290370041 4288652199 4294943062 4294961076 4294958227 4294957452 4294956935 4294956418 4292600283 4294967295 4294901503 4294835966 4294770174 4294704381 4294573053 4294507516 4290435317 4294942030 4294959265 4294958747 4294957974 4294957202 4294956684 4292600286 4294901503 4294835966 4294770174 4294704381 4294573053 4294441468 4294113017 4293586934 4294941774 4294959527 4294959011 4294958237 4294957465 4294956949 4292534752 4294835710 4294770174 4294704381 4294573053 4294441468 4294244347 4293521398 4293192948 4294941774 4294959527 4294959011 4294958237 4294957465 4294956949 4292534752 4294770174 4294704381 4294507517 4294441468 4294244347 4293521398 4293127156 4292863986 4294941774 4294959527 4294959011 4294958237 4294957465 4294956949 4292468960 4294573309 4294507516 4294375932 4294244347 4293521398 4293061620 4292798450 4292469999 4294941774 4294959527 4294959011 4294958237 4294957465 4294954882 4292466372 4294507004 4294375676 4293981689 4293324277 4293061363 4292667122 4292404207 4292141293 4294941774 4294959527 4294959011 4294958237 4294957465 4294948676 4292335044 4294375676 4293784311 4293258484 4292995571 4292666864 4292338415 4292009965 4291681259 4294941774 4294959527 4294959011 4294958237 4294951517 4294946866 4292203203 4293718775 4293192948 4292930035 4292601328 4292272878 4291878892 4291615466 4291155687 4294941774 4294959527 4294959011 4294953839 4294947900 4294946866 4291283903 4293127156 4292863986 4292535536 4292207086 4291813100 4291549674 4291155687 4290761189 4294940996 4294956423 4294952288 4294949187 4294947900 4294946866 4290036159 4290172144 4289908975 4289514990 4289186541 4288857836 4288463595 4288135145 4287740903 4293818146 4294937893 4294937378 4294936862 4294936091 4294935578 4294935064 4294934551 4294934037 4294933524 4294933011 4294932242 4294536732 4289563762 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37913095!
pasteIcon
^ Icons
		at: #pasteIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 2105376125 2097486601 2105376125 2105376125 708590651 572597788 506803247 142441853 1023433759 286788624 387269433 259882365 1046239827 1296845129 1212496435 259882365 1029396306 1313690393 336860180 336855933 1029264467 1330599187 0 4958 1012422229 1431392522 46 757795422 1012422229 1431392518 11821 724043358 1012422229 1431390982 11563 673646174 1012422229 1430997761 3024936 656802142 1012422229 1430994689 774645799 555745630 1012422229 1178550017 740828961 538771806 1012422218 1077886721 673653021 488243550 995051330 1077886721 235734790 67240286 691550263 909522485 1583242846 1583242877 2103402335 1600085855 1600085855 1602059645)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.58 0.741 0.905) #(0.58 0.741 0.936) #(0.611 0.646 0.646) #(0.611 0.776 0.936) #(0.646 0.58 0.517) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.548 0.451) #(0.678 0.611 0.58) #(0.678 0.807 0.936) #(0.71 0.776 0.741) #(0.71 0.776 0.839) #(0.71 0.839 0.936) #(0.71 0.839 0.968) #(0.741 0.517 0.321) #(0.741 0.776 0.807) #(0.741 0.807 0.839) #(0.741 0.839 0.905) #(0.741 0.87 0.968) #(0.741 0.87 1.0) #(0.776 0.741 0.646) #(0.776 0.807 0.741) #(0.776 0.807 0.807) #(0.776 0.839 0.839) #(0.776 0.839 0.87) #(0.776 0.839 0.905) #(0.807 0.807 0.807) #(0.807 0.87 0.87) #(0.807 0.87 0.936) #(0.839 0.646 0.451) #(0.839 0.839 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.58 0.353) #(0.87 0.839 0.776) #(0.87 0.905 0.87) #(0.87 0.905 0.905) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.451 0.129) #(0.936 0.482 0.129) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.419 0.0) #(1.0 0.419 0.094) #(1.0 0.451 0.063) #(1.0 0.482 0.063) #(1.0 0.517 0.0) #(1.0 0.517 0.031) #(1.0 0.517 0.063) #(1.0 0.517 0.094) #(1.0 0.548 0.094) #(1.0 0.548 0.129) #(1.0 0.58 0.063) #(1.0 0.611 0.063) #(1.0 0.611 0.258) #(1.0 0.611 0.289) #(1.0 0.646 0.321) #(1.0 0.646 0.353) #(1.0 0.71 0.192) #(1.0 0.71 0.223) #(1.0 0.71 0.258) #(1.0 0.741 0.258) #(1.0 0.776 0.223) #(1.0 0.776 0.258) #(1.0 0.776 0.321) #(1.0 0.776 0.353) #(1.0 0.776 0.388) #(1.0 0.807 0.353) #(1.0 0.807 0.388) #(1.0 0.807 0.419) #(1.0 0.807 0.517) #(1.0 0.839 0.419) #(1.0 0.839 0.451) #(1.0 0.839 0.482) #(1.0 0.839 0.517) #(1.0 0.839 0.548) #(1.0 0.839 0.58) #(1.0 0.87 0.517) #(1.0 0.87 0.548) #(1.0 0.87 0.58) #(1.0 0.87 0.611) #(1.0 0.87 0.646) #(1.0 0.905 0.611) #(1.0 0.905 0.646) #(1.0 0.905 0.71) #(1.0 0.968 0.839) #(1.0 0.968 0.87) #(1.0 1.0 0.936) #(0.0 0.0 0.0) #(0.258 0.396 0.451) #(0.772 0.369 0.109) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:20'!
printIcon
	"answer a form to be used as icon"
	^ Icons
		at: #print
		ifAbsentPut: [ (Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 0 0 4287660927 4286019978 4284840866 4283788962 0 0 0 0 0 0 0 0 0 0 0 4287600304 4288655058 4291350760 4294242296 4290495966 4284968583 0 0 0 0 0 0 0 0 4287800264 4293192437 4294638333 4294901502 4294374652 4293256689 4293256176 4284775337 4288382841 0 0 0 0 0 0 0 4287271852 4293915898 4294901502 4294440957 4293848824 4293190897 4292992751 4289443287 4284705153 0 0 0 0 0 0 0 0 4289116375 4294901502 4294506749 4293848824 4293190897 4292795628 4292794859 4284643753 4284049819 4284574110 0 0 0 0 0 0 4286744995 4293718264 4294835454 4294045431 4293453041 4292008686 4289319414 4284658682 4280512230 4279060949 4279780545 4283061147 0 0 0 0 4288186497 4289312980 4294900990 4292865786 4290109434 4286301950 4283147770 4280974577 4279128798 4279061980 4282416362 4288196840 4283585690 0 0 0 4286742676 4286949071 4291885822 4288734462 4284988926 4282554616 4281236719 4281563627 4285506548 4290763000 4294901502 4294901502 4286744788 4285950337 0 4284577209 4287670000 4291488509 4289720318 4285187582 4284001277 4284918266 4288596220 4293259774 4294901502 4294901502 4294047229 4292797425 4287735499 4283715462 0 4284184788 4290561020 4290693886 4290895614 4289059582 4290699006 4293916158 4294638334 4294244350 4293258237 4291218156 4290691566 4289573341 4284325519 4283517828 0 4284316112 4290692855 4289772017 4291482365 4293849342 4294309630 4293258237 4292402680 4291021039 4289770469 4288718814 4286087873 4284116655 4285434559 4283780737 0 4284053202 4292469246 4291021558 4290034671 4291547894 4291416305 4290626801 4289638886 4288521692 4287075790 4286221505 4287931854 4291087075 4286220996 4283785101 0 4284771749 4286946021 4292732670 4292337146 4290494447 4290100463 4289311716 4288194265 4288917977 4290693860 4293718008 4294308346 4293453556 4293650164 4289443800 4283852689 0 4285032853 4285169103 4292995837 4293652990 4291549182 4287668951 4291154666 4294901502 4294901502 4294637565 4294308346 4292401643 4288062926 4284051099 4285230722 0 0 4286214536 4284509628 4290298863 4287272414 4283718823 4285759661 4291549678 4294901502 4293191413 4287735246 4284773272 4285558655 0 0 0 0 0 4286937218 4283520669 4285097100 4287922300 0 4286743957 4287077829 4285628320 4286675840 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37920956!
printIcon
^ Icons
		at: #printIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 2122219071 757011070 2122219134 2122219134 2118073670 1702582553 2122219134 2122219134 1081344000 2087940896 1132363390 2122219134 1014562940 2020831822 427720318 2122219134 2118844416 2020830573 538122878 2122219134 2117499136 2054646354 570753284 192839294 2118406400 1901540108 117637641 1192132222 2117417836 1294141958 136929024 3615870 507668819 706224456 1979711612 1866468734 375152228 1281325312 2088067418 1326910846 375084647 2038199662 1632913713 338169214 359686741 1717984080 1161310784 1613893502 456814699 1481986117 1247639676 2004307729 2116429685 2036810083 32124 1832915749 2122199068 1514016815 1744859968 489389694 2122219060 237256574 892939828 2122219134)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.031 0.289 0.839) #(0.031 0.289 0.87) #(0.031 0.321 0.87) #(0.094 0.258 0.776) #(0.129 0.419 0.905) #(0.16 0.482 0.936) #(0.16 0.482 0.968) #(0.192 0.482 0.936) #(0.258 0.482 0.936) #(0.258 0.611 1.0) #(0.289 0.321 0.611) #(0.289 0.646 1.0) #(0.321 0.289 0.517) #(0.321 0.321 0.611) #(0.321 0.353 0.548) #(0.321 0.353 0.646) #(0.321 0.388 0.58) #(0.321 0.419 0.646) #(0.353 0.419 0.611) #(0.353 0.419 0.678) #(0.353 0.451 0.839) #(0.353 0.482 0.839) #(0.353 0.611 0.548) #(0.353 0.678 1.0) #(0.388 0.419 0.517) #(0.388 0.419 0.611) #(0.388 0.419 0.646) #(0.388 0.419 0.741) #(0.388 0.451 0.611) #(0.388 0.451 0.741) #(0.388 0.482 0.646) #(0.388 0.482 0.678) #(0.388 0.678 1.0) #(0.388 0.71 1.0) #(0.388 0.741 1.0) #(0.419 0.388 0.548) #(0.419 0.419 0.517) #(0.419 0.419 0.58) #(0.419 0.482 0.807) #(0.419 0.548 0.741) #(0.419 0.646 0.968) #(0.419 0.776 1.0) #(0.451 0.419 0.482) #(0.451 0.419 0.517) #(0.451 0.482 0.548) #(0.451 0.482 0.646) #(0.451 0.517 0.678) #(0.482 0.451 0.548) #(0.482 0.517 0.776) #(0.482 0.548 0.776) #(0.482 0.776 1.0) #(0.517 0.482 0.517) #(0.517 0.517 0.58) #(0.517 0.548 0.646) #(0.517 0.548 0.839) #(0.517 0.58 0.807) #(0.517 0.611 0.776) #(0.517 0.611 0.905) #(0.517 0.646 0.807) #(0.548 0.58 0.678) #(0.548 0.58 0.71) #(0.548 0.58 0.87) #(0.58 0.517 0.482) #(0.58 0.646 0.807) #(0.58 0.646 0.839) #(0.58 0.646 0.968) #(0.611 0.517 0.482) #(0.611 0.548 0.517) #(0.611 0.646 0.87) #(0.611 0.678 0.839) #(0.611 0.71 0.936) #(0.611 0.807 1.0) #(0.646 0.646 0.87) #(0.646 0.71 0.87) #(0.646 0.741 0.839) #(0.646 0.87 1.0) #(0.646 0.905 1.0) #(0.678 0.71 0.839) #(0.678 0.71 0.87) #(0.678 0.71 0.905) #(0.678 0.741 0.839) #(0.678 0.839 0.968) #(0.678 0.936 1.0) #(0.71 0.71 0.905) #(0.71 0.741 0.936) #(0.71 0.741 0.968) #(0.71 0.87 1.0) #(0.741 0.741 0.936) #(0.741 0.776 0.87) #(0.741 0.776 0.936) #(0.741 0.776 0.968) #(0.741 0.776 1.0) #(0.741 0.807 0.905) #(0.741 0.807 1.0) #(0.741 0.87 1.0) #(0.776 0.807 0.905) #(0.776 0.807 0.936) #(0.776 0.807 0.968) #(0.776 0.839 0.936) #(0.776 0.87 1.0) #(0.807 0.839 0.936) #(0.807 0.839 0.968) #(0.807 0.839 1.0) #(0.807 0.87 0.936) #(0.807 0.936 1.0) #(0.839 0.87 0.936) #(0.839 0.87 1.0) #(0.839 1.0 1.0) #(0.87 0.87 0.936) #(0.87 0.87 1.0) #(0.87 0.905 0.968) #(0.87 0.905 1.0) #(0.87 0.936 1.0) #(0.905 0.87 0.936) #(0.905 0.905 0.968) #(0.905 0.936 0.968) #(0.905 0.936 1.0) #(0.905 0.968 1.0) #(0.936 0.905 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.936 0.968) #(0.968 0.936 1.0) #(0.968 0.968 1.0) #(1.0 0.968 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:22'!
quitIcon
	"answer a form to be used as icon"
	^ Icons
		at: #quit
		ifAbsentPut: [ (Form
	extent: 16@16
	depth: 32
	fromArray: #( 0 4292188820 4288088834 4289279270 4289146144 4289080608 4289145629 4288949020 4288948762 4288947994 4288947992 4288816152 4288948761 4288023298 4292254613 0 4292188820 4289146144 4292455817 4290799168 4290866760 4290933064 4290933580 4291065420 4290999885 4291197774 4291067216 4291067986 4291396951 4291861610 4288552465 4292254614 4288088834 4292390024 4289344273 4289808164 4289874983 4290072620 4290139181 4291725159 4291856746 4290338872 4290470717 4290668351 4290669122 4290801223 4291728742 4288089090 4289213477 4290933067 4289807906 4290007596 4290666557 4294365119 4294967295 4294967295 4294967295 4294967295 4294101944 4291065425 4290801736 4290868043 4291529308 4288619026 4289146144 4290866247 4289874983 4290666557 4294967295 4294967295 4294431426 4292385150 4292913293 4294962658 4294967295 4294965746 4291264087 4290934864 4291463773 4288551693 4289080608 4290933064 4290072620 4294365119 4294967295 4292846473 4290470459 4293970614 4293705899 4290735172 4293045653 4294967295 4293838771 4291001429 4291595103 4288551436 4289145629 4290933580 4290931784 4294967295 4294431426 4290470459 4290602558 4294962658 4294962915 4290801736 4290868043 4294963429 4294967295 4291067735 4291530081 4288420107 4288949020 4291065420 4291725159 4294967295 4292120687 4290602558 4290668865 4294962915 4294962916 4290868043 4290934350 4293574569 4294967295 4291991411 4291596902 4288419593 4288948762 4290999885 4291856746 4294967295 4292121202 4290668865 4290735172 4294962916 4294963172 4290934350 4291001172 4293640618 4294967295 4292387974 4291662954 4288419079 4288947994 4291197774 4291196498 4294967295 4294101944 4290735172 4290801736 4294963172 4294963429 4291001172 4291067478 4294964458 4294967295 4291727467 4291991149 4288222213 4288947992 4291067216 4290470717 4294962658 4294967295 4292319611 4290868043 4294564812 4293905077 4291067478 4293310881 4294967295 4294499019 4291859827 4291795057 4288221700 4288816152 4291067987 4290668351 4291461470 4294967295 4294967295 4294564812 4292848529 4292914578 4294762960 4294967295 4294967288 4292188283 4291860857 4291992955 4288221186 4288948762 4291199059 4290734915 4290801736 4291264087 4294564812 4294967295 4294967295 4294967295 4294967295 4294829270 4292188283 4291794291 4292256131 4291992699 4288221698 4288023298 4291861867 4290801223 4290868043 4290934864 4291001429 4291463266 4292782475 4292783505 4291727467 4291859827 4291860857 4292190081 4293051046 4290867531 4288023298 4292254613 4288552465 4291728742 4291529308 4291463773 4291595103 4291530081 4291596902 4291662954 4291991149 4291795057 4291992696 4292323464 4290866761 4288089088 4292320663 0 4292254614 4288089090 4288619026 4288551693 4288551436 4288420107 4288419593 4288419079 4288222213 4288221700 4288221186 4288155649 4288023298 4292320663 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37928776!
quitIcon
^ Icons
		at: #quitIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447692 791551247 190733918 1583223839 976115543 1465331246 419978846 1578179663 1414987776 22351 773327198 1578448975 1459637304 944504919 1329138270 287324247 4995156 1412970496 1462638087 322459392 1429753600 5191736 5710085 305420032 943083264 5191224 5710852 255022848 943083264 5191224 5710852 271144704 1429753664 5191736 5710082 236858967 4995156 1396193280 1462637830 1578054446 1459637304 944504919 775095390 1577784644 777453568 22318 1141637982 1583220758 892229463 1462644277 218193502 1583242761 169552694 909514500 56516190 1583242846 1577518340 67241566 1583242846)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:20'!
redoIcon
	"answer a form to be used as icon"
	^ Icons
		at: #redo
		ifAbsentPut: [ (Form
	extent: 13@14
	depth: 32
	fromArray: #( 0 0 0 0 0 0 4294901501 4293980399 4294440950 0 0 0 0 0 0 0 0 0 0 4294638329 4294901501 4278190081 0 4294704122 0 0 0 0 0 4294901501 0 0 0 4278190081 4294900699 4278190081 0 0 0 0 0 4294835708 4278190081 4278190081 4278190081 4278190081 4278190081 4294042540 4294242771 4278584838 0 0 0 4294835708 4278190081 4294900699 4294900699 4294900699 4294900699 4294900699 4294767013 4294042540 4294242771 4278190081 0 0 4278190081 4294900699 4294303041 4294303041 4294303041 4294303041 4294303041 4294700177 4294767013 4294042540 4294242771 4278190081 4278190081 4294303041 4294303041 4294359566 4294361123 4294495032 4294562638 4294630243 4294698363 4294700177 4294621989 4278190081 0 4278190081 4294303041 4294303041 4294361122 4293302279 4278190081 4278190081 4278190081 4294169956 4294621989 4278190081 0 0 4278190081 4294303041 4294303041 4294361122 4278190081 0 0 4278190081 4294621989 4278190081 0 0 0 4278190081 4294303041 4294361122 4278190081 0 0 0 0 4278190081 0 0 0 0 4278190081 4294303041 4294361122 4278190081 0 0 0 0 0 0 0 0 0 4294901501 4278190081 4294239232 4293302278 4278190081 0 4294572536 0 4294440950 0 0 0 0 0 0 4278190081 4294239232 4293302278 4278190081 0 0 0 0 0 0 0 0 4294704122 0 4278190081 4278190081 0 0 0 0 0 0 0 0)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37936909!
redoIcon
^ Icons
		at: #redoIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 336860180 336860180 336860180 336860180 336860180 336860180 336855316 336860180 336860180 336860180 335614721 336860180 336860180 16843009 16844809 18093076 336860161 320017171 319296008 151065620 336855302 100861446 101060882 134807828 335610886 50594829 235868177 201397268 335610886 67371521 16844044 18093076 335611398 67240212 335612929 336860180 335611398 67179540 336855316 336860180 335610886 67179540 336860180 336860180 336855300 67179540 336860180 336860180 336860161 117571860 335610132 18093076 336860180 17236481 17236481 33625108 336860180 335610132 335610132 18093076 336860180 336860180 336860180 336860180)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.905 0.611 0.0) #(0.968 0.741 0.031) #(0.968 0.776 0.129) #(0.968 0.839 0.388) #(0.968 0.87 0.258) #(0.968 0.905 0.0) #(0.968 0.905 0.678) #(0.968 0.968 0.839) #(0.968 0.968 0.936) #(0.968 0.968 0.968) #(1.0 0.741 0.129) #(1.0 0.807 0.223) #(1.0 0.839 0.289) #(1.0 0.87 0.388) #(1.0 0.905 0.482) #(1.0 0.936 0.58) #(1.0 0.968 0.646) #(1.0 1.0 0.87) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:04'!
saveAsIcon
	"answer a form to be used as icon"
	^ Icons
		at: #saveAs
		ifAbsentPut: [ (Form
	extent: 13@15
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 4294824449 4294892108 4294753916 4288321714 4288914365 4288256184 4288124339 4287400619 4286348190 4285558420 4284834957 4283782025 4289102620 4294890240 4294877440 4293618957 4289045953 4293982206 4294901502 4287405502 4282933137 4290890718 4294901502 4294901502 4294896582 4294889731 4294884097 4294873352 4289418278 4288124856 4292798712 4294244606 4283591063 4280894330 4290693341 4294901502 4294901502 4294628694 4294889730 4294881037 4294408979 4285880932 4287466925 4291878127 4293455607 4288589258 4287800774 4293849594 4294901502 4294897367 4294627352 4294887701 4294878492 4290734126 4282732672 4286743205 4291154408 4291548648 4292863732 4292666352 4292337390 4291746030 4293248618 4294891804 4294884902 4294809130 4285880666 4281418874 4285953947 4290628324 4288918482 4288129227 4287537348 4286682817 4286680229 4293182773 4294891828 4294884666 4290603826 4281943407 4281088104 4285164691 4289707482 4288852945 4289115603 4288523981 4287406029 4289699690 4294894401 4294889543 4294748996 4286470740 4281551229 4280364121 4284572041 4288589776 4291022559 4294901502 4294901502 4294439150 4294431321 4294894425 4294889049 4293170771 4290884548 4284509333 4279310662 4283848578 4287931848 4290495964 4293256438 4292401648 4291741397 4294364027 4294895237 4294887016 4289428072 4287665343 4283257981 4278849852 4283256442 4286879676 4289443280 4292993015 4291414762 4290622921 4293837976 4294895301 4290609766 4286675094 4286612141 4282468977 4278586675 4282598513 4285498024 4288127684 4292203500 4290625247 4289767619 4289099612 4289757552 4286477716 4285954467 4286150559 4281942378 4278388782 4281875047 4284445082 4287403449 4291151076 4289638357 4288913084 4287521117 4286281373 4285954470 4285361560 4285887391 4281811050 4278191656 4281085020 4283390597 4285757854 4290624722 4289177539 4288585144 4287795889 4287072429 4286480032 4285887896 4285953690 4280954712 4278190107 4279965506 4279374142 4279374137 4279966272 4279834431 4279703102 4279703100 4279637050 4279571257 4279439672 4279374136 4278847786 4278584607)
	offset: 0@0)]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37943151!
saveAsIcon
^ Icons
		at: #saveAsIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 2475922323 2475922323 2475922323 2357152915 2475922323 2475922323 2475922310 2356771219 2470594883 1027092007 538789766 2070891667 2471130880 974872320 9537151 2035061651 2470340984 504322816 9012861 1931907987 2469946993 1145008640 2458354812 1410831251 2469486691 1751672420 1821016186 621908883 2468895819 1094465075 1804304725 336499603 2468499787 1262762830 2374532651 302814099 2468365663 30325 2391108189 554210195 2468102234 1852268916 2407746878 419861395 2467837264 1835161456 2421567538 369398675 2467636287 1700352838 1378626093 335778707 2467503929 1582254135 757736232 268604307 2467109417 1481261885 875505704 218207123 2466907911 185140999 117901063 83989395)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.094) #(0.0 0.0 0.16) #(0.0 0.031 0.16) #(0.0 0.031 0.192) #(0.031 0.031 0.16) #(0.031 0.063 0.223) #(0.063 0.063 0.223) #(0.063 0.094 0.258) #(0.094 0.063 0.223) #(0.094 0.063 0.258) #(0.094 0.094 0.258) #(0.129 0.16 0.353) #(0.16 0.16 0.353) #(0.16 0.223 0.419) #(0.16 0.258 0.482) #(0.192 0.258 0.419) #(0.192 0.258 0.482) #(0.192 0.289 0.482) #(0.223 0.223 0.388) #(0.223 0.258 0.419) #(0.258 0.258 0.451) #(0.258 0.289 0.451) #(0.258 0.321 0.517) #(0.289 0.289 0.482) #(0.289 0.321 0.482) #(0.289 0.353 0.517) #(0.289 0.353 0.58) #(0.321 0.321 0.517) #(0.321 0.321 0.548) #(0.321 0.419 0.58) #(0.353 0.451 0.611) #(0.388 0.388 0.548) #(0.388 0.419 0.58) #(0.419 0.419 0.58) #(0.419 0.419 0.611) #(0.419 0.517 0.678) #(0.451 0.353 0.353) #(0.451 0.353 0.388) #(0.451 0.419 0.58) #(0.451 0.451 0.611) #(0.451 0.482 0.611) #(0.451 0.482 0.646) #(0.482 0.353 0.321) #(0.482 0.451 0.58) #(0.482 0.451 0.611) #(0.482 0.482 0.611) #(0.482 0.482 0.646) #(0.517 0.482 0.58) #(0.517 0.517 0.646) #(0.517 0.517 0.678) #(0.517 0.548 0.646) #(0.517 0.548 0.678) #(0.517 0.58 0.741) #(0.517 0.58 0.776) #(0.548 0.388 0.353) #(0.548 0.548 0.678) #(0.548 0.58 0.741) #(0.548 0.611 0.741) #(0.548 0.611 0.807) #(0.548 0.646 0.776) #(0.58 0.58 0.71) #(0.58 0.58 0.741) #(0.58 0.646 0.776) #(0.58 0.646 0.807) #(0.58 0.678 0.807) #(0.611 0.611 0.71) #(0.611 0.611 0.741) #(0.611 0.678 0.807) #(0.611 0.678 0.839) #(0.646 0.451 0.353) #(0.646 0.517 0.094) #(0.646 0.611 0.741) #(0.646 0.646 0.741) #(0.646 0.646 0.776) #(0.646 0.71 0.839) #(0.678 0.321 0.129) #(0.678 0.482 0.419) #(0.678 0.611 0.419) #(0.678 0.678 0.839) #(0.678 0.71 0.839) #(0.678 0.741 0.87) #(0.71 0.517 0.451) #(0.71 0.678 0.776) #(0.741 0.419 0.16) #(0.741 0.419 0.192) #(0.741 0.517 0.388) #(0.741 0.71 0.807) #(0.741 0.741 0.839) #(0.741 0.741 0.87) #(0.741 0.776 0.87) #(0.741 0.807 0.87) #(0.741 0.807 0.905) #(0.776 0.71 0.776) #(0.776 0.776 0.905) #(0.776 0.807 0.87) #(0.776 0.839 0.936) #(0.807 0.776 0.839) #(0.807 0.807 0.936) #(0.807 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.839 0.936) #(0.839 0.87 0.936) #(0.87 0.87 0.968) #(0.87 0.905 0.968) #(0.87 0.936 1.0) #(0.905 0.58 0.321) #(0.905 0.776 0.192) #(0.905 0.776 0.419) #(0.905 0.87 0.968) #(0.905 0.905 0.968) #(0.936 0.419 0.031) #(0.936 0.776 0.611) #(0.936 0.936 0.968) #(0.936 0.968 1.0) #(0.968 0.482 0.063) #(0.968 0.807 0.482) #(0.968 0.839 0.353) #(0.968 0.968 0.936) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.58 0.031) #(1.0 0.58 0.16) #(1.0 0.646 0.0) #(1.0 0.646 0.094) #(1.0 0.678 0.031) #(1.0 0.678 0.258) #(1.0 0.741 0.0) #(1.0 0.741 0.129) #(1.0 0.741 0.223) #(1.0 0.741 0.482) #(1.0 0.776 0.419) #(1.0 0.807 0.063) #(1.0 0.807 0.353) #(1.0 0.839 0.0) #(1.0 0.839 0.094) #(1.0 0.839 0.258) #(1.0 0.839 0.321) #(1.0 0.87 0.094) #(1.0 0.87 0.192) #(1.0 0.87 0.289) #(1.0 0.905 0.258) #(1.0 0.905 0.353) #(1.0 0.905 0.517) #(1.0 0.905 0.776) #(1.0 0.936 0.776) #(1.0 0.936 0.839) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:26'!
saveIcon
	"answer a form to be used as icon"
	^ Icons
		at: #save
		ifAbsentPut: [ Form
	extent: 14@14
	depth: 32
	fromArray: #( 4288321714 4288914365 4288256184 4288124339 4287400619 4286348190 4285558420 4284834956 4284242819 4283650427 4283058549 4282006120 4279900227 4285949022 4289045953 4293982206 4294901502 4287405502 4282933137 4290890718 4294901502 4294901502 4294901502 4294901502 4294901502 4291877611 4284969375 4279307827 4288124856 4292798712 4294244606 4283591063 4280894330 4290693341 4294901502 4294901502 4294901502 4294901502 4294901502 4290365148 4284247194 4279242553 4287466925 4291878127 4293455607 4288589258 4287800774 4293849594 4294901502 4294901502 4294901502 4294901502 4294901502 4289773011 4282338684 4279045428 4286743205 4291154408 4291548648 4292863732 4292666352 4292337390 4291943146 4291745766 4291548133 4291219939 4290364375 4285957286 4281483117 4278979378 4285953947 4290628324 4288918482 4288129227 4287537348 4286814141 4286222263 4285498543 4284577954 4283392656 4282208125 4281813111 4281219175 4278913327 4285164691 4289707482 4288852945 4289115603 4288523981 4287734212 4286747063 4285563560 4284641434 4283851919 4283391111 4281944439 4280364121 4278781997 4284572041 4288589776 4291022559 4294901502 4294901502 4294638334 4293717242 4292993521 4292204008 4291348703 4291348702 4284706196 4279442762 4278715946 4283848578 4287931848 4290495964 4293256438 4292401391 4291743466 4291085281 4290361817 4289638096 4288848584 4289111497 4283982220 4279047488 4278650409 4283256442 4286879676 4289443280 4292993015 4291414502 4290690781 4290032853 4289309133 4288651204 4287927484 4288124605 4283258496 4278652728 4278584615 4282598513 4285498024 4288127684 4292203500 4290624988 4289967059 4289243339 4288585411 4287927483 4287269553 4287466675 4282535029 4278389038 4278584613 4281875047 4284445082 4287403449 4291151076 4289638098 4288914378 4288256449 4287664313 4287006384 4286348455 4286479785 4281942893 4278191655 4278584612 4281085020 4283390597 4285757854 4290624722 4289177539 4288519609 4287795889 4287072169 4286611617 4285953689 4285953434 4280954456 4278190107 4278453023 4279965506 4279374142 4279374137 4279966272 4279834687 4279703101 4279703099 4279571258 4279505465 4279374136 4279374136 4278847786 4278584607 4279242025)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37950929!
saveIcon
^ Icons
		at: #saveIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 1984713037 1195522356 757671199 420574838 1985115253 1159946869 1970632053 1798245238 1984458357 672489333 1970632053 1579879542 1984064369 1330213749 1970632053 1511786614 1983734889 1835887467 1751671645 924190838 1983209556 1262895420 842015772 387188598 1983209556 1262895420 842015772 387188598 1982945364 1414482240 942614306 454166390 1982945364 1414482240 942614306 454166390 1982681186 1970632050 1886020965 772671094 1982220894 1886152545 1549161299 705233782 1981825367 1868979289 1431193672 553976438 1981624905 1784437077 1313358659 503579254 1981295684 1633047374 1212103227 436339318 1980965430 1532120391 1044198709 318833014 1980697869 286264589 218959117 117508726)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.094) #(0.0 0.0 0.129) #(0.0 0.0 0.16) #(0.0 0.031 0.16) #(0.0 0.031 0.223) #(0.031 0.0 0.16) #(0.031 0.031 0.16) #(0.031 0.031 0.192) #(0.031 0.063 0.258) #(0.063 0.031 0.16) #(0.063 0.031 0.192) #(0.063 0.031 0.223) #(0.063 0.063 0.223) #(0.063 0.094 0.289) #(0.094 0.063 0.258) #(0.094 0.094 0.223) #(0.094 0.094 0.258) #(0.129 0.16 0.353) #(0.16 0.16 0.353) #(0.16 0.223 0.388) #(0.16 0.258 0.482) #(0.192 0.223 0.419) #(0.192 0.289 0.451) #(0.223 0.223 0.388) #(0.223 0.223 0.419) #(0.223 0.258 0.419) #(0.223 0.289 0.451) #(0.223 0.289 0.482) #(0.258 0.258 0.451) #(0.258 0.289 0.451) #(0.289 0.289 0.451) #(0.289 0.289 0.482) #(0.289 0.321 0.517) #(0.289 0.353 0.517) #(0.289 0.353 0.58) #(0.289 0.388 0.58) #(0.321 0.321 0.482) #(0.321 0.321 0.517) #(0.321 0.388 0.548) #(0.321 0.419 0.58) #(0.353 0.353 0.517) #(0.353 0.388 0.548) #(0.353 0.419 0.611) #(0.353 0.451 0.611) #(0.388 0.388 0.548) #(0.388 0.419 0.58) #(0.388 0.451 0.611) #(0.388 0.482 0.646) #(0.419 0.419 0.58) #(0.419 0.517 0.678) #(0.451 0.388 0.353) #(0.451 0.419 0.58) #(0.451 0.451 0.611) #(0.451 0.482 0.611) #(0.451 0.517 0.646) #(0.451 0.517 0.678) #(0.482 0.482 0.611) #(0.482 0.482 0.646) #(0.482 0.482 0.678) #(0.482 0.548 0.71) #(0.517 0.517 0.646) #(0.517 0.517 0.678) #(0.517 0.517 0.71) #(0.517 0.58 0.71) #(0.517 0.58 0.741) #(0.548 0.548 0.678) #(0.548 0.548 0.71) #(0.548 0.58 0.741) #(0.548 0.611 0.741) #(0.548 0.646 0.776) #(0.58 0.58 0.71) #(0.58 0.58 0.741) #(0.58 0.646 0.776) #(0.58 0.646 0.807) #(0.58 0.678 0.807) #(0.611 0.611 0.71) #(0.611 0.611 0.741) #(0.611 0.611 0.776) #(0.611 0.678 0.807) #(0.611 0.678 0.839) #(0.646 0.646 0.741) #(0.646 0.646 0.776) #(0.646 0.646 0.807) #(0.646 0.71 0.839) #(0.678 0.678 0.807) #(0.678 0.678 0.839) #(0.678 0.71 0.839) #(0.678 0.741 0.87) #(0.71 0.71 0.839) #(0.71 0.741 0.839) #(0.741 0.741 0.839) #(0.741 0.741 0.87) #(0.741 0.776 0.839) #(0.741 0.776 0.87) #(0.741 0.807 0.87) #(0.741 0.807 0.905) #(0.776 0.776 0.905) #(0.776 0.807 0.87) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.807 0.807 0.87) #(0.807 0.807 0.905) #(0.807 0.807 0.936) #(0.807 0.839 0.905) #(0.807 0.839 0.936) #(0.839 0.839 0.936) #(0.839 0.87 0.936) #(0.87 0.87 0.936) #(0.87 0.905 0.968) #(0.87 0.936 1.0) #(0.905 0.87 0.968) #(0.905 0.905 0.968) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/22/2003 17:03'!
undoIcon
	"answer a form to be used as icon"
	^ Icons
		at: #undo
		ifAbsentPut: [Form
		extent: 13 @ 14
		depth: 32
		fromArray: #(0 0 0 0 4294440950 4293980399 4294901501 0 0 0 0 0 0 0 0 4294704122 0 4278190081 4294901501 4294638329 0 0 0 0 0 0 0 0 0 4278190081 4294900699 4278190081 0 0 0 4294901501 0 0 0 0 0 4278584838 4294242771 4294042540 4278190081 4278190081 4278190081 4278190081 4278190081 4294835708 0 0 0 4278190081 4294242771 4294042540 4294767013 4294900699 4294900699 4294900699 4294900699 4294900699 4278190081 4294835708 0 4278190081 4294242771 4294042540 4294767013 4294700177 4294303041 4294303041 4294303041 4294303041 4294303041 4294900699 4278190081 0 0 4278190081 4294621989 4294700177 4294698363 4294630243 4294562638 4294495032 4294361123 4294359566 4294303041 4294303041 4278190081 0 0 4278190081 4294621989 4294169956 4278190081 4278190081 4278190081 4293302279 4294361122 4294303041 4294303041 4278190081 0 0 0 4278190081 4294621989 4278190081 0 0 4278190081 4294361122 4294303041 4294303041 4278190081 0 0 0 0 4278190081 0 0 0 0 4278190081 4294361122 4294303041 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4294361122 4294303041 4278190081 0 0 0 0 4294440950 0 4294572536 0 4278190081 4293302278 4294239232 4278190081 4294901501 0 0 0 0 0 0 0 4278190081 4293302278 4294239232 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 4294704122 0 )
		offset: 0 @ 0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37958686!
undoIcon
^ Icons
		at: #undoIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 370546198 370546198 370546198 370546198 370546198 369169942 370546198 370546198 370546198 18022678 370546198 370546198 370546177 151519489 16843009 370546198 370540809 135399443 320017171 18224662 369166600 303105542 101057286 100734486 370540812 286265102 218366979 100925718 370546177 201654529 16909316 100925718 370546198 17563926 369164804 101056790 370546198 369169942 370540804 101056790 370546198 370546198 370540804 100925718 370546198 370546198 370540804 67180054 370546177 369164566 369164807 18224662 370540802 16910081 16910081 370546198 370546177 369164566 369164566 370546198 370546198 370546198 370546198 370546198)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.905 0.611 0.0) #(0.968 0.741 0.031) #(0.968 0.776 0.129) #(0.968 0.839 0.388) #(0.968 0.87 0.258) #(0.968 0.905 0.0) #(0.968 0.905 0.678) #(0.968 0.968 0.839) #(0.968 0.968 0.936) #(0.968 0.968 0.968) #(1.0 0.741 0.129) #(1.0 0.807 0.223) #(1.0 0.839 0.289) #(1.0 0.87 0.388) #(1.0 0.905 0.482) #(1.0 0.936 0.58) #(1.0 0.968 0.646) #(1.0 1.0 0.87) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 3/30/2003 19:10'!
windowIcon
	"answer a form to be used as icon"
	^ Icons
		at: #window
		ifAbsentPut: [ Form
	extent: 16@16
	depth: 32
	fromArray: #( 3123546081 4215314408 4215050727 4214654691 4214259168 4213863644 4213467864 4213072341 4212676817 4212347086 4211951307 4211621318 4211357380 4211224512 4211157944 3120571033 4165246188 4285842174 4284789502 4283999486 4283275774 4282420222 4281695742 4280905726 4280115966 4279457278 4278864126 4278336254 4278202366 4278202110 4278201598 4160758195 4082541805 4288270078 4287349502 4286822910 4286296574 4285769982 4285178110 4284651518 4284059134 4283532542 4282940414 4282347774 4281952766 4281821438 4281952509 4078123447 4085037036 4294573310 4294507518 4294507518 4294441470 4294441470 4294375934 4294375678 4294375678 4294310142 4294178558 4293981180 4293784057 4293651960 4294111992 4082199993 4085233644 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294835709 4294572539 4294440952 4294309367 4294768887 4082462648 4085233129 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294769917 4294506747 4294375161 4294177783 4294046198 4294440438 4082265271 4085035753 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294835710 4294769917 4294572539 4294375161 4294177783 4294046197 4293848819 4294308595 4082133941 4085035496 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294835709 4294572540 4294375161 4294177783 4294046198 4293848819 4293651442 4294045425 4082002355 4084969703 4294901502 4294901502 4294901502 4294901502 4294901502 4294835710 4294506748 4294440955 4294309368 4294046198 4293783029 4293651442 4293519857 4293782512 4081936562 4084838118 4294901502 4294901502 4294901502 4294901502 4294835710 4294572540 4294375161 4294309368 4294046198 4293848819 4293651442 4293454064 4293322478 4293650669 4081870769 4084837604 4294901502 4294901502 4294901502 4294835709 4294572540 4294440955 4294177784 4294046199 4293848819 4293651442 4293454065 4293322478 4293125101 4293453036 4081804977 4084837347 4294901502 4294901502 4294835710 4294704124 4294506747 4294309369 4294046199 4293980405 4293717234 4293519857 4293322480 4293125101 4292993516 4293321707 4081804720 4084771555 4294901502 4294901502 4294704125 4294506747 4294375161 4294111992 4293980406 4293783027 4293519857 4293388272 4293125102 4292993516 4292796139 4293124585 4081739184 4084968162 4294901502 4294901501 4294901500 4294900985 4294899959 4294702839 4294439667 4294308338 4294110704 4293848046 4293715949 4293518569 4293387241 4293781480 4082067633 4013324495 4217344467 4216883150 4216619466 4216355524 4216092095 4215828156 4215630263 4215366578 4215102894 4214905258 4214905002 4214839466 4214839466 4215036587 4011079835 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
	offset: 0@0]! !

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31' prior: 37964940!
windowIcon
^ Icons
		at: #windowIcon ifAbsentPut: [((ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 354557466 403968528 252512520 100926209 592334387 857807123 286195711 100663042 793660989 1010251316 825098497 469827852 993869117 1010251316 825110062 471604267 989855744 0 0 1246317867 989855744 0 74 1229539626 989855744 0 0 42 989855744 0 19017 1229277482 989855744 0 4868425 1162168357 973078528 0 1246382405 1162167589 956301312 74 1246315845 1161905188 956301312 19018 1229276485 1094796068 956301312 19017 1229276482 1094795556 956301312 4868681 1162166849 1094730020 956301312 5065801 1229472835 1128350501 389165101 740763168 521870107 454761227)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.129 0.611) #(0.0 0.129 0.71) #(0.0 0.16 0.741) #(0.0 0.16 0.776) #(0.0 0.16 1.0) #(0.0 0.192 0.776) #(0.0 0.223 1.0) #(0.031 0.223 0.776) #(0.031 0.258 0.807) #(0.031 0.289 1.0) #(0.063 0.223 0.611) #(0.063 0.223 0.71) #(0.063 0.321 0.807) #(0.063 0.321 1.0) #(0.094 0.353 0.839) #(0.094 0.388 0.839) #(0.094 0.388 1.0) #(0.129 0.419 0.87) #(0.16 0.419 1.0) #(0.16 0.451 0.87) #(0.16 0.517 0.905) #(0.192 0.419 1.0) #(0.192 0.482 0.807) #(0.192 0.482 0.905) #(0.192 0.482 1.0) #(0.192 0.517 0.905) #(0.223 0.353 0.678) #(0.223 0.419 1.0) #(0.223 0.451 1.0) #(0.223 0.58 0.905) #(0.258 0.388 0.71) #(0.258 0.419 0.71) #(0.258 0.548 1.0) #(0.258 0.58 0.936) #(0.258 0.611 0.936) #(0.289 0.388 0.71) #(0.289 0.419 0.71) #(0.289 0.419 0.741) #(0.289 0.451 0.741) #(0.289 0.482 1.0) #(0.289 0.611 1.0) #(0.321 0.419 0.71) #(0.321 0.419 0.741) #(0.321 0.482 0.776) #(0.321 0.517 0.807) #(0.321 0.517 1.0) #(0.321 0.646 0.936) #(0.353 0.517 0.807) #(0.353 0.548 1.0) #(0.353 0.58 0.839) #(0.353 0.646 1.0) #(0.388 0.58 1.0) #(0.388 0.71 1.0) #(0.419 0.646 1.0) #(0.451 0.678 1.0) #(0.451 0.776 1.0) #(0.482 0.678 0.905) #(0.482 0.71 0.905) #(0.482 0.71 0.936) #(0.482 0.71 1.0) #(0.517 0.741 1.0) #(0.548 0.776 1.0) #(0.611 0.807 1.0) #(0.87 0.87 0.936) #(0.905 0.905 0.936) #(0.905 0.905 0.968) #(0.936 0.905 0.936) #(0.936 0.936 0.936) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.936 0.968) #(0.968 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.968 0.968) #(1.0 1.0 0.968) #(0.761 0.235 0.106) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0)  ))]! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'dgd 3/22/2003 17:01'!
initialize
"
self initialize
"
	Icons := IdentityDictionary new! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'sd 11/10/2003 13:00' prior: 37972958!
initialize
	"self initialize"

	Icons := IdentityDictionary new! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'nk 5/1/2004 16:41' prior: 37973124!
initialize
	"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.

	Smalltalk addToStartUpList: self.! !

!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: 'nk 5/1/2004 16:41'!
startUp
	self initializeTranslations.! !

!MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 3/22/2003 16:48'!
decorateMenu: aMenu 
	"decorate aMenu with icons"
	Preferences menuWithIcons
		ifFalse: [^ self].
	""
	self itemsIcons
		do: [:each | 
			| wordings icon | 
			wordings := each key.
			icon := each value.
			""
			wordings
				do: [:eachWording | ""
					self
						putIcon: icon
						onItemWithWording: eachWording
						in: aMenu]]! !

!MenuIcons class methodsFor: 'menu decoration' stamp: 'nk 3/10/2004 16:00' prior: 37974123!
decorateMenu: aMenu 
	"decorate aMenu with icons"
	| numberAdded |
	Preferences menuWithIcons
		ifFalse: [^ self].
	numberAdded := 0.
	self itemsIcons
		do: [:each | 
			| wordings icon | 
			wordings := each key.
			icon := each value.
			""
			wordings
				do: [:eachWording | (self
							putIcon: icon
							onItemWithWording: eachWording
							in: aMenu)
						ifTrue: [numberAdded := numberAdded + 1]]].
	numberAdded isZero ifTrue: [^ self].
	aMenu addBlankIconsIfNecessary: self blankIcon! !

!MenuIcons class methodsFor: 'menu decoration' stamp: 'nk 5/1/2004 16:50' prior: 37974554!
decorateMenu: aMenu 
	"decorate aMenu with icons"
	| numberAdded |
	Preferences menuWithIcons
		ifFalse: [^ self].
	numberAdded := 0.
	aMenu items do: [ :item | | icon |
		icon _ self iconForMenuItem: item.
		icon ifNotNil: [
			item icon: icon.
			numberAdded := numberAdded + 1. ]].

	numberAdded isZero ifTrue: [^ self].
	aMenu addBlankIconsIfNecessary: self blankIcon! !

!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 3/30/2003 19:17'!
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 backIcon.
	icons add: #('jump to project...' ) -> self forwardIcon.
	icons add: #('open...' ) -> self openIcon.
	icons add: #('appearance...' ) -> self appearanceIcon.
	icons add: #('help...' ) -> self helpIcon.
	icons add: #('windows...' ) -> self windowIcon.
	icons add: #('print PS to file...' ) -> self printIcon.
	icons add: #('save' 'save project on file...' ) -> self saveIcon.
	icons add: #('save as...' 'save as new version' ) -> self saveAsIcon.
	icons add: #('quit' 'save and quit' ) -> self quitIcon.
	""
	icons add: #('do it (d)' ) -> self doItIcon.
	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 inspectIcon.
	icons add: #('print it (p)' ) -> self printIcon.
	""
	icons add: #('copy (c)' ) -> self copyIcon.
	icons add: #('paste (v)' 'paste...' ) -> self pasteIcon.
	icons add: #('cut (x)' ) -> self cutIcon.
	""
	icons add: #('accept (s)' ) -> self okIcon.
	icons add: #('cancel (l)' ) -> self cancelIcon.
	""
	icons add: #('do again (j)' ) -> self redoIcon.
	icons add: #('undo (z)' ) -> self undoIcon.
	""
	icons add: #('find...(f)' 'find again (g)' 'find class... (f)' 'find method...' ) -> self findIcon.
	""
	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 deleteIcon.
	icons add: #('add item...' 'new category...' ) -> self newIcon.
	""
	icons add: #('new morph...' 'objects (o)' ) -> self morphsIcon.
	""
	^ icons! !

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

!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: 'dgd 2/22/2003 14:51' prior: 24341015!
contentString: aString 
	aString isNil 
		ifTrue: [self removeProperty: #contentString]
		ifFalse: [self setProperty: #contentString toValue: aString]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'sw 9/4/2002 22:31'!
contents: aString withMarkers: aBool inverse: inverse
	"Set the menu item entry. If aBool is true, parse aString for embedded markers."

	| markerIndex marker indent |
	self contentString: nil. "get rid of old"
	aBool ifFalse:[^super contents: aString].
	self removeAllMorphs. "get rid of old markers if updating"
	(aString size > 0 and: [(aString at: 1) = $<]) ifFalse:[^ super contents: aString].
	markerIndex _ aString indexOf: $>.
	markerIndex = 0 ifTrue:[^super contents: aString].
	marker _ (aString copyFrom: 1 to: markerIndex) asLowercase.
	(#('<on>' '<off>' '<yes>' '<no>') includes: marker) ifFalse:[^super contents: aString].
	self contentString: aString. "remember actual string"
	(marker = '<on>' or:[marker = '<yes>']) ~= inverse
		ifTrue:[marker _ self onImage]
		ifFalse:[marker _ self offImage].
	"Indent the string using white spaces"
	indent _ ' '.
	font _ self fontToUse.
	[ (font widthOfString: indent) < (marker width + 4) ] 
		whileTrue:[indent _ indent copyWith: Character space].
	"Set the string"
	super contents: indent, (aString copyFrom: markerIndex+1 to: aString size).
	"And set the marker"
	marker _ ImageMorph new image: marker.
	marker position: (self left) @ (self top + 2).
	self addMorphFront: marker.! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:51' prior: 37981678!
contents: aString withMarkers: aBool inverse: inverse 
	"Set the menu item entry. If aBool is true, parse aString for embedded markers."

	| markerIndex marker indent |
	self contentString: nil.	"get rid of old"
	aBool ifFalse: [^super contents: aString].
	self removeAllMorphs.	"get rid of old markers if updating"
	(aString 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].
	"Indent the string using white spaces"
	indent := ' '.
	font := self fontToUse.
	[(font widthOfString: indent) < (marker width + 4)] 
		whileTrue: [indent := indent copyWith: Character space].
	"Set the string"
	super 
		contents: indent , (aString copyFrom: markerIndex + 1 to: aString size).
	"And set the marker"
	marker := ImageMorph new image: marker.
	marker position: self left @ (self top + 2).
	self addMorphFront: marker! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:55' prior: 37983006!
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: 'dgd 3/22/2003 14:45'!
hasIcon
	"answer whatever the receiver has an icon"
	^ icon notNil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19' prior: 37985489!
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: 'dgd 3/22/2003 14:45'!
icon
	"answer the receiver's icon"
	^ icon! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'!
icon: aForm 
	"change the the receiver's icon"
	icon := aForm! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45' prior: 37986248!
icon: aForm 
	"change the the receiver's icon"
	icon := aForm! !

!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: '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' prior: 24352104!
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: 'di 12/4/2001 23:16'!
drawOn: aCanvas
	| selectionColor |
	isSelected & isEnabled
		ifTrue:
			[selectionColor _ Display depth <= 2
				ifTrue: [Color gray]
				ifFalse: [owner color darker darker].
			aCanvas fillRectangle: self bounds color: selectionColor].
	super drawOn: aCanvas.
	subMenu ifNotNil:
		[aCanvas
			paintImage: SubMenuMarker
			at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! !

!MenuItemMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 15:59' prior: 37987932!
drawOn: aCanvas 
	| stringColor stringBounds |
	isSelected & isEnabled
		ifTrue: [
			aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
			stringColor := color negated]
		ifFalse: [stringColor := color].
	self hasIcon
		ifTrue: [| iconForm | 
			iconForm := isEnabled ifTrue:[self icon] ifFalse:[self icon asGrayScale].
			aCanvas paintImage: iconForm at: self left @ (self top + (self height - iconForm height // 2)).
			stringBounds := bounds left: bounds left + iconForm width + 2]
		ifFalse: [stringBounds := bounds].
	aCanvas
		drawString: contents
		in: stringBounds
		font: self fontToUse
		color: stringColor.
	subMenu
		ifNotNil: [aCanvas paintImage: SubMenuMarker at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! !

!MenuItemMorph methodsFor: 'drawing' stamp: 'nk 3/10/2004 15:46' prior: 37988418!
drawOn: aCanvas 
	| stringColor stringBounds leftEdge |
	isSelected & isEnabled
		ifTrue: [
			aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
			stringColor := color negated]
		ifFalse: [stringColor := color].

	leftEdge := 0.
	self hasIcon
		ifTrue: [| iconForm | 
			iconForm := isEnabled ifTrue:[self icon] ifFalse:[self icon asGrayScale].
			aCanvas paintImage: iconForm at: self left @ (self top + (self height - iconForm height // 2)).
			leftEdge := iconForm width + 2].

	self hasMarker
		ifTrue: [ leftEdge := leftEdge + self submorphBounds width + 8 ].

	stringBounds := bounds left: bounds left + leftEdge.

	aCanvas
		drawString: contents
		in: stringBounds
		font: self fontToUse
		color: stringColor.
	subMenu
		ifNotNil: [aCanvas paintImage: SubMenuMarker at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! !

!MenuItemMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 15:59'!
selectionFillStyle
	"answer the fill style to use with the receiver is the selected  
	element"
	| fill baseColor |
	Display depth <= 2
		ifTrue: [^ Color gray].
	baseColor := owner color negated.
	Preferences gradientMenu
		ifFalse: [^ baseColor].
	fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}.
	fill origin: self topLeft.
	fill direction: self width @ 0.
	^ fill! !

!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: 'sw 10/3/2002 02:16'!
mouseEnter: evt
	"The mouse entered the receiver"

	owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: 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: 'sw 12/4/2001 19:11'!
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 == nil
		ifTrue:	[owner selectItem: nil event: evt]
		ifFalse:	[self addAlarm: #deselectTimeOut: with: evt after: 500].! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 14:52' prior: 37991306!
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: 'grabbing' stamp: 'spfa 3/13/2004 18:34' prior: 24353456!
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' prior: 24353923!
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: 'dgd 2/14/2003 20:43' prior: 24339301!
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 3/21/2003 23:53'!
minHeight
	| iconHeight |
	iconHeight := self hasIcon
				ifTrue: [self icon height]
				ifFalse: [0].
	^ self fontToUse height max: iconHeight! !

!MenuItemMorph methodsFor: 'layout' stamp: 'tlk 5/16/2004 19:47' prior: 37993966!
minHeight
	| iconHeight |
	iconHeight := self hasIcon
				ifTrue: [self icon height + 2]
				ifFalse: [0].
	^ self fontToUse height max: iconHeight! !

!MenuItemMorph methodsFor: 'layout' stamp: 'ar 12/30/2001 20:44'!
minWidth

	| f |
	f _ self fontToUse.
	^ (f widthOfString: contents) + (subMenu == nil ifTrue: [0] ifFalse: [10])! !

!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:52' prior: 37994414!
minWidth
	"answer the receiver's minWidth"

	| f |
	f := self fontToUse.
	^(f widthOfString: contents) + (subMenu isNil ifTrue: [0] ifFalse: [10])! !

!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 3/22/2003 13:13' prior: 37994614!
minWidth
	| fontToUse iconWidth subMenuWidth |
	fontToUse := self fontToUse.
	subMenuWidth := self hasSubMenu
				ifFalse: [0]
				ifTrue: [10].
	iconWidth := self hasIcon
				ifTrue: [self icon width + 2]
				ifFalse: [0].
	^ (fontToUse widthOfString: contents)
		+ subMenuWidth + iconWidth! !

!MenuItemMorph methodsFor: 'layout' stamp: 'nk 4/14/2004 14:57' prior: 37994847!
minWidth
	| fontToUse iconWidth subMenuWidth markerWidth |
	fontToUse := self fontToUse.
	subMenuWidth := self hasSubMenu
				ifFalse: [0]
				ifTrue: [10].
	iconWidth := self hasIcon
				ifTrue: [self icon width + 2]
				ifFalse: [0].
	markerWidth := self hasMarker
		ifTrue: [ self submorphBounds width + 8 ]
		ifFalse: [ 0 ].
	^ (fontToUse widthOfString: contents)
		+ subMenuWidth + iconWidth + markerWidth.! !

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

!MenuLineMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 16:00' prior: 24355525!
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: 'layout' stamp: 'dgd 2/16/2003 21:52' prior: 24356019!
minHeight
"answer the receiver's minHeight"
	^ 2! !

!MenuLineMorph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54' prior: 24356105!
minWidth
"answer the receiver's minWidth"
	^ 10! !

!MenuMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:20'!
addBlankIconsIfNecessary: anIcon
	"If any of my items have an icon, ensure that all do by using anIcon for those that don't"

	| withIcons withoutIcons |
	withIcons _ Set new.
	withoutIcons _ Set new.
	self items do: [ :item |
		item hasIconOrMarker
			ifTrue: [ withIcons add: item ]
			ifFalse: [ withoutIcons add: item ].
		item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary: anIcon ]].
	(withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ].
	withoutIcons do: [ :item | item icon: anIcon ].! !

!MenuMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:34'!
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...'].
	^ self allWordingsNotInSubMenus: verboten! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 8/30/2003 20:44' prior: 37998588!
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: '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: '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: 'hg 8/3/2000 15:29'!
items

	^ submorphs select: [:m | m isKindOf: MenuItemMorph]
! !

!MenuMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 16:20' prior: 24358489!
lastItem
	^ submorphs reverse detect: [ :m | m isKindOf: MenuItemMorph ]! !

!MenuMorph methodsFor: 'accessing' stamp: 'nk 6/8/2004 16:52' prior: 38000654!
lastItem
	^ submorphs reverse
		detect: [ :m | m isKindOf: MenuItemMorph ]
		ifNone: [ submorphs last ]! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:18' prior: 24358584!
lastSelection
	"Return the label of the last selected item or nil."

	selectedItem isNil ifTrue: [^selectedItem selector] ifFalse: [^nil]! !

!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: 'nk 3/31/2002 15:13'!
stayUp: aBoolean

	stayUp _ aBoolean.
	aBoolean ifTrue: [ self removeStayUpBox ].! !

!MenuMorph methodsFor: 'construction' stamp: 'hg 8/3/2000 15:22'!
add: aString subMenu: aMenuMorph
	"Append the given submenu with the given label."

	| item |
	item _ MenuItemMorph new.
	item contents: aString;
		subMenu: aMenuMorph.
	self addMorphBack: item.
! !

!MenuMorph methodsFor: 'construction' stamp: '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: '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: '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: 'hg 8/3/2000 15:38'!
addService: aService for: serviceUser
	"Append a menu item with the given service. If the item is selected, it will perform the given service."

	self add: aService label target: aService selector: aService requestSelector argument: serviceUser
! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:19' prior: 38003325!
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 11/26/2002 13:51'!
addServices2: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		self 
			add: service label 
			target: service 
			selector: service requestSelector 
			argument: (service getArgumentsFrom: served).
		submorphs last setBalloonText: service description.
		(linesArray includes: i) | service useLineAfter ifTrue: [self addLine]
	].
! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:11' prior: 38003926!
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: 'nk 4/6/2002 23:00'!
addStayUpIcons
	| title closeBox pinBox |
	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'].
	self addMorphFront: (AlignmentMorph newRow vResizing: #shrinkWrap;
			 layoutInset: 0;
			 color: Preferences menuTitleColor;
			 addMorphBack: closeBox;
			 addMorphBack: title;
			 addMorphBack: pinBox).
	self setProperty: #hasTitlebarWidgets toValue: true.
	self removeProperty: #needsTitlebarWidgets.
	self removeStayUpItems! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 3/22/2003 19:27' prior: 38005042!
addStayUpIcons
	| title closeBox pinBox |
	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'].
	self addMorphFront: (AlignmentMorph newRow vResizing: #shrinkWrap;
			 layoutInset: 0;
			 color: Color transparent"Preferences menuTitleColor";
			 addMorphBack: closeBox;
			 addMorphBack: title;
			 addMorphBack: pinBox).
	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 5/1/2002 00:29'!
addTitle: aString updatingSelector: aSelector updateTarget: aTarget 
	"Add a title line at the top of this menu Make aString its initial contents. 
	If aSelector is not nil, then periodically obtain fresh values for its 
	contents by sending aSelector to aTarget.."

	| title |
	title _ AlignmentMorph new.
	self setTitleParametersFor: title.
	title vResizing: #shrinkWrap.
	title listDirection: #topToBottom.
	title wrapCentering: #center;
		 cellPositioning: #topCenter;
		 borderWidth: 0;
		 layoutInset: 0.
	aSelector
		ifNil: [(aString asString findTokens: String cr)
				do: [:line | title addMorphBack: (StringMorph new contents: line;
							 font: Preferences standardMenuFont)]]
		ifNotNil: [title addMorphBack:
			(UpdatingStringMorph new
				lock;
				font: Preferences standardMenuFont;
				useStringFormat;
				target: aTarget;
				getSelector: aSelector)].

	title setProperty: #titleString toValue: aString.
	self addMorphFront: title.

	(self hasProperty: #needsTitlebarWidgets) ifTrue: [self addStayUpIcons]! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 3/22/2003 19:25' prior: 38007945!
addTitle: aString updatingSelector: aSelector updateTarget: aTarget 
	"Add a title line at the top of this menu Make aString its initial 
	contents.  
	If aSelector is not nil, then periodically obtain fresh values for its 
	contents by sending aSelector to aTarget.."
	| title |
	title := AlignmentMorph new.
	self setTitleParametersFor: title.
	title vResizing: #shrinkWrap.
	title listDirection: #topToBottom.
	title wrapCentering: #center;
		 cellPositioning: #topCenter;

		 layoutInset: 0.
	aSelector
		ifNil: [(aString asString findTokens: String cr)
				do: [:line | title addMorphBack: (StringMorph new contents: line;
							 font: Preferences standardMenuFont)]]
		ifNotNil: [title addMorphBack: (UpdatingStringMorph new lock; font: Preferences standardMenuFont; useStringFormat; target: aTarget; getSelector: aSelector)].
	title setProperty: #titleString toValue: aString.
	self addMorphFront: title.
	(self hasProperty: #needsTitlebarWidgets)
		ifTrue: [self addStayUpIcons]! !

!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: 'aoy 2/17/2003 01:20' prior: 24368701!
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 isMemberOf: String) 
				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: 'yo 7/16/2003 15:15' prior: 38010755!
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: '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: 'dgd 3/21/2003 22:36' prior: 24370286!
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: 'sw 8/4/2002 17:55'!
popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean
	"Present this menu at the given point under control of the given hand."

	| evt |
	self items isEmpty ifTrue: [^ 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 changed! !

!MenuMorph methodsFor: 'control' stamp: 'sd 11/8/2003 16:00' prior: 38014047!
popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean 
	"Present this menu at the given point under control of the given  
	hand."
	| evt |
	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: '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: 'dgd 3/22/2003 19:56'!
updateColor
	| fill title |
	Preferences gradientMenu
		ifFalse: [^ self].
	""
	fill := GradientFillStyle ramp: {0.0 -> self color lighter. 1 -> self color darker}.
	""
	fill origin: self topLeft.
	fill direction: self width @ 0.
	""
	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.
	fill 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: 'drawing' stamp: 'sw 12/18/2001 23:45'!
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: 1 borderColor: Preferences keyboardFocusColor]! !

!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: 'initialization' stamp: 'dew 2/11/2001 01:34'!
setDefaultParameters

	| worldColor |
	((Preferences menuColorFromWorld and: [Display depth > 4]) and: [(worldColor _ self currentWorld color) isColor])
		ifTrue: [self setColor: (worldColor luminance > 0.7
						ifTrue: [worldColor mixed: 0.85 with: Color black]
						ifFalse: [worldColor mixed: 0.4 with: Color white])
						"Think about whether alpha should be included."
					borderWidth: Preferences menuBorderWidth
					borderColor: #raised]
		ifFalse: [self setColor: Preferences menuColor
					borderWidth: Preferences menuBorderWidth
					borderColor: Preferences menuBorderColor].
	self layoutInset: 3.! !

!MenuMorph methodsFor: 'initialization' stamp: 'dgd 3/22/2003 18:46' prior: 38019331!
setDefaultParameters
	| 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.
	""
	self layoutInset: 3! !

!MenuMorph methodsFor: 'initialization' stamp: 'dgd 3/22/2003 19:58' prior: 24375243!
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! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'hg 12/8/2001 15:03'!
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: '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: 'di 12/10/2001 22:14'!
keyStroke: evt
	| matchString char asc selectable |
	(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 ~~ nil 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! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'dgd 2/22/2003 18:55' prior: 38022877!
keyStroke: evt 
	| matchString char asc selectable |
	(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! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'laza 5/6/2004 13:59' prior: 38025247!
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: '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: 'menu' stamp: 'dgd 8/30/2003 21:52' prior: 24375483!
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: 'hg 8/3/2000 15:29'!
detachSubMenu: evt

	| possibleTargets item subMenu |
	possibleTargets _ evt hand argumentOrNil morphsAt: evt hand targetOffset.
	item _ possibleTargets detect: [:each | each isKindOf: MenuItemMorph] ifNone: [^ self].
	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: 'nk 3/31/2002 18:22'!
removeStayUpBox

	| box |
	submorphs isEmpty ifTrue: [^self].
	(submorphs first isKindOf: AlignmentMorph) 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: 'gm 2/22/2003 13:10' prior: 38032355!
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: 'dgd 2/22/2003 18:55' prior: 24377624!
setTarget: evt 
	"Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand."

	| rootMorphs old |
	rootMorphs := self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1 
		ifTrue: [defaultTarget := rootMorphs second]
		ifFalse: [^self].
	"re-target all existing items"
	self items do: 
			[:item | 
			old := item target.
			old isHandMorph 
				ifTrue: [item target: evt hand]
				ifFalse: [item target: defaultTarget]]! !

!MenuMorph methodsFor: '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: 'ar 1/5/2002 21:33'!
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 |
	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.
	^ 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: '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 class methodsFor: 'images' stamp: 'nk 8/1/2002 17:06'!
closeBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CloseBoxImage ifNil: [CloseBoxImage _ (Form
	extent: 10@16
	depth: 2
	fromArray: #( 0 0 0 0 1342259200 1409630208 353697792 89391104 22020096 89391104 353697792 1409630208 1342259200 0 0 0)
	offset: 0@0)]! !

!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) #( )  )) ]! !

!MenuTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:28'!
resultType
	"Answer the result type of the receiver"

	^ #Menu! !

!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: 'initialization' stamp: 'sw 10/3/2002 02:16'!
initialize
	"Initialize the menu tile"

	super initialize.
	self addArrows; setLiteral: 'send to back'.
	self labelMorph useStringFormat; putSelector: nil! !

!MenuTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45' prior: 38043804!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self addArrows; setLiteral: 'send to back'.
	self labelMorph useStringFormat; putSelector: nil! !

!MenuTile methodsFor: 'initialization' stamp: 'dgd 9/6/2003 17:36' prior: 38044047!
initialize
	"Initialize the menu tile"

	super initialize.
	self addArrows; setLiteral: 'send to back' translated.
	self labelMorph useStringFormat; putSelector: nil! !

!MenuType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ MenuTile new typeColor: self typeColor! !

!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: '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)	! !

!Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'!
lookupClass

	^ lookupClass! !

!Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32' prior: 38045115!
lookupClass

	^ lookupClass! !

!Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31' prior: 24386298!
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: '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: '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: '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: 'as yet unclassified' stamp: 'md 11/14/2003 17:37'!
pushReceiver! !

!Message class methodsFor: 'instance creation' stamp: 'ajh 7/11/2001 12:05'!
catcher

	^ MessageCatcher new! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:24'!
doesNotUnderstand: aMessage

	echoToTranscript == true ifTrue: [Transcript show: aMessage printString; cr].
	^ aMessage! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:24' prior: 38047018!
doesNotUnderstand: aMessage

	echoToTranscript == true ifTrue: [Transcript show: aMessage printString; cr].
	^ aMessage! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:23'!
privEchoToTranscript

	echoToTranscript _ true! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2003 21:28'!
privEchoToTranscript: bool

	echoToTranscript _ bool! !

!MessageCatcher commentStamp: '<historical>' prior: 0!
Any message sent to me is returned as a Message object.

"Message catcher" creates an instance of me.
!
!MessageNames methodsFor: 'search' stamp: 'sw 7/30/2001 17:09'!
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 _ Smalltalk selectorsWithAnyImplementorsIn: selectorList].
	^ selectorList! !

!MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28' prior: 38047853!
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: 'sw 7/28/2001 00:43'!
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: 'sw 7/28/2001 02:18'!
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: 'sw 7/24/2001 01:49'!
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 _ Smalltalk selectorsWithAnyImplementorsIn: selectorList.
			self changed: #selectorList.
			self changed: #messageList]]! !

!MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28' prior: 38050417!
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: 'sw 7/24/2001 01:58'!
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:
				[Smalltalk allImplementorsOf: (selectorList at: selectorListIndex)].
		self messageListIndex: (messageList size > 0
			ifTrue: [1]
			ifFalse: [0])].
	^ messageList! !

!MessageNames methodsFor: 'selector list' stamp: 'sd 4/19/2003 12:12' prior: 38051563!
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: 'sw 7/24/2001 01:46'!
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: 'sw 7/24/2001 01:59'!
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 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: 'sw 7/28/2001 02:21'!
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 hideScrollBarIndefinitely.
	plugTextMor setTextMorphToSelectAllOnMouseEnter.

	searchButton _ SimpleButtonMorph new 
		target: self;
		beTransparent;
		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: 'nk 4/28/2004 10:18' prior: 38054409!
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;
		beTransparent;
		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: 'sw 8/15/2002 17:24'!
copyName
	"Copy the current selector to the clipboard"

	| selector |
	(selector _ self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil:
		[Clipboard clipboardText: selector asString asText]! !

!MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/28/2001 00:54'!
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: 'class initialization' stamp: 'asm 4/10/2003 12:53'!
initialize

	self registerInFlapsRegistry.	! !

!MessageNames class methodsFor: '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: '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] ! !

!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: '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' prior: 24413087!
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: 'printing' stamp: 'RAA 2/15/2001 19:25'!
macroPrinter

	special > 0 ifTrue: [^MacroPrinters at: special].
	^nil
! !

!MessageNode methodsFor: 'printing' stamp: 'RAA 2/16/2001 15:12'!
printIfOn: aStream indent: level

	aStream dialect = #SQ00 ifTrue:
		["Convert to if-then-else"
		(arguments last isJust: NodeNil) ifTrue:
			[aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
			self printParenReceiver: receiver on: aStream indent: level + 1.
			^ self printKeywords: #Yes: arguments: (Array with: arguments first)
						on: aStream indent: level prefix: true].
		(arguments last isJust: NodeFalse) ifTrue:
			[self printReceiver: receiver on: aStream indent: level.
			^ self printKeywords: #and: arguments: (Array with: arguments first)
						on: aStream indent: level].
		(arguments first isJust: NodeNil) ifTrue:
			[aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
			self printParenReceiver: receiver on: aStream indent: level + 1.
			^ self printKeywords: #No: arguments: (Array with: arguments last)
						on: aStream indent: level prefix: true].
		(arguments first isJust: NodeTrue) ifTrue:
			[self printReceiver: receiver on: aStream indent: level.
			^ self printKeywords: #or: arguments: (Array with: arguments last)
						on: aStream indent: level].
		aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
		self printParenReceiver: receiver on: aStream indent: level + 1.
		^ self printKeywords: #Yes:No: arguments: arguments
						on: aStream indent: level prefix: true].

	receiver 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: 'RAA 2/16/2001 15:12'!
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: [(aStream dialect = #SQ00 and: [selector key == #do:])
						ifTrue: ["Add prefix keyword"
								aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Repeat '].
								self printParenReceiver: receiver on: aStream indent: level + 1.
								self printKeywords: selector key arguments: arguments
									on: aStream indent: level prefix: true]
						ifFalse: [self printReceiver: receiver on: aStream indent: level.
								self printKeywords: selector key arguments: arguments
									on: aStream indent: level]]]! !

!MessageNode methodsFor: '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: 'equation translation' stamp: 'RAA 2/14/2001 14:07'!
receiver: val
	"14 feb 2001 - removed return arrow"

	receiver _ val! !

!MessageNode methodsFor: 'tiles' stamp: 'RAA 2/15/2001 19:34'!
asMorphicSyntaxIn: parent

	^parent 
		vanillaMessageNode: self 
		receiver: receiver 
		selector: selector 
		arguments: arguments
! !

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

!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:03'!
message: aMessage

	message := aMessage! !

!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:03'!
messageText
	"Return an exception's message text."

	^messageText == nil
		ifTrue:
			[message == nil
				ifTrue: [super messageText]
				ifFalse: [message selector asString]]
		ifFalse: [messageText]! !

!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ajh 10/9/2001 16:31' prior: 38073845!
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: 'ab 8/22/2003 11:56' prior: 38074149!
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: 'ajh 10/9/2001 16:39' prior: 24441478!
receiver
	"Answer the receiver that did not understand the message"

	^ receiver! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
arguments
	^ arguments! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'!
arguments: anArray
	arguments _ anArray! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver
	^ receiver! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver: anObject
	receiver _ anObject! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector
	^ selector! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector: aSymbol
	selector _ aSymbol! !

!MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'!
= anObject
	^ anObject species == self species 
		and: [receiver == anObject receiver
		and: [selector == anObject selector
		and: [arguments = anObject arguments]]]! !

!MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'!
hash
	^ receiver hash bitXor: selector hash! !

!MessageSend methodsFor: 'evaluating' stamp: '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: '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: '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: '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: '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: 'testing' stamp: 'nk 4/25/2002 08:04'!
isMessageSend
	^true
! !

!MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'!
isValid
	^true! !

!MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'!
asMinimalRepresentation
	^self! !

!MessageSend commentStamp: '<historical>' prior: 0!
Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. MessageSends are used to implement the #when:send:to: event system.

Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied.

Structure:
 receiver		Object -- object receiving the message send
 selector		Symbol -- message selector
 arguments		Array -- bound arguments!
!MessageSend 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! !

!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: 'nk 2/14/2004 15:10' prior: 24447946!
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: 'sw 8/1/2002 18:18'!
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: 'message functions' prior: 24449512!
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 _ SystemNavigation new confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
	confirmation == 3
		ifTrue: [^ self].
	self selectedClassOrMetaClass removeSelector: messageName.
	self deleteFromMessageList: self selection.
	self reformulateList.
	confirmation == 2
		ifTrue: [Smalltalk browseAllCallsOn: messageName]! !

!MessageSet methodsFor: 'message functions' stamp: 'sd 4/15/2003 16:12' prior: 38083166!
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: [Smalltalk browseAllCallsOn: messageName]! !

!MessageSet methodsFor: 'message functions' stamp: 'nk 6/26/2003 21:44' prior: 38083823!
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: 'contents' stamp: 'di 10/1/2001 22:26'!
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: 'sw 7/31/2002 13:09'!
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: Preferences printAlternateSyntax not].
			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: 'nk 6/19/2004 16:47' prior: 38085503!
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: Preferences printAlternateSyntax not].
			selector == #Hierarchy ifTrue: [^ class printHierarchy]].
		source _ class sourceMethodAt: selector ifAbsent:
			[currentCompiledMethod _ nil.
			^ 'Missing'].

		self showingDecompile ifTrue:
			[^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

		currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil].
		self showingDocumentation ifTrue:
			[^ self commentContents].

	source _ self sourceStringPrettifiedAndDiffed.
	^ source asText makeSelectorBoldIn: class]! !

!MessageSet methodsFor: 'contents' stamp: 'sw 2/14/2001 15:25'!
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: 'private' stamp: 'sw 6/6/2001 13:30'!
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: 'sw 7/31/2002 12:58'!
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: 'sw 6/12/2001 21:07'!
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: 'RAA 5/28/2001 11:47'!
initializeMessageList: anArray
	| s |

	messageList _ OrderedCollection new.
	anArray do: [ :each |
		MessageSet 
			parse: each  
			toClassAndSelector: [ :class :sel |
				class ifNotNil: [
					s _ class name , ' ' , sel , ' {' , 
						((class organization categoryOfElement: sel) ifNil: ['']) , '}'.
					messageList add: (
						MethodReference new
							setClass: class  
							methodSymbol: sel 
							stringVersion: s
					)
				]
			]
	].
	messageListIndex _ 0.
	contents _ ''! !

!MessageSet methodsFor: 'private' stamp: 'ff 12/13/2003 02:38' prior: 38090761!
initializeMessageList: anArray
	| s |

	messageList _ OrderedCollection new.
	anArray do: [ :each |
		MessageSet 
			parse: each  
			toClassAndSelector: [ :class :sel |
				class ifNotNil: [
					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: 'sw 6/13/2001 00:59'!
openAsMorphNamed: labelString inWorld: aWorld
	"Open the receiver in a morphic window in the given world"

	(self inMorphicWindowLabeled: labelString) openInWorld: aWorld! !

!MessageSet methodsFor: 'private' stamp: 'RAA 5/29/2001 10:12'!
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: 'filtering' stamp: 'sw 8/12/2001 13:12'!
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: 'sw 2/14/2001 18:30'!
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' prior: 24459808!
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: 'sw 8/10/2001 14:33'!
filterToImplementorsOf
	"Filter the receiver's list down to only those items with a given selector"

	| aFragment inputWithBlanksTrimmed |

	aFragment _ FillInTheBlank 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: 'sw 6/6/2001 15:14'!
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: 'sw 6/6/2001 15:15'!
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: 'sw 6/6/2001 14:10'!
filterToMessagesThat
	"Allow the user to type in a block which will be"

	| reply |
	reply _ FillInTheBlank
		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: 'sw 2/14/2001 18:24'!
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' prior: 24460811!
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: 'sw 8/10/2001 14:34'!
filterToNotImplementorsOf
	"Filter the receiver's list down to only those items whose selector is NOT one solicited from the user."

	| aFragment inputWithBlanksTrimmed |

	aFragment _ FillInTheBlank 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: 'sw 8/12/2001 13:11'!
filterToNotSendersOf
	"Filter the receiver's list down to only those items which do not send a given selector"

	| aFragment inputWithBlanksTrimmed aMethod |

	aFragment _ FillInTheBlank request: 'type selector:' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed _ aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					(aMethod _ aClass compiledMethodAt: aSelector) isNil or:
						[(aMethod hasLiteralThorough: aSymbol) not]]]! !

!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: 'sw 6/5/2001 21:42'!
filterToUnsentMessages
	"Filter the receiver's list down to only those items which have no senders"

	self filterFrom:
		[:aClass :aSelector |
			(Smalltalk allCallsOn: aSelector) size == 0]	
! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 4/29/2003 12:24' prior: 38103217!
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: 'metaclass' stamp: 'sw 8/15/2002 22:23'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."

	^ self selectedMessageName == #Comment! !

!MessageSet methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 07:32'!
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 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: 'RAA 5/29/2001 10:20'!
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
	].
	tuple _ methodRef asString findTokens: ' .'.
	cl _ Smalltalk atOrBelow: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
	(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
		ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol]
		ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! !

!MessageSet class methodsFor: 'utilities' stamp: 'bkv 4/2/2003 11:33' prior: 38105246!
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 atOrBelow: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
	(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
		ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol]
		ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! !

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

!MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:05'!
= aMessageTally

	self species == aMessageTally species ifFalse: [^ false].
	^ aMessageTally method == method! !

!MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:04'!
species
	^MessageTally! !

!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: 'ar 7/18/2001 22:27'!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay value startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifFalse: [self error: 'spy needs a block here'].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats _ Smalltalk 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.
	value := aBlock value.
	"Collect gc statistics"
	Smalltalk 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.
	^value! !

!MessageTally methodsFor: 'initialize-release' stamp: 'yo 12/12/2002 10:00' prior: 38107723!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay value startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifFalse: [self error: 'spy needs a block here'].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats _ Smalltalk 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.
	value := aBlock value.
	"Collect gc statistics"
	Smalltalk 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.
	^value! !

!MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42' prior: 38108939!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay value startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifFalse: [self error: 'spy needs a block here'].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	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.
	value := aBlock value.
	"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.
	^value! !

!MessageTally methodsFor: 'initialize-release' stamp: 'bkv 1/25/2004 21:27' prior: 38110156!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifFalse: [self error: 'spy needs a block here'].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	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: 'ar 7/18/2001 22:27'!
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 _ Smalltalk 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"
	Smalltalk getVMParameters keysAndValuesDo:
		[:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)].
	time _ Time millisecondClockValue - time0! !

!MessageTally methodsFor: 'initialize-release' stamp: 'yo 12/12/2002 10:05' prior: 38112613!
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 _ Smalltalk 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"
	Smalltalk getVMParameters keysAndValuesDo:
		[:idx :gcVal| gcStats at: idx put: (gcVal - (gcStats at: idx))].
	time _ Time millisecondClockValue - time0! !

!MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42' prior: 38113835!
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: 'sge 4/16/2001 02:34'!
printOn: aStream
	| aSelector className aClass |
	(class isNil or: [method isNil])
		ifTrue: [^ super printOn: aStream].
	aSelector _ class selectorAtMethod: method setClass: [:c | aClass _ c].
	className _ aClass name contractTo: 30.
	aStream nextPutAll: className; nextPutAll: ' >> ';
			nextPutAll: (aSelector contractTo: 60-className size)! !

!MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:14' prior: 38116282!
printOn: aStream 
	| aSelector className aClass |
	(class isNil or: [method isNil]) ifTrue: [^super printOn: aStream].
	aSelector := class selectorAtMethod: method setClass: [:c | aClass := c].
	className := aClass name contractTo: self maxClassNameSize.
	aStream
		nextPutAll: className;
		nextPutAll: ' >> ';
		nextPutAll: (aSelector 
					contractTo: self maxClassPlusSelectorSize - className size)! !

!MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:15' prior: 24474506!
printOn: aStream total: total totalTime: totalTime tallyExact: isExact 
	| aSelector className myTally aClass percentage |
	isExact 
		ifTrue: 
			[myTally := tally.
			receivers == nil 
				ifFalse: [receivers do: [:r | myTally := myTally - r tally]].
			aStream
				print: myTally;
				space]
		ifFalse: 
			[percentage := tally asFloat / total * 100.0 roundTo: 0.1.
			aStream
				print: percentage;
				nextPutAll: '% {';
				print: (percentage * totalTime / 100) rounded;
				nextPutAll: 'ms} '].
	receivers == nil 
		ifTrue: 
			[aStream
				nextPutAll: 'primitives';
				cr]
		ifFalse: 
			[aSelector := class selectorAtMethod: method setClass: [:c | aClass := c].
			className := aClass name contractTo: 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: 'nk 3/8/2004 12:23' prior: 24476017!
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' stamp: 'ar 7/18/2001 21:53'!
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].
	self reportGCStatsOn: strm.! !

!MessageTally methodsFor: 'reporting' stamp: 'spfa 6/1/2004 19:23' prior: 38119949!
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 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 class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:34' prior: 24477439!
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' prior: 24477762!
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' prior: 24478132!
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' prior: 24478647!
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: '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: 'nk 3/8/2004 12:26'!
defaultMaxTabs
	"Return the default number of tabs after which leading white space is compressed"
	^18! !

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

!Metaclass methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:51'!
theMetaClass
	"Sent to a class or metaclass, always return the metaclass"

	^self! !

!Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00' prior: 24484500!
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: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!
addObsoleteSubclass: 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: 'compiling' stamp: 'ar 5/18/2003 18:13'!
bindingOf: varName

	^thisClass classBindingOf: varName! !

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

!MethodCall methodsFor: 'initialization' stamp: 'sw 11/20/2001 13:34'!
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: 'sw 10/3/2001 15:28'!
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: 'sw 11/20/2001 12:16'!
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: 'argument access' stamp: 'sw 11/20/2001 12:16'!
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: 'sw 11/20/2001 12:15'!
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: 'method interface' stamp: 'sw 11/20/2001 13:31'!
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 classThatUnderstands: selector)]! !

!MethodCall methodsFor: 'method interface' prior: 38132079!
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: 'sw 11/20/2001 12:43'!
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: 'sw 11/20/2001 12: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! !

!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.!
!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2001 16:16'!
storeDataOn: aDataStream
	| oldMethod |
	oldMethod _ currentMethod.
	currentMethod _ nil.
	super storeDataOn: aDataStream.
	currentMethod _ oldMethod.
! !

!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: '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: 'ar 6/28/2003 00:04'!
isExecutingBlock
	"Is this executing a block versus a method"

	| r |
	Smalltalk at: #BlockClosure ifPresent:[:aClass|
		^((r _ self receiver) isKindOf: aClass) and: [r method == self method]
	].
	^false! !

!MethodContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'!
isMethodContext

	^ true! !

!MethodContext methodsFor: 'accessing' stamp: 'ajh 2/9/2003 00:08'!
methodNode

	| h |
	^ self isExecutingBlock
		ifTrue: [self method blockNodeIn: ((h _ self blockHome) ifNotNil: [h methodNode])]
		ifFalse: [super methodNode]! !

!MethodContext methodsFor: 'private' stamp: 'ajh 8/13/2002 13:34'!
startpc

	^ self method initialPC! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'hg 10/2/2001 20:43'!
cannotReturn: result

	Debugger
		openContext: 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: '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: 'controlling' stamp: 'ar 3/6/2001 15:02'!
answer: anObject
	"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: 'private-debugger' stamp: 'ajh 1/24/2003 23:38' prior: 24499681!
cachesStack

	^ false
	"^self selector == #valueUninterruptably
		and: [self receiver class == BlockContext]"! !

!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: 'printing' stamp: 'LC 1/6/2002 11:13'!
who
	| sel mcls |
	self method ifNil: [^ Array with: #unknown with: #unknown].
	sel _ self receiver class
			selectorAtMethod: self method 
			setClass: [:c | mcls _ c].
	sel == #? ifTrue: [^ self method who].
	^ Array with: mcls with: sel
! !

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

!MethodContextTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 5/31/2004 17:09'!
testCopyStack
	self assert: aMethodContext copyStack printString = aMethodContext printString.! !

!MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 17:10'!
testFindContextSuchThat
	self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString.
	self assert: (aMethodContext hasContext: aMethodContext). ! !

!MethodContextTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 5/31/2004 17:08'!
testMethodIsBottomContext
	self assert: aMethodContext bottomContext = aSender.
	self assert: aMethodContext secondFromBottom = aMethodContext.! !

!MethodContextTest methodsFor: 'testing' 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: 'testing' 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'.
! !

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

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

!MethodFinder methodsFor: 'initialize' stamp: 'md 11/14/2003 16:47' prior: 24511481!
copy: mthFinder addArg: aConstant
	| more |
	"Copy inputs and answers, add an additional data argument to the inputs.  The same constant for every example"

	more _ Array with: aConstant.
	data _ mthFinder data collect: [:argList | argList, more].
	answers _ mthFinder answers.
	self load: nil.
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/18/2001 19:23'!
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 ifKindOf:thenDo: instanceVariableValues scriptPerformer 
"flagging" flag: 
"translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel].
	#(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:"
"message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: 
) do: [:sel | AddAndRemove add: sel].

"Boolean, True, False, UndefinedObject"  
	#("logical operations" & eqv: not xor: |
"controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or:
"copying" 
"testing" isEmptyOrNil) do: [:sel | Approved add: sel].

"Behavior" 
	#("initialize-release"
"accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass
"testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords
"copying"
"printing" defaultNameStemForInstances printHierarchy
"creating class hierarchy"
"creating method dictionary"
"instance creation" basicNew basicNew: new new:
"accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses
"accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent:
"accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames
"testing class hierarchy" inheritsFrom: kindOfSubclass
"testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: scopeHas:ifTrue: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:
"enumerating"
"user interface"
"private" indexIfCompact) do: [:sel | Approved add: sel].

"ClassDescription"
	#("initialize-release" 
"accessing" classVersion isMeta name theNonMetaClass
"copying" 
"printing" classVariablesString instanceVariablesString sharedPoolsString
"instance variables" checkForInstVarsOK: 
"method dictionary" 
"organization" category organization whichCategoryIncludesSelector:
"compiling" acceptsLoggingOfCompilation wantsChangeSetLogging
"fileIn/Out" definition
"private" ) do: [:sel | Approved add: sel].

"Class"
	#("initialize-release" 
"accessing" classPool
"testing"
"copying" 
"class name" 
"instance variables" 
"class variables" classVarAt: classVariableAssociationAt:
"pool variables" 
"compiling" 
"subclass creation" 
"fileIn/Out" ) do: [:sel | Approved add: sel]. 

"Metaclass"
	#("initialize-release" 
"accessing" isSystemDefined soleInstance
"copying" "instance creation" "instance variables"  "pool variables" "class hierarchy"  "compiling"
"fileIn/Out"  nonTrivial ) do: [:sel | Approved add: sel].

"Context, BlockContext"
	#(receiver client method receiver tempAt: 
"debugger access" mclass pc selector sender shortStack sourceCode tempNames tempsAndValues
"controlling"  "printing" "system simulation" 
"initialize-release" 
"accessing" hasMethodReturn home numArgs
"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
"controlling"  "scheduling"  "instruction decoding"  "printing" "private"  "system simulation" ) do: [:sel | Approved add: sel].
	#(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].

"Message"
	#("inclass, instance creation" selector: selector:argument: selector:arguments:
"accessing" argument argument: arguments sends:
"printing" "sending" ) do: [:sel | Approved add: sel].
	#("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].

"Magnitude"
	#("comparing" < <= > >= between:and:
"testing" max: min: min:max: ) do: [:sel | Approved add: sel].

"Date, Time"
	#("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
	"in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
"accessing" day leap monthIndex monthName weekday year
"arithmetic" addDays: subtractDate: subtractDays:
"comparing"
"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
"converting" asSeconds
"printing" mmddyy mmddyyyy printFormat: 
"private" firstDayOfMonthIndex: weekdayIndex 
	"in class, instance creation" fromSeconds: now 
	"in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
"accessing" hours minutes seconds
"arithmetic" addTime: subtractTime:
"comparing"
"printing" intervalString print24 
"converting") do: [:sel | Approved add: sel].
	#("private" hours: hours:minutes:seconds: day:year: 
		 ) do: [:sel | AddAndRemove add: sel].

"Number"
	#("in class" readFrom:base: 
"arithmetic" * + - / // \\ abs negated quo: reciprocal rem:
"mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan
"truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated
"comparing"
"testing" even isDivisibleBy: isInf isInfinite isNaN isZero negative odd positive sign strictlyPositive
"converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees
"intervals" to: to:by: 
"printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel].

"Integer"
	#("in class" primesUpTo:
"testing" isPowerOfTwo
"arithmetic" alignedTo:
"comparing"
"truncation and round off" atRandom normalize
"enumerating" timesRepeat:
"mathematical functions" degreeCos degreeSin factorial gcd: lcm: take:
"bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask:
"converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit
"printing" asStringWithCommas hex hex8 radix:
"system primitives" lastDigit replaceFrom:to:with:startingAt:
"private" "benchmarks" ) do: [:sel | Approved add: sel].

"SmallInteger, LargeNegativeInteger, LargePositiveInteger"
	#("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" 
"system primitives" digitAt: digitLength 
"private" fromString:radix: ) do: [:sel | Approved add: sel].
	#(digitAt:put: ) do: [:sel | AddAndRemove add: sel].

"Float"
	#("arithmetic"
"mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower:
"comparing" "testing"
"truncation and round off" exponent fractionPart integerPart significand significandAsInteger
"converting" asApproximateFraction asIEEE32BitWord asTrueFraction
"copying") do: [:sel | Approved add: sel].

"Fraction, Random"
	#(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel].
	#(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel].

"Collection"
	#("accessing" anyOne
"testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf:
"enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect:
"converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection:
"printing"
"private" maxSize
"arithmetic"
"math functions" average max median min range sum) do: [:sel | Approved add: sel].
	#("adding" add: addAll: addIfNotPresent:
"removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel].

"SequenceableCollection"
	#("comparing" hasEqualElements:
"accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third
"removing"
"copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy:
"enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval:
"converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed
"private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel].
	#( swap:with:) do: [:sel | AddAndRemove add: sel].

"ArrayedCollection, Bag"
	#("private" defaultElement 
"sorting" isSorted
"accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" 
	) do: [:sel | Approved add: sel].
	#( mergeSortFrom:to:by: sort sort: add: add:withOccurrences:
"private" setDictionary ) do: [:sel | AddAndRemove add: sel].

"Other messages that modify the receiver"
	#(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with:  removeFirst removeLast) do: [:sel | AddAndRemove add: sel].

	self initialize2.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: Set
"

! !

!MethodFinder methodsFor: 'initialize' stamp: 'ads 3/29/2003 17:12' prior: 24523111!
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 ) (ifKindOf:thenDo: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
	Blocks add: anArray].

self initialize3.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: TranslucentColor class 
"
"Do not forget class messages for each of these classes"
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/1/2002 11:33'!
initialize3
	"additional selectors to consider"

#(asWords threeDigitName ) do: [:sel | Approved add: sel].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 2/14/2001 14:35'!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"user interface" allCallsOn: browse browseAllAccessesTo: browseAllCallsOn: browseAllStoresInto: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'sd 3/28/2003 16:25' prior: 38169250!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"user interface" allCallsOn:  browseAllAccessesTo: browseAllCallsOn: browseAllStoresInto: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'sd 3/28/2003 16:51' prior: 38173073!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"user interface" allCallsOn:   browseAllCallsOn:  "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'sd 3/28/2003 17:10' prior: 38176890!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"user interface" allCallsOn:   "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'sd 3/28/2003 18:02' prior: 38180667!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		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: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'rw 5/12/2003 11:25' prior: 38184425!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		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: removeSelectorSimply:)
		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: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'NS 1/28/2004 11:19' prior: 38188155!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		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: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!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: '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: 'find a constant' stamp: 'jla 2/4/2001 18:30'!
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: 'md 11/14/2003 16:47' prior: 38200422!
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 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 class methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 23:34'!
methodFor: dataAndAnswers
	"Return a Squeak expression that computes these answers.  (This method is called by the comment in the bottom pane of a MethodFinder.  Do not delete this method.)"

	| resultOC selFinder resultString |
	resultOC _ (self new) load: dataAndAnswers; findMessage.
	resultString _ String streamContents: [:strm |
		resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]].
	Smalltalk isMorphic ifTrue: [
		selFinder _ (ActiveWorld 
				submorphThat: [:mm | mm class == SystemWindow and: 
									[mm model isKindOf: SelectorBrowser]] 
				ifNone: [^ resultString]) model.
		selFinder searchResult: resultOC].
	^ resultString! !

!MethodHolder methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:54' prior: 24563378!
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: 'sw 3/28/2002 00:36'!
changeMethodSelectorTo: aSelector
	"Change my method selector as noted.  Reset currentCompiledMethod"

	methodSelector _ aSelector.
	currentCompiledMethod _ methodClass compiledMethodAt: aSelector ifAbsent: [nil]! !

!MethodHolder methodsFor: 'contents' stamp: 'sw 5/22/2001 18:20'!
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: 'nk 6/19/2004 16:47' prior: 38204832!
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 decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ].

	self showingDocumentation ifTrue:
		[^ self commentContents].

	^ contents _ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 5/4/2001 07:02'!
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: 'sw 3/10/2001 00:38'!
argumentVariables
	"Answer the list of argumentVariables of the interface"

	^ argumentVariables ifNil: [argumentVariables _ OrderedCollection new]! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 5/2/2001 21:19'!
argumentVariables: variableList
	"Set the argument variables"

	argumentVariables _ variableList! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 9/26/2001 11:58'!
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 absorbTranslation:
		(ElementTranslation new wording: aSelector helpMessage: 'no help available' language: #English).

	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: 'sw 3/9/2001 17:00'!
initialize
	"Initialize the receiver"

	super initialize.
	attributeKeywords _ OrderedCollection new.
	defaultStatus _ #normal.
	argumentVariables _ OrderedCollection new
! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 2/24/2001 00:34'!
initializeFor: aSelector
	"Initialize the receiver to have the given selector"

	selector _ aSelector.
	attributeKeywords _ OrderedCollection new.
	defaultStatus _ #normal
! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 9/26/2001 04:20'!
initializeFromEToyCommandSpec: tuple category: aCategorySymbol
	"tuple holds an old etoy command-item spec, of the form found in #additionsToViewerCategories methods.   Initialize the receiver to hold the same information"

	selector _ tuple second.
	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 absorbTranslation:
		(ElementTranslation new wording: (ScriptingSystem wordingForOperator: selector) helpMessage:  tuple third language: #English)! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 10/10/2001 16:35'!
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 absorbTranslation:
		(ElementTranslation new wording: (ScriptingSystem wordingForOperator: tuple second) helpMessage: tuple third language: #English).

	receiverType _ #Player.
	resultSpecification _ ResultSpecification new.
	resultSpecification resultType: tuple fourth.
	(#(getNewClone  "etc.") 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: 'sw 9/26/2001 04:21'!
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 absorbTranslation:
		(ElementTranslation new wording: ('set ', tuple second) helpMessage: ('setter for', tuple third) language: #English).
	receiverType _ #Player.
	argumentVariables _ Array with: (Variable new variableType: tuple fourth)
	! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 3/7/2001 13:05'!
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: 'sw 10/23/2001 05:42'!
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: '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: 'sw 9/12/2001 14:05'!
elementWording
	"Answer the wording to be shown on friendly tiles representing the receiver; by default, it is just the same as the method selector itself, but anything special-cased via #wordingForOperator:, and all getters/setters of slots, are transformed into somethingfriendlier here"

	^ self translatedToPrevailingLanguage wording! !

!MethodInterface methodsFor: 'access' stamp: 'sw 4/5/2001 22:21'!
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: ''', self elementWording asString, ''' selector: #', selector asString.
	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: 'access' stamp: 'sw 2/24/2001 12:04'!
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 3/9/2001 17:02'!
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: 'initialize-release' stamp: 'ar 3/3/2001 19:38'!
releaseCachedState
	"Sent by player"! !

!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 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: 'sw 5/4/2001 07:00'!
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: #none
MethodInterface isNullMarker: #znak
"! !

!MethodMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25' prior: 24572694!
initialize
	"initialize the state of the receiver"
	super initialize.
	self useRoundedCorners! !

!MethodMorph methodsFor: 'scrolling' stamp: 'sw 2/6/2002 02:26'!
showScrollBar
	"Copied down and modified to get rid of the ruinous comeToFront of the inherited version."

	| scriptor |
	(submorphs includes: scrollBar)
		ifTrue: [^ self].
	self resizeScrollBar.
	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: 'scrolling' stamp: 'nk 4/28/2004 10:23' prior: 38215924!
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]! !

!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'!
selector: symbol

	selectorOrFalse _ symbol! !

!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'!
sourceText: stringOrText

	sourceText _ stringOrText! !

!MethodNode methodsFor: 'code generation' stamp: 'ajh 3/24/2003 14:51'!
generateNative: trailer 
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	| blkSize nLits stack strm nArgs method |
	self generate: trailer ifQuick: 
		[:m |  method _ m.
		method cacheTempNames: self tempNames.
		^ method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	literals _ encoder allLiterals.
	(nLits _ literals size) > 255
		ifTrue: [^self error: 'Too many literals referenced'].
	method _ CompiledMethod	"Dummy to allocate right size"
				newBytes: blkSize
				trailerBytes: trailer 
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ ParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	method cacheTempNames: self tempNames.
	^ method! !

!MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:25'!
parserClass
	"Which parser produces this class of parse node"

	^ Parser! !

!MethodNode methodsFor: 'code generation' stamp: 'yo 8/30/2002 14:07' prior: 24576965!
selector 
	"Answer the message selector for the method represented by the receiver."

	(selectorOrFalse isSymbol)
		ifTrue: [^selectorOrFalse].
	^selectorOrFalse key.
! !

!MethodNode methodsFor: 'code generation' stamp: 'ajh 3/24/2003 14:52' prior: 24577188!
sourceMap
	"Answer a SortedCollection of associations of the form: pc (byte offset in 
	me) -> sourceRange (an Interval) in source text."

	self generateNative: #(0 0 0 0).
	^encoder sourceMap! !

!MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:26' prior: 38219106!
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 generateNative: #(0 0 0 0).  "set bytecodes to map to"
	^ methNode encoder sourceMap! !

!MethodNode methodsFor: 'converting' stamp: 'sw 5/20/2001 10:01'!
asAltSyntaxText 
	"Answer a string description of the parse tree whose root is the receiver, using the alternative syntax"

	^ DialectStream
		dialect: #SQ00
		contents: [:strm | self printOn: strm]! !

!MethodNode methodsFor: 'converting' stamp: 'sw 5/20/2001 10:00'!
asColorizedSmalltalk80Text
	"Answer a colorized Smalltalk-80-syntax string description of the parse tree whose root is the receiver."

	^ DialectStream
		dialect: #ST80
		contents: [:strm | self printOn: strm]! !

!MethodNode methodsFor: 'printing' stamp: 'ajh 1/22/2003 17:39'!
methodClass

	^ encoder classEncoding! !

!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: '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: 'tiles' stamp: 'tk 8/5/2001 11:40'!
asMorphicSyntaxUsing: aClass
	
	^ Cursor wait showWhile: [
		(aClass methodNodeOuter: self) finalAppearanceTweaks]
		! !

!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 07:42'!
actualClass 

	| actualClass |

	actualClass _ Smalltalk atOrBelow: classSymbol ifAbsent: [^nil].
	classIsMeta ifTrue: [^actualClass class].
	^actualClass

! !

!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: 'sw 6/26/2001 12:12'!
isValid
	"Answer whether the receiver represents a current selector or Comment"

	| aClass |
	(aClass _ self actualClass) ifNil: [^ false].
	^ (aClass includesSelector: methodSymbol) or:
		[methodSymbol == #Comment]! !

!MethodReference methodsFor: 'queries' stamp: 'cwp 7/7/2003 17:44' prior: 38222530!
isValid
	"Answer whether the receiver represents a current selector or Comment"

	| aClass |
	(#(DoIt DoItIn:) includes: methodSymbol) 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: '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 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 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: '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: 'tk 7/5/2001 21:49'!
= anotherMethodReference

	self species == anotherMethodReference species ifFalse: [^ false].
	classSymbol = anotherMethodReference classSymbol ifFalse: [^false].
	classIsMeta = anotherMethodReference classIsMeta ifFalse: [^false].
	^methodSymbol = anotherMethodReference methodSymbol
! !

!MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/7/2003 13:18' prior: 38225085!
= 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: '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: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'!
category
	^ self actualClass organization categoryOfElement: methodSymbol! !

!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58' prior: 38226135!
category
	^ self actualClass organization categoryOfElement: methodSymbol! !

!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'!
sourceCode
	^ self actualClass sourceCodeAt: methodSymbol! !

!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58' prior: 38226465!
sourceCode
	^ self actualClass sourceCodeAt: methodSymbol! !

!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58' prior: 38226622!
sourceCode
	^ self actualClass sourceCodeAt: methodSymbol! !

!MethodReferenceTest methodsFor: 'Running' stamp: 'dgd 3/8/2003 11:48'!
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: 'dgd 3/8/2003 11:48'!
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] ! !

!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: '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 7/18/2002 02:20'!
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.
! !

!MethodWithInterface methodsFor: 'rename' stamp: 'sw 3/11/2003 00:01' prior: 38229771!
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"! !

!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!
!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/28/2003 00:00' prior: 24584347!
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: 'dgd 9/19/2003 13:33' prior: 24588301!
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: 'tk 2/19/2001 17:51'!
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: 'tk 2/19/2001 18:43'!
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: '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: 'dgd 2/14/2003 21:24' prior: 24587229!
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! !

!MixedSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:23'!
isStereo

	^ true
! !

!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 methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'!
on: socket
	^self basicNew initialize! !

!ModalSystemWindowView methodsFor: 'modal dialog' stamp: 'BG 12/13/2002 11:33' prior: 24617464!
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.
! !

!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: 'gm 2/16/2003 20:37' prior: 24620487!
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: 'text links' stamp: 'RAA 5/29/2001 11:14'!
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 methodsFor: 'menus' stamp: 'zz 3/2/2004 23:49' prior: 24621740!
step
	"Default for morphic models is no-op"! !

!Model methodsFor: 'keyboard' stamp: 'zz 3/2/2004 23:49' prior: 24622145!
arrowKey: aChar from: view
	"Process the up and down arrows in a list pane.  Note that the listView tells us what index variable, how to get the list, and how to move the index.  Derived from a Martin Pammer submission, 02/98"

     | keyEvent oldSelection nextSelection max min howMany anEvent |

	(#(1 4 11 12 30 31) includes: (keyEvent _ aChar asciiValue)) ifFalse:
		[(Smalltalk isMorphic and: [false]) ifTrue:
			[((anEvent _ view currentEvent) isKindOf: KeyboardEvent) ifTrue: [self currentWorld keystrokeInWorld: anEvent]].
			self flag: #deferred.
			"Would like to pass all command-keys that pass through the hands of the model via this protocol but are not in fact intercepted here on to the desktop, where they might be quite relevant.  But when we obtain the event this way we are not getting the keyboard event"
			^ self].

     oldSelection := view getCurrentSelectionIndex.
     nextSelection := oldSelection.
     max := view maximumSelection.
     min := view minimumSelection.
     howMany := view numSelectionsInView.	"get this exactly??"

     keyEvent == 31 ifTrue:
		["down-arrow; move down one, wrapping to top if needed"
		nextSelection := oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].

     keyEvent == 30 ifTrue:
		["up arrow; move up one, wrapping to bottom if needed"
		nextSelection := oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].

     keyEvent == 1  ifTrue: [nextSelection := 1].  "home"
     keyEvent == 4  ifTrue: [nextSelection := max].   "end"
     keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection - howMany)].  "page up"
     keyEvent == 12  ifTrue: [nextSelection := (oldSelection + howMany) min: max].  "page down"
     nextSelection = oldSelection  ifFalse:
		[self okToChange
			ifTrue:
				[view changeModelSelection: nextSelection.
				"view controller moveMarker"]]
			! !

!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 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!
!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/26/2004 09:33'!
anyChanges
	^ self isSuperclassModified or: [self areInstVarsModified or: [self areClassVarsModified or: [self areSharedPoolsModified]]]! !

!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: 'printing' stamp: 'NS 1/21/2004 09:25'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' Super: ';
		print: self isSuperclassModified;
		nextPutAll: ' InstVars: ';
		print: self areInstVarsModified;
		nextPutAll: ' ClassVars: ';
		print: self areClassVarsModified;
		nextPutAll: ' SharedPools: ';
		print: self areSharedPoolsModified.! !

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

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

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

	^true! !

!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: 'accessing' stamp: 'NS 1/19/2004 15:08'!
oldItem
	^ oldItem! !

!ModifiedEvent methodsFor: 'private-accessing' stamp: 'NS 1/19/2004 15:08'!
oldItem: anItem
	oldItem _ anItem! !

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

!Monitor methodsFor: 'synchronization' stamp: 'NS 7/1/2002 21:54'!
critical: aBlock
	"Critical section.
	Executes aBlock as a critcal 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!!"

	[self enter.
	aBlock value] ensure: [self exit].! !

!Monitor methodsFor: 'synchronization' stamp: 'fbs 3/24/2004 14:36' prior: 38251081!
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!!"

	[self enter.
	aBlock value] ensure: [self exit].! !

!Monitor methodsFor: 'synchronization' stamp: 'NS 4/14/2004 13:13' prior: 38251489!
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: 'NS 7/1/2002 21:56'!
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, execution proceeds.
	Otherwise, the process gets blcoked and leaves the monitor again..."

	^ self waitWhile: aBlock for: nil! !

!Monitor methodsFor: 'waiting-basic' stamp: 'fbs 3/24/2004 14:39' prior: 38252883!
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: '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 7/1/2002 22:02'!
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.
	((self normalizeQueueAndReturnIfEmpty: queue) and: [queue ~~ self defaultQueue])
		ifTrue: [queue _ self defaultQueue].
	self signalQueue: queue.! !

!Monitor methodsFor: 'signaling-specific' stamp: 'NS 4/13/2004 15:12' prior: 38259194!
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: 'accessing' stamp: 'NS 7/1/2002 20:02'!
cleanup
	self checkOwnerProcess.
	self critical: [self privateCleanup].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 12:38'!
checkOwnerProcess
	(ownerProcess == Processor activeProcess)
		ifFalse: [self error: 'Monitor access violation'].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:40' prior: 38260878!
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 7/1/2002 12:36'!
enter
	self isOwnerProcess ifTrue: [^ self].
	mutex wait.
	self setOwnerProcess.! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:37' prior: 38261380!
enter
	self isOwnerProcess ifTrue: [
		nestingLevel _ nestingLevel + 1.
	] ifFalse: [
		mutex wait.
		ownerProcess _ Processor activeProcess.
		nestingLevel _ 1.
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 12:36'!
exit
	self clearOwnerProcess.
	mutex signal.! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:38' prior: 38261770!
exit
	nestingLevel _ nestingLevel - 1.
	nestingLevel < 1 ifTrue: [
		ownerProcess _ nil.
		mutex signal
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 14:52'!
exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	| lock |
	anOrderedCollection isEmpty ifTrue: [
		lock _ anOrderedCollection addLast: Semaphore new.
	] ifFalse: [
		lock _ anOrderedCollection last.
		(anIntegerOrNil notNil and: [lock isEmpty not]) ifTrue: [
			lock _ anOrderedCollection addLast: Semaphore new.
			anOrderedCollection addLast: Semaphore new]].
	
	self exit.
	anIntegerOrNil isNil
		ifTrue: [lock wait]
		ifFalse: [lock waitTimeoutMSecs: anIntegerOrNil].
	self enter.! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:32' prior: 38262066!
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 7/1/2002 17:08'!
privateCleanup
	(self normalizeQueueAndReturnIfEmpty: defaultQueue) ifTrue: [defaultQueue _ nil].
	queueDict ifNotNil: [
		queueDict copy keysAndValuesDo: [:id :queue | 
			(self normalizeQueueAndReturnIfEmpty: queue)
				ifTrue: [queueDict removeKey: id]].
		queueDict isEmpty ifTrue: [queueDict _ nil]].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:14' prior: 38263237!
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 7/1/2002 15:22'!
signalAllInQueue: anOrderedCollection
	anOrderedCollection do: [:lock |
		[lock isEmpty] whileFalse: [lock signal]].
	anOrderedCollection removeAllSuchThat: [:each | true].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10' prior: 38264330!
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 7/1/2002 16:02'!
signalQueue: anOrderedCollection
	| lock |
	(self normalizeQueueAndReturnIfEmpty: anOrderedCollection) ifTrue: [^ self].
	lock _ anOrderedCollection first.
	lock signal.
	lock isEmpty ifTrue: [anOrderedCollection removeFirst].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10' prior: 38265040!
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 methodsFor: 'initialize-release' stamp: 'NS 7/1/2002 15:10'!
initialize
	mutex _ Semaphore forMutualExclusion.! !

!Monitor methodsFor: 'initialize-release' stamp: 'NS 4/13/2004 16:12' prior: 38266029!
initialize
	mutex _ Semaphore forMutualExclusion.
	queuesMutex _ Semaphore forMutualExclusion.
	nestingLevel _ 0.! !

!Monitor commentStamp: 'fbs 3/24/2004 14:41' 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.


Usage examples

See code in class MBoundedCounter and compare it to the clumsy BoundedCounter that is written wihout a 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 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 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! !

!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' prior: 24624773!
index

	^ self monthIndex
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05' prior: 24624980!
name


	^ self monthName
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05' prior: 24624469!
previous


	^ self class starting: (self start - 1)
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05' prior: 24625286!
printOn: aStream


	aStream nextPutAll: self monthName, ' ', self year printString.! !

!Month methodsFor: 'deprecated' stamp: 'brp 8/5/2003 22:08' prior: 24625071!
eachWeekDo: aBlock

	self deprecated: 'Use #weeksDo:'.

	self weeksDo: aBlock
! !

!Month commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a month.!
!Month class methodsFor: 'squeak protocol' stamp: 'gh 5/2/2002 20:39'!
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
		newDay: 1
		month: month
		year: year! !

!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:22' prior: 38272747!
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' prior: 24625703!
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)! !

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

!MonthMorph methodsFor: 'controls' stamp: 'brp 9/3/2003 08:46' prior: 24630178!
chooseYear

	| newYear yearString |
	newYear _ (SelectionMenu selections:
					{'today'} , (month year - 5 to: month year + 5) , {'other...'})
						startUpWithCaption: 'Choose another year'.
	newYear ifNil: [^ self].
	newYear isNumber ifTrue:
		[^ self month: (Month month: month monthName year: newYear)].
	newYear = 'today' ifTrue:
		[^ self month: (Month starting: Date today)].
	yearString _ FillInTheBlank 
					request: 'Type in a year' initialAnswer: Date today year asString.
	yearString ifNil: [^ self].
	newYear _ yearString asNumber.
	(newYear between: 0 and: 9999) ifTrue:
		[^ self month: (Month month: month monthName year: newYear)].
! !

!MonthMorph methodsFor: 'controls' stamp: 'brp 1/13/2004 11:33' prior: 24631184!
nextYear
	self month: (Month month: month month year: month year + 1)
! !

!MonthMorph methodsFor: 'controls' stamp: 'brp 1/13/2004 11:33' prior: 24631441!
previousYear
	self month: (Month month: month month year: month year - 1)
! !

!MonthMorph methodsFor: 'controls' stamp: 'dgd 8/30/2003 21:53' prior: 24631599!
startMondayOrSundayString
	^ (Week startMonday
		ifTrue: ['start Sunday']
		ifFalse: ['start Monday']) translated! !

!MonthMorph methodsFor: 'controls' stamp: 'dgd 8/30/2003 21:53' prior: 38276079!
startMondayOrSundayString
	^ (Week startMonday
		ifTrue: ['start Sunday']
		ifFalse: ['start Monday']) translated! !

!MonthMorph methodsFor: 'controls' stamp: 'brp 9/2/2003 15:14' prior: 24631769!
toggleStartMonday

	(Week startDay = #Monday)
		ifTrue: [ Week startDay: #Sunday ]
		ifFalse: [ Week startDay: #Monday ].

	self initializeWeeks
! !

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

!MonthMorph methodsFor: 'initialization' stamp: 'brp 9/2/2003 15:14' prior: 38276696!
defaultColor
	"answer the default color/fill style for the receiver"

	^ Color red! !

!MonthMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:41' prior: 24626773!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	tileRect _ 0 @ 0 extent: 23 @ 19.
	self layoutInset: 1;

		 listDirection: #topToBottom;
		 vResizing: #shrinkWrap;
		 hResizing: #shrinkWrap;
		 month: Date today month.
	self rubberBandCells: false.
	self extent: 160 @ 130! !

!MonthMorph methodsFor: 'initialization' stamp: 'brp 9/2/2003 15:14' prior: 38277040!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	tileRect _ 0 @ 0 extent: 23 @ 19.
	self 
		layoutInset: 1;
		listDirection: #topToBottom;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		month: Month current.

	self rubberBandCells: false.
	self extent: 160 @ 130! !

!MonthMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:17' prior: 24627114!
initializeHeader
	| title sep frame button monthName |
	title := (self findA: WeekMorph) title.
	title hResizing: #spaceFill.
	"should be done by WeekMorph but isn't"
	title submorphsDo: [:m | m hResizing: #spaceFill].
	monthName := month name.
	self width < 160 
		ifTrue: 
			[monthName := (#(6 7 9) includes: month index) 
				ifTrue: [monthName copyFrom: 1 to: 4]
				ifFalse: [monthName copyFrom: 1 to: 3]].
	sep := (Morph new)
				color: Color transparent;
				extent: title width @ 1.
	self
		addMorph: sep;
		addMorph: title;
		addMorph: sep copy.
	button := (SimpleButtonMorph new)
				target: self;
				actWhen: #whilePressed;
				color: (Color 
							r: 0.8
							g: 0.8
							b: 0.8).
	frame := (AlignmentMorph new)
				color: Color transparent;
				listDirection: #leftToRight;
				hResizing: #spaceFill;
				vResizing: #shrinkWrap;
				layoutInset: 0.
	frame
		addMorph: (button
					label: '>>';
					actionSelector: #nextYear;
					width: 15);
		addMorph: ((button copy)
					label: '>';
					actionSelector: #next;
					width: 15);
		addMorph: (((AlignmentMorph new)
					color: Color transparent;
					listDirection: #topToBottom;
					wrapCentering: #center;
					cellPositioning: #topCenter;
					extent: (title fullBounds width - (button width * 3)) @ title height) 
						addMorph: (StringMorph new 
								contents: monthName , ' ' , month year printString));
		addMorph: ((button copy)
					label: '<';
					actionSelector: #previous;
					width: 15);
		addMorph: ((button copy)
					label: '<<';
					actionSelector: #previousYear;
					width: 15).
	"hResizing: #shrinkWrap;"
	self addMorph: frame! !

!MonthMorph methodsFor: 'initialization' stamp: 'brp 9/3/2003 08:52' prior: 24628760!
initializeWeeks
	| weeks |
	self removeAllMorphs.
	weeks _ OrderedCollection new.
	month weeksDo:
		[ :w |
		weeks add: (WeekMorph newWeek: w month: month tileRect: tileRect model: model)].

	weeks reverseDo: 
		[ :w | 
		w hResizing: #spaceFill; vResizing: #spaceFill.
		"should be done by WeekMorph but isn't"
		w submorphsDo:[ :m | m hResizing: #spaceFill; vResizing: #spaceFill ].
		self addMorph: w ].

	self 
		initializeHeader;
		highlightToday.

! !

!MonthMorph methodsFor: 'all' stamp: 'dgd 8/30/2003 21:53' prior: 24632283!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu 
		addLine;
		addUpdating: #startMondayOrSundayString action: #toggleStartMonday;
		add: 'jump to year...' translated action: #chooseYear.! !

!MonthMorph commentStamp: '<historical>' prior: 0!
A widget that displays the dates of a month in a table.!
!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:52'!
testConverting

	self assert: month asDate = '1 July 1998' asDate! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 8/5/2003 22:43'!
testDeprecated

	self 
		assert: month firstDate = '1 July 1998' asDate;
		assert: month lastDate = '31 July 1998' asDate.! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 23:38'!
testEnumerating

	| weeks |
	weeks := OrderedCollection new.
	month eachWeekDo: [ :w | weeks add: w firstDate ].

	0 to: 4 do: [ :i | weeks remove: 
		(Week fromDate: ('29 June 1998' asDate addDays: i * 7)) firstDate ].

	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: 'brp 7/26/2003 23:05'!
testInstanceCreation

	| m1 m2 |
	m1 := Month fromDate: '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! !

!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 commentStamp: 'brp 7/26/2003 22:44' prior: 0!
This is the unit test for the class Month.
!
!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/29/2003 10:55' prior: 24765249!
printPSToFile
	
	self printPSToFileNamed: self externalName! !

!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: 'nk 7/12/2003 08:59' prior: 24852835!
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.
	(SampledSound soundNames includes: 'yum') ifFalse: [
		(FileDirectory default fileExists: '') ifTrue: [
			SampledSound addLibrarySoundNamed: 'yum' fromAIFFfileNamed: 'yum.aif'
		].
	].
	(SampledSound soundNames includes: 'yum') ifTrue: [
		SampledSound playSoundNamed: 'yum'
	].
	morphToDrop rejectDropMorphEvent: evt.		"send it back where it came from"
	am delete
! !

!Morph methodsFor: 'WiW support' stamp: 'gk 2/23/2004 21:08' prior: 38283417!
eToyRejectDropMorph: morphToDrop event: evt

	| tm am |

	tm _ TextMorph new 
		beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 24);
		contents: 'GOT IT!!'.
	(am _ AlignmentMorph new)
		color: Color yellow;
		layoutInset: 10;
		useRoundedCorners;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		addMorph: tm;
		fullBounds;
		position: (self bounds center - (am extent // 2));
		openInWorld: self world.
	SoundService default playSoundNamed: 'yum' ifAbsentReadFrom: 'yum.aif'.
	morphToDrop rejectDropMorphEvent: evt.		"send it back where it came from"
	am delete
! !

!Morph methodsFor: 'WiW support' stamp: 'gk 5/24/2004 15:43' prior: 38284312!
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 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: 'ar 3/18/2001 00:14'!
shouldGetStepsFrom: aWorld
	^self world == aWorld! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:52' prior: 24640497!
actorState: anActorState 
	"change the receiver's actorState"
	self assureExtension actorState: anActorState! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:56' prior: 24640672!
actorStateOrNil
	"answer the redeiver's actorState"
	^ self hasExtension
		ifTrue: [self extension actorState]! !

!Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'!
adoptPaneColor: paneColor
	self submorphsDo:[:m| m adoptPaneColor: paneColor].! !

!Morph methodsFor: 'accessing' stamp: 'sw 6/20/2001 15:48'!
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 == nil ifTrue: [^ nil].
	(text _ extension balloonText) ifNotNil: [^ text].
	(balloonSelector _ extension balloonTextSelector)
		ifNotNil:
			[aString _ ScriptingSystem helpStringOrNilFor: balloonSelector.
			(aString == nil 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: 'dgd 2/22/2003 14:27' prior: 38286714!
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 |
	self hasExtension ifFalse: [^nil].
	(text := self extension balloonText) ifNotNil: [^text].
	(balloonSelector := self 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: 'sw 6/20/2001 14:31'!
balloonTextSelector
	"Answer balloon text selector item in the extension, nil if none"

	^ extension ifNotNil:	[extension balloonTextSelector]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:42' prior: 38288560!
balloonTextSelector
	"Answer balloon text selector item in the extension, nil if none"
	^ self hasExtension
		ifTrue: [self extension balloonTextSelector]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:50' prior: 24641426!
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' prior: 24641613!
beSticky
	"make the receiver sticky"
	self assureExtension sticky: true! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:22' prior: 24641761!
beUnsticky
	"If the receiver is marked as sticky, make it now be unsticky"
	self hasExtension
		ifTrue: [self extension sticky: false]! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'!
borderColor
	^self borderStyle color! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'!
borderColor: aColor
	| style |
	(style _ self borderStyle) baseColor = aColor ifFalse:[
		style baseColor: aColor.
		self changed].
! !

!Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 10:55' prior: 38289980!
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: '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: '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 8/25/2001 18:28'!
borderWidth
	^self borderStyle width! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:29'!
borderWidth: aNumber
	| style |
	(style _ self borderStyle) width = aNumber ifFalse:[
		style width: aNumber.
		self changed.
	].! !

!Morph methodsFor: 'accessing' stamp: 'nk 4/14/2004 17:48' prior: 38292510!
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: 'di 2/6/2001 14:02'!
borderWidthForRounding

	^ self borderWidth! !

!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/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: '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 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: 'dgd 2/16/2003 21:51' prior: 24642761!
eventHandler
	"answer the receiver's eventHandler"
	^ self hasExtension
		ifTrue: [self extension eventHandler] ! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:25' prior: 24642899!
eventHandler: anEventHandler 
	"Note that morphs can share eventHandlers and all is OK. "
	self assureExtension eventHandler: anEventHandler! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/12/2001 17:29'!
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: 2; borderColor: Color red]
			ifFalse:
				[m borderWidth: 1; borderColor: Color black]]! !

!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: 'dgd 2/16/2003 21:38' prior: 24644167!
isLocked
	"answer whether the receiver is Locked"
	self hasExtension
		ifFalse: [^ false].
	^ self extension locked! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:37' prior: 24644520!
isSticky
	"answer whether the receiver is Sticky"
	self hasExtension
		ifFalse: [^ false].
	^ self extension sticky! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48' prior: 24644733!
lock: aBoolean 
	"change the receiver's lock property"
	(self hasExtension not
			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: 'dgd 2/16/2003 21:42' prior: 24645005!
player
	"answer the receiver's player"
	^ self hasExtension
		ifTrue: [self extension player]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53' prior: 24645131!
player: anObject 
	"change the receiver's player"
	self assureExtension player: anObject! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/16/2001 12:47'!
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 raisedColor! !

!Morph methodsFor: 'accessing' stamp: 'dgd 3/7/2003 15:24' prior: 38297383!
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,f2c147045000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! !

!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: 'sw 2/15/2002 02:10'!
scaleFactor
	"Answer a number characterizing my own internal idea of what my scale-factor it."

	^ 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: 'RAA 2/19/2001 17:37'!
sticky: aBoolean

	extension sticky: aBoolean! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47' prior: 38299552!
sticky: aBoolean 
	"change the receiver's sticky property"
	self 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: 'dgd 2/16/2003 21:40' prior: 24646221!
toggleStickiness
	"togle the receiver's Stickiness"
	self hasExtension
		ifFalse: [^ self beSticky].
	self extension sticky: self extension sticky not! !

!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 - extension' stamp: 'dgd 2/16/2003 19:55' prior: 24815777!
assureExtension
	"creates an extension for the receiver if needed"
	self hasExtension
		ifFalse: [self initializeExtension].
	^ self extension! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22' prior: 24816185!
extension
	"answer the recevier's extension"
	^ extension! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:55'!
hasExtension
	"answer whether the receiver has extention"
	^ self extension notNil! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57'!
initializeExtension
	"private - initializes the receiver's extension"
	self privateExtension: MorphExtension new initialize! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57'!
privateExtension: aMorphExtension
	"private - change the receiver's extension"
	extension _ aMorphExtension! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57' prior: 24816435!
resetExtension
	"reset the extension slot if it is not needed"
	(self hasExtension
			and: [self extension isDefault])
		ifTrue: [self privateExtension: nil] ! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:58' prior: 24647061!
hasProperty: aSymbol 
	"Answer whether the receiver has the property named aSymbol"
	self hasExtension
		ifFalse: [^ false].
	^ self extension hasProperty: aSymbol! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:08' prior: 24816281!
otherProperties
	"answer the receiver's otherProperties"
	^ self hasExtension
		ifTrue: [self extension otherProperties]! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:56' prior: 24647391!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	self hasExtension
		ifFalse: [^ self].
	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: 'dgd 2/16/2003 21:49' prior: 24647560!
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: 'dgd 2/16/2003 21:00' prior: 24647820!
valueOfProperty: aSymbol 
	"answer the value of the receiver's property named aSymbol"
	^ self hasExtension
		ifTrue: [self extension valueOfProperty: aSymbol]! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 21:00' prior: 24647992!
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"
	^ self hasExtension
		ifTrue: [self extension valueOfProperty: aSymbol ifAbsent: aBlock]
		ifFalse: [aBlock value]! !

!Morph methodsFor: 'accessing - properties' stamp: 'sw 9/28/2001 08:38'!
valueOfProperty: propName 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.
	^ extension valueOfProperty: propName ifAbsentPut: aBlock! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55' prior: 38304037!
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: 'dgd 2/16/2003 20:55' prior: 24648207!
valueOfProperty: aSymbol ifPresentDo: aBlock 
	"If the receiver has a property of the given name, evaluate  
	aBlock on behalf of the value of that property"
	self hasExtension
		ifFalse: [^ self].
	^ aBlock
		value: (self extension
				valueOfProperty: aSymbol
				ifAbsent: [^ self])! !

!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: 'sw 2/6/2001 22:41'!
firedMouseUpCode
	"If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false"

	| evt |
	(self world == nil or: [self mouseUpCodeOrNil == nil]) ifTrue: [^ false].

	evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self programmedMouseUp: evt for: self.
	^ true
	

! !

!Morph methodsFor: 'button' stamp: 'dgd 2/22/2003 14:31' prior: 38306566!
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: '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: 'caching' stamp: 'ar 11/26/2001 15:25'!
releaseCachedState
	"Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."
	self wonderlandTexture: nil. "We can recreate it if needed"
	self borderStyle releaseCachedState.
! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/4/2001 21:56'!
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 size > 0 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 _ Utilities wellFormedInstanceVariableNameFrom: ea knownName.
		iVarName = ea knownName ifFalse: [ea name: iVarName].
		instVarNames _ instVarNames, iVarName, ' '].
	unnamed _ twoListsOfMorphs second.	"have default names"
	instVarNames size = 0 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 size > 0 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: 'dgd 2/22/2003 14:26' prior: 38308691!
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 := Utilities 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: '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: 'tk 11/1/2001 15:51'!
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: [^ self 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'.
	Sensor waitNoButton.
	aMorph _ self world chooseClickTarget.
	aMorph ifNil: [^ self].
	(aMorph ownerThatIsA: StackMorph) insertAsBackground: self resize: false.! !

!Morph methodsFor: 'card in a stack' stamp: 'nb 6/17/2003 12:25' prior: 38315826!
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'.
	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: 'tk 10/30/2001 13:44'!
newCard
	"Create a new card for the receiver and return it"

	| aNewInstance |
	self isStackBackground ifFalse: [^ self beep].  "bulletproof against deconstruction"
	aNewInstance _ self player class baseUniclass new.
	^ aNewInstance! !

!Morph methodsFor: 'card in a stack' stamp: 'nb 6/17/2003 12:25' prior: 38319432!
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: 'sw 11/2/2002 20:17'!
reassessBackgroundShape
	"A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'."

	| takenNames uniqueName requestedName  variableDocks docks sepDataMorphs sorted existing name1 name2 |
	"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"

self isStackBackground ifFalse: [^ self 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) ~~ nil].	"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: 'dgd 2/22/2003 19:05' prior: 38320056!
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: [^self 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: 'md 10/22/2003 15:52' prior: 38323028!
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: '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: 'sw 2/5/2002 13:31'!
showDesignationsOfObjects
	"Momentarily show the designations of objects on the receiver"

	| colorToUse aLabel |
	self isStackBackground ifFalse: [^ self].
	
	self submorphsDo: [:aMorph | 
		aMorph renderedMorph holdsSeparateDataForEachInstance 
			ifTrue:
				[colorToUse _ Color orange.
				aLabel _ aMorph externalName]
			ifFalse:
				[colorToUse _ aMorph isShared
					ifFalse:	[Color red]
					ifTrue:	[Color green].
				aLabel _ nil].
		Display border: (aMorph fullBoundsInWorld insetBy:  -6) width: 6 
				rule: Form over fillColor: colorToUse.
		aLabel ifNotNil:
			[aLabel asString
				displayOn: Display
				at:  (aMorph fullBoundsInWorld bottomLeft + (0 @ 5))
				textColor: Color blue]].
	Sensor anyButtonPressed
		ifTrue:	[Sensor waitNoButton]
		ifFalse:	[Sensor waitButton].

	World fullRepaintNeeded.! !

!Morph methodsFor: 'card in a stack' stamp: 'aoy 2/15/2003 21:50' prior: 38330800!
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: '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: 'sw 11/2/2002 20:17'!
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]].

	variableBearingMorphs _ 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: 'di 11/17/2001 11:02'!
addedOrRemovedSubmorph: aMorph
	"Report that the area occupied by this morph should be redrawn."
	"NOTE: this is subtly different from 'aMorph changed'
	in that it forces computation of aMorph fullBounds."

	"Used to be...
	self invalidRect: aMorph fullBounds from: aMorph"

	aMorph fullBounds.
	aMorph changed! !

!Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 22:27' prior: 38335836!
addedOrRemovedSubmorph: aMorph
	self deprecatedExplanation:'Use #privateInvalidateMorph: instead'.
	^self privateInvalidateMorph: aMorph "which is the equvivalent here"! !

!Morph methodsFor: 'change reporting' stamp: 'md 12/12/2003 17:01' prior: 38336234!
addedOrRemovedSubmorph: aMorph
	self deprecated:'Use #privateInvalidateMorph: instead'.
	^self privateInvalidateMorph: aMorph "which is the equvivalent here"! !

!Morph methodsFor: 'change reporting' stamp: 'nk 9/24/2003 10:01' prior: 24783032!
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].
	self wonderlandTexture ifNotNil:[self isValidWonderlandTexture: false].
! !

!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: 'ar 6/30/2001 13:13'!
isStandardViewer
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 12/16/2001 18:28'!
isTextMorph
	^false! !

!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 10/17/2001 10:06'!
duplicate
	"Make and return a duplicate of the receiver"

	| newMorph aName w aPlayer |
	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].

	^ 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: 'dgd 2/16/2003 19:53' prior: 24651244!
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])]].
	self hasExtension
		ifTrue: [self extension updateReferencesUsing: aDictionary]! !

!Morph methodsFor: 'copying' stamp: 'sw 11/27/2001 11:59'!
usableSiblingInstance
	"Return another similar morph whose Player is of the same class as mine"

	|  aName usedNames newPlayer newMorph topRenderer |
	(topRenderer _ self topRendererOrSelf) == self ifFalse:
		[^ topRenderer usableSiblingInstance].

	self assuredPlayer assureUniClass.
	newMorph _ self veryDeepCopyWithSiblingOf: self player.
	newPlayer _ newMorph player.
	newPlayer resetCostumeList.

	(aName _ self knownName) == nil ifTrue:
		[self player ~~ nil ifTrue: [aName _ newMorph innocuousName]].
			"Force a difference here"
	aName ~~ nil ifTrue:
		[usedNames _ (self world ifNil: [OrderedCollection new] ifNotNil: [
			self world allKnownNames]) copyWith: aName.
		newMorph setNameTo: (Utilities keyLike: aName satisfying: [:f | 
			(usedNames includes: f) not])].
	newMorph privateOwner: nil.
	(newMorph renderedMorph eventHandler ~~ nil) ifTrue:
		[newPlayer assureEventHandlerRepresentsStatus].
	self currentWorld addMorphBack: newMorph.

	self presenter flushPlayerListCache.

	^ newMorph! !

!Morph methodsFor: 'copying' stamp: 'dgd 2/22/2003 14:36' prior: 38341077!
usableSiblingInstance
	"Return another similar morph whose Player is of the same class as mine"

	| aName usedNames newPlayer newMorph topRenderer |
	(topRenderer := self topRendererOrSelf) == self 
		ifFalse: [^topRenderer usableSiblingInstance].
	self assuredPlayer assureUniClass.
	newMorph := self veryDeepCopyWithSiblingOf: self player.
	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.
	newMorph renderedMorph eventHandler notNil 
		ifTrue: [newPlayer assureEventHandlerRepresentsStatus].
	self currentWorld addMorphBack: newMorph.
	self presenter flushPlayerListCache.
	^newMorph! !

!Morph methodsFor: 'copying' stamp: 'dew 6/1/2003 23:54' prior: 38342162!
usableSiblingInstance
	"Return another similar morph whose Player is of the same class as mine"

	| 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.
	newMorph renderedMorph eventHandler notNil 
		ifTrue: [newPlayer assureEventHandlerRepresentsStatus].
	self currentWorld addMorphBack: newMorph.
	self presenter flushPlayerListCache.
	^newMorph! !

!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: 'tk 2/3/2001 14:30'!
veryDeepInner: deepCopier
	"The inner loop, so it can be overridden when a field should not be traced."

	"super veryDeepInner: deepCopier.	know Object has no inst vars"
	bounds _ bounds clone.	"Points are shared with original"
	"owner _ owner.	special, see veryDeepFixupWith:"
	submorphs _ submorphs veryDeepCopyWith: deepCopier.
		"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.
		"extension is treated like any generic inst var"
! !

!Morph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:59' prior: 38344736!
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"
	self
		privateExtension: (self extension veryDeepCopyWith: deepCopier)! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:36' prior: 24817943!
addDebuggingItemsTo: aMenu hand: aHandMorph
	aMenu add: 'debug...' translated subMenu:  (self buildDebugMenu: aHandMorph)! !

!Morph methodsFor: 'debug and other' stamp: 'gm 4/25/2004 14:23' prior: 24818490!
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' prior: 24818795!
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: 'tk 5/7/2001 15:47'!
allStringsAfter: aSubmorph
	"return an OrderedCollection of strings of text in my submorphs.  If aSubmorph is non-nil, begin with that container."

	| list string ok |
	list _ OrderedCollection new.
	ok _ aSubmorph == nil.
	self allMorphsDo: [:sub | 
		ok ifFalse: [ok _ sub == aSubmorph].		"and do this one too"
		ok ifTrue: [
			(string _ sub userString) ifNotNil: [
				string isString 
					ifTrue: [list add: string]
					ifFalse: [list addAll: string]]]].
	^ list! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 14:27' prior: 38347247!
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: 'tk 9/6/2001 18:32'!
buildDebugMenu: aHand
	"Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"

	| aMenu aPlayer |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	(self hasProperty: #errorOnDraw) ifTrue:
		[aMenu add: 'start drawing again' action: #resumeAfterDrawError.
		aMenu addLine].
	(self hasProperty: #errorOnStep) ifTrue:
		[aMenu add: 'start stepping again' action: #resumeAfterStepError.
		aMenu addLine].

	aMenu add: 'inspect morph' action: #inspectInMorphic:.
	aMenu add: 'inspect owner chain' action: #inspectOwnerChain.
	Smalltalk isMorphic ifFalse:
		[aMenu add: 'inspect morph (in MVC)' action: #inspect].

	(self isKindOf: MorphicModel) ifTrue:
		[aMenu add: 'inspect model' target: self model action: #inspect].
	(aPlayer _ self player) ifNotNil:
		[aMenu add: 'inspect player' target: aPlayer action: #inspect].

     aMenu add: 'explore morph' target: self selector: #explore.

	aMenu addLine.
	aMenu add: 'viewer for Player' 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'.
	aMenu add: 'viewer for Morph' target: self action: #viewMorphDirectly.
	aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player'.
	aMenu addLine.

	aPlayer ifNotNil:
		[aPlayer class isUniClass ifTrue: [
			aMenu add: 'browse player class' target: aPlayer action: #browseHierarchy]].
	aMenu add: 'browse morph class' target: self selector: #browseHierarchy.
	aMenu addLine.

	aPlayer ifNotNil:
		[aMenu add: 'player protocol (tiles)' target: aPlayer action: #openInstanceBrowserWithTiles
			"#browseProtocolForPlayer"].
	aMenu add: 'morph protocol (text)' target: self selector: #haveFullProtocolBrowsed.
	aMenu add: 'morph protocol (tiles)' target: self selector: #openInstanceBrowserWithTiles.
	aMenu addLine.

	self addViewingItemsTo: aMenu.
	aMenu 
		add: 'make own subclass' action: #subclassMorph;
		add: 'internal name ' action: #choosePartName;
		add: 'save morph in file'  action: #saveOnFile;
		addLine;
		add: 'call #tempCommand' action: #tempCommand;
		add: 'define #tempCommand' action: #defineTempCommand;
		addLine;

		add: 'control-menu...' target: self selector: #invokeMetaMenu:;
		add: 'edit balloon help' action: #editBalloonHelpText.

	^ aMenu! !

!Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:16' prior: 38348350!
buildDebugMenu: aHand 
	"Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"

	| aMenu aPlayer |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	(self hasProperty: #errorOnDraw) 
		ifTrue: 
			[aMenu add: 'start drawing again' action: #resumeAfterDrawError.
			aMenu addLine].
	(self hasProperty: #errorOnStep) 
		ifTrue: 
			[aMenu add: 'start stepping again' action: #resumeAfterStepError.
			aMenu addLine].
	aMenu add: 'inspect morph' action: #inspectInMorphic:.
	aMenu add: 'inspect owner chain' action: #inspectOwnerChain.
	Smalltalk isMorphic 
		ifFalse: [aMenu add: 'inspect morph (in MVC)' action: #inspect].
	(self isMorphicModel) 
		ifTrue: 
			[aMenu 
				add: 'inspect model'
				target: self model
				action: #inspect].
	(aPlayer := self player) ifNotNil: 
			[aMenu 
				add: 'inspect player'
				target: aPlayer
				action: #inspect].
	aMenu 
		add: 'explore morph'
		target: self
		selector: #explore.
	aMenu addLine.
	aMenu 
		add: 'viewer for Player'
		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'.
	aMenu 
		add: 'viewer for Morph'
		target: self
		action: #viewMorphDirectly.
	aMenu 
		balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player'.
	aMenu addLine.
	aPlayer ifNotNil: 
			[aPlayer class isUniClass 
				ifTrue: 
					[aMenu 
						add: 'browse player class'
						target: aPlayer
						action: #browseHierarchy]].
	aMenu 
		add: 'browse morph class'
		target: self
		selector: #browseHierarchy.
	aMenu addLine.
	aPlayer ifNotNil: 
			[aMenu 
				add: 'player protocol (tiles)'
				target: aPlayer
				action: #openInstanceBrowserWithTiles
			"#browseProtocolForPlayer"].
	aMenu 
		add: 'morph protocol (text)'
		target: self
		selector: #haveFullProtocolBrowsed.
	aMenu 
		add: 'morph protocol (tiles)'
		target: self
		selector: #openInstanceBrowserWithTiles.
	aMenu addLine.
	self addViewingItemsTo: aMenu.
	aMenu
		add: 'make own subclass' action: #subclassMorph;
		add: 'internal name ' action: #choosePartName;
		add: 'save morph in file' action: #saveOnFile;
		addLine;
		add: 'call #tempCommand' action: #tempCommand;
		add: 'define #tempCommand' action: #defineTempCommand;
		addLine;
		add: 'control-menu...'
			target: self
			selector: #invokeMetaMenu:;
		add: 'edit balloon help' action: #editBalloonHelpText.
	^aMenu! !

!Morph methodsFor: 'debug and other' stamp: 'nk 6/29/2003 17:26' prior: 38350822!
buildDebugMenu: aHand 
	"Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"

	| aMenu aPlayer |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	(self hasProperty: #errorOnDraw) 
		ifTrue: 
			[aMenu add: 'start drawing again' action: #resumeAfterDrawError.
			aMenu addLine].
	(self hasProperty: #errorOnStep) 
		ifTrue: 
			[aMenu add: 'start stepping again' action: #resumeAfterStepError.
			aMenu addLine].
	aMenu add: 'inspect morph' action: #inspectInMorphic:.
	aMenu add: 'inspect owner chain' action: #inspectOwnerChain.
	Smalltalk isMorphic 
		ifFalse: [aMenu add: 'inspect morph (in MVC)' action: #inspect].
	(self isMorphicModel) 
		ifTrue: 
			[aMenu 
				add: 'inspect model'
				target: self model
				action: #inspect].
	(aPlayer := self player) ifNotNil: 
			[aMenu 
				add: 'inspect player'
				target: aPlayer
				action: #inspect].
	aMenu 
		add: 'explore morph'
		target: self
		selector: #explore.
	aMenu addLine.
	aMenu 
		add: 'viewer for Player'
		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'.
	aMenu 
		add: 'viewer for Morph'
		target: self
		action: #viewMorphDirectly.
	aMenu 
		balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player'.
	aMenu addLine.
	aPlayer ifNotNil: 
			[aPlayer class isUniClass 
				ifTrue: 
					[aMenu 
						add: 'browse player class'
						target: aPlayer
						action: #browseHierarchy]].
	aMenu 
		add: 'browse morph class'
		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)'
				target: aPlayer
				action: #openInstanceBrowserWithTiles
			"#browseProtocolForPlayer"].
	aMenu 
		add: 'morph protocol (text)'
		target: self
		selector: #haveFullProtocolBrowsed.
	aMenu 
		add: 'morph protocol (tiles)'
		target: self
		selector: #openInstanceBrowserWithTiles.
	aMenu addLine.
	self addViewingItemsTo: aMenu.
	aMenu
		add: 'make own subclass' action: #subclassMorph;
		add: 'internal name ' action: #choosePartName;
		add: 'save morph in file' action: #saveOnFile;
		addLine;
		add: 'call #tempCommand' action: #tempCommand;
		add: 'define #tempCommand' action: #defineTempCommand;
		addLine;
		add: 'control-menu...'
			target: self
			selector: #invokeMetaMenu:;
		add: 'edit balloon help' action: #editBalloonHelpText.
	^aMenu! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 11/15/2003 19:28' prior: 38353416!
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.
	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: 'nk 6/14/2004 16:14' prior: 38356138!
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: '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: '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' prior: 24826393!
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: 'gm 2/22/2003 13:41' prior: 24827322!
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: 'dgd 8/30/2003 20:43' prior: 24829441!
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: 'drawing' stamp: 'di 2/15/2001 14:51'!
boundsWithinCorners

	^ CornerRounder rectWithinCornersOf: self bounds! !

!Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02' prior: 24680108!
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: 'dgd 2/16/2003 20:02' prior: 24680726!
clipSubmorphs
	"Drawing specific. If this property is set, clip the receiver's  
	submorphs to the receiver's clipping bounds."
	^ self
		valueOfProperty: #clipSubmorphs
		ifAbsent: [false]! !

!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 8/25/2001 17:31'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle.
! !

!Morph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:31' prior: 24684210!
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: '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: 'sw 11/27/2001 11:30'!
hasClipSubmorphsString
	"Answer a string that represents the clip-submophs checkbox"

	^ self clipSubmorphs
		ifTrue:['<on>provide clipping']
		ifFalse:['<off>provide clipping']! !

!Morph methodsFor: 'drawing' stamp: 'dgd 8/30/2003 20:20' prior: 38366772!
hasClipSubmorphsString
	"Answer a string that represents the clip-submophs checkbox"
	^ (self clipSubmorphs
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'provide clipping' translated! !

!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: 'dgd 2/16/2003 21:41' prior: 24689392!
visible
	"answer whether the receiver is visible"
	self hasExtension
		ifFalse: [^ true].
	^ self extension visible! !

!Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:24' prior: 24689510!
visible: aBoolean 
	"set the 'visible' attribute of the receiver to aBoolean"
	(self hasExtension not and:[aBoolean])
				ifTrue: [^ self].
	self visible == aBoolean
		ifTrue: [^ self].
	self assureExtension visible: aBoolean.
	self changed! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:48' prior: 24887082!
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: 'dgd 2/16/2003 21:42' prior: 24887883!
hasDropShadow
	"answer whether the receiver has DropShadow"
	^ self
		valueOfProperty: #hasDropShadow
		ifAbsent: [false]! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:49' prior: 24888258!
hasDropShadowString
	^ (self hasDropShadow
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'show shadow' translated! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:58' prior: 24888430!
hasRolloverBorder
	"answer whether the receiver has RolloverBorder"
	^ self
		valueOfProperty: #hasRolloverBorder
		ifAbsent: [false]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31' prior: 24718716!
formerOwner: aMorphOrNil 
	aMorphOrNil isNil 
		ifTrue: [self removeProperty: #formerOwner]
		ifFalse: [self setProperty: #formerOwner toValue: aMorphOrNil]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31' prior: 24719069!
formerPosition: formerPosition 
	formerPosition isNil 
		ifTrue: [self removeProperty: #formerPosition]
		ifFalse: [self setProperty: #formerPosition toValue: formerPosition]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 6/13/2001 19: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: 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: 'aoy 2/15/2003 21:51' prior: 24722716!
slideBackToFormerSituation: evt 
	| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
	formerOwner := self formerOwner.
	formerPosition := self formerPosition.
	aWorld := self 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 privateRemoveMorph: self.
	aWorld displayWorld.
	slideForm 
		slideFrom: startPoint
		to: endPoint
		nSteps: 12
		delay: 15.
	formerOwner addMorph: self.
	self position: formerPosition.
	self justDroppedInto: formerOwner event: evt! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 8/12/2003 23:35' prior: 38371793!
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: 'sw 7/27/2002 01:45'!
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 delete.  ^ 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 position: ActiveWorld bottomLeft - (0 @ (trash extent y + 26)).
				trash openInWorld.
				trash].
		endPoint _ trash fullBoundsInWorld center.
		startPoint _ self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)].
	self delete.
	ActiveWorld displayWorld.
	Preferences slideDismissalsToTrash ifTrue:
		[aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15].
	Utilities addToTrash: self! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 3/28/2001 10:00'!
undoGrabCommand
	"Return an undo command for grabbing the receiver"

	| cmd |
	owner ifNil:
		[^ nil]. "no owner - no undo"
	^ (cmd _ Command new)
		cmdWording: 'move ', 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: 'dgd 8/26/2003 21:44' prior: 38374734!
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: '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' prior: 24793636!
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: 'mir 6/13/2001 14:34'!
asWearableCostumeOfExtent: extent
	"Return a wearable costume for some player"
	^self asWearableCostume! !

!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 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: '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: 'nb 6/17/2003 12:25' prior: 24797134!
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: 'ar 2/7/2001 18:00'!
enclosingEditor
	"Return the next editor around the receiver"
	| tested |
	tested _ owner.
	[tested == nil] whileFalse:[
		tested isTileEditor ifTrue:[^tested].
		tested _ tested owner].
	^nil! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:31' prior: 38378646!
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: 'nb 6/17/2003 12:25' prior: 24799509!
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: 'ar 2/7/2001 17:58'!
isTileEditor
	"No, I'm not"
	^false! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 9/6/2003 18:10' prior: 24802360!
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: '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: 'nk 9/8/2003 17:11' prior: 24805127!
referencePlayfield
	"Answer the PasteUpMorph to be used for cartesian-coordinate reference"

	| former |
	owner ifNotNil: [
		self allOwnersDo: [ :o | o isPlayfieldLike ifTrue: [ ^o ]].
		(owner isHandMorph and: [(former _ self formerOwner) notNil])
			ifTrue:
				[^ former isPlayfieldLike 
					ifTrue: [former]
					ifFalse: [former referencePlayfield]]].
	^ self world! !

!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/12/2001 20:03'!
setNaturalLanguageTo: aLanguageSymbol
	"Set the natural language of this morph to be as indicated"! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:59'!
topEditor
	"Return the top-most editor around the receiver"
	| found tested |
	tested _ self.
	[tested == nil] whileFalse:[
		tested isTileEditor ifTrue:[found _ tested].
		tested _ tested owner].
	^found! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:35' prior: 38381617!
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 2/22/2003 14:36' prior: 24809018!
unlockOneSubpart
	| unlockables aMenu reply |
	unlockables := self submorphs select: [:m | m isLocked].
	unlockables size <= 1 ifTrue: [^self unlockContents].
	aMenu := SelectionMenu 
				labelList: (unlockables collect: [:m | m externalName])
				selections: unlockables.
	reply := aMenu startUpWithCaption: 'Who should be be unlocked?'.
	reply isNil ifTrue: [^self].
	reply unlock! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 10/8/2003 19:30' prior: 38382204!
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: '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: '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: '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: 'NS 2/22/2001 12:43'!
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].
	^ self allowsGestureStart: evt.
! !

!Morph methodsFor: 'event handling' stamp: 'nk 2/14/2004 18:42' prior: 38384525!
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: 'KTT 6/1/2004 11:41' prior: 24730423!
keyUp: anEvent
	"Handle a key up event. The default response is to do nothing."! !

!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: 'yo 11/7/2002 18:06'!
prefereredKeyboardBounds

	^ self bounds: self bounds in: World.
! !

!Morph methodsFor: 'event handling' stamp: 'yo 11/7/2002 18:06'!
prefereredKeyboardPosition

	^ (self bounds: self bounds in: World) topLeft.
! !

!Morph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:36' prior: 24735403!
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: '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-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: 'NS 2/18/2001 17:00'!
handleMouseMove: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	"Rules say that by default a morph gets #mouseMove iff
		* the hand is not dragging anything,
			+ and some button is down,
			+ and the receiver is the current mouse focus."
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 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: 'sd 5/11/2003 17:07' prior: 24867326!
handleUnknownEvent: anEvent
	"An event of an unknown type was sent to the receiver. What shall we do?!!"
	self beep.
	anEvent printString displayAt: 0@0.
	anEvent wasHandled: true.! !

!Morph methodsFor: 'events-processing' stamp: 'md 10/22/2003 15:55' prior: 38389303!
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-removing' stamp: 'rw 4/25/2002 07:18'!
releaseActionMap
	"Release the action map"
	
 	self removeProperty: #actionMap! !

!Morph methodsFor: 'fileIn/out' stamp: 'dgd 2/22/2003 14:34' prior: 24838289!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| aFileName fileStream ok |
	aFileName := ('my ' , self class name) asFileName.	"do better?"
	aFileName := FillInTheBlank 
				request: 'File name? (".morph" will be added to end)'
				initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^self beep].
	self allMorphsDo: [:m | m prepareToBeSaved].
	ok := aFileName endsWith: '.morph'.	"don't double them"
	ok := ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName := aFileName , '.morph'].
	fileStream := FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'nk 10/14/2003 09:16' prior: 38390902!
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.
	Fixed by Kazuhiro ABE on 26 July 2002 to work correctly with transformed morphs."

	| aFileName fileStream ok topRendererOrSelf |
	aFileName _ ('my ', self class name) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' 
			initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^ self beep ].
	topRendererOrSelf _ self topRendererOrSelf.
	topRendererOrSelf
		allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.morph'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.morph'].
	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: topRendererOrSelf.	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'md 10/22/2003 15:53' prior: 38391760!
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.
	Fixed by Kazuhiro ABE on 26 July 2002 to work correctly with transformed morphs."

	| aFileName fileStream ok topRendererOrSelf |
	aFileName _ ('my ', self class name) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' 
			initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^ Beeper beep ].
	topRendererOrSelf _ self topRendererOrSelf.
	topRendererOrSelf
		allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.morph'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.morph'].
	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: topRendererOrSelf.	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'dgd 11/15/2003 19:31' prior: 38392781!
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.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'dgd 2/22/2003 14:35' prior: 24840551!
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: 'gm 2/15/2003 14:58' prior: 24842659!
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 := SketchMorph withForm: f].
	newMorph setProperty: #resourceFilePath toValue: pathName.
	self owner replaceSubmorph: self by: newMorph! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
bottomCenter

	^ bounds bottomCenter! !

!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: 'di 3/6/2002 13:06'!
leftCenter

	^ bounds leftCenter! !

!Morph methodsFor: 'geometry' stamp: 'ar 12/30/2001 17:40'!
position: aPoint
	"Change the position of this morph and and all of its submorphs."

	| delta box |
	delta _ aPoint - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	box _ self fullBounds.
	(delta dotProduct: delta) > 100 ifTrue:[
		"e.g., more than 10 pixels moved"
		self invalidRect: box.
		self invalidRect: (box translateBy: delta).
	] ifFalse:[
		self invalidRect: (box merge: (box translateBy: delta)).
	].
	self privateFullMoveBy: delta.
	owner ifNotNil:[owner layoutChanged].! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
rightCenter

	^ bounds rightCenter! !

!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: 'di 3/6/2002 13:06'!
topCenter

	^ bounds topCenter! !

!Morph methodsFor: 'geometry' stamp: 'nk 5/15/2003 22:14' prior: 24699567!
worldBoundsForHalo
	"To restore older behavior, change this to return  self fullBoundsInWorld"

	| r |
	r _ self boundsIn: nil.
	Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 1 ].
	^r! !

!Morph methodsFor: 'geometry' stamp: 'nk 7/3/2003 19:39' prior: 38398548!
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: 1 ].
	^r! !

!Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 19:04' prior: 24702413!
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 |
	tfm := self transformFrom: self world.
	morphAsFlexed := tfm isIdentity 
				ifTrue: [self]
				ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm].
	myImage := morphAsFlexed imageForm offset: 0 @ 0.
	sensitivePixelMask := Form extent: myImage extent depth: 1.
	map := Bitmap new: (1 bitShift: (myImage depth min: 15)).
	map at: (i1 := sensitiveColor indexInMap: map) put: 1.
	sensitivePixelMask 
		copyBits: sensitivePixelMask boundingBox
		from: myImage form
		at: 0 @ 0
		colorMap: map.

	"get an image of the world below me"
	patchBelowMe := self world 
				patchAt: morphAsFlexed fullBounds
				without: self
				andNothingAbove: false.
	"
sensitivePixelMask displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with the sensitive pixels"
	map at: i1 put: 0.	"clear map and reuse it"
	map at: (soughtColor indexInMap: map) put: 1.
	sensitivePixelMask 
		copyBits: patchBelowMe boundingBox
		from: patchBelowMe
		at: 0 @ 0
		clippingBox: patchBelowMe boundingBox
		rule: Form and
		fillColor: nil
		map: map.
	"
sensitivePixelMask displayAt: 200@0.
"
	^(sensitivePixelMask tallyPixelValues second) > 0! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:18' prior: 38399273!
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: 'dgd 2/22/2003 19:05' prior: 24705135!
goHome
	| box |
	(owner isInMemory and: [owner notNil]) 
		ifTrue: 
			[self visible 
				ifTrue: 
					[box := owner.
					self left < box left ifTrue: [self position: box left @ self position y].
					self right > box right 
						ifTrue: [self position: (box right - self width) @ self position y].
					self top < box top ifTrue: [self position: self position x @ box top].
					self bottom > box bottom 
						ifTrue: [self position: self position x @ (box bottom - self height)]]]! !

!Morph methodsFor: 'geometry eToy' stamp: '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: 'dgd 2/22/2003 19:06' prior: 24708698!
touchesColor: soughtColor 
	"Return true if any of my pixels overlap pixels of soughtColor."

	"Make a sahdow mask with black in my shape, white elsewhere"

	| map patchBelowMe shadowForm tfm morphAsFlexed |
	tfm := self transformFrom: self world.
	morphAsFlexed := tfm isIdentity 
				ifTrue: [self]
				ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm].
	shadowForm := morphAsFlexed shadowForm offset: 0 @ 0.

	"get an image of the world below me"
	patchBelowMe := (self world 
				patchAt: morphAsFlexed fullBounds
				without: self
				andNothingAbove: false) offset: 0 @ 0.
	"
shadowForm displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with our shape."
	map := Bitmap new: (1 bitShift: (patchBelowMe depth min: 15)).
	map at: (soughtColor indexInMap: map) put: 1.
	shadowForm 
		copyBits: patchBelowMe boundingBox
		from: patchBelowMe
		at: 0 @ 0
		clippingBox: patchBelowMe boundingBox
		rule: Form and
		fillColor: nil
		map: map.
	"
shadowForm displayAt: 200@0.
"
	^(shadowForm tallyPixelValues second) > 0! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:19' prior: 38403330!
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: 'dgd 2/22/2003 14:37' prior: 24710790!
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' prior: 24711132!
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: 'dgd 2/22/2003 14:37' prior: 24712032!
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' prior: 24712510!
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' stamp: 'dgd 2/22/2003 14:33' prior: 24701105!
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: 'sw 11/15/2001 16:31'!
addHandlesTo: aHaloMorph box: box
	"Add halo handles to the halo.  Apply the halo filter if appropriate"

	| wantIt |
	aHaloMorph haloBox: box.
	Preferences haloSpecifications  do:
		[:aSpec | 
			wantIt _ Preferences selectiveHalos
				ifTrue:
					[self wantsHaloHandleWithSelector: aSpec addHandleSelector inHalo: aHaloMorph]
				ifFalse:
					[true].
			wantIt ifTrue:
				[aHaloMorph perform: aSpec addHandleSelector 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: '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: 'ar 10/8/2001 14:26'!
balloonHelpTextForHandle: aHandle
	"Answer a string providing balloon help for the given halo handle"

	|  itsSelector |
	itsSelector _ aHandle eventHandler firstMouseSelector.
	#(	(addFullHandles							'More halo handles')
		(addSimpleHandles						'Fewer halo handles')
		(chooseEmphasisOrAlignment				'Emphasis & alignment')
		(chooseFont								'Change font')
		(chooseNewGraphicFromHalo				'Choose a new graphic')
		(chooseStyle								'Change style')
		(dismiss									'Remove')
		(doDebug:with:							'Debug')
		(doDirection:with:						'Choose forward direction')
		(doDup:with:							'Duplicate')
		(doMenu:with:							'Menu')
		(doGrab:with:							'Pick up')
		(doRecolor:with:							'Change color')
		(editButtonsScript						'See the script for this button')
		(editDrawing							'Repaint')
		(maybeDoDup:with:						'Duplicate')
		(makeNascentScript						'Make a scratch script')
		(makeNewDrawingWithin				'Paint new object')
		(mouseDownInCollapseHandle:with:		'Collapse')
		(mouseDownOnHelpHandle:				'Help')
		(openViewerForArgument				'Open a Viewer for me')
		(openViewerForTarget:with:				'Open a Viewer for me')
		(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]].

	(itsSelector == #mouseDownInDimissHandle:with:) ifTrue:
		[^ Preferences preserveTrash
			ifTrue:
				['Move to trash']
			ifFalse:
				['Remove from screen']].

	^ 'unknown halo handle'! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'!
defaultBalloonFont
	^ BalloonMorph balloonFont! !

!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 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: 'dgd 2/22/2003 19:05' prior: 24777079!
isLikelyRecipientForMouseOverHalos
	^self player notNil! !

!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 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: 'dgd 2/16/2003 19:30' prior: 24778608!
setBalloonText: stringOrText maxLineLength: aLength 
	"Set receiver's balloon help text. Pass nil to remove the help."
	(self hasExtension not
			and: [stringOrText isNil])
		ifTrue: [^ self].
	self assureExtension
		balloonText: (stringOrText
				ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! !

!Morph methodsFor: 'halos and balloon help' stamp: 'nk 8/13/2003 08:48' prior: 24779898!
transferHalo: event from: formerHaloOwner
	"Progressively transfer the halo to the next likely recipient"
	| localEvt w target |

	self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers."
	(formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[
		event shiftPressed ifTrue:[
			target _ owner.
			localEvt _ event transformedBy: (self transformedFrom: owner).
		] ifFalse:[
			target _ self renderedMorph.
			localEvt _ event transformedBy: (target transformedFrom: self).
		].
		^target transferHalo: localEvt from: target].

	"Never transfer halo to top-most world"
	(self isWorldMorph and:[owner isNil]) ifFalse:[
		(self wantsHaloFromClick and:[formerHaloOwner ~~ self]) 
			ifTrue:[^self addHalo: event from: formerHaloOwner]].

	event shiftPressed ifTrue:[
		"Pass it outwards"
		owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner].
		"We're at the top level; throw the event back in to find recipient"
		formerHaloOwner removeHalo.
		^self processEvent: event copy resetHandlerFields.
	].
	self submorphsDo:[:m|
		localEvt _ event transformedBy: (m transformedFrom: self).
		(m fullContainsPoint: localEvt position) 
			ifTrue:[^m transferHalo: event from: formerHaloOwner].
	].
	"We're at the bottom most level; throw the event back up to the root to find recipient"
	formerHaloOwner removeHalo.
	(w _ self world) 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' prior: 24781872!
wantsHalo
	| topOwner |
	^(topOwner := self topRendererOrSelf owner) notNil 
		and: [topOwner wantsHaloFor: self]! !

!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: 'initialization' stamp: 'sw 8/12/2001 02:48'!
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"

	bounds _ 0@0 corner: 50@40.
	owner _ nil.
	submorphs _ EmptyArray.
	color _ self defaultColor! !

!Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00' prior: 38417590!
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' prior: 24846712!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color blue! !

!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' prior: 24634252!
initialize
	"initialize the state of the receiver"
owner _ nil.
	submorphs _ EmptyArray.
	bounds _ self defaultBounds.
	
	color _ self defaultColor! !

!Morph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:28'!
resourceJustLoaded
	"In case resource relates to me"
	self releaseCachedState.! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:31' prior: 24891966!
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 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: 'dgd 2/22/2003 14:32' prior: 24896785!
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' prior: 24899103!
minHeight
	"answer the receiver's minHeight"
	^ self
		valueOfProperty: #minHeight
		ifAbsent: [2]! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32' prior: 24899253!
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' prior: 24899473!
minWidth
	"answer the receiver's minWidth"
	^ self
		valueOfProperty: #minWidth
		ifAbsent: [2]! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32' prior: 24899621!
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' prior: 24899838!
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-menu' stamp: 'dgd 8/30/2003 16:57' prior: 24900735!
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' prior: 24901581!
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' prior: 24902223!
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: 'dgd 8/30/2003 20:09' prior: 24907901!
hasClipLayoutCellsString
	^ (self clipLayoutCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'clip to cell size' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:58' prior: 24908089!
hasDisableTableLayoutString
	^ (self disableTableLayout
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'disable layout in tables' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 2/22/2003 14:31' prior: 24908297!
hasNoLayoutString
	^self layoutPolicy isNil 
		ifTrue: ['<on>no layout']
		ifFalse: ['<off>no layout']! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 10/8/2003 19:23' prior: 38431408!
hasNoLayoutString
	^ (self layoutPolicy isNil
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'no layout' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:55' prior: 24908466!
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' prior: 24908724!
hasReverseCellsString
	^ (self reverseTableCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'reverse table cells' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09' prior: 24908914!
hasRubberBandCellsString
	^ (self rubberBandCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'rubber band cells' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:59' prior: 24909097!
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' prior: 24909327!
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: 'dgd 2/16/2003 20:07' prior: 24915253!
layoutFrame
	"Layout specific. Return the layout frame describing where the  
	receiver should appear in a proportional layout"
	^ self hasExtension
		ifTrue: [ self extension layoutFrame]! !

!Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:07' prior: 24916257!
layoutPolicy
	"Layout specific. Return the layout policy describing how children 
	of the receiver should appear."
	^ self hasExtension
		ifTrue: [ self extension layoutPolicy]! !

!Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:07' prior: 24916847!
layoutProperties
	"Return the current layout properties associated with the  
	receiver"
	^ self hasExtension
		ifTrue: [self extension layoutProperties]! !

!Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:02' prior: 24922987!
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: 'tk 10/30/2001 18:39'!
vResizeToFit: aBoolean
	aBoolean ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!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: '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 08:22'!
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"

	aMenu addLine.
	aMenu add: 'change gesture dictionary' translated action: #changeGestureDictionary.
	self gestureDictionary ifNotNil:
		[aMenu add: 'inspect gesture dictionary' translated action: #inspectGestureDictionary.
		self hasNotExportedGestureDictionary ifFalse: 
			[aMenu add: 'make own copy of gesture dictionary' translated 
				action: #makeOwnCopyOfGestureDictionary.
			aMenu add: 'make own sub-gesture dictionary' translated 
				action: #makeOwnSubGestureDictionary]].! !

!Morph methodsFor: 'menu' stamp: 'nk 2/15/2004 09:08' prior: 38435250!
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: '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: 'sw 11/27/2001 11:25'!
addCopyItemsTo: aMenu
	"Add copy-like items to the halo menu"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	subMenu add: 'copy Postscript' action: #clipPostscript.
	subMenu add: 'print Postscript to file...' target: self selector: #printPSToFile.
	aMenu add: 'copy & print...' subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'bf 7/17/2003 12:19' prior: 38436712!
addCopyItemsTo: aMenu
	"Add copy-like items to the halo menu"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	subMenu add: 'copy text' action: #clipText.
	subMenu add: 'copy Postscript' action: #clipPostscript.
	subMenu add: 'print Postscript to file...' target: self selector: #printPSToFile.
	aMenu add: 'copy & print...' subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'dgd 11/15/2003 19:25' prior: 38437163!
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 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: 'sw 2/20/2002 15:32'!
addExportMenuItems: aMenu hand: aHandMorph
	"Add export items to the menu"

	aMenu ifNotNil:
		[ | aSubMenu |
		aSubMenu _ MenuMorph new defaultTarget: self.
		aSubMenu add: 'BMP file' action: #exportAsBMP.
		aSubMenu add: 'GIF file' action: #exportAsGIF.
		aSubMenu add: 'JPEG file' action: #exportAsJPEG.
		aMenu add: 'export...' subMenu: aSubMenu]
! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:32' prior: 38438482!
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.
		aMenu add: 'export...' translated subMenu: aSubMenu]
! !

!Morph methodsFor: 'menus' stamp: 'nk 2/16/2004 13:29' prior: 38438911!
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' prior: 24757677!
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 11/27/2001 15:26'!
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' action: #dismissViaHalo.
	subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!'.

	self maybeAddCollapseItemTo: subMenu.
	subMenu add: 'grab' action: #openInHand.
	subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.'.

	subMenu addLine.

	subMenu add: 'resize' action: #resizeFromMenu.
	subMenu balloonTextForLastItem: 'Change the size of this object'.

	subMenu add: 'duplicate' action: #maybeDuplicateMorph.
	subMenu balloonTextForLastItem: 'Hand me a copy of this object'.

	subMenu addLine.
	subMenu add: 'property sheet' target: self renderedMorph action: #openAPropertySheet.
	subMenu balloonTextForLastItem: 'Open a property sheet for me. Allows changing lots of stuff at once.'.

	subMenu add: 'set color' target: self renderedMorph action: #changeColor.
	subMenu balloonTextForLastItem: 'Change the color of this object'.

	subMenu add: 'viewer' target: self action: #beViewed.
	subMenu balloonTextForLastItem: 'Open a Viewer that will allow everything about this object to be seen and controlled.'.

	subMenu add: 'tile browser' target: self action: #openInstanceBrowserWithTiles.
	subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.'.

	subMenu add: 'hand me a tile' target: self action: #tearOffTile.
	subMenu balloonTextForLastItem: 'Hand me a tile represting this object'.
	subMenu addLine.

	subMenu add: 'inspect' target: self action: #inspect.
	subMenu balloonTextForLastItem: 'Open an Inspector on this object'.

	aMenu add: 'halo actions...' subMenu: subMenu
! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:14' prior: 38440689!
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.

	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: 'nk 2/15/2004 10:04'!
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)].

	self affiliatedSelector ifNotNil:
		[subMenu add: 'open a messenger' translated action: #openMessenger.
		subMenu balloonTextForLastItem: 'Open a Messenger on the actual method call used when the button action of this object is triggered.' translated.
		subMenu addLine].

	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.

	self addGestureMenuItems: subMenu hand: ActiveHand.

	aMenu add: 'extras...' translated subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'sw 3/2/2004 22:11' prior: 38444857!
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: 'di 10/20/2001 22:12'!
addPaintingItemsTo: aMenu hand: aHandMorph
	| subMenu movies |
	subMenu _ MenuMorph new defaultTarget: self.

	subMenu add: 'repaint' action: #editDrawing.
	subMenu add: 'set rotation center' action: #setRotationCenter.
	subMenu add: 'reset forward-direction' action: #resetForwardDirection.
	subMenu add: 'set rotation style' action: #setRotationStyle.
	subMenu add: 'erase pixels of color' action: #erasePixelsOfColor:.
	subMenu add: 'recolor pixels of color' action: #recolorPixelsOfColor:.
	subMenu add: 'reduce color palette' action: #reduceColorPalette:.
	subMenu add: 'add a border around this shape...' action: #addBorderToShape:.
	movies _
		(self world rootMorphsAt: aHandMorph targetOffset)
			select: [:m | (m isKindOf: MovieMorph) or:
						[m isKindOf: SketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' action: #insertIntoMovie:].
	aMenu add: 'painting...' subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'dgd 9/5/2003 19:26' prior: 38447995!
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 isKindOf: SketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
	aMenu add: 'painting...' translated subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 12:02'!
addPlayerItemsTo: aMenu
	"Add player-related items to the menu if appropriate"

	| aPlayer subMenu |
	aPlayer _ self topRendererOrSelf player.
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'make a sibling instance' 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'.

	subMenu add: 'make multiple siblings...' target: self action: #makeMultipleSiblings:.
	subMenu balloonTextForLastItem: 'Make any number of sibling instances all at once'.

	(aPlayer belongsToUniClass and: [aPlayer class instanceCount > 1]) ifTrue:
		[subMenu addLine.
		subMenu add: 'make all siblings look like me' target: self action: #makeSiblingsLookLikeMe:.
		subMenu balloonTextForLastItem: 'make all my sibling instances look like me.'.

		subMenu add: 'bring all siblings to my location' target: self action: #bringAllSiblingsToMe:.
		subMenu balloonTextForLastItem: 'find all sibling instances and bring them to me'.

		subMenu add: 'apply status to all siblngs' target: self action: #applyStatusToAllSiblings:.
		subMenu balloonTextForLastItem: 'apply the current status of all of my scripts to the scripts of all my siblings'].

		aMenu add: 'siblings...' subMenu: subMenu

! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:30' prior: 38450074!
addPlayerItemsTo: aMenu
	"Add player-related items to the menu if appropriate"

	| aPlayer subMenu |
	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].

		aMenu add: 'siblings...' translated subMenu: subMenu

! !

!Morph methodsFor: 'menus' stamp: 'sw 11/8/2002 15:01'!
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' target: self action: #putOnBackground.
						stackSubMenu add: 'Background field, individual values' target: self action: #becomeSharedBackgroundField]
					ifFalse:
						[stackSubMenu add: 'put onto Background' target: self action: #putOnBackground]]
			ifTrue:
				[stackSubMenu add: 'remove from Background' target: self action: #putOnForeground.
				self couldHoldSeparateDataForEachInstance ifTrue:
					[self holdsSeparateDataForEachInstance
						ifFalse:
							[stackSubMenu add: 'start holding separate data for each instance' target: self action: #makeHoldSeparateDataForEachInstance]
						ifTrue:
							[stackSubMenu add: 'stop holding separate data for each instance' target: self action: #stopHoldingSeparateDataForEachInstance].
							stackSubMenu add: 'be default value on new card' target: self action: #setAsDefaultValueForNewCard.
							(self hasProperty: #thumbnailImage)
								ifTrue:
									[stackSubMenu add: 'stop using for reference thumbnail' target: self action: #stopUsingForReferenceThumbnail]
								ifFalse:
									[stackSubMenu add: 'start using for reference thumbnail' target: self action: #startUsingForReferenceThumbnail]]].
				stackSubMenu addLine].

	(self isStackBackground) ifFalse:
		[stackSubMenu add: 'be a card in an existing stack...' action: #insertAsStackBackground].
	stackSubMenu add: 'make an instance for my data' action: #abstractAModel.
	(self isStackBackground) ifFalse:
		[stackSubMenu add: 'become a stack of cards' action: #wrapWithAStack].
	aMenu add: 'stacks and cards...' subMenu: stackSubMenu
! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:34' prior: 38452950!
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: 'ar 12/16/2001 21:06'!
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' action: #goBehind.
		aMenu add: 'bring to front' 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 adMiscExtrasTo: 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 "', unlockables first externalName, '"' action: #unlockContents].
	unlockables size > 1 ifTrue:
		[aMenu add: 'unlock all contents' action: #unlockContents.
		aMenu add: 'unlock...' action: #unlockOneSubpart].

	aMenu defaultTarget: aHandMorph.
! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 16:39' prior: 38457035!
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 adMiscExtrasTo: 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: 'nk 2/15/2004 08:19' prior: 38458586!
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: 'sw 4/20/2002 01:38'!
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')
	(stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me')
	(lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions')
	(hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.')
	(hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo')
	(hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me')) do:

		[:trip | aMenu addUpdating: trip first action: trip second.
			aMenu balloonTextForLastItem: trip third].

	self couldHaveRoundedCorners ifTrue:
		[aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding.
		aMenu balloonTextForLastItem: 'whether my corners should be rounded']! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:22' prior: 38461809!
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')
	(stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me')
	(lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions')
	(hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.')
	(hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo')
	(hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me')
	) do:

		[:trip | aMenu addUpdating: trip first action: trip second.
			aMenu balloonTextForLastItem: trip third translated].

	self couldHaveRoundedCorners ifTrue:
		[aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding.
		aMenu balloonTextForLastItem: 'whether my corners should be rounded']! !

!Morph methodsFor: 'menus' stamp: 'dgd 10/17/2003 22:51' prior: 24759329!
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' prior: 24759731!
adhereToEdge: edgeSymbol 
	(owner isNil or: [owner isHandMorph]) ifTrue: [^self].
	self perform: (edgeSymbol , ':') asSymbol
		withArguments: (Array with: (owner perform: edgeSymbol))! !

!Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'!
changeDirectionHandles
	^self wantsDirectionHandles: self wantsDirectionHandles not! !

!Morph methodsFor: 'menus' stamp: 'sd 5/11/2003 22:17' prior: 24761586!
chooseNewGraphicCoexisting: aBoolean
	"Allow the user to choose a different form for her form-based morph"

	| reasonableForms replacee aGraphicalMenu myGraphic |
	reasonableForms _ (SketchMorph allInstances
		select:
			[:m | ((m owner isKindOf: SketchEditorMorph) or: [m owner isKindOf: IconicButton]) not]
		thenCollect:
			 [:m | m form]) asSet "eliminate duplicates" asOrderedCollection.

	reasonableForms addAll: Imports default images.
	reasonableForms _ reasonableForms asSet asOrderedCollection.
	(reasonableForms includes: (myGraphic _ self form))
		ifTrue:
			[reasonableForms remove: myGraphic].
	reasonableForms addFirst: myGraphic.

	aGraphicalMenu _ GraphicalMenu new initializeFor: self withForms: reasonableForms coexist: aBoolean.
	aBoolean
		ifFalse:
			[replacee _ self topRendererOrSelf.
			replacee owner replaceSubmorph: replacee by: aGraphicalMenu]
		ifTrue:
			[self primaryHand attachMorph: aGraphicalMenu]! !

!Morph methodsFor: 'menus'!
defaultArrowheadSize
	
	^ self class defaultArrowheadSize! !

!Morph methodsFor: 'menus' stamp: 'sw 7/16/2001 14:31'!
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:  Color tan;
		label: 'O' font: Preferences standardButtonFont;
		actionSelector: #delete;
		setBalloonText: 'dismiss'.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'laza 6/18/2003 11:06' prior: 38465966!
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:  Color tan;
		label: 'X' font: Preferences standardButtonFont;
		actionSelector: #delete;
		setBalloonText: 'dismiss'.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'dgd 10/8/2003 18:29' prior: 38466406!
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:  Color tan;
		label: 'X' font: Preferences standardButtonFont;
		actionSelector: #delete;
		setBalloonText: 'dismiss' translated.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'ar 10/25/2000 23:17'!
doMenuItem: menuString
	| aMenu anItem aNominalEvent aHand |
	aMenu _ self buildHandleMenu: (aHand _ self currentHand).
	aMenu allMorphsDo: [:m | m step].  "Get wordings current"
	anItem _ aMenu itemWithWording: menuString.
	anItem ifNil:
		[^ self player scriptingError: 'Menu item not found: ', menuString].
	aNominalEvent _  MouseButtonEvent new
		setType: #mouseDown
		position: anItem bounds center
		which: 4 "red"
		buttons: 4 "red"
		hand: aHand
		stamp: nil.
	anItem invokeWithEvent: aNominalEvent! !

!Morph methodsFor: 'menus' stamp: 'ar 3/23/2001 15:01'!
exportAsBMP
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' initialAnswer: self externalName,'.bmp'.
	fName isEmpty ifTrue:[^self].
	self imageForm writeBMPfileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'ar 3/23/2001 15:03'!
exportAsGIF
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' initialAnswer: self externalName,'.gif'.
	fName isEmpty ifTrue:[^self].
	GIFReadWriter putForm: self imageForm onFileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'sw 2/20/2002 15:15'!
exportAsJPEG
	"Export the receiver's image as a JPEG"

	| fName |
	fName _ FillInTheBlank request: 'Please enter the name' initialAnswer: self externalName,'.jpeg'.
	fName isEmpty ifTrue: [^ self].
	self imageForm writeJPEGfileNamed: fName! !

!Morph methodsFor: 'menus' stamp: 'nk 2/16/2004 13:29'!
exportAsPNG
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' initialAnswer: self externalName,'.png'.
	fName isEmpty ifTrue:[^self].
	PNGReadWriter putForm: self imageForm onFileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:58'!
hasDirectionHandlesString
	^(self wantsDirectionHandles ifTrue:['<on>'] ifFalse:['<off>']), 'direction handles'! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:23' prior: 38468940!
hasDirectionHandlesString
	^ (self wantsDirectionHandles
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'direction handles' translated! !

!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 15:00'!
hasDragAndDropEnabledString
	"Answer a string to characterize the drag & drop status of the receiver"

	^ self dragNDropEnabled ifTrue:['<on>accept drops'] ifFalse:['<off>accept drops']! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:24' prior: 38469323!
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: 'sw 8/10/2001 10:52'!
helpButton
	"Answer a button whose action would be to put up help concerning the receiver"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self;
		color:  Color magenta lighter lighter lighter;
		label: '?' font: Preferences standardButtonFont;
		actionSelector: #presentHelp;
		setBalloonText: 'click here for help'.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 16:19' prior: 38469848!
helpButton
	"Answer a button whose action would be to put up help concerning the receiver"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self;
		color:  Color magenta lighter lighter lighter;
		label: '?' translated font: Preferences standardButtonFont;
		actionSelector: #presentHelp;
		setBalloonText: 'click here for help' translated.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 11:29'!
lockedString
	"Answer the string to be shown in a menu to represent the 'locked' status"

	^ self isLocked
		ifTrue:
			['<on>be locked']
		ifFalse:
			['<off>be locked']! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:20' prior: 38470704!
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: 'dgd 8/30/2003 20:15' prior: 24764535!
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 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: 'dgd 2/22/2003 14:33' prior: 24765363!
printPSToFileNamed: aString 
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName := aString asFileName.
	fileName := FillInTheBlank 
				request: 'File name? (".eps" will be added to end)'
				initialAnswer: fileName.
	fileName isEmpty ifTrue: [^self beep].
	(fileName endsWith: '.eps') ifFalse: [fileName := fileName , '.eps'].
	rotateFlag := ((PopUpMenu labels: 'portrait (tall)
landscape (wide)') 
				startUpWithCaption: 'Choose orientation...') = 2.
	(FileStream newFileNamed: fileName)
		nextPutAll: (PostscriptCanvas defaultCanvasType morphAsPostscript: self
					rotated: rotateFlag);
		close! !

!Morph methodsFor: 'menus' stamp: 'md 10/22/2003 15:53' prior: 38471721!
printPSToFileNamed: aString 
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName := aString asFileName.
	fileName := FillInTheBlank 
				request: 'File name? (".eps" will be added to end)'
				initialAnswer: fileName.
	fileName isEmpty ifTrue: [^Beeper beep].
	(fileName endsWith: '.eps') ifFalse: [fileName := fileName , '.eps'].
	rotateFlag := ((PopUpMenu labels: 'portrait (tall)
landscape (wide)') 
				startUpWithCaption: 'Choose orientation...') = 2.
	(FileStream newFileNamed: fileName)
		nextPutAll: (PostscriptCanvas defaultCanvasType morphAsPostscript: self
					rotated: rotateFlag);
		close! !

!Morph methodsFor: 'menus' stamp: 'dgd 11/15/2003 19:31' prior: 38472450!
printPSToFileNamed: aString
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName _ aString asFileName.
	fileName _ FillInTheBlank 
		request: 'File name? (".eps" will be added to end)' translated
		initialAnswer: fileName.
	fileName isEmpty ifTrue: [^ Beeper beep].
	(fileName endsWith: '.eps') ifFalse: [fileName _ fileName,'.eps'].

	rotateFlag _ ((PopUpMenu labels:
'portrait (tall)
landscape (wide)') translated
			startUpWithCaption: 'Choose orientation...' translated) = 2.

	(FileStream newFileNamed: fileName)
		nextPutAll: (
			PostscriptCanvas defaultCanvasType morphAsPostscript: self rotated: rotateFlag
		); close.

! !

!Morph methodsFor: 'menus' stamp: 'nk 12/29/2003 13:18' prior: 38473182!
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? ("' translated;
			nextPutAll: psExtension;
			nextPutAll: '" will be added to end)' translated ]) 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)
		nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag);
		 close! !

!Morph methodsFor: 'menus' stamp: 'tk 11/2/2001 13:49'!
putOnForeground
	"Place the receiver, formerly on the background, onto the foreground.  If the receiver needs data carried on its behalf by the card, those data will be lost, so in this case get user confirmation before proceeding."

	self holdsSeparateDataForEachInstance "later add the refinement of not putting up the following confirmer if only a single instance of the current background's uniclass exists"
		ifTrue:
			[self confirm: 'Caution -- every card of this background
formerly had its own value for this
item.  If you put it on the foreground,
the values  of this item on all other
cards will be lost'
				orCancel: [^ self]].

	self removeProperty: #shared.
	self stack reassessBackgroundShape.
	"still work to be done here!!"! !

!Morph methodsFor: 'menus' stamp: 'dgd 9/5/2003 18:25' prior: 38474895!
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: 'sw 4/20/2002 01:50'!
resistsRemovalString
	"Answer the string to be shown in a menu to represent the 'resistsRemoval' status"

	^ self resistsRemoval
		ifTrue:
			['<on>resist being deleted']
		ifFalse:
			['<off>resist being deleted']! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:18' prior: 38476526!
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: 'sw 10/5/2002 01:48'!
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 _ Utilities obtainArrowheadFor: 'Head size for arrowheads: ' defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[self beep]! !

!Morph methodsFor: 'menus' prior: 38477085!
setArrowheads
	"Let the user edit the size of arrowheads for this object"

	| aParameter result  |
	aParameter _ self renderedMorph valueOfProperty:  #arrowSpec ifAbsent:
		[Preferences parameterAt: #arrowSpec ifAbsent: [self defaultArrowheadSize]].
	result _ self class obtainArrowheadFor: 'Head size for arrowheads: ' defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[self beep]! !

!Morph methodsFor: 'menus' stamp: 'md 10/22/2003 15:54' prior: 38477574!
setArrowheads
	"Let the user edit the size of arrowheads for this object"

	| aParameter result  |
	aParameter _ self renderedMorph valueOfProperty:  #arrowSpec ifAbsent:
		[Preferences parameterAt: #arrowSpec ifAbsent: [self defaultArrowheadSize]].
	result _ self class obtainArrowheadFor: 'Head size for arrowheads: ' defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[Beeper beep]! !

!Morph methodsFor: 'menus' stamp: 'sw 3/2/2004 22:11' prior: 38478113!
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: ' defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[Beeper beep]! !

!Morph methodsFor: 'menus' stamp: 'jcg 4/19/2002 22:14'!
stickinessString
	"Answer the string to be shown in a menu to represent the stickiness status"

	^ self isSticky
		ifTrue: ['<yes>resist being picked up']
		ifFalse: ['<no>resist being picked up']! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:19' prior: 38479162!
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: '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: 'meta-actions' stamp: 'ar 12/16/2001 21:07'!
addEmbeddingMenuItemsTo: aMenu hand: aHandMorph
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	self potentialEmbeddingTargets reverseDo: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self}].
	aMenu ifNotNil:[
		menu submorphCount > 0 
			ifTrue:[aMenu add:'embed into' subMenu: menu].
	].
	^menu! !

!Morph methodsFor: 'meta-actions' stamp: 'dgd 8/30/2003 16:42' prior: 38479939!
addEmbeddingMenuItemsTo: aMenu hand: aHandMorph
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	self potentialEmbeddingTargets reverseDo: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self}].
	aMenu ifNotNil:[
		menu submorphCount > 0 
			ifTrue:[aMenu add:'embed into' translated subMenu: menu].
	].
	^menu! !

!Morph methodsFor: 'meta-actions' stamp: 'jcg 9/21/2001 13:22'!
blueButtonDown: anEvent
	"Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
	| h tfm doNotDrag |
	h _ anEvent hand halo.
	"Prevent wrap around halo transfers originating from throwing the event back in"
	doNotDrag _ false.
	h ifNotNil:[
		(h innerTarget == self) ifTrue:[doNotDrag _ true].
		(h innerTarget hasOwner: self) ifTrue:[doNotDrag _ true].
		(self hasOwner: h target) ifTrue:[doNotDrag _ true]].

	tfm _ (self transformedFrom: nil) inverseTransformation.

	"cmd-drag on flexed morphs works better this way"
	h _ self addHalo: (anEvent transformedBy: tfm).
	doNotDrag ifTrue:[^self].
	"Initiate drag transition if requested"
	anEvent hand 
		waitForClicksOrDrag: h
		event: (anEvent transformedBy: tfm)
		selectors: { nil. nil. nil. #dragTarget:. }
		threshold: 5.
	"Pass focus explicitly here"
	anEvent hand newMouseFocus: h.! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 10:50'!
buildHandleMenu: aHand
	"Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu."

	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	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: 'ar 12/16/2001 21:06'!
buildMetaMenu: evt
	"Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph."
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	menu add: 'grab' action: #grabMorph:.
	menu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	self maybeAddCollapseItemTo: menu.
	menu add: 'delete' action: #dismissMorph:.
	menu addLine.
	menu add: 'copy Postscript' action: #clipPostscript.
	menu add: 'print PS to file...' action: #printPSToFile.
	menu addLine.
	menu add: 'go behind' action: #goBehind.
	menu add: 'add halo' action: #addHalo:.
	menu add: 'duplicate' action: #maybeDuplicateMorph:.

	self addEmbeddingMenuItemsTo: menu hand: evt hand.

	menu add: 'resize' action: #resizeMorph:.
	"Give the argument control over what should be done about fill styles"
	self addFillStyleMenuItems: menu hand: evt hand.
	self addDropShadowMenuItems: menu hand: evt hand.
	self addLayoutMenuItems: menu hand: evt hand.
	menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
	menu addLine.

	(self morphsAt: evt position) size > 1 ifTrue:
		[menu add: 'submorphs...'
			target: self
			selector: #invokeMetaMenuAt:event:
			argument: evt position].
	menu addLine.
	menu add: 'inspect' selector: #inspectAt:event: argument: evt position.
	menu add: 'explore' action: #explore.
	menu add: 'browse hierarchy' action: #browseHierarchy.
	menu add: 'make own subclass' action: #subclassMorph.
	menu addLine.
	menu add: 'set variable name...' action: #choosePartName.
	(self isMorphicModel) ifTrue:
		[menu add: 'save morph as prototype' action: #saveAsPrototype.
		(self ~~ self world modelOrNil) ifTrue:
			 [menu add: 'become this world''s model' action: #beThisWorldsModel]].
	menu add: 'save morph in file' action: #saveOnFile.
	(self hasProperty: #resourceFilePath)
		ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph')
				ifTrue: [menu add: 'save as resource' action: #saveAsResource].
				menu add: 'update from resource' action: #updateFromResource]
		ifFalse: [menu add: 'attach to resource' action: #attachToResource].
	menu add: 'show actions' action: #showActions.
	menu addLine.
	self addDebuggingItemsTo: menu hand: evt hand.

	self addCustomMenuItems: menu hand: evt hand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'bf 7/17/2003 12:20' prior: 38482640!
buildMetaMenu: evt
	"Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph."
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	menu add: 'grab' action: #grabMorph:.
	menu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	self maybeAddCollapseItemTo: menu.
	menu add: 'delete' action: #dismissMorph:.
	menu addLine.
	menu add: 'copy text' action: #clipText.
	menu add: 'copy Postscript' action: #clipPostscript.
	menu add: 'print Postscript to file...' action: #printPSToFile.
	menu addLine.
	menu add: 'go behind' action: #goBehind.
	menu add: 'add halo' action: #addHalo:.
	menu add: 'duplicate' action: #maybeDuplicateMorph:.

	self addEmbeddingMenuItemsTo: menu hand: evt hand.

	menu add: 'resize' action: #resizeMorph:.
	"Give the argument control over what should be done about fill styles"
	self addFillStyleMenuItems: menu hand: evt hand.
	self addDropShadowMenuItems: menu hand: evt hand.
	self addLayoutMenuItems: menu hand: evt hand.
	menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
	menu addLine.

	(self morphsAt: evt position) size > 1 ifTrue:
		[menu add: 'submorphs...'
			target: self
			selector: #invokeMetaMenuAt:event:
			argument: evt position].
	menu addLine.
	menu add: 'inspect' selector: #inspectAt:event: argument: evt position.
	menu add: 'explore' action: #explore.
	menu add: 'browse hierarchy' action: #browseHierarchy.
	menu add: 'make own subclass' action: #subclassMorph.
	menu addLine.
	menu add: 'set variable name...' action: #choosePartName.
	(self isMorphicModel) ifTrue:
		[menu add: 'save morph as prototype' action: #saveAsPrototype.
		(self ~~ self world modelOrNil) ifTrue:
			 [menu add: 'become this world''s model' action: #beThisWorldsModel]].
	menu add: 'save morph in file' action: #saveOnFile.
	(self hasProperty: #resourceFilePath)
		ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph')
				ifTrue: [menu add: 'save as resource' action: #saveAsResource].
				menu add: 'update from resource' action: #updateFromResource]
		ifFalse: [menu add: 'attach to resource' action: #attachToResource].
	menu add: 'show actions' action: #showActions.
	menu addLine.
	self addDebuggingItemsTo: menu hand: evt hand.

	self addCustomMenuItems: menu hand: evt hand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'dgd 11/15/2003 19:29' prior: 38485115!
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: 'nb 6/17/2003 12:25' prior: 24881327!
makeMultipleSiblings: evt
	"Make multiple siblings, first prompting the user for how many"

	| result |
	result _ FillInTheBlank request: 'how many siblings do you want?' initialAnswer: '2'.
	result isEmptyOrNil ifTrue: [^ self].
	result first isDigit ifFalse: [^ Beeper beep].
	self topRendererOrSelf makeSiblings: result asInteger.! !

!Morph methodsFor: 'meta-actions' stamp: 'sd 11/13/2003 21:28' prior: 38490420!
makeMultipleSiblings: evt
	"Make multiple siblings, first prompting the user for how many"

	| result |
	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: 'sw 11/27/2001 08:12'!
maybeDuplicateMorph
	"Maybe duplicate the morph"

	self okayToDuplicate ifTrue:
		[self duplicate openInHand]! !

!Morph methodsFor: 'meta-actions' stamp: 'RAA 3/8/2001 17:42'!
openAButtonPropertySheet

	ButtonPropertiesMorph basicNew
		targetMorph: self;
		initialize;
		openNearTarget! !

!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: 'sw 11/27/2001 14:59'!
resizeFromMenu
	"Commence an interaction that will resize the receiver"

	self resizeMorph: ActiveEvent! !

!Morph methodsFor: 'meta-actions' stamp: 'RAA 5/29/2001 10:39'!
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 classThatUnderstands: 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 classThatUnderstands: selector.
			cls ifNotNil: ["want more than default behavior"
				cls == Morph ifFalse: [adder value: cls value: selector]]].
	MessageSet 
		openMessageList: list 
		name: 'Actions of ', self printString.! !

!Morph methodsFor: 'meta-actions' prior: 38492187!
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]]].
	MessageSet openMessageList: list name: 'Actions of ' , self printString! !

!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: 'naming' stamp: 'dgd 8/30/2003 15:52' prior: 24740202!
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: 'gm 2/22/2003 13:16' prior: 24740931!
name: aName 
	(aName isString) ifTrue: [self setNameTo: aName]! !

!Morph methodsFor: 'naming' stamp: 'dgd 2/22/2003 14:33' prior: 24741251!
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: 'dgd 2/16/2003 21:57' prior: 24743805!
setNamePropertyTo: aName 
	"change the receiver's externalName"
	self assureExtension externalName: aName! !

!Morph methodsFor: 'naming' stamp: 'dgd 2/22/2003 14:35' prior: 24743971!
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' prior: 24744237!
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: 'object fileIn' stamp: 'dgd 2/22/2003 14:30' prior: 24843321!
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: 'dgd 2/22/2003 14:30' prior: 24844529!
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.
			self hasExtension 
				ifTrue: 
					[""

					self extension actorState 
						ifNotNil: [rend actorState: self extension actorState].
					self extension externalName 
						ifNotNil: [rend setNameTo: self extension externalName].
					self extension player ifNotNil: 
							[""

							rend player: self extension player.
							self extension player rawCostume: rend]].
			^rend].
	(rend := Morph new) color: Color transparent.
	^rend! !

!Morph methodsFor: 'objects from disk' stamp: 'dgd 2/22/2003 14:33' prior: 24836092!
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: '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: '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: 'dgd 2/16/2003 21:37' prior: 24810853!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	self hasExtension
		ifFalse: [^ false].
	^ self extension isPartsDonor! !

!Morph methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:39' prior: 24810993!
isPartsDonor: aBoolean 
	"change the receiver's isPartDonor property"
	(self hasExtension not
			and: [aBoolean not])
		ifTrue: [^ self].
	self assureExtension isPartsDonor: aBoolean! !

!Morph methodsFor: 'pen' stamp: 'dgd 2/22/2003 14:36' prior: 24738865!
trailMorph
	"You can't draw trails on me, but try my owner."

	owner isNil ifTrue: [^nil].
	^owner trailMorph! !

!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: 'mir 6/13/2001 14:45'!
shouldRememberCostumes
	^true! !

!Morph methodsFor: 'player commands' stamp: 'nb 6/17/2003 12:25' prior: 24786224!
beep: soundName

	self playSoundNamed: soundName
! !

!Morph methodsFor: 'player commands' stamp: 'nb 6/17/2003 12:25'!
playSoundNamed: soundName
	"Play the sound with the given name. Do nothing if this image lacks 
     sound playing facilities."
	
	Preferences soundsEnabled
		ifTrue: [ Smalltalk at: #SampledSound 
					ifPresent: [:sampledSound |
							sampledSound playSoundNamed: soundName asString]].! !

!Morph methodsFor: 'player commands' stamp: 'gk 2/23/2004 21:08' prior: 38503405!
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 viewer' stamp: 'sw 8/3/2001 18:40'!
openViewerForArgument
	"Open up a viewer for a player associated with the morph in question.  Temporarily, if shift key is down, open up an instance browser on the morph itself, not the player, with tiles showing, instead"

	ActiveEvent shiftPressed ifTrue:
		[ActiveWorld abandonAllHalos.
		^ self openInstanceBrowserWithTiles].
	self presenter viewMorph: self! !

!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' prior: 24812147!
colorString: aColor 
	aColor isNil ifTrue: [^'nil'].
	Color colorNames 
		do: [:colorName | aColor = (Color perform: colorName) ifTrue: [^'Color ' , colorName]].
	^aColor storeString! !

!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: 'dgd 2/22/2003 19:05' prior: 24814338!
printOn: aStream 
	| aName |
	super printOn: aStream.
	(aName := self knownName) notNil 
		ifTrue: [aStream nextPutAll: '<' , aName , '>'].
	aStream nextPutAll: '('.
	aStream
		print: self identityHash;
		nextPutAll: ')'! !

!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: 'rounding' stamp: 'ar 12/22/2001 22:44'!
cornerStyle: aSymbol
	aSymbol == #square
		ifTrue:[self removeProperty: #cornerStyle]
		ifFalse:[self setProperty: #cornerStyle toValue: aSymbol].
	self changed! !

!Morph methodsFor: 'rounding' stamp: 'sw 11/27/2001 11:31'!
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'
! !

!Morph methodsFor: 'rounding' stamp: 'dgd 9/6/2003 18:27' prior: 38506816!
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: '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 12/11/2001 10:53'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"

	| aClass aList predetermined genericItems genericAdditions |
	aClass _ self renderedMorph class.
	aList _ OrderedCollection new.
	[aClass == Morph] whileFalse:
		[(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
			[aList addAllFirstUnlessAlreadyPresent: (aClass additionsToViewerCategories collect:
				[:categorySpec | categorySpec first])].
		aClass _ aClass superclass]. 

	genericAdditions _ Morph additionsToViewerCategories.
	genericItems _ genericAdditions collect:
			[:categorySpec | categorySpec first].
	aList removeAllFoundIn: genericItems.

	aList addAllFirstUnlessAlreadyPresent: (genericAdditions collect:
			[:categorySpec | categorySpec first]) asSet asOrderedCollection.
	predetermined _ #(basic #'color & border' geometry motion #'pen use' tests layout #'drag & drop' scripting observation button search miscellaneous) select:
		[:sym | aList includes: sym].  "bulletproof agains change in those names elsewhere"
	aList removeAllFoundIn: predetermined.
	^ predetermined, aList
! !

!Morph methodsFor: 'scripting' stamp: 'sw 9/13/2002 16:46'!
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) includes: aGetSelector)
		ifTrue:
			[^ 0.01].
	^ 1! !

!Morph methodsFor: 'scripting' stamp: 'RAA 3/9/2001 11:47'!
isTileScriptingElement

	^ self hasButtonProperties and: [self buttonProperties isTileScriptingElement]! !

!Morph methodsFor: 'scripting' stamp: 'tk 8/19/2001 09:46'!
selectorsForViewer
	"Answer a list of symbols representing all the selectors available in all my viewer categories"

	| aClass aList itsAdditions |
	aClass _ self renderedMorph class.
	aList _ OrderedCollection new.
	[aClass == Morph superclass] whileFalse:
		[(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
			[itsAdditions _ aClass additionsToViewerCategories.
			itsAdditions do:
				[:anAddition | anAddition second "the spec list" do:
					[:aSpec |
						 aSpec first == #command ifTrue: [aList add: aSpec second].
						aSpec first == #slot ifTrue:
							[aList add: (aSpec at: 7).
							aList add: (aSpec at: 9)]]]].
		aClass _ aClass superclass]. 
	^ aList asSet copyWithoutAll: #(unused dummy)

"SimpleSliderMorph basicNew selectorsForViewer"
! !

!Morph methodsFor: 'scripting' stamp: 'dgd 2/22/2003 19:06' prior: 38510246!
selectorsForViewer
	"Answer a list of symbols representing all the selectors available in all my viewer categories"

	| aClass aList itsAdditions |
	aClass := self renderedMorph class.
	aList := OrderedCollection new.
	[aClass == Morph superclass] whileFalse: 
			[(aClass class includesSelector: #additionsToViewerCategories) 
				ifTrue: 
					[itsAdditions := aClass additionsToViewerCategories.
					itsAdditions do: 
							[:anAddition | 
							anAddition second do: 
									[:aSpec | 
									"the spec list"

									aSpec first == #command ifTrue: [aList add: aSpec second].
									aSpec first == #slot 
										ifTrue: 
											[aList add: (aSpec seventh).
											aList add: aSpec ninth]]]].
			aClass := aClass superclass].
	^aList asSet copyWithoutAll: #(#unused #dummy)

	"SimpleSliderMorph basicNew selectorsForViewer"! !

!Morph methodsFor: 'scripting' stamp: 'sw 9/2/2001 12:01'!
triggerScript: aSymbol
	"Have my player perform the script of the given name, which is guaranteed to exist."

	self player perform: aSymbol! !

!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: 'structure' stamp: 'ar 3/18/2001 00:11'!
activeHand
	^ActiveHand! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:05' prior: 24657395!
isInWorld
	"Return true if this morph is in a world."

	^self world notNil! !

!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' stamp: 'tk 11/2/2001 13:49'!
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 hasProperty: #tabAmongFields) ifTrue:
			[^ aPasteUp].
		aPasteUp _ aPasteUp owner].
	^ nil! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34' prior: 24659954!
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' prior: 24660304!
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: 'dgd 2/22/2003 19:06' prior: 24661109!
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: 'dgd 2/22/2003 14:36' prior: 24662002!
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' stamp: 'dgd 2/22/2003 14:27' prior: 24662784!
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: '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: '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' prior: 24664395!
firstSubmorph
	^submorphs first! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32' prior: 24664657!
hasSubmorphs
	^submorphs notEmpty! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32' prior: 24665068!
lastSubmorph
	^submorphs last! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32' prior: 24665489!
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 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: 'dgd 2/22/2003 14:35' prior: 24668309!
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: 'gm 2/22/2003 13:16' prior: 24669504!
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: 'dgd 2/22/2003 14:35' prior: 24671011!
submorphsDo: aBlock 
	submorphs do: aBlock! !

!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: 'di 11/17/2001 09:27'!
addAllMorphs: aCollection
	| inWorld myWorld itsWorld |
	myWorld _ self world.
	inWorld _ myWorld notNil.
	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 _ submorphs, aCollection.
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28' prior: 38522113!
addAllMorphs: aCollection
	^self privateAddAllMorphs: aCollection atIndex: submorphs size! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 11/17/2001 09:32'!
addAllMorphs: aCollection after: anotherMorph

	| index inWorld myWorld itsWorld |
	myWorld _ self world.
	inWorld _ myWorld notNil.
	index _ submorphs indexOf: anotherMorph ifAbsent: [submorphs size].
	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 _ (submorphs copyFrom: 1 to: index), aCollection,
			(submorphs copyFrom: index+1 to: submorphs size).
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:29' prior: 38522832!
addAllMorphs: aCollection after: anotherMorph
	^self privateAddAllMorphs: aCollection 
			atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! !

!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: 'dgd 2/22/2003 14:26' prior: 24675668!
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' stamp: 'dgd 2/22/2003 14:30' prior: 24675953!
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: 'RAA 4/23/2001 16:55'!
delete
	"Remove the receiver as a submorph of its owner and make its new owner be nil."
	| aWorld |
	aWorld _ self world ifNil: [World].	"or some proper of getting the World"

	"Terminate genie recognition focus"
	"I encountered a case where the hand was nil, so I put in a little protection - raa"
	aWorld ifNotNil: [
		aWorld currentHand ifNotNilDo: [ :h | h disableGenieFocus: self].
	].

	owner ifNotNil:
		[(extension == nil or: [self player == nil])
		ifTrue: [owner privateRemoveMorph: self.
				owner _ nil]
		ifFalse: ["Player must be notified"
				owner privateRemoveMorph: self.
				owner _ nil.
				self player noteDeletionOf: self fromWorld: aWorld]
		].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 2/25/2003 16:16' prior: 38524640!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."

	| aWorld |
	aWorld := self world ifNil: [World].
	"or some proper of getting the World"
	"Terminate genie recognition focus"
	"I encountered a case where the hand was nil, so I put in a little 
	protection - raa"
	aWorld 
		ifNotNil: [aWorld currentHand ifNotNilDo: [:h | h disableGenieFocus: self]].
	owner ifNotNil: 
			[owner privateRemoveMorph: self.
			 owner := nil.
			 (self hasExtension not or: [self player isNil]) 
				ifFalse: 
					["Player must be notified"
					self player noteDeletionOf: self fromWorld: aWorld]]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/11/2003 16:03' prior: 38525399!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."

	| aWorld |
	aWorld := self world ifNil: [World].
	"Terminate genie recognition focus"
	self disableSubmorphFocusForHand: self activeHand.
	owner ifNotNil:[ self privateDelete.
		self player ifNotNilDo: [ :player |
			"Player must be notified"
			player noteDeletionOf: self fromWorld: aWorld]].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/18/2003 15:20' prior: 38526113!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."

	| aWorld |
	aWorld := self world ifNil: [World].
	"Terminate genie recognition focus"
	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: 'BG 12/5/2003 22:31' prior: 38526592!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."

	| aWorld |
	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: 'sw 4/19/2002 22:56'!
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."

	Preferences preserveTrash ifFalse: [^ self dismissMorph: ActiveEvent].
	TrashCanMorph moveToTrash: self! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/10/2003 18:31' prior: 24677719!
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' prior: 24678003!
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' prior: 24678326!
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:25'!
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.
	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: '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: 'dgd 2/16/2003 21:20' prior: 24740801!
knownName
	"answer a name by which the receiver is known, or nil if none"
	^ self hasExtension
		ifTrue: [self extension externalName]! !

!Morph methodsFor: 'testing' stamp: 'sw 3/7/2002 00:24'!
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: [nil].
	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 _ (Smalltalk 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".
			(mm isKindOf: ScriptEditorMorph) ifTrue:
				[((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc)
					ifTrue: [mm hibernate; unhibernate]]]].
	^ aName! !

!Morph methodsFor: 'testing' stamp: 'sd 4/29/2003 12:00' prior: 38530503!
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 _ (SystemNavigation new 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: 'dvf 8/23/2003 11:50' prior: 38532552!
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: '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: 'ar 12/16/2001 19:06'!
changeDocumentAnchor
	"Change the anchor from/to document anchoring"
	| newType |
	self textAnchorType == #document ifTrue:[newType _ #paragraph] ifFalse:[newType _ #document].
	owner isTextMorph ifTrue:[owner anchorMorph: self at: self position type: newType].
! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:47' prior: 38537483!
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: 'ar 12/17/2001 12:45'!
changeInlineAnchor
	"Change the anchor from/to line anchoring"
	| newType |
	self textAnchorType == #inline ifTrue:[newType _ #paragraph] ifFalse:[newType _ #inline].
	owner isTextMorph ifTrue:[owner anchorMorph: self at: self position type: newType].
! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48' prior: 38538178!
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: 'ar 12/16/2001 19:28'!
changeParagraphAnchor
	"Change the anchor from/to paragraph anchoring"
	| newType |
	self textAnchorType == #paragraph ifTrue:[newType _ #document] ifFalse:[newType _ #paragraph].
	owner isTextMorph ifTrue:[owner anchorMorph: self at: self position type: newType].
! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48' prior: 38538857!
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: 'ar 12/16/2001 18:35'!
hasDocumentAnchorString
	^(self textAnchorType == #document ifTrue:['<on>'] ifFalse:['<off>']), 'Document'.! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14' prior: 38539557!
hasDocumentAnchorString
	^ (self textAnchorType == #document
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'Document' translated! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/17/2001 12:45'!
hasInlineAnchorString
	^(self textAnchorType == #inline ifTrue:['<on>'] ifFalse:['<off>']), 'Inline'.! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14' prior: 38539942!
hasInlineAnchorString
	^ (self textAnchorType == #inline
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'Inline' translated! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:35'!
hasParagraphAnchorString
	^(self textAnchorType == #paragraph ifTrue:['<on>'] ifFalse:['<off>']), 'Paragraph'.! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14' prior: 38540315!
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: 'texture support' stamp: 'dgd 2/16/2003 20:02' prior: 24850721!
isValidWonderlandTexture
	"Return true if the receiver is a valid wonderland texture"
	^ self
		valueOfProperty: #isValidWonderlandTexture
		ifAbsent: [true]! !

!Morph methodsFor: 'texture support' stamp: 'dgd 2/16/2003 20:03' prior: 24851568!
wonderlandTexture
	"Return the current wonderland texture associated with the  
	receiver"

	^ self
		valueOfProperty: #wonderlandTexture
		ifAbsent: []! !

!Morph methodsFor: 'texture support' stamp: 'dgd 2/22/2003 14:36' prior: 24851818!
wonderlandTexture: aTexture 
	"Return the current wonderland texture associated with the receiver"

	aTexture isNil 
		ifTrue: [self removeProperty: #wonderlandTexture]
		ifFalse: [self setProperty: #wonderlandTexture toValue: aTexture]! !

!Morph methodsFor: 'undo' stamp: 'gm 2/16/2003 20:34' prior: 24856368!
undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor 
	"Handle undo and redo of move commands in morphic"

	self owner ifNil: [^self beep].
	redo 
		ifFalse: 
			["undo sets up the redo state first"

			cmd 
				redoTarget: self
				selector: #undoMove:redo:owner:bounds:predecessor:
				arguments: { 
						cmd.
						true.
						owner.
						bounds.
						owner morphPreceding: self}].
	formerOwner ifNotNil: 
			[formerPredecessor ifNil: [formerOwner addMorphFront: self]
				ifNotNil: [formerOwner addMorph: self after: formerPredecessor]].
	self bounds: formerBounds.
	(self isSystemWindow) ifTrue: [self activate]! !

!Morph methodsFor: 'undo' stamp: 'md 10/22/2003 15:56' prior: 38542205!
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: 'visual properties' stamp: 'ar 12/22/2001 22:44'!
cornerStyle
	^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! !

!Morph methodsFor: 'visual properties' stamp: 'dgd 2/16/2003 20:02' prior: 24846861!
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 9/7/2002 15:25'!
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.
	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: 'nk 2/27/2003 11:48' prior: 38544339!
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: '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: 'tk 12/11/2001 10:34'!
privateAddMorph: aMorph atIndex: index

	| oldIndex myWorld itsWorld |
	((index >= 1) and: [index <= (submorphs size + 1)])
		ifFalse: [^ self error: 'index out of range'].
	myWorld _ self world.
	(aMorph owner == self 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"
		aMorph owner ifNotNil:
			[itsWorld _ aMorph world.
			itsWorld == myWorld ifFalse: [aMorph outOfWorld: itsWorld].
			aMorph owner privateRemoveMorph: aMorph].
		aMorph privateOwner: self.
		submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).
		itsWorld == myWorld ifFalse:[aMorph intoWorld: myWorld]].
	self layoutChanged.
	myWorld ifNotNil: [self addedOrRemovedSubmorph: aMorph].! !

!Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08' prior: 38546560!
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' 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: 'dgd 2/16/2003 19:53' prior: 24833895!
privateMoveBy: delta 
	"Private!! Use 'position:' instead."
	| fill |
	self hasExtension
		ifTrue: [self 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' stamp: 'ar 8/10/2003 18:46'!
privateRemove: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	submorphs _ submorphs copyWithout: aMorph.! !

!Morph methodsFor: 'private' stamp: 'di 11/17/2001 09:37'!
privateRemoveMorph: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	self isInWorld ifTrue: [self addedOrRemovedSubmorph: aMorph].
	submorphs _ submorphs copyWithout: aMorph.
	self layoutChanged.
! !

!Morph methodsFor: 'private' stamp: 'ar 8/3/2003 23:58' prior: 38550435!
privateRemoveMorph: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	| aWorld |
	aWorld := self world.
	aWorld ifNotNil:[self addedOrRemovedSubmorph: aMorph].
	aMorph outOfWorld: aWorld.
	submorphs _ submorphs copyWithout: aMorph.
	self layoutChanged.
! !

!Morph methodsFor: 'private' stamp: 'ar 8/10/2003 18:47' prior: 38550756!
privateRemoveMorph: aMorph
	self deprecatedExplanation: 'Use #removeMorph: instead.'.
	^self removeMorph: aMorph! !

!Morph methodsFor: 'private' stamp: 'md 12/12/2003 17:02' prior: 38551133!
privateRemoveMorph: aMorph
	self deprecated: 'Use #removeMorph: instead.'.
	^self removeMorph: aMorph! !

!Morph methodsFor: 'dispatching' stamp: 'NS 5/1/2003 17:28'!
disableSubmorphFocusForHand: aHandMorph
	"Check whether this morph or any of its submorph has the Genie focus.
	If yes, disable it."

	aHandMorph disableGenieFocus: self.
	self submorphsDo: [:each |
		each disableSubmorphFocusForHand: aHandMorph].! !

!Morph methodsFor: 'dispatching' stamp: 'nk 2/15/2004 09:16' prior: 38551492!
disableSubmorphFocusForHand: aHandMorph
	"Check whether this morph or any of its submorph has the Genie focus.
	If yes, disable it."
! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 09:58'!
allowsGestureStart: evt
	^false! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'NS 2/22/2001 12:39'!
handleMouseDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.
	anEvent controlKeyPressed ifTrue:[^self invokeMetaMenu: anEvent].
	"Make me modal during mouse transitions"
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent].
	(self allowsGestureStart: anEvent)
		ifTrue: [^ self gestureStart: anEvent].
	self mouseDown: anEvent.
	anEvent hand removeHaloFromClick: anEvent on: self.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue + self mouseStillDownThreshold
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 2/14/2004 18:42' prior: 38552132!
handleMouseDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.
	anEvent controlKeyPressed ifTrue:[^self invokeMetaMenu: anEvent].
	"Make me modal during mouse transitions"
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent].
	self mouseDown: anEvent.
	anEvent hand removeHaloFromClick: anEvent on: self.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue + self mouseStillDownThreshold
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 14:30' prior: 38553052!
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.
	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: '*geniestubs-stubs' 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-stubs' stamp: 'nk 3/11/2004 17:30'!
mouseStillDownStepRate
	"At what rate do I want to receive #mouseStillDown: notifications?"
	^1! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 06:38'!
redButtonGestureDictionaryOrName: aSymbolOrDictionary! !

!Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 06:38'!
yellowButtonGestureDictionaryOrName: aSymbolOrDictionary! !

!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/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 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 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: 'fileIn/Out' stamp: 'sd 2/6/2002 21:35'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'morph') | (suffix = 'morphs') | (suffix = 'sp') |
(suffix = '*')
		ifTrue: [
			{SimpleServiceEntry 
				provider: self 
				label: 'load as morph'
				selector: #fromFileName:
				description: 'load as morph'}]
		ifFalse: [#()]! !

!Morph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54' prior: 38560086!
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: 'LEG 10/24/2001 23:52'!
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 _ FileStream oldFileNamed: fullName.
	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: 'bf 2/13/2004 16:28' prior: 38560810!
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 _ FileStream readOnlyFileNamed: fullName.
	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: 'yo 8/7/2003 11:02' prior: 38561528!
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: 'misc' stamp: 'sw 9/27/2001 04:53'!
noteCompilationOf: aSelector meta: isMeta
	"Any change to an additionsToViewer... method can invalidate existing etoy vocabularies"

	(isMeta and: [aSelector beginsWith: 'additionsToViewer']) ifTrue:
		[Vocabulary changeMadeToViewerAdditions]! !

!Morph class methodsFor: 'misc' stamp: 'nk 9/29/2003 15:53' prior: 38564161!
noteCompilationOf: aSelector meta: isMeta
	"Any change to an additionsToViewer... method can invalidate existing etoy vocabularies"

	(isMeta and: [aSelector beginsWith: 'additionsToViewer']) ifTrue:
		[Vocabulary changeMadeToViewerAdditions].
	super noteCompilationOf: aSelector meta: isMeta! !

!Morph class methodsFor: '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: '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: '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: '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: 'scripting' stamp: 'sw 12/11/2001 10:16'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories.  The special generic Morph version factors each category definition into a separate method; to solve recurrent fileout-ordering problems, this method can still function even if some of those separate methods are absent."

		^ #(additionsToViewerCategoryBasic additionsToViewerCategoryScripts additionsToViewerCategoryColorAndBorder additionsToViewerCategoryGeometry additionsToViewerCategoryMiscellaneous additionsToViewerCategoryButton additionsToViewerCategoryMotion additionsToViewerCategoryObservation additionsToViewerCategoryPenUse additionsToViewerCategoryLayout additionsToViewerCategoryDragAndDrop additionsToViewerCategoryScripting additionsToViewerCategoryTests)

		select:
			[:aSelector | self respondsTo: aSelector]
		thenCollect:
			[:aSelector | self perform: aSelector]

"Morph additionsToViewerCategories size"
! !

!Morph class methodsFor: 'scripting' stamp: 'sw 9/10/2001 08:36'!
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 additionsToViewerCategories do:
		[:anAddition | anAddition first == aCategoryName ifTrue: [^ anAddition second]].
	^ #()! !

!Morph class methodsFor: '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: 'scripting' stamp: 'sw 12/9/2001 23:56'!
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 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 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: '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: '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: 'scripting' stamp: 'sw 10/24/2001 19:45'!
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 stampAndErase 'add my image to the pen trails and go away')
		)
	)

! !

!Morph class methodsFor: 'scripting' stamp: 'sw 9/27/2001 17:40'!
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 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: '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: 'scripting' stamp: 'tk 10/4/2001 17:27'!
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 penArrowheads 'whether to show arrowheads at the ends of pen strokes' Boolean readWrite Player getPenArrowheads Player setPenArrowheads:)
			(command clearOwnersPenTrails 'clear all pen trails in my containing playfield')
		)
	)
! !

!Morph class methodsFor: 'scripting' stamp: 'sw 4/17/2003 12:05' prior: 38578814!
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: 'scripting' stamp: 'sw 12/3/2001 19:22'!
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 tellAllSiblings: 'send a message to all siblings' ScriptName)
		)
	)

! !

!Morph class methodsFor: 'scripting' stamp: 'sw 2/19/2003 18:04' prior: 38580464!
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: '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: 'scripting' stamp: 'sw 9/6/2002 13:20'!
additionsToViewerCategoryTests
	"Answer viewer additions for the 'tests' category.  Note that isOverColor is commented out owing to intractable performance problems in continuously evaluating it in a Viewer -- someone should attend to this someday."

	^#(
		#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 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: 'scripting' stamp: 'ar 12/27/2001 00:04'!
helpContributions
	"Answer a list of pairs of the form (<symbol> <help message> ) to contribute to the system help dictionary"
	
"NB: Many of the items here are not needed any more since they're specified as part of command definitions now.  Someone needs to take the time to go through the list and remove items no longer needed.  But who's got that kind of time?"

	^ #(
		(acceptScript:for:
			'submit the contents of the given script editor as the code defining the given selector')
		(actorState
			'return the ActorState object for the receiver, creating it if necessary')
		(addInstanceVariable
			'start the interaction for adding a new instance variable to the receiver')
		(addPlayerMenuItemsTo:hand:
			'add player-specific menu items to the given menu, on behalf of the given hand.  At present, these are only commands relating to the turtle')
		(addYesNoToHand
			'Press here to tear off a  TEST/YES/NO unit which you can drop into your script')
		(allScriptEditors
			'answer a list off the extant ScriptEditors for the receiver')
		(amount
			'The amount of displacement')
		(angle	
			'The angular displacement')
		(anonymousScriptEditorFor:
			'answer a new ScriptEditor object to serve as the place for scripting an anonymous (unnamed, unsaved) script for the receiver')
		(append:
			'add an object to this container')
		(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 an instance variable defined by you.  Click here to change its type')
		(valueAtCursor
			'The chosen element')
		(wearCostumeOf:
			'Wear the same kind of costume as the other object')
		(width	
			'The distance between the left and right edges of the object')
		(wrap
			'If object has strayed beond the boundaries of its container, make it reappear from the opposite edge.')
		(x
			'The x coordinate, measured from the left of the container')
		(y
			'The y-coordinate, measured upward from the bottom of the container')

		)
! !

!Morph class methodsFor: 'scripting' stamp: 'sw 2/26/2003 23:35' prior: 38583758!
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: '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: 'arrow head size'!
defaultArrowheadSize
	
	^ 5 @ 4! !

!Morph class methodsFor: '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].! !

!MorphExample methodsFor: 'initialization' stamp: 'di 11/20/2001 21:27'!
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: 'initialization' stamp: 'dgd 2/21/2003 19:59' prior: 38601515!
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: 'di 11/20/2001 21:31'!
step
	phase _ phase\\8 + 1.
	phase = 1 ifTrue: [^ ball delete].
	phase = 4 ifTrue: [self addMorph: ball].
	ball align: ball center with: (star vertices at: (phase-3*2)).! !

!MorphExample methodsFor: 'stepping and presenter' stamp: 'kfr 10/26/2003 18:33' prior: 38602086!
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)).! !

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



!
!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:56' prior: 24944737!
actorState
	"answer the redeiver's actorState"
	^ actorState ! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53' prior: 24944838!
actorState: anActorState 
"change the receiver's actorState"
	actorState _ anActorState! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51' prior: 24945302!
balloonTextSelector: aSymbol 
	"change the receiver's balloonTextSelector"
	balloonTextSelector _ aSymbol! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51' prior: 24945440!
eventHandler
	"answer the receiver's eventHandler"
	^ eventHandler ! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57' prior: 24945774!
externalName: aString 
	"change the receiver's externalName"
	externalName _ aString! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:37' prior: 24945898!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	^ isPartsDonor! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:40' prior: 24946003!
isPartsDonor: aBoolean 
	"change the receiver's isPartDonor property"
	isPartsDonor _ aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38' prior: 24946127!
locked
	"answer whether the receiver is Locked"
	^ locked! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48' prior: 24946220!
locked: aBoolean 
	"change the receiver's locked property"
	locked _ aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42' prior: 24946332!
player
	"answer the receiver's player"
	^ player! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53' prior: 24946425!
player: anObject 
	"change the receiver's player"
	player _ anObject ! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47' prior: 24946630!
sticky: aBoolean 
	"change the receiver's sticky property"
	sticky _ aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41' prior: 24946742!
visible
	"answer whether the receiver is visible"
	^ visible! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32' prior: 24956592!
layoutFrame: aLayoutFrame 
	aLayoutFrame isNil
		ifTrue: [self removeProperty: #layoutFrame]
		ifFalse: [self setProperty: #layoutFrame toValue: aLayoutFrame]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32' prior: 24956981!
layoutPolicy: aLayoutPolicy 
	aLayoutPolicy isNil
		ifTrue: [self removeProperty: #layoutPolicy]
		ifFalse: [self setProperty: #layoutPolicy toValue: aLayoutPolicy]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32' prior: 24957384!
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: 'dgd 2/16/2003 21:05'!
assureOtherProperties
	"creates an otherProperties for the receiver if needed"
	self hasOtherProperties
		ifFalse: [self initializeOtherProperties].
	^ self otherProperties! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:03'!
hasOtherProperties
	"answer whether the receiver has otherProperties"
	^ self otherProperties notNil! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:15' prior: 24946956!
hasProperty: aSymbol 
	"Answer whether the receiver has the property named aSymbol"
	| property |
	self hasOtherProperties
		ifFalse: [^ false].
	property _ self otherProperties
				at: aSymbol
				ifAbsent: [].
	property isNil
		ifTrue: [^ false].
	property == false
		ifTrue: [^ false].
	^ true! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:12'!
initializeOtherProperties
	"private - initializes the receiver's otherProperties"
	self privateOtherProperties: IdentityDictionary new! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:04' prior: 24947403!
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: 'dgd 2/16/2003 21:12' prior: 24955429!
removeOtherProperties
	"Remove the 'other' properties"
	self privateOtherProperties: nil! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:17' prior: 24947518!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	self hasOtherProperties
		ifFalse: [^ self].
	self otherProperties
		removeKey: aSymbol
		ifAbsent: [].
	self otherProperties isEmpty
		ifTrue: [self removeOtherProperties]! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:49' prior: 24947775!
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: 'dgd 2/22/2003 13:32' prior: 24955578!
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].
	self hasOtherProperties 
		ifTrue: [self 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' prior: 24948092!
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:09' prior: 24948249!
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"
	self hasOtherProperties
		ifFalse: [^ aBlock value].
	^ self otherProperties
		at: aSymbol
		ifAbsent: [^ aBlock value]! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'sw 9/28/2001 08:39'!
valueOfProperty: propName 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"

	otherProperties == nil ifTrue: [otherProperties _ IdentityDictionary new].
	^ otherProperties at: propName ifAbsentPut: aBlock! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:28' prior: 38609862!
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: 'copying' stamp: 'dgd 2/22/2003 13:32' prior: 24949301!
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])]]].
	self hasOtherProperties 
		ifTrue: 
			[""

			self otherProperties associationsDo: 
					[:assn | 
					assn value: (aDictionary at: assn value ifAbsent: [assn value])]]! !

!MorphExtension methodsFor: 'copying' stamp: 'dgd 2/16/2003 21:11' prior: 24950190!
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!!!!"
	| list |
	super veryDeepFixupWith: deepCopier.
	self hasOtherProperties
		ifTrue: [""
			list _ self copyWeakly.
			"Properties whose values are only copied weakly"
			"replace those values if they were copied via another  
			path"
			list
				do: [:pp | ""
					(self otherProperties
						at: pp
						ifAbsent: [])
						ifNotNil: [""
							self otherProperties
								at: pp
								put: (deepCopier references
										at: (self otherProperties at: pp)
										ifAbsent: [self otherProperties at: pp])]]]! !

!MorphExtension methodsFor: 'copying' stamp: 'dgd 2/16/2003 21:13' prior: 24950884!
veryDeepInner: deepCopier 
	"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."
	| list values vv |
	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"
	self hasOtherProperties
		ifTrue: [""
			self privateOtherProperties: self otherProperties copy.
			list _ self copyWeakly.
			"Properties whose values are only copied weakly"
			values _ list
						collect: [:pp | 
							vv _ self otherProperties
										at: pp
										ifAbsent: [].
							vv
								ifNotNil: [self otherProperties at: pp put: nil].
							"zap it"
							vv].
			self
				privateOtherProperties: (self otherProperties veryDeepCopyWith: deepCopier).
			1
				to: list size
				do: [:ii | "put old values back"
					(values at: ii)
						ifNotNil: [self otherProperties
								at: (list at: ii)
								put: (values at: ii)]]]! !

!MorphExtension methodsFor: 'object fileIn' stamp: 'dgd 2/16/2003 21:06' prior: 24952681!
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: 'other' stamp: 'tk 10/18/2002 17:10'!
inspectElement
	| key obj |
	"Create and schedule an Inspector on the otherProperties and the named properties."

	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: 'dgd 2/16/2003 21:09' prior: 38614904!
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 _ self 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: 'dgd 2/16/2003 21:14' prior: 24953732!
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].
	self hasOtherProperties
		ifTrue: [self otherProperties isEmpty
				ifFalse: [^ false]].
	^ true! !

!MorphExtension methodsFor: 'printing' stamp: 'dgd 2/16/2003 21:58' prior: 24954329!
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 , '] '].
	self hasOtherProperties
		ifTrue: [self otherProperties isEmpty
				ifFalse: [^ self]].
	aStream nextPutAll: ' [other: '.
	self otherProperties
		keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')'].
	aStream nextPut: $]! !

!MorphExtension methodsFor: 'printing' stamp: 'nk 7/20/2003 11:00' prior: 38616585!
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 , '] '].
	(self hasOtherProperties not or: [ self otherProperties isEmpty ])
		ifTrue: [^ self].
	aStream nextPutAll: ' [other: '.
	self otherProperties
		keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')'].
	aStream nextPut: $]! !

!MorphTest methodsFor: 'initialize-release' stamp: 'md 4/16/2003 17:10'!
setUp
	morph := Morph new.! !

!MorphTest methodsFor: 'initialize-release' stamp: 'md 4/16/2003 17:10'!
tearDown
	morph delete.! !

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

!MorphTest methodsFor: 'testing - classification' stamp: 'md 4/16/2003 17:11'!
testIsMorph
	self assert: (morph isMorph).! !

!MorphTest methodsFor: 'testing - initialization' stamp: 'md 4/16/2003 17:10'!
testOpenInWorld
	self shouldnt: [morph openInWorld] raise: Error.! !

!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!
!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 14:41' prior: 24962870!
revealOriginal
	((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) 
		ifTrue: [^self beep].
	morphRepresented owner isNil 
		ifTrue: [^owner replaceSubmorph: self by: morphRepresented].
	self beep! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'md 10/22/2003 15:24' prior: 38623899!
revealOriginal
	((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) 
		ifTrue: [^Beeper beep].
	morphRepresented owner isNil 
		ifTrue: [^owner replaceSubmorph: self by: morphRepresented].
	Beeper beep! !

!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' prior: 24961528!
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' prior: 24960358!
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: 'parts bin' stamp: 'dgd 2/16/2003 21:37' prior: 24963318!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	^ self partRepresented isPartsDonor! !

!MorphThumbnail methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:40' prior: 24963440!
isPartsDonor: aBoolean
	"change the receiver's isPartDonor property"
	self partRepresented isPartsDonor: aBoolean! !

!MorphWithSubmorphsWrapper methodsFor: 'hierarchy' stamp: 'ls 3/1/2004 17:34'!
contents
	^item submorphs collect: [ :m |
		self class with: m ]! !

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

!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'aoy 2/17/2003 01:26' prior: 24969091!
updateSubWindowExtent
	"If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView."

	| numMorphs subWindow scrollBarWidth |
	numMorphs := model submorphs size.
	"(Allow for the existence of an extra NewHandleMorph (for resizing).)"
	(numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^self].
	subWindow := model submorphs detect: [:ea | ea respondsTo: #label]
				ifNone: [^self].
	superView label = subWindow label ifFalse: [^self].
	scrollBarWidth := (Preferences valueOfFlag: #inboardScrollbars) 
				ifTrue: [0]
				ifFalse: [14]. 
	subWindow position: model position + (scrollBarWidth @ -16).	"adjust for WiW changes"
	subWindow extent: model extent - (scrollBarWidth @ -16).
	subWindow isActive ifFalse: [subWindow activate]! !

!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: '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: 'dgd 2/14/2003 20:47' prior: 24997018!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	open _ false! !

!MorphicModel methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:53' prior: 25005820!
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: 'naming' stamp: 'dgd 2/21/2003 23:00' prior: 24999748!
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: 'submorphs-accessing' stamp: 'sw 3/28/2001 10:01'!
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 ~~ nil) and: [e knownName ~~ nil]] thenCollect: [:e | e knownName])]
		ifFalse:
			[superNames]! !

!MorphicModel methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 18:51' prior: 38629818!
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' prior: 24996019!
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 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: 'prototype access' stamp: 'gm 2/22/2003 19:13' prior: 25010800!
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' 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"! !

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

!MouseButtonEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:00' prior: 25026101!
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: '*geniestubs-accessing' stamp: 'nk 3/11/2004 17:44'!
whichButton
	^whichButton! !

!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: 'jcg 9/21/2001 13:16'!
handleEvent: evt from: aHand
	"Process the given mouse event to detect a click, double-click, or drag.
	Return true if the event should be processed by the sender, false if it shouldn't.
	NOTE: This method heavily relies on getting *all* mouse button events."
	| localEvt timedOut isDrag |
	timedOut _ (evt timeStamp - firstClickTime) > dblClickTime.
	localEvt _ evt transformedBy: (clickClient transformedFrom: aHand owner).
	isDrag _ (localEvt cursorPoint - firstClickDown cursorPoint) r > dragThreshold.
	clickState == #firstClickDown ifTrue: [
		"Careful here - if we had a slow cycle we may have a timedOut mouseUp event"
		(timedOut and:[localEvt isMouseUp not]) ifTrue:[
			"timeout before #mouseUp -> keep waiting for drag if requested"
			clickState _ #firstClickTimedOut.
			dragSelector ifNil:[
				aHand resetClickState.
				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: localEvt].
			^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: localEvt. "***"
			^true].
		^false].

	clickState = #firstClickUp ifTrue:[
		(timedOut) ifTrue:[
			"timed out after mouseUp - send #click: and mouseUp"
			aHand resetClickState.
			self doubleClickTimeout. "***"
			^true].
		localEvt isMouseDown ifTrue:["double click"
			aHand resetClickState.
			self doubleClick.
			^false]].
	^true! !

!MouseClickState methodsFor: 'event handling' stamp: 'nk 5/8/2003 19:10' prior: 38634932!
handleEvent: evt from: aHand
	"Process the given mouse event to detect a click, double-click, or drag.
	Return true if the event should be processed by the sender, false if it shouldn't.
	NOTE: This method heavily relies on getting *all* mouse button events."
	| localEvt timedOut isDrag |
	timedOut _ (evt timeStamp - firstClickTime) > dblClickTime.
	localEvt _ evt transformedBy: (clickClient transformedFrom: aHand owner).
	isDrag _ (localEvt cursorPoint - firstClickDown cursorPoint) r > dragThreshold.
	clickState == #firstClickDown ifTrue: [
		"Careful here - if we had a slow cycle we may have a timedOut mouseUp event"
		(timedOut and:[localEvt isMouseUp not]) ifTrue:[
			"timeout before #mouseUp -> keep waiting for drag if requested"
			clickState _ #firstClickTimedOut.
			dragSelector ifNil:[
				aHand resetClickState.
				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: localEvt].
			^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: localEvt. "***"
			^true].
		^false].

	clickState = #firstClickUp ifTrue:[
		(timedOut) ifTrue:[
			"timed out after mouseUp - send #click: and mouseUp"
			aHand resetClickState.
			self doubleClickTimeout. "***"
			^true].
		localEvt isMouseDown ifTrue:["double click"
			clickState _ #secondClickDown.
			^false]].

	clickState == #secondClickDown ifTrue: [
		localEvt isMouseUp ifTrue: ["double click"
			aHand resetClickState.
			self doubleClick.
			^false]
	].

	^true! !

!MouseClickState methodsFor: 'event handling' stamp: 'nk 2/17/2004 12:01' prior: 38637133!
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 - send #click: and mouseUp"
			aHand resetClickState.
			self doubleClickTimeout. "***"
			^true].
		localEvt isMouseDown ifTrue:["double click"
			clickState _ #secondClickDown.
			^false]].

	clickState == #secondClickDown ifTrue: [
		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.! !

!MouseDownMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45' prior: 25034837!
handlesMouseDown: evt 
	^model notNil! !

!MouseDownMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:54' prior: 25031762!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
"template..."
	aCustomMenu addLine.
	aCustomMenu add: 'set variable name...' translated action: #renameMe.
	aCustomMenu addLine.
	aCustomMenu add: 'plug mouseDown to model slot' translated action: #plugMouseDownToSlot.
	aCustomMenu add: 'plug mouseMove to model slot' translated action: #plugMouseMoveToSlot.
	aCustomMenu add: 'plug all to model slots' translated action: #plugAllToSlots.
	aCustomMenu addLine.
	aCustomMenu add: 'plug mouseDown to model' translated action: #plugMouseDownToModel.
	aCustomMenu add: 'plug mouseMove to model' translated action: #plugMouseMoveToModel.
	aCustomMenu add: 'plug all to model' translated action: #plugAllToModel.
	aCustomMenu addLine.
	aCustomMenu add: 'set target...' translated action: #setTarget.
	aCustomMenu add: 'set mouseDown selector...' translated action: #setMouseDownSelector.
	aCustomMenu add: 'set mouseMove selector...' translated action: #setMouseMoveSelector.
	aCustomMenu add: 'set mouseUp selector...' translated action: #setMouseUpSelector.
! !

!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17' prior: 25038229!
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' prior: 25038394!
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' prior: 25038790!
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: 'NS 5/19/2003 15:17' prior: 25039237!
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 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! !

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

!MouseMoveEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:01' prior: 25049324!
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)! !

!MouseOverHandler methodsFor: 'event handling' stamp: 'ar 4/23/2001 17:22'!
processMouseOver: anEvent
	"Re-establish the z-order for all morphs wrt the given event"
	| hand localEvt focus evt |
	hand _ anEvent hand.
	leftMorphs _ mouseOverMorphs asIdentitySet.
	"Assume some coherence for the number of objects in over list"
	overMorphs _ WriteStream on: (Array new: leftMorphs size).
	enteredMorphs _ WriteStream on: #().
	"Now go looking for eventual mouse overs"
	hand handleEvent: anEvent asMouseOver.
	"Get out early if there's no change"
	(leftMorphs size = 0 and:[enteredMorphs position = 0]) 
		ifTrue:[^leftMorphs _ enteredMorphs _ overMorphs _ nil].
	focus _ hand mouseFocus.
	"Send #mouseLeave as appropriate"
	evt _ anEvent asMouseLeave.
	"Keep the order of the left morphs by recreating it from the mouseOverMorphs"
	leftMorphs size > 1 ifTrue:[leftMorphs _ mouseOverMorphs select:[:m| leftMorphs includes: m]].
	leftMorphs do:[:m|
		(m == 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: 'event handling' stamp: 'dgd 2/21/2003 23:00' prior: 38646040!
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! !

!MouseOverMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:40' prior: 25052563!
handlesMouseOver: evt 
	^model notNil! !

!MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:09' prior: 25061743!
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: 'dgd 2/22/2003 14:09' prior: 25065693!
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]! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'dgd 2/21/2003 22:58' prior: 25073433!
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)]! !

!MovieMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:47' prior: 25075867!
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' prior: 25076061!
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' prior: 25075021!
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: 'dgd 8/30/2003 21:55' prior: 25076691!
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 isKindOf: SketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
	aCustomMenu add: 'movie...' translated subMenu: subMenu
! !

!MovieMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:47' prior: 25077933!
editDrawing
	| frame |
	frame := self currentFrame.
	frame notNil 
		ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]! !

!MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:03' prior: 25079348!
currentFrame
	frameList isEmpty ifTrue: [^nil].
     currentFrameIndex := currentFrameIndex min: (frameList size).
     currentFrameIndex := currentFrameIndex max: 1.
	^frameList at: currentFrameIndex! !

!MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:08' prior: 25080021!
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! !

!MoviePlayerMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 19:01' prior: 25085057!
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: 'dgd 2/14/2003 22:07' prior: 25085314!
setInitialState
	super setInitialState.
""
	self layoutInset: 3.
	pageSize _ frameSize _ 200 @ 200.
	frameDepth _ 8.
	self disableDragNDrop! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:22' prior: 25085586!
stopSoundTrackIfAny
	scorePlayer isNil ifTrue: [^self].
	(scorePlayer isKindOf: SampledSound) 
		ifTrue: [scorePlayer endGracefully]
		ifFalse: [scorePlayer := nil]! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 13:21' prior: 25099006!
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: 'dgd 2/22/2003 13:21' prior: 25099890!
invokeBookMenu
	"Invoke the book's control panel menu."

	| aMenu |
	aMenu := MVCMenuMorph new defaultTarget: self.
	aMenu add: 'make a new movie' action: #makeAMovie.
	aMenu add: 'open movie file' action: #openMovieFile.
	aMenu add: 'add sound track' action: #addSoundTrack.
	aMenu addLine.
	scorePlayer ifNotNil: 
			[soundTrackForm isNil 
				ifTrue: [aMenu add: 'show sound track' action: #showHideSoundTrack]
				ifFalse: [aMenu add: 'hide sound track' action: #showHideSoundTrack]].
	aMenu add: 'make thumbnail' action: #thumbnailForThisPage.
	cueMorph ifNotNil: 
			["Should check if piano roll and score already have a start event
		prior to this time."

			aMenu add: 'end clip here' action: #endClipHere].
	aMenu popUpEvent: self world activeHand lastEvent in: self world! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'dgd 10/8/2003 19:32' prior: 38657568!
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: 'navigation' stamp: 'md 12/12/2003 16:21' prior: 25091759!
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: 'stepping' stamp: 'mir 6/4/2001 11:02'!
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 == nil
		ifTrue: [ms _ Time millisecondClockValue.
				msAtStart _ ms - ((frameNumber-1) * msPerFrame).
				msAtLastSync _ ms - msAtStart.
				frameAtLastSync _ frameNumber]
		ifFalse: [(playDirection > 0 and: [scorePlayer isKindOf: SampledSound]) ifTrue:
					[scorePlayer reset;
							playSilentlyUntil: (frameNumber - 1 * msPerFrame / 1000.0);						initialVolume: 1.0.
					[scorePlayer resumePlaying.
					msAtLastSync _ scorePlayer millisecondsSinceStart]
						forkAt: Processor userInterruptPriority].
				msAtLastSync _ scorePlayer millisecondsSinceStart.
				frameAtLastSync _ frameNumber]! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:22' prior: 38659677!
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' prior: 25095309!
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' prior: 25097998!
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: 'private' stamp: 'sw 5/23/2001 13:51'!
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.
	(Smalltalk platformName = 'Mac OS') ifTrue:[
		(Smalltalk 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 ' , (Smalltalk extraVMMemory printString) , ' allocated.
You can evaluate ''Smalltalk extraVMMemory'' to check your allocation,
and ''Smalltalk extraVMMemory: 485000'' or the like to increase your allocation.
Note that raising your allocation in this way only marks your image as
needing this much, so you must then save, quit, and start over again
before you can run this movie.  Good luck.']].
! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'md 10/26/2003 13:07' prior: 38665154!
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 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: 'sd 2/1/2002 22:18'!
services

	^ Array with: self serviceOpenAsMovie

	! !

!MoviePlayerMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'!
unload

	FileList unregisterFileReader: self ! !

!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: 'yo 2/15/2001 15:58'!
initialize

	super initialize.
	self color: Color black.
	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: 'initialization' stamp: 'dgd 3/7/2003 14:42' prior: 38670103!
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 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'! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:16'!
asBinaryOrTextStream

	^ self
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:16'!
ascii
	isBinary _ false
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 16:01'!
basicNext

	^ super next 
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:20'!
basicNext: anInteger.

	^ super next: anInteger.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicNext: n into: aString

	^ super next: n into: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicNextInto: aString

	^ super nextInto: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicNextPut: char

	^ super nextPut: char.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicNextPutAll: aString

	^ super nextPutAll: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicPeek

	^ super peek
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicPosition

	^ super position.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:21'!
basicPosition: pos

	^ super position: pos.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:16'!
binary
	isBinary _ true
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:26'!
contents

	^ self upToEnd.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 8/7/2003 09:03'!
converter

	converter ifNil: [converter _ UTF8TextConverter new].
	^ converter
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 8/7/2003 09:12'!
converter: aConverter

	converter _ aConverter.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 11/11/2002 13:25'!
isBinary
	^ isBinary! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 11/12/2002 04:28'!
next: anInteger 

	| multiString |
	"self halt."
	self isBinary ifTrue: [^ (super next: anInteger) asByteArray].
	multiString _ MultiString 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: 'as yet unclassified' stamp: 'yo 11/11/2002 13:24'!
nextDelimited: terminator

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	self next = terminator ifFalse: [
		"absorb initial terminator"
		self position: (self position - converter currentCharSize)
	].
	[(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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 11/14/2002 13:54'!
nextPut: aCharacter

	aCharacter isInteger ifTrue: [^ super nextPut: aCharacter asCharacter].
	^ self converter nextPut: aCharacter toStream: self
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:24'!
nextPutAll: aCollection

	self isBinary ifTrue: [
		^ super nextPutAll: aCollection.
	].
	aCollection do: [:e | self nextPut: e].
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 11/11/2002 13:25'!
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 next.
	self position: self position - converter currentCharSize.
	^ next.

! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/7/2003 09:13'!
reset

	super reset.
	isBinary ifNil: [isBinary _ false].
	collection class == ByteArray ifTrue: ["Store as String and convert as needed."
		collection _ collection asString.
		isBinary _ true].

	converter ifNil: [converter _ UTF8TextConverter new].
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 13:49'!
setFileTypeToObject
	"do nothing.  We don't have a file type"! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 16:17'!
skipSeparators

	[self atEnd] whileFalse: [
		self basicNext isSeparator ifFalse: [
			^ self position: self position - 1]]

! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 13:24'!
skipSeparatorsAndPeekNext

	"A special function to make nextChunk fast"
	| peek |
	[self atEnd] whileFalse: [
		(peek _ self next) isSeparator ifFalse: [
			self position: self position - converter currentCharSize.
			^ peek.
		].
	].
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 16:33'!
text
	isBinary _ false
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 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! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:06'!
accepts: aSymbol

 	^ converter accepts: aSymbol.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 16:34'!
basicNext

	^ super basicNext 
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:06'!
basicNext: anInteger.

	^ super next: anInteger.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:07'!
basicNext: n into: aString

	^ super next: n into: aString.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:07'!
basicNextInto: aString

	^ super nextInto: aString.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:07'!
basicNextPut: char

	^ super nextPut: char.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:07'!
basicNextPutAll: aString

	^ super nextPutAll: aString.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:07'!
basicPeek

	^ super peek
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicPosition

	^ super position.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicPosition: pos

	^ super position: pos.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicReadInto: byteArray startingAt: startIndex count: count

	^ super readInto: byteArray startingAt: startIndex count: count.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicSetToEnd

	^ super setToEnd.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicSkip: n

	^ super skip: n.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:08'!
basicUpTo: delim

	^ super upTo: delim.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:09'!
basicVerbatim: aString

	^ super verbatim: aString.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:11'!
converter

	converter ifNil: [converter _ TextConverter defaultSystemConverter].
	^ converter
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:09'!
converter: aConverter

	converter _ aConverter.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/6/2003 11:56'!
fileInEncodingName: aString

	self converter: (TextConverter newForEncoding: aString).
	super fileIn.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/30/2002 16:35'!
next

	^ self converter nextFromStream: self
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:11'!
next: anInteger 

	| multiString |
	self isBinary ifTrue: [^ super next: anInteger].
	multiString _ MultiString 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.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:12'!
nextDelimited: terminator

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	self next = terminator ifFalse: [
		"absorb initial terminator"
		self position: (self position - converter currentCharSize)
	].
	[(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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 12/30/2002 10:53'!
nextPut: aCharacter

	| leadingChar |
	aCharacter isInteger ifTrue: [^ super nextPut: aCharacter].
	leadingChar _ aCharacter leadingChar.
	"((EncodedCharSet charsetAt: leadingChar) isKindOf: Unicode class) ifTrue: [^ self]."
	^ self converter nextPut: aCharacter toStream: self
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/13/2003 11:53'!
open: fileName forWrite: writeMode

	| result |
	result _ super open: fileName forWrite: writeMode.
	result ifNotNil: [
		converter ifNil: [
			self localName = (FileDirectory localNameFor: Smalltalk sourcesName) ifTrue: [
				converter _ MacRomanTextConverter new
			] ifFalse: [
				converter _ UTF8TextConverter new.
			].
		].
	].
	^result.
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:14'!
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 next.
	self position: self position - converter currentCharSize.
	^ next.

! !

!MultiByteFileStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'yo 8/13/2003 13:51'!
reset

	super reset.
	converter ifNil: [
		converter _ UTF8TextConverter new.
	].
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 16:37'!
skipSeparators

	[self atEnd] whileFalse: [
		self basicNext isSeparator ifFalse: [
			^ self position: self position - 1]]


"	[self atEnd] whileFalse: [
		self next isSeparator ifFalse: [
			^ self position: self position - converter currentCharSize.
		].
	].
"
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:16'!
skipSeparatorsAndPeekNext

	"A special function to make nextChunk fast"
	| peek |
	[self atEnd] whileFalse: [
		(peek _ self next) isSeparator ifFalse: [
			self position: self position - converter currentCharSize.
			^ peek.
		].
	].
! !

!MultiByteFileStream methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 class methodsFor: 'as yet unclassified' 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.
! !

!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'!
doesDisplaying
	^false   "it doesn't do displaying using copyBits"! !

!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'!
setFont
	foregroundColor ifNil: [foregroundColor _ Color black].
	super setFont.
	destY _ lineY + line baseline - font ascent! !

!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'!
textColor: color
	foregroundColor _ color! !

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

!MultiCharacter methodsFor: 'converting' stamp: 'yo 11/30/2003 16:09'!
asUnicode

	| table charset v |
	charset _ EncodedCharSet charsetAt: self leadingChar.
	(charset isKindOf: Unicode class) ifTrue: [^ self charCode].
	table _ charset ucsTable.
	table isNil ifTrue: [^ 16rFFFD].

	v _ table at: self charCode + 1.
	v = -1 ifTrue: [^ 16rFFFD].

	^ v.
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:08'!
asCharacter

	^ self isOctetCharacter
		ifTrue: [Character value: self asciiValue]
		ifFalse: [self]! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:10'!
asString

	^MultiString with: self.
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:12'!
hash

	"Hash is reimplemented because = is implemented."
	^ value
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 13:33'!
hex

	^ value hex.
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:10'!
isoToSqueak

	^ self.
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:11'!
squeakToIso 

	^ self
! !

!MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:11'!
value: anInteger

	value _ anInteger.
! !

!MultiCharacter methodsFor: 'testing' stamp: 'yo 12/30/2002 15:56'!
isUnicode

	^ (EncodedCharSet charsetAt: self leadingChar) isKindOf: Unicode class.
! !

!MultiCharacter methodsFor: 'comparing' stamp: 'yo 9/2/2002 16:51'!
= other

	^(other isCharacter) and: [self asciiValue = other asciiValue].
! !

!MultiCharacter class methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:44'!
allCharacters

	self shouldNotImplement.
! !

!MultiCharacter class methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 11:45'!
from: aCharacter

	^ self value: aCharacter asciiValue.
! !

!MultiCharacter class methodsFor: 'as yet unclassified' stamp: 'yo 12/30/2002 11:01'!
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.
! !

!MultiCharacter class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 16:39'!
value: anInteger

	anInteger < 256
		ifTrue: [^ Character value: anInteger].
	^ self basicNew value: anInteger.
! !

!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: 'yo 12/18/2002 13:56'!
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 == nil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint _ line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex ~~ nil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
					textLine: line].
	destX _ leftMargin _ line leftMarginForAlignment: alignment.
	destY _ line top.
	runLength _ text runLengthFor: line first.
	characterIndex ~~ nil
		ifTrue:	[lineStop _ characterIndex  "scanning for index"]
		ifFalse:	[lineStop _ line last  "scanning for point"].
	runStopIndex _ lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0.

	done  _ false.
	[done] whileFalse:
		[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth == nil
			ifTrue: [font widthOf: (text at: lastIndex)]
			ifFalse: [specialWidth]).
		(self perform: stopCondition) ifTrue:
			[characterIndex == nil
				ifTrue: ["Result for characterBlockAtPoint: "
						^ (CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifFalse: ["Result for characterBlockForIndex: "
						^ (CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern) - kern @ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !

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

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
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! !

!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: 'yo 12/18/2002 13:56'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (textStyle 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! !

!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: 'yo 12/18/2002 13:53'!
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 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 8/6/2003 05:56'!
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: [
		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: [^ stops at: CrossedX].
		destX _ nextDestX + kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 8/18/2003 17:49'!
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| charCode encoding f nextDestX maxAscii startEncoding combining combined combiningIndex |
	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.
	].

	combining _ nil.
	[lastIndex <= stopIndex] whileTrue: [
		charCode _ (sourceString at: lastIndex) charCode.
		combining ifNil: [
			combining _ CombinedChar new.
			combining add: charCode.
			combiningIndex _ lastIndex.
			lastIndex _ lastIndex + 1.
		] ifNotNil: [
			(combining add: charCode) ifFalse: [
				self addCharToPresentation: (combined _ combining combined).
				combining _ CombinedChar new.
				combining add: charCode.
				charCode _ combined charCode.
				encoding _ combined leadingChar.
				encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ 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: Latin1) ifTrue: [
					self registerBreakableIndex.
				].
				nextDestX _ destX + (self widthOf: combined inFont: font).
				nextDestX > rightX ifTrue: [
					lastIndex _ combiningIndex.
					self removeLastCharFromPresentation.
					^ stops at: CrossedX].
				destX _ nextDestX + kernDelta.
				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 8/18/2003 17:49'!
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: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
		(self isBreakableAt: lastIndex in: sourceString in: Latin1) 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: 'scanner methods' stamp: 'yo 8/18/2003 17:49'!
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: Latin1) 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 12/18/2002 13:53'!
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.
	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: 'yo 12/27/2002 04:33'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| startEncoding selector |
	(sourceString isKindOf: String) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.].

	(sourceString isKindOf: MultiString) 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: '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: '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 class methodsFor: 'instance creation' stamp: 'yo 12/18/2002 13:54'!
new
	^super new initialize! !

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

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/3/2003 12:09'!
addCharToPresentation: char

	presentation nextPut: char.
! !

!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 1/23/2003 14:26'!
removeLastCharFromPresentation

	presentation ifNotNil: [
		presentation position: presentation position - 1.
	].
! !

!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: '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 1/3/2003 11:55'!
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:	[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
! !

!MultiCompositionScanner methodsFor: 'scanning' stamp: 'yo 1/23/2003 17:58'!
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.
	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: (MultiString 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: 'yo 1/23/2003 17:58'!
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.
	presentationLine _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	numOfComposition _ 0.
	presentation _ TextStream on: (Text fromString: (MultiString 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: 'yo 12/18/2002 13:57'!
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]! !

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

!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 12/18/2002 13:58'!
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]! !

!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 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: 'MVC-compatibility' stamp: 'yo 12/18/2002 13:58'!
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].
			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]]! !

!MultiDisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 12/18/2002 13:58'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
	bitBlt _ BitBlt current 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 8/6/2003 11:48'!
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"! !

!MultiDisplayScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:58'!
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! !

!MultiDisplayScanner class methodsFor: 'queries' stamp: 'yo 12/18/2002 13:58'!
defaultFont
	^ TextStyle defaultFont! !

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

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:40'!
at: index 

	^ MultiCharacter value: (self basicAt: index).
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:42'!
at: index put: aCharacter 

	aCharacter isCharacter ifFalse: [
		self error: 'MultiStrings only store (descendents of) Characters'.
	].
	self basicAt: index put: aCharacter asciiValue.
! !

!MultiString 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).
! !

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

!MultiString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'!
byteSize

	^ self size * 4.
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:46'!
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: (MultiString with: delim) 
						startingAt: start ifAbsent: [min]]
			ifFalse: [ind _ self indexOfSubCollection: (MultiString from: delim) 
						startingAt: start ifAbsent: [min]].
			min _ min min: ind].
	^ min.
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 11/4/2002 12:05'!
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
			findMultiSubstring: key asMultiString
			in: self
			startingAt: start
			matchTable: nil.
	] ifFalse: [
		self
			findMultiSubstring: key asLowercase asMultiString
			in: self asLowercase
			startingAt: start
			matchTable: nil.
	].
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:20'!
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! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:21'!
indexOf: aCharacter

	^ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self startingAt: 1
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:22'!
indexOf: aCharacter startingAt: start

	^ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self startingAt: start.
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:23'!
indexOf: aCharacter  startingAt: start  ifAbsent: aBlock

	| ans |
	ans _ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self  startingAt: start.
	ans = 0
		ifTrue: [^ aBlock value]
		ifFalse: [^ ans]
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:24'!
indexOfAnyOf: aCharacterSet  startingAt: start ifAbsent: aBlock
	"returns the index of the first character in the given set, starting from start"

	| ans |
	ans _ MultiString findFirstInMultiString: self  inSet: aCharacterSet byteArrayMap startingAt: start.

	ans = 0
		ifTrue: [^ aBlock value]
		ifFalse: [^ ans]
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 10/31/2002 22:32'!
wordAt: index

	^ (self basicAt: index).
! !

!MultiString methodsFor: 'accessing' stamp: 'yo 11/3/2002 13:20'!
wordAt: index put: anInteger

	self basicAt: index put: anInteger.
! !

!MultiString methodsFor: 'encoding' stamp: 'yo 10/23/2002 23:32'!
getInteger32: location

	| integer |
	integer := 
		((self basicAt: location) bitShift: 24) +
		((self basicAt: location+1) bitShift: 16) +
		((self basicAt: location+2) bitShift: 8) +
		(self basicAt: location+3).

	integer > 1073741824 ifTrue: [^ 1073741824 - integer ].
	^ integer.
! !

!MultiString methodsFor: 'encoding' stamp: 'yo 10/23/2002 23:32'!
putInteger32: anInteger at: location

	| integer |
	integer _ anInteger.
	integer < 0 ifTrue: [integer :=  1073741824 - integer. ].
	self basicAt: location+3 put: (integer \\ 256).
	self basicAt: location+2 put: (integer bitShift: -8) \\ 256.
	self basicAt: location+1 put: (integer bitShift: -16) \\ 256.
	self basicAt: location put: (integer bitShift: -24) \\ 256.
! !

!MultiString methodsFor: 'encoding' stamp: 'yo 7/29/2003 22:45'!
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.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:17'!
asByteArray
	"Convert to a ByteArray with the ascii values of the string."

	| b |
	b _ ByteArray new: self size * 4.
	1 to: self size * 4 do: [:i |
		b at: i put: (self byteAt: i).
	].
	^ b.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 10/24/2002 14:09'!
asFileName

	| string |
	string _ self isOctetString
				ifTrue: [self]
				ifFalse: [self convertToSystemString].
	^ FileDirectory checkName: string fixErrors: true! !

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

!MultiString methodsFor: 'converting' stamp: 'yo 8/26/2002 23:08'!
asHtml

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/30/2002 16:44'!
asMultiString 

	^ self! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/30/2002 14:09'!
asMultiSymbol

	^ self asSymbol.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:18'!
asOctetString

	| n |
	self isOctetString ifFalse: [
		self error: 'I have non-single byte character(s)'.
	].
	n _ String new: self size.
	1 to: self size do: [:i |
		n basicAt: i put: (self basicAt: i).
	].
	^ n.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:47'!
asPacked

	self inject: 0 into: [:pack :next | pack _ pack * 16r100000000 + next asInteger].
! !

!MultiString methodsFor: 'converting' stamp: 'yo 11/4/2002 21:06'!
asTranslatedWording

	^ self
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:44'!
asUnHtml

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:45'!
capitalized

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 9/26/2003 11:51'!
convertToSystemString

	| readStream writeStream converter |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter _ Smalltalk systemLanguage defaultSystemConverter.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		converter nextPut: readStream next toStream: writeStream
	].
	converter emitSequenceToResetStateIfNeededOn: writeStream.
	^ writeStream contents.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 7/28/2003 14:20'!
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.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:47'!
encodeForHTTP

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 10/31/2002 22:30'!
substrings
	"Answer an array of the substrings that compose the receiver."

	^self findBetweenSubStrs: (MultiString from: Character separators).
! !

!MultiString methodsFor: 'converting' stamp: 'yo 10/31/2002 22:30'!
translateFrom: start to: stop table: table
	"translate the characters in the string by the given table, in place"

	self flag: #whatToDoWithThis.
	super translateFrom: start to: stop table: table.
! !

!MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:04'!
unzipped

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:22'!
< aString 

	^ (self multiStringCompare: self with: aString asMultiString collated: nil) = 1.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:35'!
<= aString

	^ (self multiStringCompare: self with: aString collated: nil) <= 2.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:36'!
= aString 

	aString isString ifFalse: [^ false].

	^ (self multiStringCompare: self with: (MultiString from: aString) collated: nil) = 2.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:37'!
> aString

	^ (self multiStringCompare: self with: aString collated: nil) = 3.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:37'!
>= aString

	^ (self multiStringCompare: self with: aString collated: nil) >= 2.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:38'!
beginsWith: prefix
	"Answer whether the receiver begins with the given prefix string."

	self size < prefix size ifTrue: [^ false].
	^ (self findMultiSubstring: (MultiString from: prefix) in: self startingAt: 1
			matchTable: nil) = 1
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 11/12/2002 10:59'!
caseInsensitiveLessOrEqual: aString 

	^ (self multiStringCompare: self with: aString asMultiString collated: CaseInsensitiveOrder) <= 2.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:39'!
caseSensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case sensitive."

	^ (self multiStringCompare: self with: aString collated: nil) <= 2
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 10/31/2002 22:31'!
compare: aString 
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
"

	^ self multiStringCompare: self with: aString collated: nil
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:41'!
crc16
	"Compute a 16 bit cyclic redundancy check."

	| crc |
	crc := 0.
	1 to: self size * 4 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.
! !

!MultiString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:14'!
sameAs: aString 
	"Answer whether the receiver sorts equal to aString. The 
	collation sequence is ascii with case differences ignored."

	^ (self multiStringCompare: self with: aString asMultiString collated: CaseInsensitiveOrder) = 2.

! !

!MultiString methodsFor: 'system primitives' stamp: 'yo 8/28/2002 14:35'!
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."

	^ self multiStringCompare: string1 with: string2 collated: order.
! !

!MultiString methodsFor: 'system primitives' stamp: 'yo 12/27/2002 04:34'!
findMultiSubstring: 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 c1 c2 |
	self var: #key declareC: 'unsigned int *key'.
	self var: #body declareC: 'unsigned int *body'.
	self var: #matchTable declareC: 'unsigned char *matchTable'.
	self var: #c1 declareC: 'unsigned int c1'.
	self var: #c2 declareC: 'unsigned int 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
! !

!MultiString methodsFor: 'system primitives' stamp: 'yo 11/4/2002 12:06'!
findSubstring: key in: body startingAt: start matchTable: matchTable

	^ self findMultiSubstring: key asMultiString in: body asMultiString startingAt: start matchTable: matchTable.
! !

!MultiString methodsFor: 'system primitives' stamp: 'yo 11/5/2002 15:14'!
multiStringCompare: 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 |
	self var: #string1 declareC: 'unsigned int *string1'.
	self var: #string2 declareC: 'unsigned int *string2'.
	self var: #order declareC: 'unsigned char *order'.

	order == nil ifTrue: [
		len1 _ string1 size.
		len2 _ string2 size.
		1 to: (len1 min: len2) do:
			[:i |
			c1 _ string1 basicAt: i.
			c2 _ string2 basicAt: i.
			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 basicAt: i.
		c2 _ string2 basicAt: i.
		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].
! !

!MultiString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:10'!
includesUnifiedCharacter

	^ self isUnicodeStringWithCJK
! !

!MultiString methodsFor: 'testing' stamp: 'yo 8/28/2002 22:43'!
isOctetString

	1 to: self size do: [:pos |
		(self basicAt: pos) >= 256 ifTrue: [^ false].
	].
	^ true.
! !

!MultiString methodsFor: 'testing' stamp: 'yo 12/30/2002 15:57'!
isUnicodeString

	self do: [:c |
		c isUnicode ifTrue: [
			^ true
		].
	].

	^ false.
! !

!MultiString methodsFor: 'testing' stamp: 'yo 12/30/2002 16:15'!
isUnicodeStringWithCJK

	self do: [:c |
		c isUnicodeCJK ifTrue: [
			^ true
		].
	].

	^ false.
! !

!MultiString methodsFor: 'private' stamp: 'yo 8/18/2003 11:02'!
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: (MultiCharacter leadingChar: UnicodeJapanese leadingChar code: (c asUnicode)) asciiValue.
		]
	].
! !

!MultiString methodsFor: 'private' stamp: 'yo 8/28/2002 16:56'!
replaceFrom: start to: stop with: replacement startingAt: repStart 

	<primitive: 105>
	replacement class == String ifTrue: [
		^ self replaceFrom: start to: stop with: (replacement asMultiString) startingAt: repStart.
	]. 

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

!MultiString methodsFor: 'internet' stamp: 'yo 8/26/2002 22:39'!
decodeQuotedPrintable
	"Assume receiver is in MIME 'quoted-printable' encoding, and decode it."

	self flag: #toBeImplemented.
! !

!MultiString methodsFor: 'internet' stamp: 'yo 8/26/2002 22:47'!
unescapePercents

	self flag: #toBeImplemented.
! !

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

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

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

!MultiString class methodsFor: 'enumeration' stamp: 'yo 8/5/2003 14:20'!
string: str hasEncoding: encoding

	str do: [:each | each leadingChar = encoding ifTrue: [^ true]].
	^ false.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:00'!
findFirstInMultiString: aString  inSet: inclusionMap  startingAt: start
	| i stringSize ascii more |
	
	self var: #aString declareC: 'unsigned int *aString'.
	self var: #inclusionMap declareC: 'char *inclusionMap'.

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

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:07'!
findFirstInString: aString  inSet: inclusionMap  startingAt: start

	^ self findFirstInMultiString: aString inSet: inclusionMap startingAt: start.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:05'!
indexOfAscii: anInteger inMultiString: aString startingAt: start

	| stringSize |

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

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

	^ 0
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:06'!
indexOfAscii: anInteger inString: aString startingAt: start

	^ self indexOfAscii: anInteger inMultiString: aString startingAt: start.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:16'!
multiStringHash: aString initialHash: speciesHash

	| stringSize hash low |

	self var: #aHash declareC: 'int speciesHash'.
	self var: #aString declareC: 'unsigned int *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.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 11/7/2002 14:18'!
stringHash: aString initialHash: speciesHash

	aString isOctetString ifTrue: [^ aString asOctetString hash].
	^ self multiStringHash: aString initialHash: speciesHash.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 15:10'!
translate: aString from: start  to: stop  table: table

	^ self translateMultiString: aString from: start  to: stop  table: table.
! !

!MultiString class methodsFor: 'primitives' stamp: 'yo 11/4/2002 22:58'!
translateMultiString: aString from: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"

	| char |
	self var: #table  declareC: 'unsigned char *table'.
	self var: #aString  declareC: 'unsigned int *aString'.

	start to: stop do: [:i |
		char _ aString basicAt: i.
		char < 256 ifTrue: [
			aString basicAt: i put: (table at: char+1) asciiValue
		].
	].
! !

!MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 14:51'!
correspondingSymbolClass

	^ MultiSymbol
! !

!MultiString class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 16:57'!
from: aString 

	| multiString |
	(aString isMemberOf: self)
		ifTrue: [^ aString copy].
	multiString _ self new: aString size.
	1 to: aString size do: [:index | multiString basicAt: index put: (aString basicAt: index)].
	^ multiString
! !

!MultiString class methodsFor: 'instance creation' stamp: 'yo 10/23/2002 23:33'!
fromByteArray: aByteArray 

	| inst |
	aByteArray size \\ 4 = 0 ifFalse: [^ String 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
! !

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

!MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:25'!
fromPacked: aLong
	"Convert from a longinteger to a String of length 4."

	| s val |
	s _ self new: 1.
	val _ ((aLong digitAt: 4) << 24) |
			((aLong digitAt: 3) << 16) |
			((aLong digitAt: 2) << 8) |
			(aLong digitAt: 1).
	s basicAt: 1 put: val.
	^ s.

"MultiString fromPacked: 'TEXT' asPacked"
! !

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

!MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:30'!
value: anInteger

	^ self with: (MultiCharacter value: anInteger).
! !

!MultiString class methodsFor: 'plugin generation' stamp: 'yo 8/26/2002 20:42'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asCharPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isBytes')! !

!MultiString class methodsFor: 'plugin generation' stamp: 'yo 8/26/2002 20:42'!
ccgDeclareCForVar: aSymbolOrString

	^'char *', aSymbolOrString! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:14'!
asExplorerString

	^ self printString.
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:14'!
asMultiSymbol 
	"Refer to the comment in String|asMultiSymbol."
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:14'!
asString 
	"Refer to the comment in String|asString."

	| newString |
	newString _ String new: self size.
	1 to: self size do: [:index | newString at: index put: (self at: index)].
	^ newString
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
asSymbol 
	"Refer to the comment in String|asMultiSymbol."
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
at: anInteger put: anObject 
	"You cannot modify the receiver."

	self errorNoModification
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
byteEncode:aStream

	^ aStream writeSymbol: self.
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
capitalized

	^ self asString capitalized asMultiSymbol.
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
clone
	"Answer with the receiver, because MultiSymbols are unique."
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:15'!
copy
	"Answer with the receiver, because MultiSymbols are unique."
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
errorNoModification

	self error: 'symbols can not be modified.'
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
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>
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^ map newHashFor: self
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
isInfix
	"Answer whether the receiver is an infix message selector."

	^ self precedence == 2
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
isKeyword
	"Answer whether the receiver is a message keyword."

	^ self precedence == 3
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
isLiteral
	"Answer whether the receiver is a valid Smalltalk literal."

	^ true
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:16'!
isOrientedFill
	"Needs to be implemented here because symbols can occupy 'color' slots of morphs."

	^ false
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:17'!
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]].
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:17'!
isUnary
	"Answer whether the receiver is an unary message selector."

	^ self precedence == 1.
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:17'!
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
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:17'!
replaceFrom: start to: stop with: replacement startingAt: repStart

	self errorNoModification
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:17'!
shallowCopy
	"Answer with the receiver, because MultiSymbols are unique."
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:18'!
storeOn: aStream 

	aStream nextPut: $#.
	(Scanner isLiteralMultiSymbol: self)
		ifTrue: [aStream nextPutAll: self]
		ifFalse: [super storeOn: aStream].
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 11/3/2002 13:21'!
sunitAsClass

        ^ SUnitNameResolver classNamed: self.
! !

!MultiSymbol methodsFor: 'as yet unclassified' stamp: 'yo 11/3/2002 13:23'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."
! !

!MultiSymbol methodsFor: 'private' stamp: 'yo 11/3/2002 13:22'!
species

	^ MultiString
! !

!MultiSymbol methodsFor: 'private' stamp: 'yo 11/3/2002 13:21'!
string: aString

	1 to: aString size do: [:j | super at: j put: (aString at: j)].
	^ self

! !

!MultiSymbol methodsFor: 'testing' stamp: 'yo 11/3/2002 13:22'!
isSymbol

	^ true.
! !

!MultiSymbol methodsFor: '-- all --' stamp: 'yo 8/30/2002 14:14'!
= another

	"Use == between two symbols..."
	self == another ifTrue: [^ true].  "Was == "
	another class == MultiSymbol ifTrue: [^ false].  "Was not == "

	"Otherwise use string =..."
	^ super = another.
! !

!MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/4/2002 23:16'!
intern: aStringOrMultiSymbol 

	aStringOrMultiSymbol isOctetString
		ifTrue: [^ Symbol intern: aStringOrMultiSymbol].
	^ (self lookup: aStringOrMultiSymbol)
		ifNil: [NewMultiSymbols
				add: ((aStringOrMultiSymbol isKindOf: MultiSymbol)
						ifTrue: [aStringOrMultiSymbol]
						ifFalse: [(self new: aStringOrMultiSymbol size)
								string: aStringOrMultiSymbol])]
! !

!MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/11/2002 23:43'!
internLoadedSymbol: aStringOrMultiSymbol 

	aStringOrMultiSymbol isOctetString
		ifTrue: [^ Symbol intern: aStringOrMultiSymbol].
	^ (self lookupForLoadedSymbol: aStringOrMultiSymbol)
		ifNil: [NewMultiSymbols
				add: ((aStringOrMultiSymbol isKindOf: MultiSymbol)
						ifTrue: [aStringOrMultiSymbol]
						ifFalse: [(self new: aStringOrMultiSymbol size)
								string: aStringOrMultiSymbol])]
! !

!MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/11/2002 23:13'!
lookupForLoadedSymbol: aStringOrMultiSymbol

	^(MultiSymbolTable likeLoadedSymbol: aStringOrMultiSymbol) ifNil: [
		NewMultiSymbols likeLoadedSymbol: aStringOrMultiSymbol
	].
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:55'!
allMultiSymbolTablesDo: aBlock

	NewMultiSymbols do: aBlock.
	MultiSymbolTable do: aBlock.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:55'!
allMultiSymbolTablesDo: aBlock after: aMultiSymbol

	NewMultiSymbols do: aBlock after: aMultiSymbol.
	MultiSymbolTable do: aBlock after: aMultiSymbol.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:56'!
compactMultiSymbolTable
	"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 _ MultiSymbolTable array size.
	MultiSymbolTable growTo: MultiSymbolTable size * 4 // 3 + 100.
	^oldSize printString,'  ',(oldSize - MultiSymbolTable array size) printString, ' slot(s) reclaimed'
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:56'!
compareTiming
"
MultiSymbol compareTiming
"
	| answer t selectorList implementorLists flattenedList md |

	answer _ WriteStream on: String new.
	Smalltalk timeStamp: answer.
	answer cr; cr.
	answer nextPutAll: MethodDictionary instanceCount printString,' method dictionaries'; cr; cr.
	answer nextPutAll: (
		MethodDictionary allInstances inject: 0 into: [ :sum :each | sum + each size]) printString,
		' method dictionary entries'; cr; cr.

	md _ MethodDictionary allInstances.
	t _ [100 timesRepeat: [md do: [ :each | each includesKey: #majorShrink]]] timeToRun.
	answer nextPutAll: t printString,
		' ms to check all method dictionaries for #majorShrink 1000 times'; cr; cr.

	selectorList _ MultiSymbol selectorsContaining: 'help'.
	t _ [
		3 timesRepeat: [selectorList collect: [:each | Smalltalk allImplementorsOf: each]]
	] timeToRun.
	answer nextPutAll: t printString,' ms to do #allImplementorsOf: for ',
		selectorList size printString,' selectors like *help* 3 times'; cr; cr.

	t _ [
		3 timesRepeat: [
			selectorList do: [:eachSel | md do: [ :eachMd | eachMd includesKey: eachSel]]
		]
	] timeToRun.
	answer nextPutAll: t printString,' ms to do #includesKey: for ',
		md size printString,' methodDicts for ',
		selectorList size printString,' selectors like *help* 3 times'; cr; cr.

	#('help' 'majorShrink') do: [ :substr |
		answer nextPutAll: (MultiSymbol selectorsContaining: substr) size printString,
				' selectors containing "',substr,'"'; cr.

		t _ [
			3 timesRepeat: [
				selectorList _ MultiSymbol selectorsContaining: substr.
			].
		] timeToRun.
		answer nextPutAll: t printString,' ms to find MultiSymbols containing *',substr,'* 3 times'; cr.

		t _ [
			3 timesRepeat: [
				selectorList _ MultiSymbol selectorsContaining: substr.
				implementorLists _ selectorList collect: [:each | Smalltalk allImplementorsOf: each].
				flattenedList _ SortedCollection new.
				implementorLists do: [:each | flattenedList addAll: each].
			].
		] timeToRun.
		answer nextPutAll: t printString,' ms to find implementors of *',substr,'* 3 times'; cr; cr.
	].
	StringHolder new contents: answer contents; openLabel: 'timing'.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:58'!
hasInterned: aString ifTrue: symBlock 
	"Answer with false if aString hasnt been interned (into a MultiSymbol), 
	otherwise supply the symbol to symBlock and return true."

	| symbol |
	^(symbol _ self lookup: aString)
		ifNil: [false]
		ifNotNil: [symBlock value: symbol. true]
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:56'!
initialize

	"MultiSymbol initialize"

	MultiSymbol rehash.
	OneCharacterMultiSymbols _ nil.
	OneCharacterMultiSymbols _ (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol].
	Smalltalk addToShutDownList: self.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:57'!
internCharacter: aCharacter

	OneCharacterMultiSymbols ifNil: [^self intern: aCharacter asString].

	^ OneCharacterMultiSymbols at: aCharacter asciiValue + 1
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:57'!
lookup: aStringOrMultiSymbol

	^(MultiSymbolTable like: aStringOrMultiSymbol) ifNil: [
		NewMultiSymbols like: aStringOrMultiSymbol
	].
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:57'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ (aCollection as: MultiString) asMultiSymbol

"	MultiSymbol newFrom: {$P. $e. $n}
	{$P. $e. $n} as: MultiSymbol
"
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:57'!
newFromStream: stream 

	| length multiString |
	self isPointers | self isWords not
		ifTrue: [^ super newFromStream: stream].
	stream next = 128
		ifTrue: [^ self error: 'not implemented'].
	stream skip: -1.
	length _ stream nextInt32.
	multiString _ stream
				nextWordsInto: (MultiString basicNew: length).
	^ multiString asSymbol
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:58'!
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 allMultiSymbolTablesDo: [: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"
		MultiSymbol hasInterned: binary ifTrue: [:him | best addFirst: him]].
	^ best
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:58'!
readFrom: strm  "MultiSymbol readFromString: '#abc'"

	strm peek = $# ifFalse: [self error: 'MultiSymbols must be introduced by #'].
	^ (Scanner new scan: strm) advance  "Just do what the code scanner does"
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:58'!
rehash		"MultiSymbol rehash"
	"Rebuild the hash table, reclaiming unreferenced MultiSymbols."

	MultiSymbolTable _ WeakSet withAll: self allInstances.
	NewMultiSymbols _ WeakSet new.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:54'!
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: (OneCharacterMultiSymbols at: ascii+1)]
	].

	aString first isLetter ifFalse: [
		aString size = 2 ifTrue: 
			[MultiSymbol hasInterned: aString ifTrue:
				[:s | selectorList add: s]].
		^ selectorList
	].

	selectorList _ selectorList copyFrom: 2 to: selectorList size.

	self allMultiSymbolTablesDo: [: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]].

"MultiSymbol selectorsContaining: 'scon'"! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:59'!
shutDown: aboutToQuit

	MultiSymbolTable addAll: NewMultiSymbols.
	NewMultiSymbols _ WeakSet new.
! !

!MultiSymbol class methodsFor: 'as yet unclassified' stamp: 'yo 8/30/2002 14:55'!
thatStarts: leadingCharacters skipping: skipSym
	"Answer a selector symbol that starts with leadingCharacters.
	MultiSymbols 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 allMultiSymbolTablesDo: [: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

"MultiSymbol thatStarts: 'sf' skipping: nil"
"MultiSymbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:"
"MultiSymbol thatStarts: 'candidate' skipping: nil"
! !

!MultiSymbol class methodsFor: 'private' stamp: 'yo 11/11/2002 23:22'!
hasInternedALoadedSymbol: aString ifTrue: symBlock 
	"Answer with false if aString hasnt been interned (into a MultiSymbol), 
	otherwise supply the symbol to symBlock and return true."

	| symbol |
	^(symbol _ self lookupForLoadedSymbol: aString)
		ifNil: [false]
		ifNotNil: [symBlock value: symbol. true]
! !

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

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

! !

!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: 'ls 10/11/2003 13:13'!
display: items  atRow: row on: canvas
        "display the specified item, which is on the specified row; for Multicolumn lists, item w
ill 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)). ].
                canvas text: item bounds: drawBounds  font: font color: (self colorForRow: row) ]! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:19' prior: 38804248!
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: 'ls 2/9/2002 01:00'!
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 widthOfString: item).
				widthOfItem > currentWidth
					ifTrue: [ self changed.  widthOfItem ]
					ifFalse: [ currentWidth ] ] ]! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'sps 3/23/2004 15:51' prior: 38806089!
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"
! !

!MulticolumnLazyListMorph commentStamp: '<historical>' prior: 0!
A variant of LazyListMorph that can display multi-column lists.!
!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' prior: 25115686!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	drawState _ IdentityDictionary new.
	self clear! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:55' prior: 25116729!
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:."
! !

!MyResumableTestError methodsFor: 'exceptionDescription' stamp: 'tfei 6/13/1999 00:46'!
isResumable

	^true! !

!NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 12:36'!
defaultAction
	"Backward compatibility"
	| response |
	response _ (PopUpMenu labels: 'Retry\Give Up' withCRs)
			startUpWithCaption: 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 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 class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:57'!
hostName: aString
	^ self new hostName: aString! !

!NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0!
Shows the name of the morph in the halo. !
!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 25126206!
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' prior: 25126410!
showStats

	DEBUG ifNil: [^Beeper beep].
	DEBUG explore.! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 25126551!
showStats: queueName

	DEBUG ifNil: [^Beeper beep].
	self 
		showStats: queueName 
		from: DEBUG.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 25127547!
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
	].! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'yo 11/4/2002 21:06' prior: 25129176!
fontForButtons

	^ TextStyle defaultFont.
	"^Preferences standardButtonFont"! !

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

!NebraskaServer class methodsFor: 'instance creation' stamp: 'mu 11/28/2003 19:38' prior: 25136534!
newForWorld: aWorld

	^self basicNew initializeForWorld: aWorld! !

!NebraskaServerMorph methodsFor: 'accessing' stamp: 'RAA 5/31/2001 15:03'!
currentBacklogString

	^currentBacklogString! !

!NebraskaServerMorph methodsFor: 'drawing' stamp: 'RAA 5/31/2001 15:03'!
updateCurrentStatusString

	self server ifNil:[
		currentStatusString _ '<Nebraska not active>'.
		currentBacklogString _ ''.
	] ifNotNil:[
		currentStatusString _ 
			' Nebraska: ', 
			self server numClients printString, 
			' clients'.
		currentBacklogString _ 'backlog: ',
				((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: 'RAA 5/31/2001 15:07'!
initialize

	super initialize.
	fullDisplay _ false.
	color _ Color white.
	lastFullUpdateTime _ 0.
	self listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:29' prior: 38812260!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	fullDisplay _ false.
	
	lastFullUpdateTime _ 0.
	self listDirection: #topToBottom;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'RAA 5/31/2001 15:13'!
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--') 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: 'RAA 5/31/2001 14:54'!
setColorsAndBorder

	| worldColor c |
	((Preferences menuColorFromWorld and: [Display depth > 4]) and: 
						[(worldColor _ self currentWorld color) isColor]) ifTrue: [
		c _ worldColor luminance > 0.7 ifTrue: [
			worldColor mixed: 0.8 with: Color black
		] ifFalse: [
			worldColor mixed: 0.4 with: Color white
		].
	] ifFalse: [
		c _ Preferences menuColor.
	].
	self color: c.
	self borderColor: #raised.
	self borderWidth: Preferences menuBorderWidth.
	self useRoundedCorners.! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:35' prior: 38814658!
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! !

!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 methodsFor: 'lookups' stamp: 'mir 6/18/2001 21:18'!
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 |

	"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: [
			result _ (self waitForResolverReadyUntil: deadline)
				ifTrue: [
					self primStartLookupOfName: hostName.
					(self waitForCompletionUntil: deadline)
						ifTrue: [self primNameLookupResult]
						ifFalse: [nil]]
				ifFalse: [nil]]
		ifError: [:msg :rcvr| rcvr error: msg].
	^result! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:50' prior: 38816383!
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]]
		ifError: [:msg :rcvr| rcvr error: msg].
	^result! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mu 9/7/2003 22:53' prior: 38817660!
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: 'mir 2/22/2002 15:50' prior: 25146218!
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: 'mir 6/18/2001 21:19'!
nameForAddress: hostAddress timeout: secs
	"Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses."
	"NetNameResolver
		nameForAddress: (NetNameResolver addressFromString: '128.111.92.40')
		timeout: 30"

	| deadline result |
	deadline _ Time millisecondClockValue + (secs * 1000).
	"Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction."
	"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]]
		ifError: [:msg :rcvr| rcvr error: msg].
	^result
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:50' prior: 38821144!
nameForAddress: hostAddress timeout: secs
	"Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses."
	"NetNameResolver
		nameForAddress: (NetNameResolver addressFromString: '128.111.92.40')
		timeout: 30"

	| deadline 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."
	"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]]
		ifError: [:msg :rcvr| rcvr error: msg].
	^result
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'nk 6/27/2003 10:51' prior: 38822278!
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: 'mir 2/22/2002 16:31' prior: 25147489!
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 _ FillInTheBlank
		request: 'Host name or address?'
		initialAnswer: default.
	hostName isEmpty ifTrue: [^ 0].
	serverAddr _ NetNameResolver addressForName: hostName timeout: 15.
	serverAddr = nil ifTrue: [(NameLookupFailure hostName: hostName) signal: 'Could not find the address for ', hostName].
	hostName size > 0 ifTrue: [DefaultHostName _ hostName].
	^ serverAddr! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mu 9/8/2003 14:24' prior: 38824445!
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 _ FillInTheBlank
		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: '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: 'private' stamp: 'mir 6/18/2001 21:05'!
resolverMutex
	ResolverMutex ifNil: [ResolverMutex _ Semaphore forMutualExclusion].
	^ResolverMutex! !

!NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0!
Abstract super class for all network related exceptions.!
!NetworkTerminalMorph methodsFor: 'layout' stamp: 'RAA 3/7/2001 22:32'!
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 class methodsFor: 'instance creation' stamp: 'mir 5/15/2003 18:06' prior: 25166639!
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

! !

!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: 'initialization' stamp: 'dgd 3/7/2003 14:29' prior: 25167478!
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.! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:16'!
obsoleteSelfBasicNewInitialize
	"This pattern is obsoleted by Object class>>new"
	^self basicNew initialize! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:23'!
obsoleteSuperBasicNewInitialize
	"This pattern is obsoleted by Object class>>new"
	^super basicNew initialize! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:22'!
obsoleteSuperNew
	"This is pointless unless specifically documented"
	^super new! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:16'!
obsoleteSuperNewInitialize
	"This pattern is obsoleted by Object class>>new"
	^super new initialize! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:19'!
obsoleteSuperNewInitializeWithTemp
	"This pattern is obsoleted by Object class>>new"
	| temp |
	temp := super new.
	temp initialize.
	^temp! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:20'!
obsoleteSuperNewInitializeWithTempDirectly
	"This pattern is obsoleted by Object class>>new"
	| temp |
	temp := super new initialize.
	^temp! !

!NewInitializeTest methodsFor: 'patterns' stamp: 'ar 9/16/2003 00:17'!
obsoleteSuperNewInitializeYourself
	"This pattern is obsoleted by Object class>>new"
	^(super new) initialize; yourself! !

!NewInitializeTest commentStamp: 'ar 9/16/2003 01:16' prior: 0!
NewInitializeTest is a test which is run on all classes in the system to detect obsolete or otherwise considered invalid implementations of #new. It provides a set of patterns against which all implementations of #new are run. To add a new pattern provide a method beginning with #obsolete such as #obsoleteStrangeNewTest.!
!NewInitializeTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 15:07'!
classesToTest
	^super classesToTest collect: [:aClass| aClass class]! !

!NewInitializeTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 12:53'!
obsoleteMethodSelector
	^#new! !

!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: 'RAA 5/6/2001 15:04'!
wantsColumnBreaks

	^wantsColumnBreaks! !

!NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks _ aBoolean! !

!NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:06'!
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]].
			row size >= 1 ifTrue:
			[lineY _ lineY + lineHeight.
			lineY > bottom
				ifTrue: ["Oops -- the line is really too high to fit -- back out"
						charIndex _ saveCharIndex.
						row do: [:r | lines removeLast]]
				ifFalse: ["It's OK -- the line still fits."
						maxRightX _ maxRightX max: scanner rightX.
						1 to: row size - 1 do:  "Adjust heights across row if necess"
							[:i | (lines at: lines size - row size + i)
									lineHeight: lines last lineHeight
									baseline: lines last baseline].
						charIndex > text size ifTrue:
							["end of text"
							hitCR ifTrue:
								["If text ends with CR, add a null line at the end"
								((lineY + lineHeightGuess) <= container bottom) ifTrue:
									[row _ container rectanglesAt: lineY height: lineHeightGuess.
									row size > 0 ifTrue:
										[line _ (TextLine start: charIndex stop: charIndex-1
											internalSpaces: 0 paddingWidth: 0)
										rectangle: row first;
										lineHeight: lineHeightGuess baseline: textStyle baseline.
										lines addLast: line]]].
							lines _ lines asArray.
							^ maxRightX].
						firstLine _ false]]
				ifFalse:
				[lineY _ lineY + lineHeight].
			(maybeSlide and: [charIndex > stop]) ifTrue:
				["Check whether we are now in sync with previously composed lines"
				 [priorIndex < priorLines size
					and: [(priorLines at: priorIndex) first < (charIndex - delta)]]
						whileTrue: [priorIndex _ priorIndex + 1].
				(priorLines at: priorIndex) first = (charIndex - delta)
					ifTrue: ["Yes -- next line will have same start as prior line."
							priorIndex _ priorIndex - 1.
							maybeSlide _ false.
							sliding _ true]
					ifFalse: [priorIndex = priorLines size ifTrue:
								["Weve reached the end of priorLines,
								so no use to keep looking for lines to slide."
								maybeSlide _ false]]]]].

	firstLine ifTrue: ["No space in container or empty text"
		line _ (TextLine start: start stop: start-1
						internalSpaces: 0 paddingWidth: 0)
				rectangle: (container topLeft extent: 0@lineHeightGuess);
				lineHeight: lineHeightGuess baseline: textStyle baseline.
		lines _ Array with: line
	] ifFalse: [
		self fixLastWithHeight: lineHeightGuess
	].
	"end of container"
	lines _ lines asArray.
	^ maxRightX! !

!NewParagraph methodsFor: 'composition' stamp: 'jm 2/25/2003 16:20' prior: 38832708!
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: 'yo 12/20/2002 16:18' prior: 25171737!
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: '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: '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' prior: 25176711!
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: 'display' stamp: 'gm 2/28/2003 01:40' prior: 25182675!
displaySelectionInLine: line on: aCanvas 
	| leftX rightX w caretColor |
	selectionStart ifNil: [^self].	"No selection"
	selectionStart = selectionStop 
		ifTrue: 
			["Only show caret on line where clicked"

			selectionStart textLine ~= line ifTrue: [^self]]
		ifFalse: 
			["Test entire selection before or after here"

			(selectionStop stringIndex < line first 
				or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self].	"No selection on this line"
			(selectionStop stringIndex = line first 
				and: [selectionStop textLine ~= line]) ifTrue: [^self].	"Selection ends on line above"
			(selectionStart stringIndex = (line last + 1) 
				and: [selectionStop textLine ~= line]) ifTrue: [^self]].	"Selection begins on line below"
	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' prior: 25184431!
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' prior: 25184610!
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: 'dew 11/22/2001 13:25'!
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 forStyle: textStyle.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+1).
				box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil].
				box ifNotNil:
					[Utilities awaitMouseUpIn: ((editor transformFrom: nil) invertBoundsRect: 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: 'nk 3/8/2004 14:56' prior: 38850880!
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 forStyle: textStyle.
				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: 'fonts-display' stamp: 'ar 12/17/2001 01:52'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"
	| visibleRectangle offset leftInRun line |
	visibleRectangle _ aCanvas clipRect.
	offset _ somePosition - positionWhenComposed.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ lines at: i.
			self displaySelectionInLine: line on: aCanvas.
			line first <= line last ifTrue:
				[leftInRun _ displayScanner displayLine: line
								offset: offset leftInRun: leftInRun]].
! !

!NewParagraph methodsFor: 'fonts-display' stamp: 'nk 3/20/2004 11:13' prior: 38853213!
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: 'fonts-display' stamp: 'nk 3/20/2004 11:13' prior: 38853895!
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: 'selection' stamp: 'ar 12/17/2001 01:51'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line _ lines at: (self lineIndexForPoint: aPoint).
	^ (CharacterBlockScanner new text: text textStyle: textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'yo 1/1/2003 15:09' prior: 38855264!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line _ lines at: (self lineIndexForPoint: aPoint).
	^ ((text string isKindOf: MultiString) ifTrue: [
		MultiCharacterBlockScanner new text: text textStyle: textStyle
	] ifFalse: [CharacterBlockScanner new text: text textStyle: textStyle])
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'yo 1/1/2003 15:11' prior: 25178000!
characterBlockForIndex: index 
	"Answer a CharacterBlock for the character in text at index."
	| line |
	line _ lines at: (self lineIndexForCharacter: index).
	^ ((text string isKindOf: MultiString) 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: '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: 'private' stamp: 'nk 6/23/2004 14:50' prior: 25187950!
moveBy: delta
	lines do: [:line | line moveBy: delta].
	positionWhenComposed _ (positionWhenComposed ifNil: [ container origin ]) + delta.
	container _ container translateBy: delta! !

!NewParagraph methodsFor: 'private' stamp: 'nk 6/23/2004 14:50' prior: 38857996!
moveBy: delta
	lines do: [:line | line moveBy: delta].
	positionWhenComposed _ (positionWhenComposed ifNil: [ container origin ]) + delta.
	container _ container translateBy: delta! !

!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!
!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: 'color' stamp: 'nb 6/17/2003 12:25' prior: 25190498!
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
		
! !

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

!NoInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 14:59'!
nextCharFrom: sensor firstEvt: evtBuf



	| keyValue |

	keyValue := evtBuf third.

	^ keyValue asCharacter.

! !

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

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

!Norwegian methodsFor: 'accessing' stamp: 'dgd 8/24/2003 18:27'!
name
	"answer the receiver's name"
	^ #'Norsk'! !

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

!Number methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49' prior: 25207073!
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: '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' stamp: 'RAH 4/25/2000 19:49' prior: 25209829!
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: '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: 'testing' stamp: 'sw 9/27/2001 17:26'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Number! !

!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: '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' 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: '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' 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: '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' 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: 'printing' stamp: 'sw 9/13/2002 17:50'!
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."

	| aString |
	placesDesired <= 0 ifTrue: [^ self rounded printString].

	aString _ ((self asFloat roundTo: (Utilities floatPrecisionForDecimalPlaces: placesDesired)) asString), ((String new: placesDesired) atAllPut: $0).
	^ aString copyFrom: 1 to: ((aString indexOf: $.) + placesDesired)

"
23 printShowingDecimalPlaces: 2
23.5698 printShowingDecimalPlaces: 2
-234.567 printShowingDecimalPlaces: 5
23.4567 printShowingDecimalPlaces: 0
"! !

!Number methodsFor: 'vocabulary' stamp: 'sw 8/3/2001 13:43'!
vocabularyDemanded
	"Answer the vocabulary normally preferred by this object"

	^ Vocabulary numberVocabulary! !

!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 class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 22:40' prior: 25221499!
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' prior: 25222402!
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: 'instance creation' stamp: 'RAH 4/25/2000 19:49' prior: 25223011!
readRemainderOf: integerPart from: aStream base: base withSign: sign 
	"Read optional fractional part and exponent, and return the final result"
	| value fraction fractionDigits fracpos peekChar scale |
	#Numeric.
	"Changed 200/01/19 For ANSI Numeric Literals support."
	value := integerPart.
	fractionDigits := 0.
	(aStream peekFor: $.)
		ifTrue: ["<integer>.<fraction>"
			(aStream atEnd not and: [aStream peek digitValue between: 0 and: base - 1])
				ifTrue: 
					[fracpos := aStream position.
					fraction := Integer readFrom: aStream base: base.
					fraction := fraction asFloat / (base raisedTo: aStream position - fracpos).
					fractionDigits := aStream position - fracpos.
					value := value asFloat + fraction]
				ifFalse: 
					["oops - just <integer>."
					aStream skip: -1.
					"un-gobble the period"
					^ value * sign"Number readFrom: '3r-22.2'"]].
	peekChar := aStream peek.
	"<number>(e|d|q)<exponent>>"
	peekChar = $e | (peekChar = $d) | (peekChar = $q)
		ifTrue: 
			[aStream next.
			value := value * (base raisedTo: (Integer readFrom: aStream))]
		ifFalse: [peekChar = $s
				ifTrue: 
					["<number>s[<scale>]"
					aStream next.
					(aStream atEnd not and: ["<number>s<scale>"
						aStream peek digitValue between: 0 and: 10])
						ifTrue: [scale := Integer readFrom: aStream].
					scale isNil
						ifTrue: ["<number>s"
							fractionDigits = 0
								ifTrue: ["<integer>s"
									scale := 0]
								ifFalse: ["<integer>.<fraction>s"
									scale := fractionDigits]].
					value := ScaledDecimal newFromNumber: value scale: scale]].
	(value isFloat
		and: [value = 0.0 and: [sign = -1]])
		ifTrue: [^ Float negativeZero]
		ifFalse: [^ value * sign]! !

!NumberType methodsFor: 'tiles' stamp: 'sw 9/15/2002 16:45'!
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...' selector: #setPrecisionFor: argument: slotSym.
	aMenu balloonTextForLastItem: 'Lets you choose how many decimal places should be shown in readouts for this variable'! !

!NumberType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:30' prior: 38874656!
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: '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: 'tiles' stamp: 'sw 9/27/2001 17:36'!
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"

	super addWatcherItemsToMenu: aMenu forGetter: aGetter.
	aMenu add: 'detailed watcher' selector: #tearOffFancyWatcherFor: argument: aGetter! !

!NumberType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:29' prior: 38876057!
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"

	super addWatcherItemsToMenu: aMenu forGetter: aGetter.
	aMenu add: 'detailed watcher' translated selector: #tearOffFancyWatcherFor: argument: aGetter! !

!NumberType methodsFor: '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: 'tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ 5 newTileMorphRepresentative typeColor: self typeColor! !

!NumberType methodsFor: '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: '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: '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! !

!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: 'sw 10/10/2001 06:24'!
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: '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 commentStamp: 'sw 10/3/2002 02:18' prior: 0!
NumberType is a data type representing a numeric value.!
!NumericReadoutTile methodsFor: 'event handling' stamp: 'sw 11/29/2001 12:35'!
mouseStillDown: evt
	"Copied from TileMorph mouseMove to use literal:width: rather than literal:."

	| p label |
	self flag: #arNote. "Fix 'significant' events below"
	upArrow ifNotNil:
		[p _ evt cursorPoint.
		self abandonLabelFocus.
		label _ self findA: UpdatingStringMorph.

		label ifNotNil:
			[label step. literal _ label valueFromContents].

		(upArrow containsPoint: p)
			ifTrue: [self variableDelay:
						[self literal: (self numericValue + self arrowDelta)].
					^ evt "hand noteSignificantEvent: evt"].
		(downArrow containsPoint: p)
			ifTrue: [self variableDelay:
						[self literal: (self numericValue - self arrowDelta)].
					^ evt "hand noteSignificantEvent: evt"]].

	super mouseStillDown: evt.
! !

!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 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: 'parts bin' stamp: 'tk 11/6/2001 08:13'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'Number (fancy)'
		categoryList: #(' Basic 1 ')
		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 1 ')
		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 1 ')
		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.! !

!Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 11:39' prior: 25231688!
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' stamp: 'yo 6/29/2004 13:08' prior: 25232466!
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: 'md 12/12/2003 16:25' prior: 25234973!
doIfNotNil: aBlock
	self deprecated: 'use ifNotNilDo:'.
	^ self ifNotNilDo: aBlock
! !

!Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59' prior: 25235290!
in: aBlock
	"Evaluate the given block with the receiver as its argument."

	^ aBlock value: self
! !

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

	^ self class == other class and: [self = other]! !

!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: 'ajh 3/11/2003 10:27'!
asStringOrText
	"Answer a string that represents the receiver."

	^ self printString ! !

!Object methodsFor: 'converting' stamp: 'hmm 7/29/2001 21:35'!
mustBeBoolean
	"Catches attempts to test truth of non-Booleans.  This message is sent from the
	interpreter.
	The sending context is rewound to just before the jump causing this exception."

	| proceedValue |
	thisContext sender skipBackBeforeJump.
	proceedValue _ NonBooleanReceiver new
		object: self;
		signal: 'proceed for truth.'.
	^proceedValue ~~ false! !

!Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:37' prior: 38890367!
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: 'copying' stamp: 'ajh 8/18/2001 21:25' prior: 25242613!
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: 'tpr 2/14/2004 21:53' prior: 25243242!
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' prior: 25243925!
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: '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: 'tk 3/11/2003 13:58' prior: 25246436!
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 9/4/2001 10:51'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new uc sup has mine |
	deepCopier references at: self ifPresent: [:newer | ^ newer]. 	"already did him"
	class _ self class.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self clone.
	class isSystemDefined ifFalse: [
		uc _ deepCopier uniClasses at: class ifAbsent: [nil].
		uc ifNil: [
			deepCopier uniClasses at: class put: (uc _ self copyUniClassWith: deepCopier).
			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 3/11/2003 14:12' prior: 38895640!
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 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: 'sw 1/29/2002 21:43'!
asMorph
	"Open a morph, as best one can, on the receiver"

	^ self asString asMorph

	"
234 asMorph
(ScriptingSystem formAtKey: #TinyMenu) asMorph
'fred' asMorph
"

! !

!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: '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: '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: 'deprecated' stamp: 'nb 6/17/2003 12:25' prior: 25286813!
beep: soundName
	"Make the given sound, unless the making of sound is disabled in Preferences."

	self deprecatedExplanation: 'Use SampledSound>>playSoundNamed: instead.'.
	Preferences soundsEnabled
		ifTrue: [self playSoundNamed: soundName]
! !

!Object methodsFor: 'deprecated' stamp: 'md 12/12/2003 17:02' prior: 38901628!
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: 'deprecated' stamp: 'sd 5/11/2003 16:46'!
beepPrimitive
	"Beep in the absence of sound support"

	<primitive: 140>
	self primitiveFailed! !

!Object methodsFor: 'deprecated' stamp: 'md 10/22/2003 16:27' prior: 38902252!
beepPrimitive
	"Beep in the absence of sound support"
	
	self deprecatedExplanation: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'.
	Beeper beepPrimitive! !

!Object methodsFor: 'deprecated' stamp: 'md 12/12/2003 17:02' prior: 38902430!
beepPrimitive
	"Beep in the absence of sound support"
	
	self deprecated: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'.
	Beeper beepPrimitive! !

!Object methodsFor: 'deprecated' stamp: 'gk 2/24/2004 08:50' prior: 38902684!
beepPrimitive
	"Deprecated. Beep in the absence of sound support."
	
	self deprecated: 'Use Beeper class>>beep or Beeper class>>beepPrimitive instead.'.
	Beeper beepPrimitive! !

!Object methodsFor: 'drag and drop' stamp: 'bh 9/16/2001 18:10'!
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 
	
	^false.! !

!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: 'sd 5/11/2003 18:34'!
deprecated: aBlock explanation: aString 
	 "Warn that the sender has been deprecated. answer the value of aBlock on resumption"

	Deprecation signal: thisContext sender printString, ' has been deprecated. ', aString.
	^ aBlock value.! !

!Object methodsFor: 'error handling' stamp: 'avi 9/16/2003 11:44' prior: 38904060!
deprecated: aBlock explanation: aString 
	 "Warn that the sender has been deprecated. answer the value of aBlock on resumption"

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation
			signal: thisContext sender printString, ' has been deprecated. ', aString].
	^ aBlock value.
! !

!Object methodsFor: 'error handling' stamp: 'dew 10/16/2003 00:11' prior: 38904381!
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: thisContext sender printString, ' has been deprecated. ', aString].
	^ aBlock value.
! !

!Object methodsFor: 'error handling' stamp: 'sd 11/13/2003 21:11' prior: 38904755!
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: 'error handling' stamp: 'sd 5/11/2003 18:34'!
deprecatedExplanation: aString
	"Warn that the sending method has been deprecated"

	Deprecation signal: thisContext sender printString, ' has been deprecated. ', aString
! !

!Object methodsFor: 'error handling' stamp: 'dew 9/17/2003 00:02' prior: 38905635!
deprecatedExplanation: aString
	"Warn that the sending method has been deprecated"

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation signal: thisContext sender printString, ' has been deprecated. ', aString]! !

!Object methodsFor: 'error handling' stamp: 'dew 10/16/2003 00:10' prior: 38905894!
deprecatedExplanation: aString
	"This method is OBSOLETE.  Use #deprecated: instead."
	self deprecated: 'Use Object>>deprecated: instead of deprecatedExplanation:.'.

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation signal: thisContext sender printString, ' has been deprecated. ', aString]! !

!Object methodsFor: 'error handling' stamp: 'sd 11/13/2003 21:10' prior: 38906201!
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: 'error handling' stamp: 'ajh 10/9/2001 17:21' prior: 25264602!
doesNotUnderstand: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)."
	"Testing: (3 activeProcess)"

	(Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage])
		ifTrue: [^ aMessage sentTo: self].

	^ MessageNotUnderstood new 
		message: aMessage;
		receiver: self;
		signal! !

!Object methodsFor: 'error handling' stamp: 'ar 2/13/2001 20:49'!
externalCallFailed
	"A call to an external function has failed."
	^(Smalltalk at: #ExternalFunction ifAbsent:[^self error: 'FFI not installed'])
		externalCallFailed! !

!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' stamp: 'sw 5/23/2001 13:43'!
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."

	Debugger
		openContext: thisContext
		label: aString
		contents: aString

	"nil notifyWithLabel: 'let us see if this works'"! !

!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' stamp: 'ajh 9/7/2002 21:20' prior: 25267421!
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 methodSelector printString! !

!Object methodsFor: 'error handling' stamp: 'tk 6/18/2001 15:04'!
tryToDefineVariableAccess: aMessage
	"See if the message just wants to get at an instance variable of this class.  Ask the user if its OK.  If so, define the message to read or write that instance or class variable and retry."
	| ask newMessage sel canDo classOrSuper |
	aMessage arguments size > 1 ifTrue: [^ false].
	sel _ aMessage selector asString.	"works for 0 args"
	aMessage arguments size = 1 ifTrue: [
		sel last = $: ifFalse: [^ false].
		sel _ sel copyWithout: $:].
	canDo _ false.  classOrSuper _ self class.
	[((classOrSuper instVarNames includes: sel) 	
		ifTrue: [canDo _ true. nil]
		ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse.
	canDo ifFalse: [classOrSuper _ self class.
		[((classOrSuper classVarNames includes: sel) 	
			ifTrue: [canDo _ true. nil]
			ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse].
	canDo ifFalse: [^ false].

	ask _ self confirm: 'A ', thisContext sender sender receiver 
		class printString, ' wants to ', 
		(aMessage arguments size = 1 ifTrue: ['write into'] ifFalse: ['read from']), '
', sel ,' in class ', classOrSuper printString, '.
Define a this access message?'.
	ask ifTrue: [
		aMessage arguments size = 1 
			ifTrue: [newMessage _ aMessage selector, ' anObject
	', sel, ' _ anObject']
			ifFalse: [newMessage _ aMessage selector, '
	^', aMessage selector].
		classOrSuper compile: newMessage classified: 'accessing' notifying: nil].
	^ ask! !

!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
with: anArg
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector
		arguments: (Array with: anArg))! !

!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-removing' stamp: 'reThink 2/18/2001 15:33'!
releaseActionMap

	EventManager releaseActionMapFor: self! !

!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-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: 'SqR 2/19/2001 14:09'!
removeActionsWithReceiver: anObject

	self actionMap keysDo:
		[:eachEventSelector |
			self
   				removeActionsSatisfying: [:anAction | anAction receiver == anObject]
				forEvent: eachEventSelector
		]! !

!Object methodsFor: 'events-removing' stamp: 'rw 7/29/2003 17:18' prior: 38915366!
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-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 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: '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: 'finalization' stamp: 'ar 5/19/2003 20:10'!
finalizationRegistry
	"Answer the finalization registry associated with the receiver."
	^WeakRegistry default! !

!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: '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: 'ar 3/18/2001 00:03'!
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! !

!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: '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: 'nb 6/17/2003 12:25' prior: 25289761!
playSoundNamed: soundName
	"Play the sound with the given name. Do nothing if this image lacks sound playing facilities."

	self deprecatedExplanation: 'Use SampledSound>>playSoundNamed: instead.'.
	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		sampledSound playSoundNamed: soundName asString].
! !

!Object methodsFor: 'macpal' stamp: 'md 12/12/2003 17:02' prior: 38921128!
playSoundNamed: soundName
	"Play the sound with the given name. Do nothing if this image lacks sound playing facilities."

	self deprecated: 'Use SampledSound>>playSoundNamed: instead.'.
	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		sampledSound playSoundNamed: soundName asString].
! !

!Object methodsFor: 'macpal' stamp: 'gk 2/23/2004 20:51' prior: 38921515!
playSoundNamed: soundName
	"Deprecated.
	Play the sound with the given name."

	self deprecated: 'Use "SoundService default playSoundNamed: aName" instead.'.
	SoundService default playSoundNamed: soundName! !

!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: '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: 'ajh 1/28/2003 12:32'!
withArgs: argArray executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and args in argArray"

	| selector |
	<primitive: 188>
	selector _ Symbol new.
	self class addSelector: selector withMethod: compiledMethod.
	^ [self perform: selector withArguments: argArray]
		ensure: [self class removeSelectorSimply: selector]! !

!Object methodsFor: 'message handling' stamp: 'NS 1/28/2004 11:19' prior: 38922573!
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: 'objects from disk' stamp: 'nb 6/17/2003 12:25' prior: 25296878!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  Does not file out the class of the object.  tk 6/26/97 13:48"

	| aFileName fileStream |
	aFileName _ self class name asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ Beeper beep].

	fileStream _ FileStream newFileNamed: aFileName.
	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: '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: '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: '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: 'RAA 3/5/2001 18:13'!
contentsGetz: x

	self contents: x! !

!Object methodsFor: 'scripting' stamp: 'RAA 3/9/2001 17:08'!
evaluateUnloggedForSelf: aCodeString

	^Compiler evaluate:
		aCodeString
		for: self
		logged: false! !

!Object methodsFor: 'scripting' stamp: 'sw 8/3/2001 22:02'!
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 == #'instance variables') ifTrue:		"user-defined instance variables"
		[^ self methodInterfacesForInstanceVariablesCategoryIn: aVocabulary].

	(categorySymbol == #scripts) ifTrue:						"user-defined scripts"
		[^ self methodInterfacesForScriptsCategoryIn: aVocabulary].

	^ (self usableMethodInterfacesIn: (aVocabulary methodInterfacesInCategory: (aVocabulary translatedWordingFor: categorySymbol) forInstance: self ofClass: self class limitClass: aLimitClass))   "all others"! !

!Object methodsFor: 'scripting' stamp: 'sw 2/6/2003 18:05' prior: 38927829!
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].

	^ (self usableMethodInterfacesIn: (aVocabulary methodInterfacesInCategory: (aVocabulary translatedWordingFor: categorySymbol) forInstance: self ofClass: self class limitClass: aLimitClass))   "all others"! !

!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: 'scripts-kernel' stamp: 'sw 9/6/2002 11:33'!
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:) 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: 'system primitives' stamp: 'di 1/9/1999 15:19' prior: 25274472!
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: 'brp 9/19/2003 16:20'!
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 recevier.
	Fails if either argument is a SmallInteger."

	(Array with: self)
		elementsForwardIdentityTo:
			(Array with: otherObject)
				copyHash: copyHash! !

!Object methodsFor: 'system primitives' stamp: 'zz 3/3/2004 23:53' prior: 38933207!
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: '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: '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 1/30/2001 22:24'!
haveFullProtocolBrowsed
	"Open up a Lexicon on the receiver"

	^ self haveFullProtocolBrowsedShowingSelector: nil

	"(2@3) haveFullProtocolBrowsed"
! !

!Object methodsFor: 'testing' stamp: 'sw 3/20/2001 12:20'!
haveFullProtocolBrowsedShowingSelector: aSelector
	"Open up a Lexicon on the receiver, having it open up showing aSelector, which may be nil"

	| aBrowser |
	aBrowser _ InstanceBrowser new useVocabulary: Vocabulary fullVocabulary.
	aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: aSelector

	"(2@3) haveFullProtocolBrowsed"! !

!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: 'nk 4/17/2004 19:43'!
isColorForm
	^false! !

!Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'!
isCompiledMethod

	^ false! !

!Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'!
isForm
	^false! !

!Object methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'!
isHeap

	^ 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: 'gm 2/22/2003 12:56'!
isMorphicModel
	"Return true if the receiver is a morphic model"
	^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' stamp: 'ar 8/14/2001 23:19'!
isVariableBinding
	"Return true if I represent a literal variable binding"
	^false
	! !

!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' 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: '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 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: 'translation support' prior: 25292947!
inline: inlineFlag
	"For translation only; noop when running in Smalltalk."! !

!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: '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: 'user interface' stamp: 'sd 5/11/2003 16:57' prior: 25269884!
beep
	"if sound system is present use it otherwise do whatever we can"
	
	| classOrNil |
	classOrNil := self class environment at: #SampledSound ifAbsent: [nil].
	classOrNil isNil
			ifTrue: [self primitiveBeep]
			ifFalse: [ classOrNil beep]
			
! !

!Object methodsFor: 'user interface' stamp: 'nk 7/3/2003 17:45' prior: 38940551!
beep
	"if sound system is present use it otherwise do whatever we can"
	
	| classOrNil |
	classOrNil := self class environment at: #SampledSound ifAbsent: [nil].
	classOrNil isNil
			ifTrue: [self beepPrimitive ]
			ifFalse: [ classOrNil beep]
			
! !

!Object methodsFor: 'user interface' stamp: 'md 10/22/2003 16:26' prior: 38940884!
beep
	"If sound system is present use it, otherwise do whatever we can."
	
	| classOrNil |
	self deprecatedExplanation: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'.
	classOrNil := self class environment at: #SampledSound ifAbsent: [nil].
	classOrNil ifNil: [self primitiveBeep] ifNotNil: [classOrNil beep]
			
! !

!Object methodsFor: 'user interface' stamp: 'md 12/12/2003 17:02' prior: 38941220!
beep
	"If sound system is present use it, otherwise do whatever we can."
	
	| classOrNil |
	self deprecated: 'Use Beeper>>beep or Beeper>>beepPrimitive instead of 1 beep.'.
	classOrNil := self class environment at: #SampledSound ifAbsent: [nil].
	classOrNil ifNil: [self primitiveBeep] ifNotNil: [classOrNil beep]
			
! !

!Object methodsFor: 'user interface' stamp: 'gk 2/24/2004 08:49' prior: 38941637!
beep
	"Deprecated."
	
	self deprecated: 'Use Beeper class>>beep instead.'.
	Beeper beep! !

!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: 'ar 12/14/2001 20:08'!
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: aString.
	aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
	aMorph openInHand! !

!Object methodsFor: 'user interface' stamp: 'jcg 11/1/2001 13:13'!
notYetImplemented
	self inform: 'Not yet implemented (', thisContext sender printString, ')'! !

!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 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 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: 'sw 9/17/2002 13:12'!
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 interfaces firstIndex secondIndex |
	masterOrder _ Vocabulary eToyVocabulary masterOrderingOfPhraseSymbols.
	interfaces _ interfaceList asSortedCollection:
		[:a :b |
			firstIndex _ masterOrder indexOf: a elementSymbol.
			secondIndex _ masterOrder indexOf: b elementSymbol.
			firstIndex > 0
				ifTrue:
					[secondIndex = 0 or: [secondIndex > firstIndex]]
				ifFalse:
					[secondIndex ==  0
						ifTrue:
							[b elementSymbol < a elementSymbol]
						ifFalse:
							["b in list, a not"
							false]]].
	^ interfaces asArray! !

!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 11/13/2001 09:37'!
tilePhrasesForCategory: aCategorySymbol inViewer: aViewer
	"Return a collection of phrases for the category.  If using classic tiles, only include phrases that have fewer than two arguments, because all that they can handle."

	| interfaces itsSelector toSuppress |
	interfaces _ self methodInterfacesForCategory: aCategorySymbol inVocabulary: aViewer currentVocabulary limitClass: aViewer limitClass.
	interfaces _ self methodInterfacesInPresentationOrderFrom: interfaces forCategory: aCategorySymbol.
	toSuppress _ aViewer currentVocabulary phraseSymbolsToSuppress.
	interfaces _ interfaces select: [:int | (toSuppress includes: int selector) not].
	Preferences universalTiles ifFalse:
		[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 |
			aMethodInterface wantsReadoutInViewer
				ifTrue:
					[aViewer phraseForVariableFrom: aMethodInterface]
				ifFalse:
					[aViewer phraseForCommandFrom: aMethodInterface]]! !

!Object methodsFor: 'viewer' stamp: 'sw 5/22/2003 14:06' prior: 38951419!
tilePhrasesForCategory: aCategorySymbol inViewer: aViewer
	"Return a collection of phrases for the category.  If using classic tiles, only include phrases that have fewer than two arguments, because all that they can handle."

	| interfaces itsSelector toSuppress resultType |
	interfaces _ self methodInterfacesForCategory: aCategorySymbol inVocabulary: aViewer currentVocabulary limitClass: aViewer limitClass.
	interfaces _ self methodInterfacesInPresentationOrderFrom: interfaces forCategory: aCategorySymbol.
	toSuppress _ aViewer currentVocabulary phraseSymbolsToSuppress.
	interfaces _ interfaces select: [:int | (toSuppress includes: int selector) not].
	Preferences universalTiles ifFalse:
		[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]) 
			"aMethodInterface wantsReadoutInViewer"
				ifTrue:
					[aViewer phraseForVariableFrom: aMethodInterface]
				ifFalse:
					[aViewer phraseForCommandFrom: aMethodInterface]]! !

!Object methodsFor: 'viewer' stamp: 'sw 12/11/2001 16:31'!
tilePhrasesForSelectorList: aList inViewer: aViewer
	"Return a collection of phrases for the list.  If using classic tiles, only include phrases that have fewer than two arguments, because all that they can handle."

	| interfaces itsSelector toSuppress aVocab |
	aVocab _ aViewer currentVocabulary.
	interfaces _ aList collect: [:aSel | aVocab methodInterfaceForSelector: aSel class: self class].
	interfaces _ self methodInterfacesInPresentationOrderFrom: interfaces forCategory: #search.
	toSuppress _ aViewer currentVocabulary phraseSymbolsToSuppress.
	interfaces _ interfaces select: [:int | (toSuppress includes: int selector) not].

	Preferences messengersInViewers ifTrue:
		[^ interfaces collect:
			[:anInterface | self messengerFrom: anInterface freeStanding: false]].

	Preferences universalTiles ifFalse:
		[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 |
			aMethodInterface wantsReadoutInViewer
				ifTrue:
					[aViewer phraseForVariableFrom: aMethodInterface]
				ifFalse:
					[aViewer phraseForCommandFrom: aMethodInterface]]! !

!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: '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: 'sw 3/7/2002 01:01'!
uniqueNameForReferenceFrom: proposedName
	"Answer a satisfactory symbol, similar to the proposedName but obeying the rules, to represent the receiver"

	| aName nameSym stem knownClassVars |
	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.
	knownClassVars _ ScriptingSystem allKnownClassVariableNames.
	aName _ Utilities keyLike: stem satisfying:
		[:jinaLake |
			nameSym _ jinaLake asSymbol.
			 (References includesKey:  nameSym) not and:
				[(knownClassVars includes: nameSym) not]].
	^ aName asSymbol! !

!Object methodsFor: 'viewer' stamp: 'sw 3/15/2004 23:53' prior: 38956434!
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 scopeHas: nameSym ifTrue: [:x | okay _ false "don't use it"].
			okay].
	^ aName asSymbol! !

!Object methodsFor: 'viewer' stamp: 'sw 11/21/2001 15:18'!
uniqueNameForReferenceOrNil
	"If the receiver has a unique name for reference, return it here, else return nil"

	| aName |
	(References includesIdentity: self) ifTrue: [^ References keyAtValue: self].

	(aName _ Smalltalk keyAtValue: self ifAbsent: [nil]) ifNotNil: [^ aName].
	^ nil! !

!Object methodsFor: 'viewer' stamp: 'sw 3/15/2004 23:01' prior: 38957976!
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: '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: 'private' stamp: 'ccn 1/19/2000 20:37' prior: 25281045!
errorNotIndexable
	"Create an error notification that the receiver is not indexable."

	self error: self class name asPlural , ' are not indexable'! !

!Object methodsFor: 'private' stamp: 'yo 6/29/2004 11:37' prior: 38959651!
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' stamp: 'ar 3/17/2001 23:52'!
primitiveError: aString 
	"This method is called when the error handling results in a recursion in 
	calling on error: or halt or halt:."

	| context |
	Sensor eventQueue: nil. "Or else we won't get keyboard and possibly run out of memory"
	(String
		streamContents: 
			[:s |
			s nextPutAll: '***System error handling failed***'.
			s cr; nextPutAll: aString.
			context _ thisContext sender sender.
			20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]].
			s cr; nextPutAll: '-------------------------------'.
			s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
			s cr; nextPutAll: 'Type any other character to restart.'])
		displayAt: 0 @ 0.
	[Sensor keyboardPressed] whileFalse.
	Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator].
	Smalltalk isMorphic
		ifTrue: [World install "init hands and redisplay"]
		ifFalse: [ScheduledControllers searchForActiveController]! !

!Object methodsFor: 'private' stamp: 'ar 2/6/2004 14:47' prior: 38960117!
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: '*system-support' stamp: 'dvf 8/23/2003 10:30'!
systemNavigation

	^ SystemNavigation new! !

!Object methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:27' prior: 38962059!
systemNavigation

	^ SystemNavigation default! !

!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: 'inspecting' stamp: 'ajh 1/31/2003 15:49' prior: 25269653!
basicInspect
	"Create and schedule an Inspector in which the user can examine the 
	receiver's variables. This method should not be overriden."

	BasicInspector openOn: self withEvalPane: false! !

!Object methodsFor: 'inspecting' stamp: 'ajh 2/3/2003 19:19' prior: 25272052!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."

	self inspectorClass openOn: self withEvalPane: true! !

!Object methodsFor: 'inspecting' stamp: 'ajh 2/3/2003 19:18'!
inspectorClass

	^ Inspector! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'!
sunitAddDependent: anObject
 
        self addDependent: anObject! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58' prior: 38963226!
sunitAddDependent: anObject
 
        self addDependent: anObject! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'!
sunitChanged: anAspect
 
        self changed: anAspect! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58' prior: 38963516!
sunitChanged: anAspect
 
        self changed: anAspect! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'!
sunitRemoveDependent: anObject
 
        self removeDependent: anObject! !

!Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58' prior: 38963786!
sunitRemoveDependent: anObject
 
        self removeDependent: anObject! !

!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' prior: 25270055!
browseHierarchy
	self systemNavigation browseHierarchy: self class! !

!Object class methodsFor: 'instance creation' stamp: 'sw 2/5/2002 21:09'!
categoryForUniclasses
	"Answer the category into which to place unique-class instances"

	^ 'EToy-UserObjects'! !

!Object class methodsFor: 'instance creation' stamp: 'sw 1/23/2003 09:45' prior: 38964372!
categoryForUniclasses
	"Answer the default system category into which to place unique-class instances"

	^ 'UserObjects'! !

!Object class methodsFor: 'instance creation' stamp: 'ajh 5/23/2002 00:35' prior: 25325887!
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: 'private' stamp: 'mir 8/22/2001 15:20'!
releaseExternalSettings
	"Do nothing as a default"! !

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

!ObjectExplorer methodsFor: 'accessing' stamp: 'hg 9/7/2001 12:35'!
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: 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: 'accessing' stamp: 'nk 7/24/2003 10:08' prior: 38966400!
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: 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: 'accessing' stamp: 'rhi 5/27/2004 17:05' prior: 38967109!
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' prior: 25339312!
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: 'menus' stamp: 'nk 7/24/2003 10:25'!
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: 'nk 7/24/2003 10:25'!
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: 'nk 7/24/2003 10:26'!
exploreSelection
	"Open an ObjectExplorer on the current selection"
	self object explore! !

!ObjectExplorer methodsFor: 'menus' stamp: 'rhi 5/27/2004 17: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: 'sd 3/28/2003 16:26' prior: 25337982!
genericMenu: aMenu

	| insideObject menu |
	currentSelection ifNil:
		[menu _ aMenu.
		menu add: '*nothing selected*' target: self selector: #yourself]
	 ifNotNil:
		[menu _ DumberMenuMorph new defaultTarget: self.
		insideObject _ currentSelection withoutListWrapper.
		menu 
			add: 'explore' target: insideObject  selector: #explore;
			add: 'inspect' target: insideObject  selector: #inspect;
			addLine;
			add: 'objects pointing to this value' target: Smalltalk  selector:  #browseAllObjectReferencesTo:except:ifNone:  argumentList: (Array with: insideObject with: #() with: nil);
			addLine;
			add: 'browse full' target: Browser  selector: #fullOnClass:  argument: insideObject class;
			add: 'browse class' target: self  selector: #openBrowser: argument: insideObject class;
			add: 'browse hierarchy' target: Utilities  selector:  #spawnHierarchyForClass:selector: argumentList: (Array with: insideObject class with: nil).
		insideObject class == Symbol ifTrue: [
			menu 
				addLine;
				add: ('senders of ', insideObject printString) target: Smalltalk  selector: #browseAllCallsOn:  argument: insideObject;
				add: ('implementors of ', insideObject printString) target: Smalltalk  selector: #browseAllImplementorsOf:  argument: insideObject]].

	^ menu! !

!ObjectExplorer methodsFor: 'menus' stamp: 'sd 4/16/2003 11:41' prior: 38971401!
genericMenu: aMenu

	| insideObject menu |
	currentSelection ifNil:
		[menu _ aMenu.
		menu add: '*nothing selected*' target: self selector: #yourself]
	 ifNotNil:
		[menu _ DumberMenuMorph new defaultTarget: self.
		insideObject _ currentSelection withoutListWrapper.
		menu 
			add: 'explore' target: insideObject  selector: #explore;
			add: 'inspect' target: insideObject  selector: #inspect;
			addLine;
			add: 'objects pointing to this value' target: self systemNavigation  selector:  #browseAllObjectReferencesTo:except:ifNone:  argumentList: (Array with: insideObject with: #() with: nil);
			addLine;
			add: 'browse full' target: Browser  selector: #fullOnClass:  argument: insideObject class;
			add: 'browse class' target: self  selector: #openBrowser: argument: insideObject class;
			add: 'browse hierarchy' target: Utilities  selector:  #spawnHierarchyForClass:selector: argumentList: (Array with: insideObject class with: nil).
		insideObject class == Symbol ifTrue: [
			menu 
				addLine;
				add: ('senders of ', insideObject printString) target:  self systemNavigation  selector: #browseAllCallsOn:  argument: insideObject;
				add: ('implementors of ', insideObject printString) target: self systemNavigation  selector: #browseAllImplementorsOf:  argument: insideObject]].

	^ menu! !

!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:24' prior: 38972753!
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: 'nk 7/24/2003 10:26'!
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: 'user interface' stamp: 'sd 3/28/2003 16:27'!
openBrowser: aClass

	Browser newOnClass: aClass! !

!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: 'monitoring' stamp: 'nk 7/12/2003 18:33'!
monitor: anObjectExplorerWrapper
	"Start stepping and watching the given wrapper for changes."
	anObjectExplorerWrapper ifNil: [ ^self ].
	ActiveWorld ifNil: [ ^self ].
	self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString.
	ActiveWorld startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:46'!
monitorList
	^monitorList ifNil: [ monitorList _ WeakIdentityKeyDictionary new ].! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:59'!
release
	ActiveWorld ifNotNil: [ ActiveWorld 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: 'nk 7/12/2003 18:29'!
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: 'nk 7/12/2003 18:34'!
stopMonitoring
	monitorList _ nil.
	ActiveWorld stopStepping: self selector: #step! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'hg 9/7/2001 12:15'!
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]) ,
	((1 to: item basicSize) collect: [:index |
		self class
			with: (item basicAt: index)
			name: index printString
			model: item])! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:17' prior: 38978146!
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: '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: '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: 'hg 9/7/2001 19:58'!
asString
	| explorerString string |
	explorerString _ 
		[item asExplorerString]
			on: Error 
			do: ['<error 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 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
! !

!ObjectFinalizer methodsFor: 'initialize' stamp: 'ar 5/19/2003 20:12'!
receiver: aReceiver selector: aSelector argument: anObject
	receiver := aReceiver.
	selector := aSelector.
	arguments := Array with: anObject! !

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

!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: 'RAA 3/8/2001 18:03'!
numberOneColor: aColor

	myTarget fillStyle isGradientFill ifFalse: [
		^(myTarget isKindOf: SystemWindow) ifTrue: [
			myTarget setWindowColor: aColor
		] ifFalse: [
			myTarget fillStyle: aColor
		]
	].
	myTarget fillStyle firstColor: aColor forMorph: myTarget hand: nil
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/16/2003 20:36' prior: 38984202!
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: 'RAA 3/15/2001 16:35'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Properties for ',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' action: #doAccept color: color lighter 
			help: 'keep changes made and close panel'.
		self 
			buttonNamed: 'Cancel' action: #doCancel color: color lighter 
			help: 'cancel changes made and close panel'.
	}, self rebuildOptionalButtons.

	thingsToRevert _ Dictionary new.
	"thingsToRevert at: #fillStyle: put: myTarget fillStyle."
	(myTarget isKindOf: SystemWindow) 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: 'gm 2/16/2003 20:36' prior: 38984942!
rebuild
	self removeAllMorphs.
	self addARow: { 
				self lockedString: 'Properties for ' , 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'
					action: #doAccept
					color: color lighter
					help: 'keep changes made and close panel'.
				self 
					buttonNamed: 'Cancel'
					action: #doCancel
					color: color lighter
					help: 'cancel changes made and close panel'} , 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: 'dgd 10/8/2003 19:35' prior: 38986447!
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: 'RAA 3/15/2001 13:02'!
rebuildOptionalButtons

	| answer |

	answer _ {
		self transparentSpacerOfSize: 20@3.
		self 
			buttonNamed: 'Button' action: #doButtonProperties color: color lighter 
			help: 'open a button properties panel for the morph'.
	}.
	(myTarget isKindOf: TextMorph) ifTrue: [
		answer _ answer, {
			self 
				buttonNamed: 'Text' action: #doTextProperties color: color lighter 
				help: 'open a text properties panel for the morph'.
		}.
	].
	^answer! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/22/2003 13:16' prior: 38989531!
rebuildOptionalButtons
	| answer |
	answer := { 
				self transparentSpacerOfSize: 20 @ 3.
				self 
					buttonNamed: 'Button'
					action: #doButtonProperties
					color: color lighter
					help: 'open a button properties panel for the morph'}.
	(myTarget isTextMorph) 
		ifTrue: 
			[answer := answer , { 
								self 
									buttonNamed: 'Text'
									action: #doTextProperties
									color: color lighter
									help: 'open a text properties panel for the morph'}].
	^answer! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:37' prior: 38990086!
rebuildOptionalButtons

	| answer |

	answer _ {
		self transparentSpacerOfSize: 20@3.
		self 
			buttonNamed: 'Button' translated action: #doButtonProperties color: color lighter 
			help: 'open a button properties panel for the morph' translated.
	}.
	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: 'RAA 3/15/2001 11:52'!
initialize

	super initialize.
	myTarget ifNil: [myTarget _ RectangleMorph new openInWorld].
	self color:  (Color r: 0.548 g: 0.839 b: 0.452).
	self borderColor: self color darker.
	self rebuild.
! !

!ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44' prior: 38993653!
initialize
"initialize the state of the receiver"
	super initialize.
""
	myTarget
		ifNil: [myTarget _ RectangleMorph new openInWorld].
	self rebuild! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'ar 8/25/2001 19:12'!
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'.
		selector on: #mouseDown send: #beep to: self.
		selector addMorphCentered: ((Morph new) color: (Color black alpha: 0.5); extent: selector extent).
	].
	^selector! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'nb 6/17/2003 12:25' prior: 38994177!
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'.
		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: 'sd 11/13/2003 21:03' prior: 38995174!
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: 'RAA 3/3/2001 15:02'!
paneFor2ndGradientColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self getter: #tgt2ndGradientColor setter: #tgt2ndGradientColor:.
				self lockedString: '2nd gradient color'.
				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:21' prior: 38997168!
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: 'ar 8/25/2001 18:27'!
paneForBorderColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self
				getter: #targetBorderColor
				setter: #targetBorderColor:.
			self lockedString: 'Border Color'.
			(self paneForBorderStyle) hResizing: #shrinkWrap; layoutInset: 5.
			self lockedString: 'Border style'.
			self paneForBorderWidth.
		} 
		named: #pickerForBorderColor.

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:23' prior: 38998364!
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: 'ar 11/26/2001 15:02'!
paneForBorderStyle

	^self inARow: {
		self borderPrototype: (BorderStyle width: 4 color: Color black)
			help:'Click to select a simple colored border'.
		self borderPrototype: (BorderStyle raised width: 4)
			help:'Click to select a simple raised border'.
		self borderPrototype: (BorderStyle inset width: 4)
			help:'Click to select a simple inset border'.
		self borderPrototype: (BorderStyle complexFramed width: 4)
			help:'Click to select a complex framed border'.
		self borderPrototype: (BorderStyle complexRaised width: 4)
			help:'Click to select a complex raised border'.
		self borderPrototype: (BorderStyle complexInset width: 4)
			help:'Click to select a complex inset border'.
		self borderPrototype: (BorderStyle complexAltFramed width: 4)
			help:'Click to select a complex framed border'.
		self borderPrototype: (BorderStyle complexAltRaised width: 4)
			help:'Click to select a complex raised border'.
		self borderPrototype: (BorderStyle complexAltInset width: 4)
			help:'Click to select a complex inset border'.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:25' prior: 38999274!
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: 'RAA 2/21/2001 10:58'!
paneForBorderWidth

	^(self inARow: {
		self
			buildFakeSlider: 'Border width' 
			selector: #adjustTargetBorderWidth:
			help: 'Drag in here to change the border width'
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:29' prior: 39001627!
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: 'RAA 3/8/2001 18:04'!
paneForCornerRoundingToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #wantsRoundedCorners setter: #toggleCornerRounding
			help: 'Turn rounded corners on or off'.
		self lockedString: ' Rounded corners'.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18' prior: 39002217!
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: 'RAA 3/8/2001 18:01'!
paneForDropShadowToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #hasDropShadow setter: #toggleDropShadow
			help: 'Turn drop shadows on or off'.
		self lockedString: ' Drop shadow color'.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:40' prior: 39002888!
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: 'RAA 2/21/2001 11:05'!
paneForGradientDirection

	^(self inARow: {
		self
			buildFakeSlider: 'Direction' 
			selector: #adjustTargetGradientDirection:
			help: 'Drag in here to change the direction of the gradient'
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22' prior: 39003528!
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: 'RAA 2/20/2001 17:44'!
paneForGradientFillToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasGradientFill
			setter: #toggleTargetGradientFill
			help: 'Turn gradient fill on or off'.
		self lockedString: ' Gradient fill'.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22' prior: 39004163!
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: 'RAA 2/21/2001 10:51'!
paneForGradientOrigin

	^(self inARow: {
		self
			buildFakeSlider: 'Origin' 
			selector: #adjustTargetGradientOrigin:
			help: 'Drag in here to change the origin of the gradient'
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21' prior: 39004831!
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: 'RAA 3/8/2001 18:04'!
paneForLockedToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #isLocked setter: #toggleLocked
			help: 'Turn lock on or off'.
		self lockedString: ' Lock'.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:19' prior: 39005441!
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: 'RAA 3/3/2001 15:00'!
paneForMainColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self 
				getter: #numberOneColor 
				setter: #numberOneColor:.
			self lockedString: 'Color'.
			(self paneForSolidFillToggle)  hResizing: #shrinkWrap.
		} 
		named: #pickerForColor.

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20' prior: 39006014!
paneForMainColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self 
				getter: #numberOneColor 
				setter: #numberOneColor:.
			self lockedString: 'Color' translated.
			(self paneForSolidFillToggle)  hResizing: #shrinkWrap.
		} 
		named: #pickerForColor.

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'RAA 2/20/2001 12:34'!
paneForRadialGradientToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetRadial setter: #toggleTargetRadial
			help: 'Turn radial gradient on or off'.
		self lockedString: ' Radial gradient'.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21' prior: 39006721!
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: 'RAA 2/22/2001 09:21'!
paneForShadowOffset

	^(self inARow: {
		self
			buildFakeSlider: 'Offset' 
			selector: #adjustTargetShadowOffset:
			help: 'Drag in here to change the offset of the shadow'
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:36' prior: 39007738!
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: 'RAA 2/20/2001 17:47'!
paneForSolidFillToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasSolidFill
			setter: #toggleTargetSolidFill
			help: 'Turn solid fill on or off'.
		self lockedString: ' Solid fill'.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20' prior: 39008337!
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: 'RAA 3/8/2001 18:04'!
paneForStickinessToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #isSticky setter: #toggleStickiness
			help: 'Turn stickiness on or off'.
		self lockedString: ' Sticky'.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18' prior: 39008974!
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.! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 10:27' prior: 25444228!
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"
! !

!ObjectTest methodsFor: 'testing - error handling' stamp: 'm 8/12/2003 17:26'!
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.! !

!ObjectTracer methodsFor: 'very few messages' stamp: 'hg 10/2/2001 20:43'!
doesNotUnderstand: aMessage 
	"All external messages (those not caused by the re-send) get trapped here"
	"Present a dubugger before proceeding to re-send the message"

	Debugger openContext: thisContext
				label: 'About to perform: ', aMessage selector
				contents: nil.
	^ aMessage sentTo: tracedObject.
! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 11/5/2001 15:36'!
documentation: maneno
	"Set the receiver's documentation, in the current langauge"

	| wording |
	wording _ self wording.
	self absorbTranslation: (ElementTranslation new wording: wording  helpMessage: maneno language: #English) ! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 9/12/2001 23:19'!
documentationOrNil
	"Answer the contents of the receiver's documentation slot.  This interface has perhaps outlived its usefulness."

	^ self documentation! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'ka 6/13/2002 19:43'!
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 _ FillInTheBlank
				multiLineRequest: 'Kindly edit the description'
				centerAt: Sensor cursorPoint
				initialAnswer: helpMessage
				answerHeight: 200.
	reply isEmptyOrNil
		ifFalse: [self documentation: reply]! !

!ObjectWithDocumentation methodsFor: 'queries' stamp: 'sw 9/12/2001 14:36'!
documentation
	"Answer the receiver's documentation"

	^ self translatedToPrevailingLanguage helpMessage! !

!ObjectWithDocumentation methodsFor: 'queries' stamp: 'sw 9/12/2001 15:13'!
wording
	"Answer the receiver's wording"

	^ self translatedToPrevailingLanguage wording! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'sw 9/12/2001 23:03'!
absorbTranslation: anElementTranslation
	"Absorb the given translation, which could overlay a prior version"

	naturalLanguageTranslations ifNil:
		[naturalLanguageTranslations _ OrderedCollection new].
	naturalLanguageTranslations removeAllSuchThat:
		[:tr | tr language == anElementTranslation language].
	naturalLanguageTranslations add: anElementTranslation! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'dgd 12/4/2003 19:08'!
translatedToLanguage: languageSymbol
	"Answer an ElementTranslation object in the prevailing natural language, or, if none found, in English"

	| fallback elSym el wrd doc |

	elSym _ self elementSymbol.
	^ naturalLanguageTranslations isEmptyOrNil 
		ifFalse:
			[naturalLanguageTranslations do:
				[:aTranslation |
					aTranslation language == languageSymbol
						ifTrue:
							[^ aTranslation].
					aTranslation language == #English
						ifTrue:
							[fallback _ aTranslation]].
			fallback ifNil: [ElementCategory new categoryName: #none]]

		ifTrue:
			[(el _ self elementSymbol) ifNotNil:
				[((el beginsWith: 'get') and: [elSym size > 3])
					ifTrue:
						[wrd _ (elSym copyFrom: 4 to: elSym size) withFirstCharacterDownshifted.
						doc _ 'get value of ', elSym]
					ifFalse:
						[((elSym beginsWith: 'set') and: [elSym size > 4])
							ifTrue:
								[wrd _ (elSym copyFrom: 4 to: elSym size - 1) withFirstCharacterDownshifted.
								doc _ 'set value of ', elSym]
							ifFalse:
								[wrd _ ScriptingSystem wordingForOperator: elSym.
								doc _ nil]]].
			^ ElementTranslation new wording: wrd helpMessage: doc language: #English]! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'dgd 2/24/2004 20:02' prior: 39014093!
translatedToLanguage: languageSymbol 
	"Answer an ElementTranslation object in the prevailing natural  
	language, or, if none found, in English"
	| fallback elSym el wrd doc |
	elSym := self elementSymbol.
	^ naturalLanguageTranslations isEmptyOrNil
		ifTrue: [(el := self elementSymbol)
				ifNotNil: [((el beginsWith: 'get')
							and: [elSym size > 3])
						ifTrue: [wrd := (elSym copyFrom: 4 to: elSym size) withFirstCharacterDownshifted.
							doc := 'get value of ' , elSym]
						ifFalse: [((elSym beginsWith: 'set')
									and: [elSym size > 4])
								ifTrue: [wrd := (elSym copyFrom: 4 to: elSym size - 1) withFirstCharacterDownshifted.
									doc := 'set value of ' , elSym]
								ifFalse: [wrd := ScriptingSystem wordingForOperator: elSym.
									doc := nil]]].
			^ ElementTranslation new
				wording: wrd
				helpMessage: doc
				language: #English]
		ifFalse: [naturalLanguageTranslations
				do: [:aTranslation | 
					aTranslation language == languageSymbol
						ifTrue: [^ aTranslation].
					aTranslation language == #English
						ifTrue: [fallback := aTranslation]].
			fallback
				ifNil: [ElementCategory new categoryName: elSym]]! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'sw 12/18/2001 22:14'!
translatedToPrevailingLanguage
	"Answer an ElementTranslation object in the prevailing natural language, or, if none found, in English"

	| prevailingLanguage fallback elSym el wrd doc |

	prevailingLanguage _ self currentWorld currentNaturalLanguage.
	elSym _ self elementSymbol.
	^ naturalLanguageTranslations isEmptyOrNil 
		ifFalse:
			[naturalLanguageTranslations do:
				[:aTranslation |
					aTranslation language == prevailingLanguage
						ifTrue:
							[^ aTranslation].
					aTranslation language == #English
						ifTrue:
							[fallback _ aTranslation]].
			fallback ifNil: [ElementCategory new categoryName: #none]]

		ifTrue:
			[(el _ self elementSymbol) ifNotNil:
				[((el beginsWith: 'get') and: [elSym size > 3])
					ifTrue:
						[wrd _ (elSym copyFrom: 4 to: elSym size) withFirstCharacterDownshifted.
						doc _ 'get value of ', elSym]
					ifFalse:
						[((elSym beginsWith: 'set') and: [elSym size > 4])
							ifTrue:
								[wrd _ (elSym copyFrom: 4 to: elSym size - 1) withFirstCharacterDownshifted.
								doc _ 'set value of ', elSym]
							ifFalse:
								[wrd _ ScriptingSystem wordingForOperator: elSym.
								doc _ nil]]].
			^ ElementTranslation new wording: wrd helpMessage: doc language: #English]! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'dgd 12/4/2003 19:09' prior: 39016612!
translatedToPrevailingLanguage
	"Answer an ElementTranslation object in the prevailing natural language, or, if none found, in English"

	^ Preferences translationWithBabel
			ifTrue:[ self translatedToPrevailingLanguageUsingBabel ]
			ifFalse:[ self translatedToLanguage:self currentWorld currentNaturalLanguage]
! !

!ObjectWithDocumentation methodsFor: 'translation' stamp: 'dgd 12/4/2003 19:14'!
translatedToPrevailingLanguageUsingBabel
	"Answer an ElementTranslation object in the prevailing natural  
	language using the Babel mechanism"
	| elSym |
	elSym := self elementSymbol.
	""
	elSym isNil
		ifFalse: [""
			((elSym beginsWith: 'get')
					and: [elSym size > 3])
				ifTrue: [""
					^ ElementTranslation new
						wording: (elSym allButFirst: 3) withFirstCharacterDownshifted translated
						helpMessage: ('get value of {1}' translated format: {elSym})
						language: self currentWorld currentNaturalLanguage].
			""
			((elSym beginsWith: 'set')
					and: [elSym size > 4])
				ifTrue: [""
					^ ElementTranslation new
						wording: (elSym allButFirst: 3) withFirstCharacterDownshifted translated
						helpMessage: ('set value of {1}' translated format: {elSym})
						language: self currentWorld currentNaturalLanguage]].
	""
	^ (self translatedToLanguage: #English) translated! !

!ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'sw 9/12/2001 23:03'!
elementSymbol
	"Answer the receiver's element symbol"

	^ elementSymbol! !

!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.!
!ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:38'!
classVar

	^ ClassVar! !

!ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:54'!
initialize
	"self initialize"
	
	Transcript show: 'Initializing ObjectWithInitialize. classVar state was: ', ClassVar asString; cr.
	
	ClassVar isNil  
		ifTrue: [ClassVar := 1]
		ifFalse: [ClassVar := 2].
	Transcript show: 'After initializing ObjectWithInitialize. classVar state is: ', ClassVar asString; cr.! !

!ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:39'!
reset
	"self reset"
	
	ClassVar := nil! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'sw 8/12/2001 17:32'!
alphabeticTabs
	"Answer a list of buttons which, when hit, will trigger the choice of a morphic category"

	| buttonList aButton tabLabels |
	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: 'sw 8/12/2001 16:35'!
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 |
	aPartsBin _ self findDeeplyA: PartsBin.
	aPartsBin removeAllMorphs.
	sortedQuads _ quads asSortedCollection:
		[:a :b | a third < b third].
	aPartsBin listDirection: #leftToRight quadList: sortedQuads.
	aPartsBin width: self innerBounds width.
	aButton ifNotNil: [self tabsPane highlightOnlySubmorph: aButton]! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'nk 5/1/2004 18:15' prior: 39021081!
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 |
	aPartsBin _ self findDeeplyA: PartsBin.
	aPartsBin removeAllMorphs.
	sortedQuads _ quads asSortedCollection:
		[:a :b | a third < b third].
	aPartsBin listDirection: #leftToRight quadList: sortedQuads.
	aPartsBin width: self innerBounds width.
	aButton ifNotNil: [self tabsPane highlightOnlySubmorph: aButton].
	aPartsBin vResizing: #shrinkWrap.! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'sw 8/11/2001 14:00'!
showAlphabeticCategory: aString fromButton: aButton
	"Blast items beginning with a given letter into my lower pane"

	| eligibleClasses quads uc |
	submorphs last removeAllMorphs.
	uc _ aString asUppercase asCharacter.
	eligibleClasses _ Morph withAllSubclasses.

	quads _ OrderedCollection new.
	eligibleClasses do:
		[:aClass |
			aClass theNonMetaClass addPartsDescriptorQuadsTo: quads if:
				[:info | info formalName asUppercase first  = uc]].
	self installQuads: quads fromButton: aButton! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'dgd 12/11/2003 12:58' prior: 39022260!
showAlphabeticCategory: aString fromButton: aButton
	"Blast items beginning with a given letter into my lower pane"

	| eligibleClasses quads uc |
	submorphs last removeAllMorphs.
	uc _ aString asUppercase asCharacter.
	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: 'alphabetic' stamp: 'sw 8/12/2001 16:33'!
showAlphabeticTabs
	"Switch to the mode of showing alphabetic tabs"

	modeSymbol == #alphabetic ifFalse:
		[self initializeWithTabs: self alphabeticTabs.
		self modeSymbol: #alphabetic.
		self tweakAppearanceAfterModeShift]! !

!ObjectsTool methodsFor: 'categories' stamp: 'sw 8/12/2001 17:37'!
showCategories
	"Set the receiver up so that it shows tabs for each of the standard categories"

	modeSymbol == #categories ifFalse:
		[self initializeWithTabs: self tabsForCategories.
		self modeSymbol: #categories.
		self tweakAppearanceAfterModeShift]! !

!ObjectsTool methodsFor: 'categories' stamp: 'sw 8/12/2001 02:53'!
showCategory: aCategoryName fromButton: aButton
	"Project items from the given category into my lower pane"

	| quads  |
	submorphs last removeAllMorphs.
	quads _ OrderedCollection new.
	Morph withAllSubclasses do:
		[:aClass | aClass theNonMetaClass addPartsDescriptorQuadsTo: quads if: [:aDescription | aDescription categories includes: aCategoryName]].
	quads _ quads asSortedCollection:
		[:q1 :q2 | q1 third <= q2 third].
	self installQuads: quads fromButton: aButton! !

!ObjectsTool methodsFor: 'categories' stamp: 'dgd 4/8/2004 18:59' prior: 39024042!
showCategory: aCategoryName fromButton: aButton
	"Project items from the given category into my lower pane"

	| quads  |
	submorphs last removeAllMorphs.
	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: 'sw 8/12/2001 17:39'!
tabsForCategories
	"Answer a list of buttons which, when hit, will trigger the choice of a category"

	| buttonList aButton classes categoryList |
	classes _ Morph withAllSubclasses.
	categoryList _ Set new.
	classes do: [:aClass |
		(aClass class includesSelector: #descriptionForPartsBin) ifTrue:
			[categoryList addAll: aClass descriptionForPartsBin categories].
		(aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue:
			[aClass supplementaryPartsDescriptions do:
				[:aDescription | categoryList addAll: aDescription categories]]].
	categoryList _ categoryList asSortedArray.

	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: 'categories' stamp: 'dgd 4/8/2004 18:59' prior: 39025156!
tabsForCategories
	"Answer a list of buttons which, when hit, will trigger the choice of a category"

	| buttonList aButton classes categoryList |
	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 _ categoryList asSortedArray.

	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: 'sw 8/12/2001 17:33'!
initializeForFlap
	"Initialize the receiver to operate in a flap at the top of the screen.  This worked in the past, but is not currently in the released UI and is not likely to work without some fixup."

	| aPane aBin |
	self borderWidth: 2; borderColor: Color darkGray.
	self layoutInset: 0.
	self hResizing: #shrinkWrap; vResizing: #rigid.
	self listDirection: #topToBottom.
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.

	aPane _ self paneForTabs: self modeTabs.
	aPane color: aPane color darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.

	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"

	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #spaceFill.
	aBin extent: (self currentWorld width) @ 250.
	aBin color: Color orange muchLighter.
	aBin setNameTo: 'Objects'.
	aBin dropEnabled: false.
	self addMorphBack: aBin


! !

!ObjectsTool methodsFor: 'initialization' stamp: 'dgd 8/30/2003 16:10' prior: 39027114!
initializeForFlap
	"Initialize the receiver to operate in a flap at the top of the screen.  This worked in the past, but is not currently in the released UI and is not likely to work without some fixup."

	| aPane aBin |
	self borderWidth: 2; borderColor: Color darkGray.
	self layoutInset: 0.
	self hResizing: #shrinkWrap; vResizing: #rigid.
	self listDirection: #topToBottom.
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.

	aPane _ self paneForTabs: self modeTabs.
	aPane color: aPane color darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.

	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"

	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #spaceFill.
	aBin extent: (self currentWorld width) @ 250.
	aBin color: Color orange muchLighter.
	aBin setNameTo: 'Objects' translated.
	aBin dropEnabled: false.
	self addMorphBack: aBin


! !

!ObjectsTool methodsFor: 'initialization' stamp: 'nk 5/1/2004 17:59' prior: 39028340!
initializeForFlap
	"Initialize the receiver to operate in a flap at the top of the screen.  This worked in the past, but is not currently in the released UI and is not likely to work without some fixup."

	| aPane aBin |
	self borderWidth: 2; borderColor: Color darkGray.
	self layoutInset: 0.
	self hResizing: #shrinkWrap; vResizing: #rigid.
	self listDirection: #topToBottom.
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.

	aPane _ self paneForTabs: self modeTabs.
	aPane color: aPane color darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.

	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"

	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #shrinkWrap.
	aBin extent: (self currentWorld width) @ 250.
	aBin color: Color orange muchLighter.
	aBin setNameTo: 'Objects' translated.
	aBin dropEnabled: false.
	self addMorphBack: aBin


! !

!ObjectsTool methodsFor: 'initialization' stamp: 'sw 8/11/2001 20:14'!
initializeToStandAlone
	"Initialize the receiver so that it can live as a stand-alone morph"

	| aPane aBin aColor |
	self basicInitialize.
	self layoutInset: 6. 
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.
	self useRoundedCorners.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	aPane _ self paneForTabs: self modeTabs.
	aPane addMorphFront: self dismissButton.
	aPane addMorphBack: self helpButton.

	aPane color: (aColor _ aPane color) darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.

	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"

	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #spaceFill.
	aBin extent: (self currentWorld width) @ 250.
	aBin color: aColor lighter lighter.
	aBin setNameTo: 'parts'.
	aBin dropEnabled: false.
	self addMorphBack: aBin.
	self submorphs last width: 350; hResizing: #rigid.
	self color: (Color r: 0.0 g: 0.839 b: 0.226).
	self setProperty: #initialWidth toValue: 268.
	self setNameTo: 'Objects'.
	self showCategories.




! !

!ObjectsTool methodsFor: 'initialization' stamp: 'dgd 8/30/2003 16:09' prior: 39030796!
initializeToStandAlone
	"Initialize the receiver so that it can live as a stand-alone morph"

	| aPane aBin aColor |
	self basicInitialize.
	self layoutInset: 6. 
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.
	self useRoundedCorners.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	aPane _ self paneForTabs: self modeTabs.
	aPane addMorphFront: self dismissButton.
	aPane addMorphBack: self helpButton.

	aPane color: (aColor _ aPane color) darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.

	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"

	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #spaceFill.
	aBin extent: (self currentWorld width) @ 250.
	aBin color: aColor lighter lighter.
	aBin setNameTo: 'parts'.
	aBin dropEnabled: false.
	self addMorphBack: aBin.
	self submorphs last width: 350; hResizing: #rigid.
	self color: (Color r: 0.0 g: 0.839 b: 0.226).
	self setProperty: #initialWidth toValue: 268.
	self setNameTo: 'Objects' translated.
	self showCategories.




! !

!ObjectsTool methodsFor: 'initialization' stamp: 'KLC 2/21/2004 02:28' prior: 39032208!
initializeToStandAlone
	"Initialize the receiver so that it can live as a stand-alone morph"
	| aPane aBin aColor |
	self basicInitialize.
	self layoutInset: 6. 
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.
	self useRoundedCorners.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	aPane _ self paneForTabs: self modeTabs.
	aPane addMorphFront: self dismissButton.
	aPane addMorphBack: self helpButton.
	aPane color: (aColor _ aPane color) darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.
	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"
	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #spaceFill.
	aBin extent: (self currentWorld width) @ 300.
	aBin color: aColor lighter lighter.
	aBin setNameTo: 'parts'.
	aBin dropEnabled: false.
	self addMorphBack: aBin.
	self submorphs last width: 350; hResizing: #rigid.
	self color: (Color r: 0.0 g: 0.839 b: 0.226).
	self setProperty: #initialWidth toValue: 268.
	self setNameTo: 'Objects' translated.
	self showCategories.
! !

!ObjectsTool methodsFor: 'initialization' stamp: 'nk 5/1/2004 18:07' prior: 39033631!
initializeToStandAlone
	"Initialize the receiver so that it can live as a stand-alone morph"
	| aPane aBin aColor |
	self basicInitialize.
	self layoutInset: 6. 
	self listCentering: #topLeft.
	self cellPositioning: #topLeft.
	self wrapCentering: #center.
	self useRoundedCorners.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	aPane _ self paneForTabs: self modeTabs.
	aPane addMorphFront: self dismissButton.
	aPane addMorphBack: self helpButton.
	aPane color: (aColor _ aPane color) darker.
	aPane listSpacing: #equal.
	aPane cellInset: 10 @ 10.
	aPane listCentering: #center; height: 38.
	aPane wrapDirection: nil.
	self addMorphFront: aPane.
	self addMorphBack: Morph new.  "Place holder for a tabs or text pane"
	aBin _ PartsBin newPartsBinWithOrientation: #leftToRight from: #().
	aBin listDirection: #leftToRight.
	aBin wrapDirection: #topToBottom.
	aBin hResizing: #spaceFill; vResizing: #shrinkWrap.
	aBin extent: (self currentWorld width) @ 300.
	aBin color: aColor lighter lighter.
	aBin setNameTo: 'parts'.
	aBin dropEnabled: false.
	self addMorphBack: aBin.
	self submorphs last width: 350; hResizing: #spaceFill.
	self color: (Color r: 0.0 g: 0.839 b: 0.226).
	self setProperty: #initialWidth toValue: 268.
	self setNameTo: 'Objects' translated.
	self showCategories.
! !

!ObjectsTool methodsFor: 'initialization' stamp: 'sw 8/12/2001 17:41'!
tweakAppearanceAfterModeShift
	"After the receiver has been put into a given mode, make an initial selection of category, if appropriate, and try to overcome persistent and annoying layout problems associated with initial state.  This method contains a mish-mash of measures, sometimes obviously desparate, some likely overkill, some no longer required.  Pax!!"

	| aWidth prevailingWidth |
	prevailingWidth _ self width.
	self searchPane ifNil:
		[self tabsPane submorphs first doButtonAction].
	(aWidth _ self valueOfProperty: #initialWidth) ifNotNil:
		[submorphs second width: aWidth.
		prevailingWidth _ aWidth.
		self removeProperty: #initialWidth].
	self fullBounds.
	self firstSubmorph firstSubmorph firstSubmorph layoutChanged.  "By gum"
	self firstSubmorph submorphs do:
		[:aButton | 
			aButton borderWidth: 0.
			(aButton valueOfProperty: #modeSymbol) = modeSymbol
				ifTrue:
					[aButton firstSubmorph color: Color red]
				ifFalse:
					[aButton firstSubmorph color: Color black]].
	submorphs last height: (200 max: submorphs last height); layoutChanged.
	self firstSubmorph firstSubmorph layoutChanged.
	submorphs second width: prevailingWidth - 10! !

!ObjectsTool methodsFor: 'initialization' stamp: 'nk 5/1/2004 18:18' prior: 39036445!
tweakAppearanceAfterModeShift
	"After the receiver has been put into a given mode, make an initial selection of category, if appropriate, and try to overcome persistent and annoying layout problems associated with initial state.  This method contains a mish-mash of measures, sometimes obviously desparate, some likely overkill, some no longer required.  Pax!!"

	| aWidth prevailingWidth |
	prevailingWidth _ self width.
	self searchPane ifNil:
		[self tabsPane submorphs first doButtonAction].
	(aWidth _ self valueOfProperty: #initialWidth) ifNotNil:
		[submorphs second width: aWidth.
		prevailingWidth _ aWidth.
		self removeProperty: #initialWidth].
	submorphs last minHeight: 200; vResizing: #shrinkWrap; layoutChanged.
	self fullBounds.
	self firstSubmorph firstSubmorph firstSubmorph layoutChanged.  "By gum"
	self firstSubmorph submorphs do:
		[:aButton | 
			aButton borderWidth: 0.
			(aButton valueOfProperty: #modeSymbol) = modeSymbol
				ifTrue:
					[aButton firstSubmorph color: Color red]
				ifFalse:
					[aButton firstSubmorph color: Color black]].
	self firstSubmorph firstSubmorph layoutChanged.
	submorphs second width: prevailingWidth - 10! !

!ObjectsTool methodsFor: 'major modes' stamp: 'sw 8/12/2001 16:30'!
modeSymbol
	"Answer the modeSymbol"

	^ modeSymbol! !

!ObjectsTool methodsFor: 'major modes' stamp: 'sw 8/10/2001 14:46'!
modeSymbol: aSymbol
	"Set the receiver's modeSymbol as indicated"

	modeSymbol _ aSymbol! !

!ObjectsTool methodsFor: 'major modes' stamp: 'sw 8/12/2001 01:39'!
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.
			aButton actWhen: #buttonUp.
			aButton setProperty: #modeSymbol toValue: tuple second.
			aButton target: self; actionSelector: tuple third.
			aButton setBalloonText: tuple fourth.
			aButton].
	^ buttonList

"ObjectsTool new modeTabs"! !

!ObjectsTool methodsFor: 'major modes' stamp: 'dgd 8/30/2003 16:11' prior: 39039223!
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].
	^ buttonList

"ObjectsTool new modeTabs"! !

!ObjectsTool methodsFor: 'menu' stamp: 'sw 11/27/2001 11:42'!
addCustomMenuItems: aMenu hand: aHand
	"Add items to the given halo-menu, given a hand"

	super addCustomMenuItems: aMenu hand: aHand.
	aMenu addLine.
	aMenu add: 'alphabetic' target: self selector: #showAlphabeticTabs.
	aMenu add: 'find' target: self selector: #showSearchPane.
	aMenu add: 'categories' target: self selector: #showCategories.
	aMenu addLine.
	aMenu add: 'reset thumbnails' target: self selector: #resetThumbnails.! !

!ObjectsTool methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:22' prior: 39041088!
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: 'sw 11/27/2001 13:30'!
resetThumbnails
	"Reset the thumbnail cache"

	PartsBin clearThumbnailCache.
	modeSymbol == #categories ifFalse: [self showCategories] ifTrue: [self showAlphabeticTabs]! !

!ObjectsTool methodsFor: 'menu' stamp: 'nk 9/7/2003 07:42' prior: 39042144!
resetThumbnails
	"Reset the thumbnail cache"

	PartsBin clearThumbnailCache.
	modeSymbol == #categories ifTrue: [self showCategories] ifFalse: [self showAlphabeticTabs]! !

!ObjectsTool methodsFor: 'menu' stamp: 'nk 9/7/2003 07:42' prior: 39042393!
resetThumbnails
	"Reset the thumbnail cache"

	PartsBin clearThumbnailCache.
	modeSymbol == #categories ifTrue: [self showCategories] ifFalse: [self showAlphabeticTabs]! !

!ObjectsTool methodsFor: 'miscellaneous' stamp: 'sw 8/12/2001 17:36'!
setExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed"

	modeSymbol == #search
		ifFalse:
			[submorphs second width: anExtent x]
		ifTrue:
			[submorphs second firstSubmorph width: anExtent x - 6].
	submorphs last height: (anExtent y - (submorphs first height + submorphs second height))! !

!ObjectsTool methodsFor: 'search' stamp: 'sw 7/20/2001 15:58'!
newSearchPane
	"Answer a type-in pane for searches"

	| aTextMorph aBox |
	aTextMorph _ TextMorph new.
	aTextMorph setProperty: #defaultContents toValue: '' asText allBold.
	aTextMorph on: #keyStroke send: #searchPaneCharacter: to: self.

	aTextMorph setNameTo: 'SearchPane'.
	aTextMorph setBalloonText: 'Type here and all entries that match will be shown.'.

	aTextMorph extent: ((self innerBounds width - 16) @ 20).
	aTextMorph vResizing: #rigid.
	aBox _ AlignmentMorph new hResizing: #spaceFill; vResizing: #shrinkWrap.
	aBox color: Color white.
	aBox addMorphBack: aTextMorph.
	^ aBox! !

!ObjectsTool methodsFor: 'search' stamp: 'dgd 8/30/2003 16:25' prior: 39043320!
newSearchPane
	"Answer a type-in pane for searches"

	| aTextMorph aBox |
	aTextMorph _ TextMorph new.
	aTextMorph setProperty: #defaultContents toValue: '' asText allBold.
	aTextMorph on: #keyStroke send: #searchPaneCharacter: to: self.

	aTextMorph setNameTo: 'SearchPane'.
	aTextMorph setBalloonText: 'Type here and all entries that match will be shown.' translated.

	aTextMorph extent: ((self innerBounds width - 16) @ 20).
	aTextMorph vResizing: #rigid.
	aBox _ AlignmentMorph new hResizing: #spaceFill; vResizing: #shrinkWrap.
	aBox color: Color white.
	aBox addMorphBack: aTextMorph.
	^ aBox! !

!ObjectsTool methodsFor: 'search' stamp: 'sw 6/27/2001 17:15'!
searchPane
	"Answer the receiver's search pane, nil if none"

	^ self findDeepSubmorphThat: [:m | m knownName = 'SearchPane'] ifAbsent: [nil]! !

!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: 'sw 8/12/2001 17:36'!
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: 'sw 4/25/2002 00:52'!
showMorphsMatchingSearchString
	"Put items matching the search string into my lower pane"

	| quads |
	self setSearchStringFromSearchPane.
	submorphs last removeAllMorphs.
	searchString size = 0 ifTrue: [^ self].
	quads _ OrderedCollection new.
	Morph withAllSubclasses do:
		[:aClass |
			aClass addPartsDescriptorQuadsTo: quads if:
				[:info | info formalName includesSubstring:  searchString caseSensitive: false]].

	self installQuads: quads fromButton: nil! !

!ObjectsTool methodsFor: 'search' stamp: 'dgd 2/22/2003 13:36' prior: 39045670!
showMorphsMatchingSearchString
	"Put items matching the search string into my lower pane"

	| quads |
	self setSearchStringFromSearchPane.
	submorphs last removeAllMorphs.
	searchString isEmpty ifTrue: [^self].
	quads := OrderedCollection new.
	Morph withAllSubclasses do: 
			[:aClass | 
			aClass addPartsDescriptorQuadsTo: quads
				if: [:info | info formalName includesSubstring: searchString caseSensitive: false]].
	self installQuads: quads fromButton: nil! !

!ObjectsTool methodsFor: 'search' stamp: 'dgd 12/11/2003 13:01' prior: 39046217!
showMorphsMatchingSearchString
	"Put items matching the search string into my lower pane"

	| quads |
	self setSearchStringFromSearchPane.
	submorphs last removeAllMorphs.
	searchString isEmpty ifTrue: [^ self].
	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: 'sw 4/25/2002 00:52'!
showSearchPane
	"Set the receiver up so that it shows the search pane"

	| aPane |
	modeSymbol == #search ifFalse:
		[self replaceSubmorph: submorphs second by: (aPane _ self newSearchPane).
		self modeSymbol: #search.
		self tweakAppearanceAfterModeShift.
		self showMorphsMatchingSearchString.
		ActiveHand newKeyboardFocus: aPane firstSubmorph]! !

!ObjectsTool methodsFor: 'tabs' stamp: 'sw 6/30/2001 14:27'!
initializeWithTabs: tabList
	"Initialize the receiver to have the given tabs"

	self replaceSubmorph: submorphs second by: (self paneForTabs: tabList)
! !

!ObjectsTool methodsFor: 'tabs' stamp: 'sw 7/12/2001 16:56'!
paneForTabs: tabList
	"Answer a pane bearing tabs for the given list"

	| aPane |
	aPane _ AlignmentMorph newRow.
	aPane listDirection: #leftToRight.
	aPane wrapDirection: #topToBottom.
	aPane vResizing: #shrinkWrap.
	aPane hResizing: #spaceFill.
	aPane cellInset: 6.
	aPane listCentering: #center.
	aPane listSpacing: #equal.
	aPane addAllMorphs: tabList.
	self prepareInitialAppearanceForTabs: tabList.
	^ aPane! !

!ObjectsTool methodsFor: 'tabs' stamp: 'sw 8/12/2001 16:34'!
prepareInitialAppearanceForTabs: tabList
	"Prepare the initial appearance for a list of tabs"

	tabList do:
		[:t | t color: Color transparent.
			t borderWidth: 1; borderColor: Color black]! !

!ObjectsTool methodsFor: 'tabs' stamp: 'sw 8/11/2001 23:11'!
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.'

	openInWorkspaceWithTitle: 'About Objects'! !

!ObjectsTool methodsFor: 'tabs' stamp: 'dgd 8/30/2003 16:09' prior: 39048670!
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: 'tabs' stamp: 'sw 6/27/2001 16:49'!
tabsPane
	"Answer the pane that holds the tabs"

	^ submorphs second! !

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

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

!ObsoleteMethodTest methodsFor: 'private'!
copySuperedMethod: aMethod 
	"Create a copy of a potentially supered method"

	| copy nLits lastLit |
	copy := aMethod copyWithTrailerBytes: #(0 0 0 0).	"regular"
	nLits := aMethod numLiterals.
	nLits > 0 
		ifTrue: 
			[lastLit := copy literalAt: nLits.
			(lastLit isVariableBinding and: [lastLit value == self class]) 
				ifTrue: [copy literalAt: nLits put: nil -> self targetClass class]].
	^copy! !

!ObsoleteMethodTest methodsFor: 'private' stamp: 'Noury Bouraqadi 9/16/2003 12:48'!
patterns
	"Answer all the methods implementing one of the obsolete #new methods"
	| list |
	list := IdentityDictionary new.
	self class selectorsAndMethodsDo:[:sel :meth|
		(sel beginsWith: 'obsolete') ifTrue:[
			list at: sel put: (self copySuperedMethod: meth)]].
	^list! !

!ObsoleteMethodTest methodsFor: 'printing'!
printOn: aStream 
	aStream
		nextPutAll: self class printString;
		nextPutAll: '>>#';
		nextPutAll: testSelector.
	self targetClass ifNotNil: 
			[aStream
				nextPutAll: ' for ';
				nextPutAll: self targetClass name]! !

!ObsoleteMethodTest methodsFor: 'accessing' stamp: 'Noury Bouraqadi 9/16/2003 15:48'!
targetClass
	^targetClass! !

!ObsoleteMethodTest methodsFor: 'accessing' stamp: 'Noury Bouraqadi 9/16/2003 15:48'!
targetClass: aClass 
	targetClass := aClass! !

!ObsoleteMethodTest methodsFor: 'tests'!
testObsoleteMethod
	"Test if the implementation of obsoleteMethod matches any of the patterns defined in this test"

	| aMethod |
	aMethod := self targetClass compiledMethodAt: self class obsoleteMethodSelector
				ifAbsent: [^self].	"allow the test to succeed if (for example) the method was removed"
	self patterns 
		keysAndValuesDo: [:obsoleteSelector :obsoleteMethod | self deny: aMethod = obsoleteMethod]! !

!ObsoleteMethodTest commentStamp: 'Noury Bouraqadi 10/22/2003 09:32' prior: 0!
Abstract class.
Subclasses should implement #obsoleteMethodSelector!
!ObsoleteMethodTest class methodsFor: 'Building Suites' stamp: 'md 11/13/2003 17:14'!
buildSuite
	"Construct this test suite from all classes implementing the obsoleteMethod"
	| suite mcClasses  |

	suite := self suiteClass named: self name asString.
	self isAbstract ifTrue: [^suite].
	
	mcClasses := (PackageInfo named: 'Monticello') classes.
	mcClasses addAll: (mcClasses copy collect: [:each | each class]).
	
	self classesToTest do:[:aClass|
		((aClass includesSelector: self obsoleteMethodSelector) & (mcClasses includes: aClass) not) ifTrue:[
			suite addTest: 
				(self 
					selector: self testMethodSelector 
					targetClass: aClass).
		].
	].
	^suite! !

!ObsoleteMethodTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 10/22/2003 09:44'!
buildSuiteFromSelectors
	^self buildSuite! !

!ObsoleteMethodTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 12:58'!
classesToTest
	^Smalltalk allClasses asArray sort:[:cls1 :cls2| cls1 name <= cls2 name]! !

!ObsoleteMethodTest class methodsFor: 'Building Suites' stamp: 'Noury Bouraqadi 9/16/2003 12:53'!
obsoleteMethodSelector
	self subclassResponsibility! !

!ObsoleteMethodTest class methodsFor: 'Building Suites'!
testMethodSelector
	^#testObsoleteMethod! !

!ObsoleteMethodTest class methodsFor: 'Testing'!
isAbstract
	^(self class whichClassIncludesSelector: #obsoleteMethodSelector) == ObsoleteMethodTest class! !

!ObsoleteMethodTest class methodsFor: 'Instance Creation'!
selector: aSelector targetClass: aClass 
	^(self new)
		setTestSelector: aSelector;
		targetClass: aClass;
		yourself! !

!OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'mir 5/13/2003 10:45' prior: 27921472!
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: 'POP mail example' stamp: 'mir 5/13/2003 10:45' prior: 27925490!
popTest
	"SimpleClientSocket popTest"

	| addr userName userPassword s msgs header |
	addr _ NetNameResolver promptUserForHostAddress.
	userName _ FillInTheBlank
		request: 'What is your email name?'
		initialAnswer: 'johnm'.
	userPassword _ FillInTheBlank
		request: 'What is your email password?'.

	s _ 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: 'remote cursor example' stamp: 'mir 5/13/2003 10:45' prior: 27927197!
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: 'mir 5/13/2003 10:45' prior: 27929321!
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' prior: 27930772!
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: 'other examples' stamp: 'mir 5/13/2003 10:45' prior: 27932753!
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' prior: 27933299!
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' prior: 27935454!
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.
! !

!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: 'sending-receiving' stamp: 'RAA 3/28/2001 09:59'!
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: [self error: '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: '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 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: 'network initialization' stamp: 'mir 11/14/2002 19:36' prior: 28164697!
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' prior: 28165276!
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 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: 'examples' stamp: 'ikp 9/1/2003 20:59' prior: 28186736!
remoteTestServerTCP
	"See remoteTestClientTCP for instructions on running this method."
	"OldSocket remoteTestServerTCP"

	| socket client buffer n |
	Transcript show: 'initializing network ... '.
	Socket 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! !

!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: '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' 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: '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: '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' 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: 'private' stamp: 'BG 1/9/2004 12:26' prior: 25470558!
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' prior: 25470823!
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' stamp: 'BG 1/9/2004 12:28' prior: 25472380!
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.! !

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

!OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'sd 1/10/2004 15:28'!
testAddBefore
	"self run: #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: 'testing-public methods' stamp: 'BG 1/10/2004 21:52'!
testAddBeforeAndRemove
	"self run: #testAddBefore"
	| 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: 'testing-public methods' stamp: 'BG 1/10/2004 21:46'!
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: 'testing-public methods' stamp: 'BG 1/10/2004 21:49'!
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: 'testing-public methods' stamp: 'BG 1/10/2004 21:50'!
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: 'testing-public methods' stamp: 'BG 1/10/2004 21:55'!
testIndexOf

   | collection indices |

   collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
   indices := collection collect: [:item | collection indexOf: item].
   self assert: (1 to: 4) asOrderedCollection = indices.

   " note that this assertion does not hold in the presence of duplicate items. "
! !

!OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 22:45'!
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 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.!
!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:03'!
direction
	^direction ifNil:[direction _ normal y @ normal x negated]! !

!OrientedFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:35' prior: 25477342!
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 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.!
!OutOfScopeNotification methodsFor: 'as yet unclassified' stamp: 'RAA 2/5/2001 10:41'!
defaultAction

	self resume: false! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'md 11/14/2003 16:51' prior: 25479990!
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 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')! !

!PDA methodsFor: 'currentItem' stamp: 'sw 5/23/2001 13:52'!
acceptCurrentItemText: aText
	"Accept into the current item from the text provided, and update lists accordingly"

	currentItem ifNil:
		[self inform: 'Can''t accept -- no item is selected'. ^ false].
	viewDescriptionOnly ifTrue:
		[currentItem description: aText string. ^ true].

	currentItem readFrom: aText.
	(currentItem isKindOf: PDAEvent) ifTrue: [self updateScheduleList].
	(currentItem isMemberOf: PDAToDoItem) ifTrue: [self updateToDoList].
	(currentItem isMemberOf: PDAPerson) ifTrue: [self updatePeopleList].
	(currentItem isMemberOf: PDARecord) ifTrue: [self updateNotesList].
	^ true! !

!PDA methodsFor: 'date' stamp: 'aoy 2/15/2003 21:33' prior: 25492882!
setDate: aDate fromButton: aButton down: down 
	dateButtonPressed ifNotNil: [dateButtonPressed setSwitchState: false].
	dateButtonPressed := down 
				ifTrue:  
					[self selectDate: aDate.
					aButton]
				ifFalse: 
					[self selectDate: nil.
					nil].
	self currentItem: nil.
	aButton ifNotNil: 
			[aButton owner owner highlightToday	"ugly hack to restore highlight for today"]! !

!PDA methodsFor: 'example' stamp: 'sw 8/28/2002 23:12'!
sampleNotes

	^ {
	PDARecord new key: 'home'; description: 'sprinkler schedule'.
	PDARecord new key: 'home'; description: 'directions to our house
Take the expressway, #93 south
Then south on Rte 24
East at the T with 195
Take exit 12 and go right to Faunce Corner
Cross rte 6, continue on Old Westport Rd
takes a bend left and becomes Chase Rd
Continue for 3.5-4 mi
Rt at T intersection on Russell Mills Rd
Pass DPW on left
Lg Yellow bldg Davall''s store
left on Rocko Dundee Rd
down a swail and up.  We''re #419 on the left'.
	PDARecord new key: 'work'; description: 'archaeology memo'.
	PDARecord new key: 'work'; description: 'worlds and envts memo'.
	PDARecord new key: 'work'; description: PDA comment asString.
	}! !

!PDA methodsFor: 'example' stamp: 'brp 9/3/2003 08:45' prior: 25512903!
sampleScheduleList

	^ {
	PDAEvent new key: 'home'; date: Date today; description: 'wake up'; time: (Time hour: 6 minute: 0 second: 0).
	PDAEvent new key: 'home'; date: Date today; description: 'go for a run'; time: (Time hour: 7 minute: 0 second: 0).
	PDAEvent new key: 'home'; date: Date today; description: 'take a shower'; time: (Time hour: 8 minute: 0 second: 0).
	PDAEvent new key: 'home'; date: (Date today addDays: 2); description: 'dinner out'; time: (Time hour: 18 minute: 0 second: 0).
	PDAEvent new key: 'work'; date: (Date today addDays: 1); description: 'conf call'; time: (Time hour: 10 minute: 0 second: 0).
	PDAEvent new key: 'work'; date: (Date today addDays: 2); description: 'Leave for Conference'; time: (Time hour: 8 minute: 0 second: 0).
	PDAEvent new key: 'work'; date: Date today; description: 'call Boss'; time: (Time hour: 15 minute: 0 second: 0).
	PDAEvent new key: 'work'; date: Date today; description: 'Call about 401k'; time: (Time hour: 10 minute: 0 second: 0).
	}! !

!PDA methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:27' prior: 25486688!
loadDatabase
	| aName aFileStream list |
	aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
	aName
		ifNil: [^ self].
	"User made no choice"
	aName == #none
		ifTrue: [^ self inform: 'Sorry, no suitable files found
(names should end with .data or .data.gz)'].
	aFileStream _ FileStream oldFileNamed: aName.
	list _ aFileStream fileInObjectAndCode.
	userCategories _ list first.
	allPeople _ list second.
	allEvents _ list third.
	recurringEvents _ list fourth.
	allToDoItems _ list fifth.
	allNotes _ list sixth.
	date _ Date today.
	self selectCategory: 'all'! !

!PDA methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:28' prior: 25487376!
mergeDatabase
	| aName aFileStream list |
	aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
	aName
		ifNil: [^ self].
	"User made no choice"
	aName == #none
		ifTrue: [^ self inform: 'Sorry, no suitable files found
(names should end with .data or .data.gz)'].
	aFileStream _ FileStream oldFileNamed: aName.
	list _ aFileStream fileInObjectAndCode.
	userCategories _ (list first , userCategories) asSet asArray sort.
	allPeople _ (list second , allPeople) asSet asArray sort.
	allEvents _ (list third , allEvents) asSet asArray sort.
	recurringEvents _ (list fourth , recurringEvents) asSet asArray sort.
	allToDoItems _ (list fifth , allToDoItems) asSet asArray sort.
	allNotes _ ((list sixth)
				, allNotes) asSet asArray sort.
	date _ Date today.
	self selectCategory: 'all'! !

!PDA methodsFor: 'initialization' stamp: 'ar 8/19/2001 16:35'!
openAsMorphIn: window  "PDA new openAsMorph openInWorld"
	"Create a pluggable version of all the morphs for a Browser in Morphic"
	| dragNDropFlag paneColor chooser |
	window color: Color black.
	paneColor _ (Color r: 0.6 g: 1.0 b: 0.0).
	window model: self.
	Preferences alternativeWindowLook ifTrue:[
		window color: Color white.
		window paneColor: paneColor].
	dragNDropFlag _ Preferences browseWithDragNDrop.
	window addMorph: ((PluggableListMorph on: self list: #peopleListItems
			selected: #peopleListIndex changeSelected: #peopleListIndex:
			menu: #peopleMenu: keystroke: #peopleListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0@0 corner: 0.3@0.25).
	window addMorph: ((chooser _ PDAChoiceMorph new color: paneColor) contentsClipped: 'all';
			target: self; actionSelector: #chooseFrom:categoryItem:; arguments: {chooser};
			getItemsSelector: #categoryChoices)
		frame: (0@0.25 corner: 0.3@0.3).
	window addMorph: ((MonthMorph newWithModel: self) color: paneColor; extent: 148@109)
		frame: (0.3@0 corner: 0.7@0.3).
	window addMorph: (PDAClockMorph new color: paneColor;
						faceColor: (Color r: 0.4 g: 0.8 b: 0.6))  "To match monthMorph"
		frame: (0.7@0 corner: 1.0@0.3).

	window addMorph: ((PluggableListMorph on: self list: #toDoListItems
			selected: #toDoListIndex changeSelected: #toDoListIndex:
			menu: #toDoMenu: keystroke: #toDoListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0@0.3 corner: 0.3@0.7).
	window addMorph: ((PluggableListMorph on: self list: #scheduleListItems
			selected: #scheduleListIndex changeSelected: #scheduleListIndex:
			menu: #scheduleMenu: keystroke: #scheduleListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0.3@0.3 corner: 0.7@0.7).
	window addMorph: ((PluggableListMorph on: self list: #notesListItems
			selected: #notesListIndex changeSelected: #notesListIndex:
			menu: #notesMenu: keystroke: #notesListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0.7@0.3 corner: 1@0.7).

	window addMorph: (PluggableTextMorph on: self
			text: #currentItemText accept: #acceptCurrentItemText:
			readSelection: #currentItemSelection menu: #currentItemMenu:)
		frame: (0@0.7 corner: 1@1).
	Preferences alternativeWindowLook ifFalse:[
		window firstSubmorph color: paneColor.
	].
	window updatePaneColors.
	window step.
	^ window! !

!PDA methodsFor: 'notes' stamp: 'HEG 5/18/2004 05:38' prior: 25505432!
notesMenu: aMenu

	aMenu add: 'add new note' target: self selector: #addNote.
	notesListIndex > 0 ifTrue:
		[aMenu add: 'remove note' target: self selector: #removeNote].
	^ aMenu! !

!PDA methodsFor: 'schedule' stamp: 'gm 3/2/2003 18:26' prior: 25501082!
updateScheduleList
	(date isNil
			and: [category ~= 'recurring'])
		ifTrue: [scheduleList _ Array new.
			scheduleListIndex _ 0.
			^ self changed: #scheduleListItems].
	scheduleList _ (category = 'recurring'
				ifTrue: ["When 'recurring' is selected, edit actual masters"
					(recurringEvents
						select: [:c | c matchesKey: category andMatchesDate: date]) ]
				ifFalse: ["Otherwise, recurring events just spawn copies."
					((allEvents
						select: [:c | c matchesKey: category andMatchesDate: date])
						, ((recurringEvents
								select: [:c | c matchesKey: category andMatchesDate: date])
								collect: [:re | (re as: PDAEvent)
										date: date])) ])sort.
	scheduleListIndex _ scheduleList indexOf: currentItem.
	self changed: #scheduleListItems!
]style[(18 3 4 16 8 4 11 14 12 3 5 9 17 3 1 7 4 10 18 4 12 4 8 3 11 14 51 7 15 16 3 2 1 13 8 17 4 19 48 8 9 16 3 2 1 13 8 17 4 13 15 18 3 2 1 13 8 17 4 21 4 3 2 5 8 18 4 13 17 3 12 10 11 3 4 10 18)f1b,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c198198122,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c198198122,f1,f1cmagenta;,f1,f1c198198122,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c198198122,f1,f1c148046000,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c148046000,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c198198122! !

!PDA methodsFor: 'to do' stamp: 'dgd 2/22/2003 13:26' prior: 25502208!
declareItemDone
	| report |
	report := FillInTheBlank 
				request: 'This item will be declared done as of
' , date printString 
						, '.
Please give a short summary of status'
				initialAnswer: 'Completed.'.
	(report isNil or: [report isEmpty]) ifTrue: [^self].
	currentItem
		dayDone: date;
		result: report.
	self currentItem: currentItem! !

!PDAChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'!
drawOn: aCanvas

	| offset |
	offset _ 4@(bounds height - self fontToUse height // 2).
	aCanvas frameAndFillRectangle: bounds fillColor: backgroundColor
			borderWidth: 1 borderColor: Color black.
	aCanvas drawString: contents
			in: ((bounds translateBy: offset) intersect: bounds)
			font: self fontToUse color: Color black.
! !

!PDAChoiceMorph commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDAClockMorph commentStamp: '<historical>' prior: 0!
See PDA comment. '!
!PDAEvent methodsFor: 'comparing' stamp: 'dgd 2/22/2003 14:39' prior: 25518471!
<= other 
	date = other date ifFalse: [^date < other date].
	time isNil ifTrue: [^true].
	other time isNil ifTrue: [^false].
	^time <= other time! !

!PDAEvent commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDAMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!PDAMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:48' prior: 25518834!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self extent: 406 @ 408.
	PDA new initialize openAsMorphIn: self! !

!PDAMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 22:50'!
initializeToStandAlone
	super initializeToStandAlone.
	self fullBounds  "seemingly necessary to get its icon right in a parts bin"! !

!PDAMorph methodsFor: 'stepping' stamp: 'di 4/9/2001 16:54'!
wantsStepsWhenCollapsed
	"Keep time up to date in title bar"

	^ true! !

!PDAMorph methodsFor: 'stepping and presenter' stamp: 'di 4/3/2001 22:09'!
step

	self setLabel: model labelString.  "Super won't step if collapsed"
	super step.
	! !

!PDAMorph commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDAMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:51'!
descriptionForPartsBin
	^ self partName:	'PDA'
		categories:		#('Useful')
		documentation:	'A Personal Digital Assistant'! !

!PDAPerson commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDARecord commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDARecurringEvent methodsFor: 'date' stamp: 'dgd 2/22/2003 14:51' prior: 25525542!
matchesDate: aDate 
	(firstDate isNil or: [firstDate > aDate]) ifTrue: [^false].
	(lastDate notNil and: [lastDate < aDate]) ifTrue: [^false].
	recurrence == #eachDay ifTrue: [^true].
	recurrence == #dayOfWeek ifTrue: [^aDate weekday = firstDate weekday].
	recurrence == #dayOfMonth 
		ifTrue: [^aDate dayOfMonth = firstDate dayOfMonth].
	recurrence == #dateOfYear 
		ifTrue: 
			[^aDate monthIndex = firstDate monthIndex 
				and: [aDate dayOfMonth = firstDate dayOfMonth]].
	recurrence == #nthWeekdayOfMonth 
		ifTrue: 
			[^aDate weekday = firstDate weekday 
				and: [(aDate dayOfMonth - 1) // 7 = ((firstDate dayOfMonth - 1) // 7)]].
	recurrence == #nthWeekdayOfMonthEachYear 
		ifTrue: 
			[^aDate monthIndex = firstDate monthIndex and: 
					[aDate weekday = firstDate weekday 
						and: [(aDate dayOfMonth - 1) // 7 = ((firstDate dayOfMonth - 1) // 7)]]]! !

!PDARecurringEvent commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PDAToDoItem commentStamp: '<historical>' prior: 0!
See PDA comment. !
!PNGReadWriter methodsFor: 'accessing' stamp: 'ar 2/12/2004 22:40' prior: 25543320!
nextImage
	bigEndian := Smalltalk isBigEndian.
	filtersSeen _ Bag new.
	globalDataChunk _ nil.
	transparentPixelValue _ nil.
	unknownChunks _ Set new.
	stream reset.
	(stream respondsTo: #binary) ifTrue: [ stream binary] .
	stream skip: 8.
	[stream atEnd] whileFalse: [self processNextChunk].
	"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.
	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: 'ar 2/29/2004 03:59' prior: 39095854!
nextImage
	bigEndian := Smalltalk isBigEndian.
	filtersSeen _ Bag new.
	globalDataChunk _ nil.
	transparentPixelValue _ nil.
	unknownChunks _ Set new.
	stream reset.
	(stream respondsTo: #binary) ifTrue: [ stream binary] .
	stream skip: 8.
	[stream atEnd] whileFalse: [self processNextChunk].
	"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: 'sd 1/30/2004 15:20' prior: 39097155!
nextImage
	bigEndian := Smalltalk 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: 'chunks' stamp: 'nk 3/30/2001 14:13'!
processBackgroundChunk

	| val red green blue max |

	"Transcript show: '  BACKGROUND: ',chunk printString."
	colorType = 3 ifTrue: [
		form fillColor: (palette at: chunk first + 1).
		^self
	].
	max _ (2 raisedTo: bitsPerChannel) - 1.
	(colorType = 0 or: [colorType = 4]) ifTrue: [
		val _ chunk unsignedShortAt: 1 bigEndian: true.
		form fillColor: (Color gray: val / max).
		^self
	].
	(colorType = 2 or: [colorType = 6]) ifTrue: [
		red _ chunk unsignedShortAt: 1 bigEndian: true.
		green _ chunk unsignedShortAt: 3 bigEndian: true.
		blue _ chunk unsignedShortAt: 5 bigEndian: true.
		form fillColor: (Color r: red/max g: green/max b: blue/max).
		^self
	].
"self halt."

"====
The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. 

For color type 3 (indexed color), the bKGD chunk contains: 


   Palette index:  1 byte

The value is the palette index of the color to be used as background. 

For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: 


   Gray:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. 

For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: 


   Red:   2 bytes, range 0 .. (2^bitdepth)-1
   Green: 2 bytes, range 0 .. (2^bitdepth)-1
   Blue:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. 

When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. 
==="
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55' prior: 39099785!
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: 'ar 2/10/2004 23:55' prior: 25546329!
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/28/2004 14:40' prior: 25547257!
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 verifyAdler32.! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19' prior: 39104228!
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' prior: 25548426!
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/28/2004 14:40' prior: 25549535!
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 verifyAdler32.
	debug ifTrue: [Transcript  nextPutAll: ' compressed size='; print: z position  ].
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19' prior: 39108036!
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' prior: 25550195!
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: '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: 'pixel copies' stamp: 'ar 1/1/1970 21:00' prior: 25558680!
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: 'ar 10/7/2003 17:31' prior: 25561756!
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 over.

! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/18/2004 23:58' prior: 25562969!
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: 'ar 10/7/2003 17:30' prior: 25563861!
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 over.

! !

!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: 'miscellaneous' stamp: 'ar 2/11/2004 01:27' prior: 25565331!
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: '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: 'ar 2/12/2004 22:40'!
nextPutImage: aForm interlace: aMethod filter: aFilterType
	"Note: For now we keep it simple - interlace and filtering are simply ignored"
	| crcStream |
	bigEndian := Smalltalk 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 isKindOf: ColorForm) 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 4/17/2004 19:44' prior: 39117068!
nextPutImage: aForm interlace: aMethod filter: aFilterType
	"Note: For now we keep it simple - interlace and filtering are simply ignored"
	| crcStream |
	bigEndian := Smalltalk 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: 'nk 2/17/2004 16:04'!
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 hex  ].
	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: 'ar 12/12/2003 17:36'!
writePLTEChunkOn: aStream
	"Write the PLTE chunk"
	| r g b colors |
	aStream nextPutAll: 'PLTE' asByteArray.
	(form isKindOf: ColorForm) 
		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: 'nk 4/17/2004 19:44' prior: 39121843!
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 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: 'ar 2/11/2004 00:55' prior: 25566690!
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: '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')! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test16Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test16BitDisplay
	self encodeAndDecodeDisplay: 16! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'!
test16BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test1Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:43'!
test1BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test1BitDisplay
	self encodeAndDecodeDisplay: 1! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'!
test1BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test2Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:43'!
test2BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test2BitDisplay
	self encodeAndDecodeDisplay: 2! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'!
test2BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test32Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test32BitDisplay
	self encodeAndDecodeDisplay: 32! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'!
test32BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test4Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:44'!
test4BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test4BitDisplay
	self encodeAndDecodeDisplay: 4! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'!
test4BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'!
test8Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:44'!
test8BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'!
test8BitDisplay
	self encodeAndDecodeDisplay: 8! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'!
test8BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:49'!
testAlphaCoding
	self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'nk 2/17/2004 18:14'!
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 should: [ self encodeAndDecodeStream: mbr contentStream ] raise: Error ]
			ifFalse: [	self encodeAndDecodeStream: mbr contentStream ] ].
	] ensure:[file close].! !

!PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/29/2004 03:55' prior: 39131937!
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: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlack16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlack32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlack8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlue16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlue32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testBlue8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testGreen16
	self encodeAndDecodeColor: Color green depth: 16! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'!
testGreen32
	self encodeAndDecodeColor: Color green depth: 32! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'!
testGreen8
	self encodeAndDecodeColor: Color green depth: 8! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'!
testRed16
	self encodeAndDecodeColor: Color red depth: 16! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:48'!
testRed32
	self encodeAndDecodeColor: Color red depth: 32! !

!PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'!
testRed8
	self encodeAndDecodeColor: Color red depth: 8! !

!PNGReadWriterTest methodsFor: '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: '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: '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: '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: '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: 'decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors16
	self decodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors32
	self decodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors8
	self decodeColors: self coloredFiles8 depth: 8.! !

!PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors16
	self encodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors32
	self encodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors8
	self encodeColors: self coloredFiles8 depth: 8.! !

!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 2/17/2004 11:09'!
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 isKindOf: ColorForm) 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 4/17/2004 19:45' prior: 39145356!
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: 'ar 2/12/2004 22:47'!
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 isKindOf: ColorForm) 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 4/17/2004 19:45' prior: 39148969!
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].! !

!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 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 methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:15'!
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)) hex asLowercase.
		     "NB: trim unwanted 16r from start"
			hash _ hash copyFrom: 4 to: hash size]
		ifFalse: [(POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.'].

	self sendCommand: 'APOP ', self user, ' ', hash.
	self logProgress: self lastResponse]
		on: ProtocolClientError
		do: [:ex |
			self close.
			(LoginFailedException protocolInstance: self) signal: 'Login failed.']! !

!POP3Client methodsFor: 'private protocol' stamp: 'mdr 9/3/2003 16:52' prior: 39155288!
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)) hex asLowercase.
			"trim starting 16r and zero pad it to 32 characters if needed"
			hash _ (hash allButFirst: 3) 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: '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 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 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: 'mir 11/11/2002 16:52'!
example
	"POP3Client example"
	"download a user's messages into an OrderedCollection and inspect the OrderedCollection"

	| ps messages userName password |
	userName := (FillInTheBlank request: 'POP username').
	password := (FillInTheBlank request: 'POP password').
	ps _ POP3Client openOnHostNamed: (FillInTheBlank 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.! !

!POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0!
Exception for signaling POP3 login failures.!
!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,f3c148046000,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 12/25/2003 14:34'!
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:  
			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: '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: '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 12/22/2003 20:47'!
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].
	""
	^ 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 12/26/2003 16:15'!
getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory 
	| args thumbnail uploader |
	args := Dictionary new.
	""
	args at: 'contents' put: {(localDirectory oldFileNamed: fileNameString) contentsOfEntireFile}.
	""
	args at: 'name' put: {aProject name}.
	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 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 12/24/2003 11:35'!
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}].
	projectDetails
		at: 'projectauthor'
		ifPresent: [:value | args at: 'author' put: {value}].
	projectDetails
		at: 'projectcategory'
		ifPresent: [:value | args at: 'category' put: {value}].
	projectDetails
		at: 'projectsubcategory'
		ifPresent: [:value | args at: 'subcategory' put: {value}].
	projectDetails
		at: 'projectkeywords'
		ifPresent: [:value | args at: 'keywords' put: {value}]! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/26/2003 16:43'!
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 := Smalltalk perform: each.
			args at: 'extra-' , each asString put: {value asString}]! !

!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 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 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,f3c148046000,f3,f3cmagenta;,f3,f3cblue;i,f3,f3cblue;i,f3,f3c255148000b,f3! !

!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: 'ab 11/13/2002 01:23'!
includesClass: aClass
	^ self includesSystemCategory: aClass theNonMetaClass category! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:08'!
includesClassNamed: aClassName
	^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! !

!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: '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: '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: 'ab 11/14/2002 18:06'!
includesMethodReference: aMethodRef
	^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! !

!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 methodsFor: 'naming' stamp: 'ab 10/17/2002 00:05'!
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: 'ab 6/10/2003 17:21'!
methodCategoryPrefix
	^ methodCategoryPrefix ifNil: [methodCategoryPrefix _ '*', self packageName asLowercase]! !

!PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 16:57'!
packageName
	^ packageName ifNil: [packageName _ self categoryName]! !

!PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 16:56'!
packageName: aString
	packageName _ aString! !

!PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'!
systemCategoryPrefix
	^ self packageName! !

!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: 'dvf 9/17/2002 00:56'!
classesAndMetaClasses
	| baseClasses |
	baseClasses := self classes.
	^baseClasses , (baseClasses collect: [:c | c class])! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 11/13/2002 01:23'!
coreMethods
	^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! !

!PackageInfo methodsFor: 'listing' stamp: 'cwp 3/17/2004 21:32'!
extensionClasses
	^ self externalClasses reject: [:class | (self extensionCategoriesForClass: class) isEmpty]! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 6/10/2003 17:12'!
extensionMethods
	^ self externalClasses gather: [:class | self extensionMethodsForClass: class]! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 12/3/2002 14:38'!
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: 'ab 7/6/2003 21:49'!
methods
	^ (self extensionMethods, self coreMethods)
		select: [:method | method isValid and: [(#(DoIt DoItIn:) includes: method methodSymbol) 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: 'dependencies' stamp: 'ab 11/18/2002 01:16'!
externalCallers
	^ self 
		externalRefsSelect: [:literal | literal isKindOf: Symbol] 
		thenCollect: [:l | l].! !

!PackageInfo methodsFor: 'dependencies' stamp: 'ab 6/10/2003 17:18'!
externalClasses
	| myClasses |
	myClasses _ self classesAndMetaClasses.
	^ Array streamContents:
		[:s |
		ProtoObject withAllSubclassesDo:
			[:class |
			(myClasses includes: class) ifFalse: [s nextPut: class]]]! !

!PackageInfo methodsFor: 'dependencies' stamp: 'avi 2/29/2004 13:38'!
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: 'cwp 11/13/2002 00:24'!
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: 'modifying' stamp: 'avi 10/13/2003 15:40'!
addCoreMethod: aMethodReference
	| category |
	category _ self baseCategoryOfMethod: aMethodReference.
	aMethodReference actualClass organization
		classify: aMethodReference methodSymbol
		under: category
		suppressIfDefault: false! !

!PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:17'!
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: 'avi 10/13/2003 15:39'!
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: 'avi 10/11/2003 15:14'!
removeMethod: aMethodReference! !

!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'!
= other
	^ other species = self species and: [other packageName = self packageName]! !

!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'!
hash
	^ packageName hash! !

!PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'!
register
	PackageOrganizer default registerPackage: self! !

!PackageInfo commentStamp: '<historical>' prior: 0!
Subclass this class to create new Packages.!
!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! !

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

!PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:37'!
buildList
	^ PluggableListMorph
		on: self
		list: #packageList
		selected: #packageSelection
		changeSelected: #packageSelection:
		menu: #packageMenu:! !

!PackageList methodsFor: 'morphic' stamp: 'avi 2/18/2004 00:28'!
buildWindow
	| window |
	window _ SystemWindow labelled: self label.
	window model: self.
	window addMorph: self buildList fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1)).
	^ window! !

!PackageList methodsFor: 'morphic' stamp: 'avi 2/18/2004 00:28'!
defaultBackgroundColor 
	^ Color white! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:28'!
defaultExtent
	^ 200@200! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:36'!
label
	^ 'Packages'! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:24'!
openInWorld
	self packageOrganizer addDependent: self.
	self buildWindow openInWorldExtent: self defaultExtent! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 13:09'!
packageContextMenu: aMenu
	aMenu
		addLine;
		add: 'remove package' action: #removePackage;
		addServices: PackageServices allServices for: selectedPackage extraLines: #()! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:10'!
packageList
	^ self packages collect: [:ea | ea packageName]! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:24'!
packageMenu: aMenu
	aMenu
		defaultTarget: self;
		add: 'add package' action: #addPackage.
	selectedPackage ifNotNil: [self packageContextMenu: aMenu].
	^ aMenu! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:41'!
packageSelection
	^ self packages indexOf: selectedPackage! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:41'!
packageSelection: aNumber
	selectedPackage _ self packages at: aNumber ifAbsent: [].
	self changed: #packageSelection! !

!PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:15'!
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]! !

!PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:26'!
addPackage
	| packageName |
	packageName _ FillInTheBlank request: 'Package name:'.
	packageName isEmpty ifFalse:
		[selectedPackage _ self packageOrganizer registerPackageNamed: packageName.
		self changed: #packageSelection]! !

!PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:17'!
packageOrganizer
	^ PackageOrganizer default! !

!PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:24'!
removePackage
	self packageOrganizer unregisterPackage: selectedPackage! !

!PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:23'!
update: aSymbol
	aSymbol = #packages ifTrue:
		[packages _ nil.
		self changed: #packageList; changed: #packageSelection]! !

!PackageList methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 00:18'!
packages
	^ packages ifNil: [packages _ self packageOrganizer packages asSortedCollection:
									[:a :b | a packageName <= b packageName]]! !

!PackageList class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:43'!
initialize
	TheWorldMenu registerOpenCommand: {'Package List'. {self. #open}}! !

!PackageList class methodsFor: 'as yet unclassified' stamp: 'avi 10/10/2003 22:38'!
open
	^ self new openInWorld! !

!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 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: 'initializing' stamp: 'avi 11/12/2003 23:01'!
initialize
	packages _ Dictionary new! !

!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 class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 00:17'!
default
	^ default ifNil: [default _ self new]! !

!PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'avi 10/13/2003 15:25'!
new
	^ self basicNew initialize! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'RAA 2/6/2001 12:50'!
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: '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: 'JF 7/30/2003 12:25' prior: 25657563!
package
	"Answer the receiver's 'package'."

	^ self hasPackageSelected
		ifFalse: [nil]
		ifTrue: [self packageList at: packageListIndex]
! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'nk 2/14/2004 15:09' prior: 25659417!
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: 'class list' stamp: 'JF 7/30/2003 12:26' prior: 25660984!
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: 'dragNDrop util' stamp: 'ls 6/22/2001 23:21' prior: 25661923!
dstCategoryDstListMorph: dstListMorph internal: internal 
	| dropItem |
	^ internal & (dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [(dropItem _ dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]]
		ifFalse: [self selectedSystemCategoryName]! !

!PackagePaneBrowser class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:39'!
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: 'class initialization' stamp: 'asm 4/10/2003 13:15'!
initialize

	self registerInFlapsRegistry.! !

!PackagePaneBrowser class methodsFor: '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: '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] ! !

!PackageServices methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:06'!
seeClassSide! !

!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: 'avi 10/11/2003 12:59'!
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! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'aoy 2/17/2003 01:14' prior: 25665700!
selectColor: evt 
	"Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically."

	| r |
	locOfCurrent := evt cursorPoint - self topLeft.
	r := Rectangle center: locOfCurrent extent: 9 @ 9.
	locOfCurrent := locOfCurrent 
				+ (r amountToTranslateWithin: (5 @ 11 corner: 140 @ 136)).
	locOfCurrent x > 128 ifTrue: [locOfCurrent := 135 @ locOfCurrent y].	"snap into grayscale"
	currentColor := locOfCurrent y < 17 
				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! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03' prior: 25687850!
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: 'dgd 2/22/2003 19:03' prior: 25691102!
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: 'dgd 2/22/2003 19:03' prior: 25691410!
eyedropper: aButton action: aSelector cursor: aCursor evt: evt 
	"Take total control and pick up a color!!!!"

	| pt feedbackColor |
	aButton state: #on.
	tool ifNotNil: [tool state: #off].
	currentCursor := aCursor.
	evt hand showTemporaryCursor: currentCursor
		hotSpotOffset: 6 negated @ 4 negated.
	"<<<< the form was changed a bit??"
	feedbackColor := Display colorAt: Sensor cursorPoint.
	colorMemory align: colorMemory bounds topRight
		with: colorMemoryThin bounds topRight.
	self addMorphFront: colorMemory.
	"Full color picker"
	[Sensor anyButtonPressed] whileFalse: 
			[pt := Sensor cursorPoint.
			"deal with the fact that 32 bit displays may have garbage in the 
			alpha bits"
			feedbackColor := Display depth = 32 
						ifTrue: 
							[Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 4278190080)
								depth: 32]
						ifFalse: [Display colorAt: pt].
			"the hand needs to be drawn"
			evt hand position: pt.
			self world displayWorldSafely].
	Sensor waitNoButton.
	evt hand showTemporaryCursor: nil hotSpotOffset: 0 @ 0.
	self currentColor: feedbackColor evt: evt.
	colorMemory delete.
	tool ifNotNil: 
			[tool state: #on.
			currentCursor := tool arguments third].
	aButton state: #off! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'nk 3/31/2004 13:06' prior: 39204932!
eyedropper: aButton action: aSelector cursor: aCursor evt: evt 
	"Take total control and pick up a color!!!!"

	| pt feedbackColor |
	aButton state: #on.
	tool ifNotNil: [tool state: #off].
	currentCursor := aCursor.
	evt hand showTemporaryCursor: currentCursor
		hotSpotOffset: 6 negated @ 4 negated.
	"<<<< the form was changed a bit??"
	feedbackColor := Display colorAt: Sensor cursorPoint.
	colorMemory align: colorMemory bounds topRight
		with: colorMemoryThin bounds topRight.
	self addMorphFront: colorMemory.

	"Full color picker"
	[Sensor anyButtonPressed] whileFalse: 
			[pt := Sensor cursorPoint.
			"deal with the fact that 32 bit displays may have garbage in the 
			alpha bits"
			feedbackColor := Display depth = 32 
						ifTrue: 
							[Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 4278190080)
								depth: 32]
						ifFalse: [Display colorAt: pt].
			"the hand needs to be drawn"
			evt hand position: pt.
			currentColor ~= feedbackColor ifTrue: [
				currentColor _ feedbackColor.
				self showColor ].
			self world displayWorldSafely].

	"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 ].

	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: 'dgd 2/22/2003 19:03' prior: 25692791!
getNib
	^currentBrush arguments third! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/21/2003 23:17' prior: 25693015!
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: 'dgd 2/22/2003 19:04' prior: 25695498!
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: 'dgd 2/22/2003 19:04' prior: 25699670!
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: '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' prior: 25669072!
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' prior: 25670169!
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: '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: 'md 11/14/2003 16:52' prior: 25681064!
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: 'other' stamp: 'dgd 8/30/2003 21:55' prior: 25684827!
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: 'recent colors' stamp: 'ar 9/5/2001 14:20'!
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 == nil 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: 'dgd 2/21/2003 23:17' prior: 39221425!
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/5/2001 14:19'!
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 at: 1) color: aColor.
	RecentColors at: 1 put: aColor.! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17' prior: 39225641!
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 class methodsFor: 'instance creation' stamp: 'tk 2/14/2001 14:05'!
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! !

!PaintInvokingMorph methodsFor: 'dropping/grabbing' stamp: 'ar 3/3/2001 20:41'!
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.
		^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: 'parts bin' stamp: 'sw 8/12/2001 17:19'!
initializeToStandAlone
	super initializeToStandAlone.
	self image: (ScriptingSystem formAtKey: 'Painting')! !

!PaintInvokingMorph class methodsFor: 'parts bin' stamp: 'sw 4/1/2002 23:27'!
descriptionForPartsBin
	^ self partName:	'Paint'
		categories:		#(' Basic 1 ' 'Graphics')
		documentation:	'Drop this icon to start painting a new object.'! !

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

!Paragraph methodsFor: 'composition' stamp: 'yo 1/23/2003 22:47' prior: 25725814!
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: 'selecting' stamp: 'ar 9/22/2001 16:22'!
clickAt: clickPoint for: model controller: aController
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action range box boxes |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle) 
		do: [:att | att mayActOnClick ifTrue:
				[range _ text rangeOf: att startingAt: startBlock stringIndex forStyle: textStyle.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+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' stamp: 'dvf 10/1/2003 13:28' prior: 39230914!
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' 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: '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: 'converting' stamp: 'yo 6/23/2003 19:05' prior: 25745251!
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: 'private' stamp: 'yo 1/23/2003 22:48' prior: 25747290!
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' 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 commentStamp: '<historical>' prior: 0!
I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.!
!ParagraphEditor methodsFor: 'initialize-release' stamp: 'th 10/21/2003 15:49' prior: 25758057!
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: 'scrolling' stamp: 'th 9/17/2002 12:01' prior: 25764062!
scrollBy: heightToMove
	"Move the paragraph by heightToMove, and reset the text selection."
	^ paragraph scrollBy: heightToMove withSelectionFrom: self startBlock to: self stopBlock! !

!ParagraphEditor methodsFor: 'scrolling' stamp: 'BG 12/12/2003 15:31' prior: 39239070!
scrollBy: heightToMove
	"Move the paragraph by heightToMove, and reset the text selection."
	^ paragraph scrollBy: heightToMove withSelectionFrom: self pointBlock to: self markBlock! !

!ParagraphEditor methodsFor: 'sensor access' stamp: 'th 9/19/2002 18:24' prior: 25766363!
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: 'menu messages' stamp: 'sw 4/24/2001 12:22'!
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: 'menu messages' stamp: 'sd 1/16/2004 21:14' prior: 25769516!
browseClassFromIt
	"Launch a hierarchy browser for the class indicated by the current selection.  If multiple classes matching the selection exist, let the user choose among them."

	| aClass |
	self lineSelectAndEmptyCheck: [^ self].

	aClass _ Utilities classFromPattern: (self selection string copyWithout: Character cr) withCaption: 'choose a class to browse...'.
	aClass ifNil: [^ view flash].

	self terminateAndInitializeAround:
		[self systemNavigation spawnHierarchyForClass: aClass selector: nil]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 09:42' prior: 25770089!
browseIt
	"Launch a browser for the current selection, if appropriate"

	| aSymbol anEntry brow |

	Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].

	self lineSelectAndEmptyCheck: [^ self].
	(aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash].

	self terminateAndInitializeAround:
		[aSymbol first isUppercase
			ifTrue:
				[anEntry _ (Smalltalk
					at: aSymbol
					ifAbsent:
						[ self systemNavigation browseAllImplementorsOf: aSymbol.
						^ nil]).
				anEntry isNil ifTrue: [^ view flash].
				(anEntry isKindOf: Class)
					ifFalse:	[anEntry _ anEntry class].
				brow _ Preferences browseToolClass new.
				brow setClass: anEntry selector: nil.
				brow class
					openBrowserView: (brow openEditString: nil)
					label: 'System Browser']
			ifFalse:
				[ self systemNavigation browseAllImplementorsOf: aSymbol]]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 7/16/2003 15:00' prior: 39242105!
browseIt
	"Launch a browser for the current selection, if appropriate"

	| aSymbol anEntry brow |
	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 isKindOf: Class)
					ifFalse:	[anEntry _ anEntry class].
				brow _ Preferences browseToolClass new.
				brow setClass: anEntry selector: nil.
				brow class
					openBrowserView: (brow openEditString: nil)
					label: 'System Browser']
			ifFalse:
				[ self systemNavigation browseAllImplementorsOf: aSymbol]]
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 12/17/2001 12:54'!
changeAlignment
	| aList reply  |
	aList _ #(leftFlush centered justified rightFlush).
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ifNil:[^self].
	self setAlignment: reply.
	paragraph composeAll.
	self recomputeSelection.
	self mvcRedisplay.
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'fc 2/19/2004 22:09' prior: 25773015!
changeEmphasis
	| aList reply  |
	aList _ #(normal bold italic narrow underlined struckOut).
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self setEmphasis: reply.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'fc 2/19/2004 22:09' prior: 25773385!
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: 'nk 7/3/2003 18:27' prior: 25773975!
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: [self beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 10/22/2003 15:27' prior: 39245382!
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: 'tk 5/1/2001 21:45'!
classCommentsContainingIt
	"Open a browser class comments which contain the current selection somewhere in them."

	self lineSelectAndEmptyCheck: [^ self].
	self terminateAndInitializeAround: [
		Smalltalk browseClassCommentsWithString: self selection string]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/15/2003 22:40' prior: 39246738!
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: 'sw 7/31/2002 01:54'!
classNamesContainingIt
	"Open a browser on classes whose names contain the selected string"

	self lineSelectAndEmptyCheck: [^ self].
	
	Smalltalk browseClassesWithNamesContaining: self selection string caseSensitive: Sensor leftShiftDown! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'nk 6/26/2003 22:24' prior: 39247442!
classNamesContainingIt
	"Open a browser on classes whose names contain the selected string"

	self lineSelectAndEmptyCheck: [^ self].
	
	SystemNavigation new browseClassesWithNamesContaining: self selection string caseSensitive: Sensor leftShiftDown! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dvf 8/23/2003 11:51' prior: 39247775!
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: 'sd 4/16/2003 09:42' prior: 25780908!
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' prior: 25781590!
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: 'sd 4/16/2003 19:31' prior: 25782186!
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: 'sd 4/15/2003 22:35' prior: 25782561!
methodSourceContainingIt
	"Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source).   EXTREMELY slow!!"

	self lineSelectAndEmptyCheck: [^ self].
	(self confirm: 'This will take a few minutes.
Shall I proceed?') ifFalse: [^ self].
	self systemNavigation browseMethodsWithSourceString: self selection string! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:28' prior: 25782998!
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: 'th 9/20/2002 11:21' prior: 25783563!
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: 'sd 1/19/2004 20:59' prior: 25784512!
presentSpecialMenu
	"Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor.  Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane"

	| reply items |
	self terminateAndInitializeAround:
		[reply _ (PopUpMenu labelArray: (items _ self specialMenuItems) lines: #()) startUp.
		reply = 0 ifTrue: [^ self].
		Compiler new evaluate: (items at: reply) in: [] to: self]
	! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 10/22/2002 14:54'!
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: [Smalltalk browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 11:47' prior: 39251639!
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: 'sw 3/12/2002 20:59'!
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 _ FillInTheBlank request: 'File name?'
			initialAnswer: suggestedName.
	fileName isEmptyOrNil ifFalse:
		[(FileStream newFileNamed: fileName) nextPutAll: stringToSave; close]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:27' prior: 25787502!
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 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' prior: 25788349!
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' prior: 25788893!
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: 'ar 12/17/2001 12:55'!
setAlignment: aSymbol
	| attr string left right |
	attr _ TextAlignment perform: aSymbol.
	string _ paragraph text string.
	left _ string lastIndexOf: Character cr startingAt: startBlock stringIndex-1 ifAbsent:[1].
	right _ string indexOf: Character cr startingAt: stopBlock stringIndex ifAbsent:[string size].
	paragraph replaceFrom: left to: right with:
		((paragraph text copyFrom: left to: right) addAttribute: attr) displaying: true.
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/18/2002 17:28' prior: 39255832!
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' prior: 25789232!
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: 'explain' stamp: 'nb 5/6/2003 16:54' prior: 25793336!
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, 'Smalltalk browseAllImplementorsOf: #' , symbol! !

!ParagraphEditor methodsFor: 'explain' stamp: 'nk 6/26/2003 22:02' prior: 39257019!
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: 'tk 8/6/2001 13:32'!
explainClass: symbol 
	"Is symbol a class variable or a pool variable?"
	| class reply classes |
	(model respondsTo: #selectedClassOrMetaClass)
		ifFalse: [^ nil].
	(class _ model selectedClassOrMetaClass) ifNil: [^ nil].
	"no class is selected"
	(class isKindOf: Metaclass)
		ifTrue: [class _ class soleInstance].
	classes _ (Array with: class)
				, class allSuperclasses.
	"class variables"
	reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name]
					ifNone: [])
					~~ nil]
				ifNone: [].
	reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').'].
	"pool variables"
	classes do: [:each | (each sharedPools
			detect: [:pool | (pool includesKey: symbol)
					and: 
						[reply _ pool.
						true]]
			ifNone: [])
			~~ nil].
	reply
		ifNil: [(Undeclared includesKey: symbol)
				ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'Smalltalk browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']]
		ifNotNil: 
			[classes _ WriteStream on: Array new.
			Smalltalk
				allBehaviorsDo: [:each | (each sharedPools
						detect: 
							[:pool | 
							pool == reply]
						ifNone: [])
						~~ nil ifTrue: [classes nextPut: each]].
			"Perhaps not print whole list of classes if too long. (unlikely)"
			^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' associationAt: #' , symbol , ').'].
	^ nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'sd 4/17/2003 20:47' prior: 39261378!
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 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 , ' associationAt: #' , symbol , ').'].
	^ nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/29/2003 18:19' prior: 39263180!
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 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: 'nk 6/10/2004 07:02' prior: 39265024!
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: 'sd 4/17/2003 20:50' prior: 25801383!
explainGlobal: symbol 
	"Is symbol a global variable?"
	| reply classes |
	reply _ Smalltalk at: symbol ifAbsent: [^nil].
	(reply isKindOf: Behavior)
		ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,
			'."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.'].
	symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
	reply class == Dictionary
		ifTrue: 
			[classes _ Set new.
			self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]
					ifNone: [])
					~~ nil ifTrue: [classes add: each]].
			classes _ classes printString.
			^'"is a global variable.  ' , symbol , ' is a Dictionary.  It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].
	^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/29/2003 20:07' prior: 39268706!
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' prior: 25802372!
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' prior: 25803036!
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: 'nb 5/6/2003 16:54' prior: 25804864!
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: 'editing keys' stamp: 'ls 11/10/2002 12:58'!
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 indexOfOldAttributes |		 "control 0..9 -> 0..9"
	keyCode _ ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.

	"grab the old set of attributes"
	indexOfOldAttributes _
		startBlock stringIndex < stopBlock stringIndex
			ifTrue: [ startBlock stringIndex ]
			ifFalse: [
				"if selection is empty, look on character to the left; this is consistent with setEmphasisHere"
				(startBlock stringIndex - 1) max: 1 ].
	oldAttributes _ paragraph text attributesAt: indexOfOldAttributes forStyle: paragraph textStyle.

	thisSel _ self selection.

	"Decipher keyCodes for Command 0-9..."
	(keyCode between: 1 and: 5) ifTrue:
		[attribute _ TextFontChange fontNumber: keyCode].
	keyCode = 6 ifTrue:
		[colors _ #(black magenta red yellow green blue cyan white).
		extras _ ((self class name = #TextMorphEditor) and: 
			[(self morph isKindOf: TextMorphForEditView) not]) "not a system window"
				ifTrue: [#()]
				ifFalse: [#('Link to comment of class' 'Link to definition of class' 
						'Link to hierarchy of class' 'Link to method')].
		index _ (PopUpMenu labelArray: 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)) startUp.
		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 + 5].	"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]].	"Could not figure out what to link to"
		].
	(keyCode between: 7 and: 11) ifTrue:
		[sensor leftShiftDown
		ifTrue:
			[keyCode = 10 ifTrue: [attribute _ TextKern kern: -1].
			keyCode = 11 ifTrue: [attribute _ TextKern kern: 1]]
		ifFalse:
			[attribute _ TextEmphasis perform:
					(#(bold italic narrow underlined struckOut) at: keyCode - 6).
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	(keyCode = 0) ifTrue:
		[attribute _ TextEmphasis normal].

	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream]
		ifFalse:
			[self replaceSelectionWith: (thisSel asText addAttribute: attribute)].

	emphasisHere _ 	Text addAttribute: attribute toArray: oldAttributes.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'nk 7/17/2003 08:31' prior: 39274403!
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 indexOfOldAttributes |		 "control 0..9 -> 0..9"
	keyCode _ ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.

	"grab the old set of attributes"
	indexOfOldAttributes _
		startBlock stringIndex < stopBlock stringIndex
			ifTrue: [ startBlock stringIndex ]
			ifFalse: [
				"if selection is empty, look on character to the left; this is consistent with setEmphasisHere"
				(startBlock stringIndex - 1) max: 1 ].
	oldAttributes _ paragraph text attributesAt: indexOfOldAttributes forStyle: paragraph textStyle.

	thisSel _ self selection.

	"Decipher keyCodes for Command 0-9..."
	(keyCode between: 1 and: 5) ifTrue:
		[attribute _ TextFontChange fontNumber: keyCode].
	keyCode = 6 ifTrue:
		[colors _ #(black magenta red yellow green blue cyan white).
		extras _ ((self class name = #TextMorphEditor) and: 
			[(self morph isKindOf: TextMorphForEditView) not]) "not a system window"
				ifTrue: [#()]
				ifFalse: [#('Link to comment of class' 'Link to definition of class' 
						'Link to hierarchy of class' 'Link to method')].
		index _ (PopUpMenu labelArray: 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)) startUp.
		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]].	"Could not figure out what to link to"
		].
	(keyCode between: 7 and: 11) ifTrue:
		[sensor leftShiftDown
		ifTrue:
			[keyCode = 10 ifTrue: [attribute _ TextKern kern: -1].
			keyCode = 11 ifTrue: [attribute _ TextKern kern: 1]]
		ifFalse:
			[attribute _ TextEmphasis perform:
					(#(bold italic narrow underlined struckOut) at: keyCode - 6).
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	(keyCode = 0) ifTrue:
		[attribute _ TextEmphasis normal].

	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream]
		ifFalse:
			[self replaceSelectionWith: (thisSel asText addAttribute: attribute)].

	emphasisHere _ 	Text addAttribute: attribute toArray: oldAttributes.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:07' prior: 39278188!
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:
		[colors _ #(black magenta red yellow green blue cyan white).
		extras _ ((self class name = #TextMorphEditor) and: 
			[(self morph isKindOf: TextMorphForEditView) not]) "not a system window"
				ifTrue: [#()]
				ifFalse: [#('Link to comment of class' 'Link to definition of class' 
						'Link to hierarchy of class' 'Link to method')].
		index _ (PopUpMenu labelArray: 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)) startUp.
		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 + 5].	"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]].	"Could not figure out what to link to"
		].
	(keyCode between: 7 and: 11) ifTrue:
		[sensor leftShiftDown
		ifTrue:
			[keyCode = 10 ifTrue: [attribute _ TextKern kern: -1].
			keyCode = 11 ifTrue: [attribute _ TextKern kern: 1]]
		ifFalse:
			[attribute _ TextEmphasis perform:
					(#(bold italic narrow underlined struckOut) at: keyCode - 6).
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	(keyCode = 0) ifTrue:
		[attribute _ TextEmphasis normal].

	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream.
			emphasisHere _ Text addAttribute: attribute toArray: oldAttributes.
			^ true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: '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: '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' stamp: 'th 9/20/2002 11:41' prior: 25814152!
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' prior: 25814657!
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' 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: 'tk 5/7/2001 08:48'!
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: (startBlock stringIndex +
stopBlock stringIndex)//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' stamp: 'th 9/18/2002 16:31' prior: 39287866!
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' stamp: 'th 9/18/2002 16:28' prior: 25816532!
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 _ String new: size + ((numLines * delta) max: 0).
	outStream _ ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart _ (realStart + delta) max: start].
	realStop _ realStop + outStream position - size.

	"Prepare for another iteration"
	indentation _ indentation + delta.
	size _ outStream position.
	inStream _ outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[view flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString _ outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:21' prior: 25820616!
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: 'th 9/19/2002 18:48' prior: 25823728!
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: 'th 9/19/2002 18:07' prior: 25825621!
setEmphasis: emphasisSymbol
	"Change the emphasis of the current selection."

	| oldAttributes attribute |
	oldAttributes _ paragraph text attributesAt: self pointIndex forStyle: paragraph textStyle.
	(emphasisSymbol == #plain) 
		ifTrue:
			[attribute _ TextEmphasis normal]
		ifFalse:
			[attribute _ TextEmphasis perform: emphasisSymbol.
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]].
	self replaceSelectionWith: (self selection addAttribute: attribute)! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'fc 2/19/2004 10:39' prior: 39293493!
setEmphasis: emphasisSymbol
	"Change the emphasis of the current selection."

	| oldAttributes attribute |
	oldAttributes _ paragraph text attributesAt: self pointIndex 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: 'yo 5/27/2004 13:56' prior: 39294087!
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' prior: 25826178!
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: 'th 9/19/2002 18:00' prior: 25827681!
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: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:08' prior: 25829319!
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/21/2003 16:15' prior: 25830562!
cursorEnd: characterStream 

	"Private - Move cursor end of current line."
	| string |
	self closeTypeIn: characterStream.
	string _ paragraph text string.
	self
		moveCursor:
			[:position | Preferences wordStyleCursorMovement
				ifTrue:[| answer |
					answer _ (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) last.
					answer = string size ifTrue:[answer + 1]ifFalse:[answer]]
				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 10/28/2003 10:47' prior: 39297787!
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' prior: 25831256!
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' prior: 25831938!
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' prior: 25832802!
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' prior: 25834976!
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' prior: 25835149!
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' prior: 25835949!
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: 'typing/selecting keys' stamp: 'th 9/20/2002 11:22' prior: 25838135!
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' prior: 25838754!
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' prior: 25839548!
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' stamp: 'th 9/20/2002 11:25' prior: 25840422!
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' stamp: 'th 9/18/2002 11:39' prior: 25842794!
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' stamp: 'th 9/19/2002 18:25' prior: 25844702!
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' stamp: 'th 9/19/2002 17:34' prior: 25846245!
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: 'typing support' stamp: 'th 9/19/2002 17:36' prior: 25846609!
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
		ifNil: [self openTypeIn. UndoSelection _ self nullText. self stopIndex]
		ifNotNil: [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' prior: 25848097!
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' stamp: 'th 9/17/2002 16:23' prior: 25851393!
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' prior: 25851666!
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: 'ls 11/10/2002 12:59'!
readKeyboard
	"Key struck on the keyboard. Find out which one and, if special, carry 
	out the associated special action. Otherwise, add the character to the 
	stream of characters.  Undoer & Redoer: see closeTypeIn."

	| typeAhead char |
	typeAhead _ WriteStream on: (String new: 128).
	[sensor keyboardPressed] whileTrue: 
		[self deselect.
		 [sensor keyboardPressed] whileTrue: 
			[char _ sensor keyboardPeek.
			(self dispatchOnCharacter: char with: typeAhead) ifTrue:
				[self doneTyping.
				^self selectAndScroll; updateMarker].
			self openTypeIn].
		startBlock = stopBlock ifFalse: "save highlighted characters"
			[UndoSelection _ self selection]. 
		self zapSelectionWith: 
			(Text string: typeAhead contents emphasis: emphasisHere).
		typeAhead reset.
		startBlock _ stopBlock copy.
		sensor keyboardPressed ifFalse: 
			[self selectAndScroll.
			sensor keyboardPressed
				ifFalse: [self updateMarker]]]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 18:26' prior: 39311920!
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' prior: 25853963!
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' prior: 25854211!
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: 'undoers' stamp: 'th 9/19/2002 18:46' prior: 25857544!
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: 'current selection' stamp: 'th 9/20/2002 11:41' prior: 25861249!
recomputeInterval
	"The same characters are selected but their coordinates may have changed."

	self computeIntervalFrom: self mark to: self pointIndex - 1! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/18/2002 17:30' prior: 25861682!
reverseSelection
	"Reverse the valence of the current selection highlighting."
	selectionShowing _ selectionShowing not.
	paragraph reverseFrom: self markBlock to: self pointBlock! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'BG 12/12/2003 12:50' prior: 39315790!
reverseSelection
	"Reverse the valence of the current selection highlighting."
	selectionShowing _ selectionShowing not.
	paragraph reverseFrom: self pointBlock to: self markBlock! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:47' prior: 25862084!
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' prior: 25862715!
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: '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 9/20/2002 11:20' prior: 25863198!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: self pointIndex ! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 10/28/2003 12:11' prior: 39317977!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: self stopIndex ! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/17/2002 16:11' prior: 25863346!
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: '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: 'ls 11/10/2002 13:00'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse:
		[self deselect.
		self selectInvisiblyFrom: start to: stop].
	self selectAndScroll.

	"the cursor or selection is, in general,  moving.  Drop any user-specified emphasis in favor of the emphasis at the new cursor location.  Rationale: It is not recorded whether the current emphasisHere was user-specified or was picked up automatically from neighboring text with setEmphasisHere; in the former case, it is unclear whether the emphasis should be reset, and in the later it should definitely be reset.  Reseting it is always either a reasonable choice or clearly the best choice."
	self setEmphasisHere.  ! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:50' prior: 39319017!
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' 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' prior: 25866701!
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' prior: 25867283!
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' prior: 25867783!
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: 'private' stamp: 'th 9/19/2002 18:48' prior: 25869886!
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' stamp: 'th 9/18/2002 16:53' prior: 25870919!
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' prior: 25872839!
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' prior: 25874943!
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: 'th 9/18/2002 16:34' prior: 25877811!
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 max:1.
	^(anInterval last + fudge < self startIndex or:
			[anInterval first - fudge >= self stopIndex])
! !

!ParagraphEditor methodsFor: 'private' stamp: 'cmm 4/9/2004 14:00' prior: 39331703!
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: '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: 'th 10/21/2003 16:16'!
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 currentLineNumber targetLineNumber |
	wordStyle _ Preferences wordStyleCursorMovement.
	wordStyle
		ifTrue: [
			lines _ paragraph lines.
			currentLineNumber  _ paragraph lineIndexOfCharacterIndex: start.
			currentLine _ lines at: currentLineNumber]
		ifFalse: [
			lines _ self lines.
			currentLine _ lines
				detect:[:lineInterval | lineInterval last >= start]
				ifNone:[lines last].
			currentLineNumber _ currentLine second].
	column _ start - currentLine first.
	targetLineNumber _ ((lineBlock value: currentLineNumber) max: 1) min: lines size.
	offsetAtTargetLine _ (lines at: targetLineNumber) first.
	targetEOL _ (lines at: targetLineNumber) last + (targetLineNumber == lines size 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: 'BG 4/29/2004 11:19' prior: 39334595!
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: 'th 9/19/2002 19:02'!
setIndices: shiftPressed forward: forward
	"Little helper method that sets the moving and fixed indices according to some flags."
	| indices |
	indices _ Dictionary new.
	(shiftPressed and:[Preferences selectionsMayShrink])
		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 methodsFor: 'do-its' stamp: 'vb 8/13/2001 23:41'!
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: #(0 0 0 0).
	^method copyWithTempNames: methodNode tempNames! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'vb 8/13/2001 23:41'!
debug: aCompiledMethod receiver: anObject in: evalContext

	| selector guineaPig debugger context |
	selector _ evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:].
	anObject class addSelector: 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 removeSelectorSimply: selector! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/28/2004 11:19' prior: 39338773!
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: 'do-its' stamp: 'vb 8/13/2001 23:38'!
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: 'do-its' stamp: 'RAA 2/5/2001 10:43'!
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]
	] 
		on: OutOfScopeNotification 
		do: [ :ex | ex resume: true].
	FakeClassPool adopt: nil.
	Smalltalk logChange: self selection string.
	^ result! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/16/2004 15:41' prior: 39341118!
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]
	] 
		on: OutOfScopeNotification 
		do: [ :ex | ex resume: true].
	FakeClassPool adopt: nil.
	SmalltalkImage current logChange: self selection string.
	^ result! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/19/2004 10:08' prior: 39341909!
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 selection string
			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: 'gk 3/3/2004 17:15' prior: 39342713!
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: 'sd 4/16/2003 11:41' prior: 25880564!
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: '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: '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: 'th 9/18/2002 17:28' prior: 25760497!
selection
	"Answer the text in the paragraph that is currently selected."

	^paragraph text copyFrom: self startIndex to: self stopIndex - 1 ! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:10' prior: 25760699!
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' prior: 25760950!
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' prior: 25761800!
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: 'parenblinking' stamp: 'AB 1/7/2002 03:51'!
blinkParenAt: parenLocation 
	self text
		addAttribute: TextEmphasis bold
		from: parenLocation
		to: parenLocation.
	lastParenLocation _ 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: 'AB 1/10/2002 00:30'!
clearParens
	lastParenLocation ifNotNil:
		[self text string size >= lastParenLocation ifTrue: [
			self text
				removeAttribute: TextEmphasis bold
				from: lastParenLocation
				to: lastParenLocation]]
! !

!ParagraphEditor methodsFor: 'parenblinking' stamp: 'AB 1/8/2002 03:30' prior: 25849260!
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.
  
	char asciiValue = 13 ifTrue: [
		^ sensor controlKeyPressed
			ifTrue: [self normalCharacter: typeAheadStream]
			ifFalse: [self crWithIndent: 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 class methodsFor: 'class initialization' stamp: 'rhi 12/6/2001 11:07'!
initializeTextEditorMenus
	"Initialize the yellow button pop-up menu and corresponding messages."
	"ParagraphEditor initializeTextEditorMenus"

	TextEditorYellowButtonMenu _ SelectionMenu
		labels:
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
paste...
do it (d)
print it (p)
inspect it (i)
explore it (I)
debug it
accept (s)
cancel (l)
show bytecodes
more...'
		lines: #(3 5 9 14 16 17)
		selections: #(find findAgain setSearchString again undo copySelection cut paste pasteRecent doIt printIt inspectIt exploreIt debugIt accept cancel showBytecodes shiftedTextPaneMenuRequest).! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 9/5/2003 19:02' prior: 39351977!
initializeTextEditorMenus
	"Initialize the yellow button pop-up menu and corresponding messages."
	"ParagraphEditor initializeTextEditorMenus"

	TextEditorYellowButtonMenu _ SelectionMenu
		fromArray: {
		{'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}.	     
		#-.	     
		{'more...' translated.			#shiftedTextPaneMenuRequest}.
	}
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 7/31/2002 01:35'!
shiftedYellowButtonMenu
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ SelectionMenu fromArray: #(
		('set font... (k)'					offerFontMenu)
		('set style... (K)'					changeStyle)
		('set alignment...'				chooseAlignment)
		-
		('explain'						explain)
		('pretty print'					prettyPrint)
		('pretty print with color'		prettyPrintWithColor)
		('file it in (G)'					fileItIn)
		('tiles from it'					selectionAsTiles)
		('recognizer (r)'					recognizeCharacters)
		('spawn (o)'						spawn)
		-
		('definition of word'				wordDefinition)
		('verify spelling of word'		verifyWordSpelling)
"		('spell check it'					spellCheckIt)	"
		('translate it'					translateIt)
		('choose language'				languagePrefs)
		-
		('browse it (b)'					browseIt)
		('senders of it (n)'				sendersOfIt)
		('implementors of it (m)'		implementorsOfIt)
		('references to it (N)'			referencesToIt)
		-
		('selectors containing it (W)'		methodNamesContainingIt)
		('method strings with it (E)'		methodStringsContainingit)
		('method source with it'			methodSourceContainingIt)
		('class names containing it'		classNamesContainingIt)
		('class comments with it'		classCommentsContainingIt)
		('change sets with it'			browseChangeSetsWithSelector)
		-
		('save contents to file...'			saveContentsInFile)
		('send contents to printer'		sendContentsToPrinter)
		('printer setup'					printerSetup)
		-
		('special menu...'				presentSpecialMenu)
		('more...'						yellowButtonActivity))! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 9/5/2003 18:52' prior: 39353970!
shiftedYellowButtonMenu
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ SelectionMenu fromArray: {
		{'set font... (k)' translated.					#offerFontMenu}.
		{'set style... (K)' translated.					#changeStyle}.
		{'set alignment...' translated.				#chooseAlignment}.
		#-.
		{'explain' translated.						#explain}.
		{'pretty print' translated.					#prettyPrint}.
		{'pretty print with color' translated.		#prettyPrintWithColor}.
		{'file it in (G)' translated.					#fileItIn}.
		{'tiles from it' translated.					#selectionAsTiles}.
		{'recognizer (r)' translated.					#recognizeCharacters}.
		{'spawn (o)' translated.						#spawn}.
		#-.
		{'definition of word' translated.				#wordDefinition}.
		{'verify spelling of word' translated.		#verifyWordSpelling}.
		{'translate it' translated.						#translateIt}.
		{'choose language' translated.				#languagePrefs}.
		#-.
		{'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: 'keyboard shortcut tables' stamp: 'sw 12/7/2001 22:54'!
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 cmds |
	cmdMap := Array new: 256 withAll: #noop:.	"use temp in case of a crash"
	cmdMap at: 1 + 1 put: #cursorHome:.	"home key"
	cmdMap at: 4 + 1 put: #cursorEnd:.	"end key"
	cmdMap at: 8 + 1 put: #backspace:.	"ctrl-H or delete key"
	cmdMap at: 11 + 1 put: #cursorPageUp:.	"page up key"
	cmdMap at: 12 + 1 put: #cursorPageDown:.	"page down key"
	cmdMap at: 13 + 1 put: #crWithIndent:.	"cmd-Return"
	cmdMap at: 27 + 1 put: #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:.
	cmds := #($a #selectAll: $b #browseIt: $c #copySelection: $d #doIt: $e #exchange: $f #find: $g #findAgain: $h #setSearchString: $i #inspectIt: $j #doAgainOnce: $k #offerFontMenu: $l #cancel: $m #implementorsOfIt: $n #sendersOfIt: $o #spawnIt: $p #printIt: $q #querySymbol: $r #recognizer: $s #save: $t #tempCommand: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:).
	1 to: cmds size
		by: 2
		do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)].
	CmdActions := cmdMap! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sw 12/9/2001 21:33'!
initializeShiftCmdKeyShortcuts 
	"Initialize the shift-command-key (or control-key) shortcut table."
	"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
	"wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the 
	capitalized versions of the letters.
	TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."

	| cmdMap cmds |

	"shift-command and control shortcuts"
	cmdMap _ Array new: 256 withAll: #noop:.  "use temp in case of a crash"
	cmdMap at: ( 1 + 1) put: #cursorHome:.			"home key"
	cmdMap at: ( 4 + 1) put: #cursorEnd:.			"end key"
	cmdMap at: ( 8 + 1) put: #forwardDelete:.		"ctrl-H or delete key"
	cmdMap at: (11 + 1) put: #cursorPageUp:.		"page up key"
	cmdMap at: (12 + 1) put: #cursorPageDown:.		"page down key"
	cmdMap at: (13 + 1) put: #crWithIndent:.			"ctrl-Return"
	cmdMap at: (27 + 1) put: #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:]."

	cmds _ #(
		$a	argAdvance:
		$b	browseItHere:
		$c	compareToClipboard:
		$d	duplicate:
		$e	methodStringsContainingIt:
		$f	displayIfFalse:
		$g	fileItIn:
		$h	cursorTopHome:
		$i	exploreIt:
		$j	doAgainMany:
		$k	changeStyle:
		$l	outdent:
		$m	selectCurrentTypeIn:
		$n	referencesToIt:
		$p	makeProjectLink:
		$r	indent:
		$s	search:
		$t	displayIfTrue:
		$u	changeLfToCr:
		$v	pasteInitials:
		$w	methodNamesContainingIt:
		$x	makeLowercase:
		$y	makeUppercase:
		$z	makeCapitalized:
	).
	1 to: cmds size by: 2 do: [ :i |
		cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1).		"plain keys"
		cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1).		"shifted keys"
		cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1).		"ctrl keys"
	].
	ShiftCmdActions _ cmdMap! !

!ParameterTile methodsFor: 'access' stamp: 'sw 7/4/2002 23:41'!
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 ownerThatIsA: ScriptEditorMorph)
		ifNotNil:
			[scriptEditor _ aScriptEditor]
		ifNil:
			[scriptEditor]! !

!ParameterTile methodsFor: 'access' stamp: 'sw 1/18/2004 22:12' prior: 39362306!
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: 'sw 7/18/2002 10:59'!
storeCodeOn: aStream indent: tabCount
	"Store code on the stream"
 
	| myTypeString |
	myTypeString _ submorphs first contents.
	(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: 'sw 7/18/2002 02:32'!
forScriptEditor: aScriptEditor
	"Make the receiver be associated with the given script editor"

	scriptEditor _ aScriptEditor.
	self line1: aScriptEditor typeForParameter! !

!ParameterTile methodsFor: 'initialization' stamp: 'sw 7/18/2002 02:32'!
initialize
	"Initialize the receiver"

	super initialize.
	self typeColor: Color red! !

!ParameterTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45' prior: 39364493!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self typeColor: Color red! !

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

!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.!
!ParseNode methodsFor: 'code generation' stamp: 'hmm 7/15/2001 21:34'!
pc
	"Used by encoder source mapping."

	pc==nil ifTrue: [^0] ifFalse: [^pc]! !

!ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/12/2002 11:10'!
blockReturnCode

	^ EndRemote! !

!ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/6/2002 12:04'!
popCode

	^ Pop! !

!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: 'ajh 6/22/2003 22:48' prior: 25907319!
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 parser s p |
        (req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]])
                ifTrue: [parser _ self as: DialectParser]
                ifFalse: [parser _ self].
        myStream _ sourceStream.
        [repeatNeeded _ false.
	   p _ myStream position.
	   s _ myStream upToEnd.
	   myStream position: p.
        parser init: myStream notifying: req failBlock: [^ aBlock value].
        doitFlag _ noPattern.
        failBlock_ aBlock.
        [methNode _ parser method: noPattern context: ctxt
                                encoder: (Encoder new init: class context: ctxt notifying: parser)] 
                on: ParserRemovedUnusedTemps 
                do: 
                        [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
                        myStream _ ReadStream on: requestor text string.
                        ex resume].
        repeatNeeded] whileTrue.
        encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
	   methNode sourceText: s.
        ^ methNode! !

!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: 'yo 8/30/2002 14:41' prior: 25913823!
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: 'sw 9/6/2001 15:30'!
temporaries
	" [ '|' (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)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Vertical bar'! !

!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: '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' stamp: 'LC 1/6/2002 14:30' prior: 25923886!
notify: string at: location
	requestor isNil
		ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail  "failure setting up syntax error"].
				SyntaxErrorNotification
					inClass: encoder classEncoding
					withCode: 
						(source contents
							copyReplaceFrom: location
							to: location - 1
							with: string , ' ->')
					doitFlag: doitFlag]
		ifFalse: [requestor
					notify: string , ' ->'
					at: location
					in: source].
	^self fail! !

!Parser methodsFor: 'error correction' stamp: 'yo 8/28/2002 22:32' prior: 25924712!
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 _ (PopUpMenu labels: aStream contents lines: lines)
		startUpWithCaption: 
'Unknown selector, please 
confirm, correct, or cancel'.

	(choice = 0) | (choice > (lines at: 2))
		ifTrue: [ ^ abortAction value ].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ].
	correctSelector _ alternatives at: choice - 1.
	self substituteSelector: correctSelector keywords wordIntervals: spots.
	((proposedKeyword last ~= $:) and: [correctSelector last == $:]) ifTrue: [
		^ abortAction value].
	^ correctSelector.
! !

!Parser methodsFor: 'error correction' stamp: 'lr 7/17/2003 19:55' prior: 25926527!
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."

	| tempIvar labels actions lines alternatives binding userSelection choice action |

	"Check if this is an i-var, that has been corrected already (ugly)"
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [
		^LiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding instVarNames 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 isLowercase.
	(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: '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 _ (PopUpMenu labelArray: labels asArray lines: lines asArray)
		startUpWithCaption: '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' stamp: 'md 11/12/2003 11:13' prior: 39376325!
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."

	"inst-Var support has been disabled for now. See the comment in Parser>>declareInstVar:"

	| tempIvar labels actions lines alternatives binding userSelection choice action |

	"Check if this is an i-var, that has been corrected already (ugly)"
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [
		^LiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding instVarNames 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 isLowercase.
	(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: '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 _ (PopUpMenu labelArray: labels asArray lines: lines asArray)
		startUpWithCaption: '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' stamp: 'rr 3/8/2004 10:12' prior: 39379034!
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. "

	"inst-Var support has been disabled for now. See the comment in Parser>>declareInstVar:"

	| tempIvar labels actions lines alternatives binding userSelection choice action |

	"Check if this is an i-var, that has been corrected already (ugly)"
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [
		^LiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding instVarNames 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 isLowercase.
	(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 _ (PopUpMenu labelArray: labels asArray lines: lines asArray)
		startUpWithCaption: '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' stamp: 'md 3/13/2004 17:12' prior: 39381834!
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 instVarNames includes: proposedVariable) ifTrue: [
		^LiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding instVarNames 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 isLowercase.
	(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 _ (PopUpMenu labelArray: labels asArray lines: lines asArray)
		startUpWithCaption: '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' stamp: 'yo 11/11/2002 10:20' prior: 39384785!
correctVariable: proposedVariable interval: spot
	"Correct the proposedVariable to a known variable, or declare it as a new
	variable if such action is requested.  We support declaring lowercase
	variables as temps, and uppercase variables as Globals or ClassVars,
	depending on whether the context is nil (class=UndefinedObject).
	Spot is the interval within the test stream of the variable."

	| alternatives aStream choice userSelection temp binding globalToo |
	"If we can't ask the user for correction, make it undeclared"
	self interactive ifFalse: [^ encoder undeclared: proposedVariable].

	temp _ proposedVariable first canBeNonGlobalVarInitial.
	"First check to see if the requestor knows anything about the variable"
	(temp and: [(binding _ requestor bindingOf: proposedVariable) notNil])
		ifTrue: [^ encoder global: binding name: proposedVariable].
	userSelection _ requestor selectionInterval.
	requestor selectFrom: spot first to: spot last.
	requestor select.

	alternatives _ encoder possibleVariablesFor: proposedVariable.

	aStream _ WriteStream on: (String new: 200).
	globalToo _ 0.
	aStream nextPutAll: 'declare ' ,
		(temp ifTrue: ['temp']
			ifFalse: [encoder classEncoding == UndefinedObject
					ifTrue: ['Global']
					ifFalse: [globalToo _ 1.  'Class Variable']]); cr.
	globalToo = 1 ifTrue: [aStream nextPutAll: 'declare Global'; cr].
	alternatives do:
		[:sel | aStream nextPutAll: sel; cr].
	aStream nextPutAll: 'cancel'.

	choice _ (PopUpMenu
				labels: aStream contents
				lines: (Array with: (globalToo + 1) with: (globalToo + alternatives size + 1)))
		startUpWithCaption:
(('Unknown variable: ', proposedVariable, '
please correct, or cancel:') asText makeBoldFrom: 19 to: 19 + proposedVariable size).
	(choice = 0) | (choice > (globalToo + alternatives size + 1))
		ifTrue: [^ self fail].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	choice =1 ifTrue:
			[temp ifTrue: [^ self declareTempAndPaste: proposedVariable]
				ifFalse: [encoder classEncoding == UndefinedObject
					ifTrue: [^ self declareGlobal: proposedVariable]
					ifFalse: [^ self declareClassVar: proposedVariable]]].
	(choice = 2) & (globalToo = 1) ifTrue: [^ self declareGlobal: proposedVariable].
	"Spelling correction"
	self substituteWord: (alternatives at: choice-1-globalToo)
			wordInterval: spot
			offset: 0.
	^ encoder encodeVariable: (alternatives at: choice-1-globalToo)! !

!Parser methodsFor: 'error correction' stamp: 'lr 7/16/2003 20:42'!
declareInstVar: name
	| index |
	encoder classEncoding addInstVarName: name.
	index _ encoder classEncoding instVarNames indexOf: name.
	^LiteralVariableNode new
		name: name index: index - 1 type: 1;
		yourself! !

!Parser methodsFor: 'error correction' stamp: 'md 11/12/2003 11:15' prior: 39390160!
declareInstVar: name
	| index |
	encoder classEncoding addInstVarName: name.
	index _ encoder classEncoding instVarNames indexOf: name.
	^LiteralVariableNode new
		name: name index: index - 1 type: 1;
		yourself
		
"
md: This doesn't yet worked. I uncommented the menu-entry for
now. Will look into this soon. This is Lukas' comment:

From: Lukas Renggli <renggli@student.unibe.ch>
Date: Mar nov 4, 2003  09:18:04 Europe/Zurich
To: ducasse <ducasse@iam.unibe.ch>
Subject: Re: about some fixes

Hi Stef,

I was wondering if this ever worked?

yes, it works. But some cases (where the class has got super- and subclasses with i-vars) you might get a mess with the indexes of the i-vars. I don't know how to fix that problem as the Squeak parser is really messy.

Anyway, the generation of the menu should be included as it makes it much easier to write modify that menu.
"! !

!Parser methodsFor: 'error correction' stamp: 'rr 3/6/2004 16:07' prior: 39390461!
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: 'rr 3/4/2004 10:57'!
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 := FillInTheBlank request: 'Enter class category : ' initialAnswer: 'Unknown'.
	cat ifEmpty: [cat := 'Unknown'].
	def := 'Object subclass: #', sym, '
		instanceVariableNames: '''' 
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''' , cat, ''''.
	d2 := FillInTheBlank 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: 'sw 5/23/2001 13:55'!
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 |
		((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption:
			((temp , ' appears to be
unused in this method.
OK to remove it?') asText makeBoldFrom: 1 to: temp size))
			= 1
		ifTrue:
		[(encoder encodeVariable: temp) isUndefTemp
			ifTrue:
			[end _ tempsMark.
			["Beginning at right temp marker..."
			start _ end - temp size + 1.
			end < temp size or: [temp = (str copyFrom: start to: end)
					and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]]
			whileFalse:
				["Search left for the unused temp"
				end _ requestor nextTokenFrom: end direction: -1].
			end < temp size ifFalse:
				[(str at: start-1) = $  ifTrue: [start _ start-1].
				requestor correctFrom: start to: end with: ''.
				str _ str copyReplaceFrom: start to: end with: ''. 
				madeChanges _ true.
				tempsMark _ tempsMark - (end-start+1)]]
			ifFalse:
			[self inform:
'You''ll first have to remove the
statement where it''s stored into']]].
	madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! !

!Parser methodsFor: 'primitives' stamp: 'md 11/14/2003 16:53' prior: 25934032!
externalFunctionDeclaration
	"Parse the function declaration for a call to an external library."
	| descriptorClass callType retType externalName args argType module fn |
	descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil].
	descriptorClass == nil ifTrue:[^0].
	callType _ descriptorClass callingConventionFor: here.
	callType == nil ifTrue:[^0].
	"Parse return type"
	self advance.
	retType _ self externalType: descriptorClass.
	retType == nil ifTrue:[^self expected:'return type'].
	"Parse function name or index"
	externalName _ here.
	(self match: #string) 
		ifTrue:[externalName _ externalName asSymbol]
		ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
	(self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list'].
	args _ WriteStream on: Array new.
	[here == #')'] whileFalse:[
		argType _ self externalType: descriptorClass.
		argType == nil ifTrue:[^self expected:'argument'].
		argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
	].
	(self matchToken:')' asSymbol) ifFalse:[^self expected:')'].
	(self matchToken: 'module:') ifTrue:[
		module _ here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module _ module asSymbol].
	Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
		fn _ xfn name: externalName 
				module: module 
				callType: callType
				returnType: retType
				argumentTypes: args contents.
		self allocateLiteral: fn.
	].
	^120! !

!PartsBin methodsFor: 'dropping/grabbing' stamp: 'sw 6/13/2001 17:36'!
morphToDropFrom: aMorph
	"Answer the morph to drop if the user attempts to drop aMorph"

	| aButton |
	aButton _ IconicButton new.
	aButton 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: 'ar 12/15/2001 14:10'!
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) withLabel: tuple third 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: 'dgd 8/31/2003 18:46' prior: 39397265!
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) withLabel: tuple third translated andSend: tuple second to: aClass.
			(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
				[aButton setBalloonText: tuple fourth translated].
 			self addMorphBack: aButton]! !

!PartsBin methodsFor: 'properties' stamp: 'sw 6/13/2001 18:50'!
innocuousName
	"Answer a harmless name for an unnamed instance"

	^ 'parts bin'! !

!PartsBin methodsFor: 'properties' stamp: 'dgd 8/30/2003 15:52' prior: 39399458!
innocuousName
	"Answer a harmless name for an unnamed instance"

	^ 'parts bin' translated! !

!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: 'instance creation' stamp: 'sw 6/13/2001 12:06'!
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: 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: 'sw 11/27/2001 13:32'!
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"

	| aThumbnail aSymbol formToThumbnail |
	aSymbol _ aQuint third.
	^ Thumbnails at: aSymbol ifAbsent:
		[formToThumbnail _ 
			((aQuint size >= 5) and: [aQuint fifth notNil])
				ifTrue:
					[aQuint fifth]
				ifFalse:
					[((Smalltalk at: aQuint first) perform: aQuint second) imageForm].
		aThumbnail _ Thumbnail new makeThumbnailFromForm: formToThumbnail.
		self cacheThumbnail: aThumbnail forSymbol: aSymbol.
		^ aThumbnail]

"PartsBin initialize"! !

!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: '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' prior: 25938557!
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: 'menus' stamp: 'dgd 8/30/2003 21:56' prior: 25937271!
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! !

!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.!
!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 methodsFor: 'accessing' stamp: 'hg 9/29/2001 21:56'!
passwordFor: serverDir
	"Returned the password from one of many sources.  OK if send in a nil arg."

	| sp msg |
	cache ifNotNil: [^ cache].
	sequence ifNotNil: [
		(sp _ self serverPasswords) ifNotNil: [
			sequence <= sp size ifTrue: [^ sp at: sequence]]].
	msg _ (serverDir isKindOf: ServerDirectory)
		ifTrue: [serverDir moniker]
		ifFalse: ['this directory'].
	(serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [
			^ cache _ FillInTheBlank request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs
			initialAnswer: 'yourName@company.com'].

	^ cache _ FillInTheBlank requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'.
		"Diff between empty string and abort?"! !

!Password methodsFor: 'accessing' stamp: 'dgd 12/27/2003 10:50' prior: 39406443!
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 _ FillInTheBlank request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs
			initialAnswer: 'yourName@company.com'].

	^ cache _ FillInTheBlank requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'.
		"Diff between empty string and abort?"! !

!Password methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:01'!
sequence
	^sequence! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'!
ascent
	^baseFont ascent! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
baseFont
	^baseFont! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
baseFont: aFont
	baseFont := aFont! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'!
baseKern
	^baseFont baseKern! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'!
descent
	^baseFont descent! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'!
descentKern
	^baseFont descentKern! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'!
emphasized: emph
	^PasswordFont new baseFont: (baseFont emphasized: emph)! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
height
	^baseFont height! !

!PasswordFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'!
passwordCharacter
	^$*! !

!PasswordFont methodsFor: 'measuring' stamp: 'ar 1/5/2003 17:02'!
widthOf: aCharacter
	^baseFont widthOf: self passwordCharacter! !

!PasswordFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:02'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
	| maskedString |
	maskedString := String new: (stopIndex-startIndex+1).
	maskedString atAllPut: self passwordCharacter.
	^baseFont 
		displayString: maskedString 
		on: aDisplayContext 
		from: 1 
		to: maskedString size 
		at: aPoint 
		kern: kernDelta! !

!PasswordFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:00'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! !

!PasswordFont methodsFor: 'as yet unclassified' stamp: 'nk 3/15/2004 18:48'!
releaseCachedState
	baseFont releaseCachedState.! !

!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: '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: 'caching' stamp: 'ar 2/21/2001 17:39'!
releaseCachedState
	super releaseCachedState.
	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: '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: 'ar 5/25/2001 15:30'!
cursorWrapped: aNumber
	"Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."

	| truncP oldRect newRect |
	cursor ~= aNumber ifTrue:[
		self hasSubmorphs 
			ifTrue:[oldRect _ self selectedRect].
		cursor _ self asNumber: aNumber.
		truncP _ cursor truncated.
		truncP > submorphs size ifTrue:
			[submorphs size > 0
				ifTrue: [cursor _ cursor \\ submorphs size]
				ifFalse: [cursor _ 1]].
		truncP < 0 ifTrue: [cursor _ 1].
		self hasSubmorphs ifTrue:[
			newRect _ self selectedRect.
			self indicateCursor 
				ifTrue:[self invalidRect: oldRect; invalidRect: newRect]]].! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'dgd 2/22/2003 14:09' prior: 39411646!
cursorWrapped: aNumber 
	"Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."

	| truncP oldRect newRect |
	cursor ~= aNumber 
		ifTrue: 
			[self hasSubmorphs ifTrue: [oldRect := self selectedRect].
			cursor := self asNumber: aNumber.
			truncP := cursor truncated.
			truncP > submorphs size 
				ifTrue: [submorphs notEmpty ifTrue: [cursor \\ submorphs size] ifFalse: [1]].
			truncP < 0 ifTrue: [cursor := 1].
			self hasSubmorphs 
				ifTrue: 
					[newRect := self selectedRect.
					self indicateCursor 
						ifTrue: 
							[self
								invalidRect: oldRect;
								invalidRect: newRect]]]! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'ar 7/31/2003 22:56' prior: 39412369!
cursorWrapped: aNumber 
	"Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."

	| truncP oldRect newRect |
	cursor ~= aNumber 
		ifTrue: 
			[self hasSubmorphs ifTrue: [oldRect := self selectedRect].
			cursor := self asNumber: aNumber.
			truncP := cursor truncated.
			truncP > submorphs size 
				ifTrue: [cursor := submorphs notEmpty ifTrue: [cursor \\ submorphs size] ifFalse: [1]].
			truncP < 0 ifTrue: [cursor := 1].
			self hasSubmorphs 
				ifTrue: 
					[newRect := self selectedRect.
					self indicateCursor 
						ifTrue: 
							[self
								invalidRect: oldRect;
								invalidRect: newRect]]]! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'jdl 3/28/2003 08:17' prior: 25948442!
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: '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: 'drawing' stamp: 'nk 4/16/2002 11:39'!
drawOn: aCanvas
	"Update and draw the turtleTrails form. See the comment in updateTrailsForm."

	super drawOn: aCanvas.
	(self griddingOn and: [self gridVisible]) ifTrue:
		[aCanvas fillRectangle: self bounds fillStyle:
			(self gridFormOrigin: self gridOrigin grid: self gridModulus background: nil line: Color lightGray)].
	self updateTrailsForm.
	turtleTrailsForm ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].

	(submorphs size > 0 and: [self indicateCursor]) ifTrue:
		[aCanvas
			frameRectangle: self selectedRect
			width: 2
			color: Color black].

! !

!PasteUpMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:10' prior: 39414874!
drawOn: aCanvas 
	"Update and draw the turtleTrails form. See the comment in updateTrailsForm."

	super drawOn: aCanvas.
	(self griddingOn and: [self gridVisible]) 
		ifTrue: 
			[aCanvas fillRectangle: self bounds
				fillStyle: (self 
						gridFormOrigin: self gridOrigin
						grid: self gridModulus
						background: nil
						line: Color lightGray)].
	self updateTrailsForm.
	turtleTrailsForm 
		ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].
	(submorphs notEmpty and: [self indicateCursor]) 
		ifTrue: 
			[aCanvas 
				frameRectangle: self selectedRect
				width: 2
				color: Color black]! !

!PasteUpMorph methodsFor: 'drawing' stamp: 'nk 7/4/2003 16:07' prior: 39415539!
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: 'nb 6/17/2003 12:25' prior: 25951383!
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]! !

!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: 'tk 2/26/2001 15:03'!
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 == nil])
		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 isKindOf: SyntaxMorph])
		ifFalse: [^ aMorph].
	aMorph userScriptSelector isEmptyOrNil ifTrue: ["non-user"
		self automaticPhraseExpansion ifFalse: [^ aMorph]].
	^ aMorph morphToDropInPasteUp: self! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 13:08' prior: 39419114!
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: 'e-toy support' stamp: 'nk 9/8/2003 17:17' prior: 26046946!
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: '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: '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: 'jcg 9/21/2001 13:22'!
mouseDown: evt
	"Handle a mouse down event."
	| grabbedMorph handHadHalos |
	grabbedMorph _ self morphToGrab: evt.
	grabbedMorph ifNotNil:[
		grabbedMorph isSticky ifTrue:[^self].
		self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph].
		grabbedMorph _ grabbedMorph partRepresented duplicate.
		grabbedMorph restoreSuspendedEventHandler.
		(grabbedMorph fullBounds containsPoint: evt position) 
			ifFalse:[grabbedMorph position: evt position].
		"Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead"
		^evt hand grabMorph: grabbedMorph from: self].

	(super handlesMouseDown: evt)
		ifTrue:[^super mouseDown: evt].
	handHadHalos _ evt hand halo notNil.
	evt hand halo: nil. "shake off halos"
	evt hand releaseKeyboardFocus. "shake of keyboard foci"
	evt shiftPressed ifTrue:[
		^evt hand 
			waitForClicksOrDrag: self 
			event: evt 
			selectors: { #findWindow:. nil. nil. #dragThroughOnDesktop:}
			threshold: 5].
	self isWorldMorph ifTrue: [
		handHadHalos ifTrue: [^self addAlarm: #invokeWorldMenu: with: evt after: 200].
		^self invokeWorldMenu: evt
	].
	"otherwise, explicitly ignore the event if we're not the world,
	so that we could be picked up if need be"
	self isWorldMorph ifFalse:[evt wasHandled: false].
! !

!PasteUpMorph methodsFor: '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 4/30/2001 20:31'!
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.
	CurrentProjectRefactoring currentFlapsSuppressed ifTrue: [use _ false].
	"Smalltalk isMorphic ifFalse: [use _ false]."
	thisWorld _ use 
		ifTrue: [self]
		ifFalse: [PasteUpMorph new initForProject:  "fake to be flap owner"
						WorldState new;
					bounds: (0@0 extent: 4000@4000);
					viewBox: (0@0 extent: 4000@4000)].
	
	Flaps globalFlapTabsIfAny do: [:aFlapTab |
		(CurrentProjectRefactoring isFlapEnabled: aFlapTab) ifTrue:
			[(aFlapTab world == thisWorld) ifFalse:
				[thisWorld addMorphFront: aFlapTab.
				aFlapTab adaptToWorld: thisWorld].	"always do"
			use ifTrue:
				[aFlapTab spanWorld.
				aFlapTab adjustPositionAfterHidingFlap.
				aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]]! !

!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: '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: 'gridding' stamp: 'dgd 12/13/2003 19:30' prior: 26058367!
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: 'dgd 12/13/2003 19:30' prior: 26058877!
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: 'dgd 9/6/2003 18:09' prior: 26059138!
setGridSpec
	"Gridding rectangle provides origin and modulus"
	| response result mx |
	mx _ 36.  "... because it was that way before ..."
	response _ FillInTheBlank
			request: 'New grid origin (usually 0@0):' translated
			initialAnswer: self gridOrigin printString.
	response isEmpty ifTrue: [^ self].
	result _ [Compiler evaluate: response] ifError: [^ self].
	(result isPoint and: [(result >= (0@0)) & (result < (mx @ mx))])
		ifTrue: [self gridOrigin: result]
		ifFalse: [self inform: ('Must be a Point with coordinates between 0 & {1}' translated format: {mx-1})].

	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)) & (result <= (mx @ mx))])
		ifTrue: [self gridModulus: result]
		ifFalse: [self inform: ('Must be a Point with coordinates between 1 & {1}' translated format: {mx})].

! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'gm 2/16/2003 20:36' prior: 25979161!
wantsHaloFromClick
	^(owner isSystemWindow) not! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'ar 3/17/2001 23:25'!
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.
	ActiveWorld _ priorWorld.
	ActiveEvent _ priorEvent.
	ActiveHand _ priorHand.! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'mir 10/29/2003 13:05' prior: 39429508!
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' prior: 25946045!
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' prior: 26052980!
doOneCycleNow
	"see the comment in doOneCycleNowFor:"
	worldState doOneCycleNowFor: self.
! !

!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: 'sw 11/27/2001 06:56'!
addCustomMenuItems: menu hand: aHandMorph
	"Add morph-specific menu itemns to the menu for the hand"

	super addCustomMenuItems: menu hand: aHandMorph.
	self addStackMenuItems: menu hand: aHandMorph.
	self addPenMenuItems: menu hand: aHandMorph.
	self addPlayfieldMenuItems: menu hand: aHandMorph.

	self isWorldMorph ifTrue:
		[(owner isKindOf: BOBTransformationMorph) ifTrue:
			[self addScalingMenuItems: menu hand: aHandMorph].
		Flaps sharedFlapsAllowed ifTrue:
			[menu addUpdating: #suppressFlapsString
				target: CurrentProjectRefactoring 
				action: #currentToggleFlapsSuppressed].
		menu add: 'desktop menu...' target: self action: #putUpDesktopMenu:].

	menu addLine! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 21:56' prior: 39432674!
addCustomMenuItems: menu hand: aHandMorph
	"Add morph-specific menu itemns to the menu for the hand"

	super addCustomMenuItems: menu hand: aHandMorph.
	self addStackMenuItems: menu hand: aHandMorph.
	self addPenMenuItems: menu hand: aHandMorph.
	self addPlayfieldMenuItems: menu hand: aHandMorph.

	self isWorldMorph ifTrue:
		[(owner isKindOf: BOBTransformationMorph) ifTrue:
			[self addScalingMenuItems: menu hand: aHandMorph].
		Flaps sharedFlapsAllowed ifTrue:
			[menu addUpdating: #suppressFlapsString
				target: CurrentProjectRefactoring 
				action: #currentToggleFlapsSuppressed].
		menu add: 'desktop menu...' translated target: self action: #putUpDesktopMenu:].

	menu addLine! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:53' prior: 25960126!
addPenMenuItems: menu hand: aHandMorph
	"Add a pen-trails-within submenu to the given menu"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	self addPenTrailsMenuItemsTo: subMenu.
	menu add: 'pens trails within...' translated subMenu: subMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:14' prior: 39434224!
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: 'dgd 9/6/2003 17:54' prior: 25960444!
addPenTrailsMenuItemsTo: aMenu
	| oldTarget |
	"Add items relating to pen trails to aMenu"

	oldTarget _ aMenu defaultTarget.
	aMenu defaultTarget: self.
	aMenu add: 'clear pen trails' translated action: #clearTurtleTrails.
	aMenu add: 'all pens up' translated action: #liftAllPens.
	aMenu add: 'all pens down' translated action: #lowerAllPens.
	aMenu defaultTarget: oldTarget! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:15' prior: 39434840!
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: 'dgd 9/5/2003 19:31' prior: 25960861!
addPlayfieldMenuItems: menu hand: aHandMorph 
	menu
		add: 'playfield options...' translated
		target: self
		action: #presentPlayfieldMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 17:52' prior: 39436116!
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' prior: 25961058!
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 11/27/2001 14:37'!
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 adMiscExtrasTo: 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 "', unlockables first externalName, '"' action: #unlockContents].
	unlockables size > 1 ifTrue:
		[aMenu add: 'unlock all contents' action: #unlockContents.
		aMenu add: 'unlock...' action: #unlockOneSubpart].

	aMenu defaultTarget: aHandMorph.
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 10/17/2003 22:48' prior: 39437468!
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 adMiscExtrasTo: 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: 'nk 2/15/2004 08:19' prior: 39438558!
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' prior: 25961969!
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' prior: 25962290!
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' prior: 25962571!
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' prior: 25962855!
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' prior: 25963144!
buildDebugMenu: aHandMorph
	| aMenu |
	aMenu _ super buildDebugMenu: aHandMorph.
	aMenu add:  'abandon costume history' translated target: self action: #abandonCostumeHistory.
	^ aMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:01' prior: 25964309!
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' prior: 25964576!
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' prior: 25964865!
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' prior: 25965161!
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: 'dgd 9/6/2003 17:58' prior: 25965654!
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' prior: 25965940!
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: 'dgd 9/5/2003 19:33' prior: 25966237!
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.
	aMenu add: 'save as SqueakPage at url...' translated action: #saveOnURL.
	aMenu add: 'update all from resources' translated action: #updateAllFromResources.
	(self valueOfProperty: #classAndMethod) ifNotNil:
		[aMenu add: 'broadcast as documentation' translated action: #saveDocPane].
	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' translated)
		(indicateCursorString	toggleIndicateCursor
			'whether the "current" submorph should be indicated with a dark black border' translated)
		(isPartsBinString		toggleIsPartsBin
			'whether dragging an object from the interior should produce a COPY of the object' translated)
		(isOpenForDragNDropString	toggleDragNDrop
			'whether objects can be dropped into and dragged out of me' translated)
		(mouseOverHalosString	toggleMouseOverHalos
			'whether objects should put up halos when the mouse is over them' translated)
		(autoExpansionString	toggleAutomaticPhraseExpansion
			'whether tile phrases, dropped on me, should automatically sprout Scriptors around them' translated)
		(originAtCenterString	toggleOriginAtCenter
			'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield' translated)
		(showThumbnailString	toggleAlwaysShowThumbnail
			'whether large objects should be represented by thumbnail miniatures of themselves' translated)
		(fenceEnabledString	toggleFenceEnabled
			'whether moving objects should stop at the edge of their container' translated)
		(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.' translated)

	) do:

			[:triplet |
				(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail) includes: triplet second]) ifFalse:
					[aMenu addUpdating: triplet first action: triplet second.
					aMenu balloonTextForLastItem: triplet third]]. 

	aMenu addUpdating: #autoViewingString action: #toggleAutomaticViewing.
	aMenu balloonTextForLastItem:  'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.' 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: 'dgd 9/6/2003 18:04' prior: 25972083!
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: 'mir 8/23/2001 16:58'!
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 ', self class name) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' 
			initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ self beep].
	self allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.project'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.project'].
	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 2/22/2003 14:11' prior: 39454717!
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 ' , self class name) asFileName.	"do better?"
	aFileName := FillInTheBlank 
				request: 'File name? (".project" will be added to end)'
				initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^self beep].
	self allMorphsDo: [:m | m prepareToBeSaved].
	ok := aFileName endsWith: '.project'.	"don't double them"
	ok := ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName := aFileName , '.project'].
	fileStream := FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self	"Puts UniClass definitions out anyway"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'md 10/22/2003 16:07' prior: 39455655!
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 ' , self class name) asFileName.	"do better?"
	aFileName := FillInTheBlank 
				request: 'File name? (".project" will be added to end)'
				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.
	fileStream fileOutClass: nil andObject: self	"Puts UniClass definitions out anyway"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sd 11/13/2003 21:26' prior: 39456600!
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.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!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: 'dgd 9/6/2003 18:00' prior: 25977797!
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: '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: 'dgd 8/30/2003 15:52' prior: 26010713!
innocuousName
	^ (self isFlap)
		ifTrue:
			['flap' translated]
		ifFalse:
			[super innocuousName]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/9/2003 23:22' prior: 26011920!
mouseX
	"Answer the x-coordinate of the mouse, in my coordinate system"

	^ self isInWorld
		ifTrue:
			[(self cursorPoint x) - self cartesianOrigin x]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/9/2003 23:23' prior: 26012076!
mouseY
	"Answer the y-coordinate of the mouse, in my coordinate system"

	^ self isInWorld
		ifTrue:
			[self cartesianOrigin y - (self cursorPoint y)]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/23/2003 03:46' prior: 26013046!
prepareToBeSaved
	"Prepare for export via the ReferenceStream mechanism"

	| exportDict soundKeyList players |
	super prepareToBeSaved.
	turtlePen _ nil.
	self isWorldMorph
		ifTrue: [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: 'sw 11/22/2001 06:21'!
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! !

!PasteUpMorph methodsFor: 'model' stamp: 'dgd 2/22/2003 14:09' prior: 25979286!
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: 'options' stamp: 'dgd 9/6/2003 17:55' prior: 25981724!
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' prior: 25982047!
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 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: 'dgd 12/13/2003 19:30' prior: 25984775!
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: 'dgd 9/6/2003 18:05' prior: 25985623!
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: 'tk 10/30/2001 18:41'!
toggleResizeToFit
	"Toggle whether the receiver is set to resize-to-fit"

	self vResizeToFit: self resizeToFit not! !

!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: 'bf 10/2/2002 18:41'!
backgroundForm: aForm

	self backgroundSketch: (SketchMorph 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: '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: 'ar 6/3/2001 14:01'!
prepareToPaint
	"We're about to start painting. Do a few preparations that make the system more responsive."
	^self prepareToPaint: true.! !

!PasteUpMorph methodsFor: 'painting' stamp: 'ar 6/3/2001 14:01'!
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 stopRunningAll]. "stop scripts"
	self abandonAllHalos. "no more halos"! !

!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: '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: 'nk 7/7/2003 11:17' prior: 25992821!
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 10/4/2002 17:35'!
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 |
	turtleTrailsDelta _ self valueOfProperty: #turtleTrailsDelta ifAbsent:[0@0].
	newPoint _ targetPoint - turtleTrailsDelta.
	oldPoint = newPoint ifTrue: [^ self].
	self createOrResizeTrailsForm.
	origin _ self topLeft.
	mPenSize _ aMorph getPenSize.
	turtlePen sourceForm width ~= mPenSize
		ifTrue: [turtlePen squareNib: mPenSize].
	offset _ (mPenSize // 2)@(mPenSize // 2).
	turtlePen color: aMorph getPenColor.
	turtlePen drawFrom: (oldPoint - origin - offset) asIntegerPoint
				to: (newPoint - origin - offset) asIntegerPoint.
	((aPlayer _ aMorph player) getPenArrowheads and: [oldPoint ~= newPoint]) ifTrue:
		[turtlePen
			arrowHeadFrom: (oldPoint - origin - offset) 
			to: (newPoint - origin - offset)
			forPlayer: aPlayer].
	self invalidRect: ((oldPoint rect: newPoint) expandBy: mPenSize)! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/17/2003 12:01' prior: 39471287!
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 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: 'tk 10/4/2001 18:03'!
noArrowheadsOnAllPens

	submorphs do: [:m | m assuredPlayer setPenArrowheads: false]
! !

!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' prior: 25996123!
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: 'project' stamp: 'gm 2/16/2003 20:35' prior: 26052680!
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: 'nk 7/4/2003 16:47' prior: 26024214!
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: 'nk 4/15/2002 09:38'!
viewBox: newViewBox
	"I am now displayed within newViewBox; react."

	self isWorldMorph ifTrue: [
		(self viewBox == nil
		  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: 'project state' stamp: 'dgd 2/22/2003 14:12' prior: 39477220!
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: 'sw 9/25/2001 23: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 isKindOf: Player) ifTrue:
					[^ Vocabulary eToyVocabulary].
			(aScriptableObject isKindOf: Number) ifTrue:
					[^ Vocabulary numberVocabulary].
			(aScriptableObject isKindOf: Time) ifTrue:
					[^ Vocabulary vocabularyForClass: Time].
			(aScriptableObject isKindOf: String) ifTrue:
					[^ Vocabulary vocabularyForClass: String].
			(aScriptableObject isKindOf: Point) ifTrue:
					[(aPointVocab _ Vocabulary vocabularyForClass: Point) ifNotNil: [^ aPointVocab]].
			(aScriptableObject isKindOf: Date) ifTrue:
					[^ Vocabulary vocabularyForClass: Date].
			"OrderedCollection and Holder??"
			^Vocabulary fullVocabulary]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:08' prior: 39479149!
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 isKindOf: Player) 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: 'sw 7/28/2001 00:27'!
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').
	ActiveWorld abandonOldReferenceScheme.
	ActiveWorld relaunchAllViewers.! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'dgd 8/31/2003 19:39' prior: 39482174!
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: 'di 2/19/2001 15:29'!
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 isKindOf: StandardViewer) 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' prior: 39483411!
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: 'sw 7/24/2001 21:26'!
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 isKindOf: StandardViewer] ifNone: [nil].
		aViewer ifNotNil:
			[aViewer relaunchViewer]]
"ActiveWorld relaunchAllViewers"! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:09' prior: 39484532!
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: '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: 'structure' stamp: 'dgd 2/22/2003 14:12' prior: 25947154!
world
	worldState isNil ifTrue: [^super world].
	^self! !

!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 18:14'!
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
	"Include hands if the receiver is the World"
	self isWorldMorph ifTrue:[
		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-accessing' stamp: 'nk 7/4/2003 16:49' prior: 39485794!
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: 'user interface' stamp: 'dgd 2/22/2003 14:11' prior: 26024803!
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: '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: 'dgd 9/6/2003 17:50' prior: 26066233!
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' prior: 26066569!
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' prior: 26066968!
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' prior: 26067346!
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: '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: 'dgd 9/21/2003 17:39' prior: 26071588!
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: '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: 'mir 11/14/2002 17:37' prior: 26072592!
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: 'sw 2/23/2004 18:33'!
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"

	^ {
		{ $b.	Browser.						#openBrowser.							'Open a new System Browser'}.
		{ $k.	Workspace.						#open.									'Open a new, blank Workspace'}.
		{ $m.	self.							#putUpNewMorphMenu.					'Put up the "New Morph" menu'}.
		{ $o.	ActiveWorld.					#activateObjectsTool.						'Activate the "Objects Tool"'}.
		{ $r.	ActiveWorld.					#restoreMorphicDisplay.					'Redraw the screen'}.		
		{ $t.		self. 							#findATranscript:.						'Make a System Transcript visible'}.
		{ $w.	SystemWindow.					#closeTopWindow.						'Close the topmost window'}.
		{ $z.	self.							#undoOrRedoCommand.					'Undo or redo the last undoable command'}.

		{ $C.	self.							#findAChangeSorter:.					'Make a Change Sorter visible'}.
		{ $F.	CurrentProjectRefactoring.		#currentToggleFlapsSuppressed.			'Toggle the display of flaps'}.

		{ $L.	self.							#findAFileList:.							'Make a File List visible'}.
		{ $N.    self.							#toggleClassicNavigatorIfAppropriate.	'Show/Hide the classic Navigator, if appropriate'}.
		{ $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'}.}! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/21/2003 17:40' prior: 26073532!
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: '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: 'di 10/18/2001 03:28'!
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: (SketchMorph 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: 'sw 7/22/2002 08:56'!
findAFileList: evt
	"Locate a file list, open it, and bring it to the front.  Create one if necessary"

	self findAWindowSatisfying:
		[:aWindow | aWindow model isKindOf: FileList] orMakeOneUsing: [FileList openAsMorph]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'nk 6/14/2004 09:08' prior: 39495519!
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: [Preferences useFileList2
				ifTrue: [FileList2 prototypicalToolWindow]
				ifFalse: [FileList 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: 'sw 7/22/2002 08:52'!
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) isKindOf: SystemWindow) 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: 'gm 2/16/2003 20:35' prior: 39497450!
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' prior: 26076229!
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' prior: 26076702!
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: 'gm 2/16/2003 20:35' prior: 26077143!
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: [^self beep].
	(expanded 
		asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) 
			do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #activateAndForceLabelToShow.
				w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) 
		ifFalse: [menu addLine].
	(collapsed 
		asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) 
			do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #collapseOrExpand.
				w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	nakedMorphs isEmpty ifFalse: [menu addLine].
	(nakedMorphs asSortedCollection: 
			[:w1 :w2 | 
			w1 nameForFindWindowFeature 
				caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) 
		do: 
			[:w | 
			menu 
				add: w nameForFindWindowFeature
				target: w
				action: #comeToFrontAndAddHalo].
	menu addTitle: 'find window'.
	menu popUpEvent: evt in: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'md 10/22/2003 15:58' prior: 39499656!
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'.
	menu popUpEvent: evt in: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sd 11/13/2003 21:25' prior: 39501591!
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: '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: 'di 10/18/2001 02:25'!
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: (SketchMorph 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: 'sw 7/22/2002 08:58'!
keystrokeInWorld: evt
	"A keystroke was hit when no keyboard focus was in set, so it is sent here to the world instead.  This current implementation is regrettably hard-coded; until someone cleans this up, you may wish to edit this method to suit your personal taste in interpreting cmd-keys issued to the desktop."

	|  aChar isCmd |
	aChar _ evt keyCharacter.
	aChar asciiValue = 27 ifTrue: "escape key"
		[^ ActiveWorld putUpWorldMenuFromEscapeKey].
	isCmd _ evt commandKeyPressed and: [Preferences cmdKeysInText].
	(evt commandKeyPressed and: [Preferences eToyFriendly])
			ifTrue:
				[(aChar == $W) ifTrue: [^ self putUpWorldMenu: evt]].
	(isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue:
		[(aChar == $o) ifTrue: [^ ActiveWorld activateObjectsTool].
		(aChar == $F) ifTrue: [^ CurrentProjectRefactoring currentToggleFlapsSuppressed].
		(aChar == $N) ifTrue:
			[Preferences classicNavigatorEnabled ifTrue: [^ Preferences togglePreference: #showProjectNavigator]].
		(aChar == $r) ifTrue: [^ ActiveWorld restoreMorphicDisplay].

		Preferences eToyFriendly
			ifFalse:
				[(aChar == $\) ifTrue: [^ SystemWindow sendTopWindowToBack].

				(aChar == $b) ifTrue: [^ Browser openBrowser].
				(aChar == $k) ifTrue: [^ Workspace open].
				(aChar == $m) ifTrue: [^ TheWorldMenu new adaptToWorld: World; newMorph].
				(aChar == $t) ifTrue: [^ self findATranscript: evt].
				(aChar == $w) ifTrue: [^ SystemWindow closeTopWindow].
				(aChar == $z) ifTrue: [^ self commandHistory undoOrRedoCommand].

				(aChar == $C) ifTrue: [^ self findAChangeSorter: evt].
				(aChar == $L) ifTrue: [^ self findAFileList: evt].
				(aChar == $R) ifTrue: [^ self openRecentSubmissionsBrowser: evt].
				(aChar == $P) ifTrue: [^ self findAPreferencesPanel: evt].
				(aChar == $W) ifTrue: [^ self findAMessageNamesWindow: evt]]]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 5/20/2003 14:59' prior: 39509063!
keystrokeInWorld: evt
	"A keystroke was hit when no keyboard focus was in 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].
	(#(1 4 8 28 29 30 31 32) includes: ascii) ifTrue:  "home, end, backspace, arrow keys, space"
		[self keyboardNavigationHandler ifNotNilDo:
			[:aHandler | ^ aHandler 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]! !

!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: '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: 'dgd 8/26/2003 21:10' prior: 26084086!
putUpDesktopMenu: evt
	"Put up the desktop menu"
	^ ((self buildWorldMenu: evt) addTitle: Preferences desktopMenuTitle translated) popUpAt: evt position forHand: evt hand in: self! !

!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: 'di 12/3/2001 21:45'!
putUpWorldMenu: evt
	"Put up a menu in response to a click on the desktop, triggered by evt."

	| menu |
	self bringFlapTabsToFront.
	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.
	menu popUpEvent: evt in: self.
	^ menu! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 8/26/2003 21:10' prior: 39515080!
putUpWorldMenu: evt
	"Put up a menu in response to a click on the desktop, triggered by evt."

	| menu |
	self bringFlapTabsToFront.
	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: 'di 12/10/2001 22:02'!
putUpWorldMenuFromEscapeKey

	^ self putUpWorldMenu: ActiveEvent! !

!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: '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 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' prior: 26085116!
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: 'sw 9/13/2001 10:06'!
abandonVocabularyPreference
	"Remove any memory of a preferred vocabulary in the project"

	self removeProperty: #currentVocabularySymbol

"ActiveWorld abandonVocabularyPreference"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:09' prior: 26029986!
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: 'gm 2/16/2003 20:35' prior: 26031500!
allNonFlapRelatedSubmorphs
	"Answer all non-window submorphs that are not flap-related"

	^submorphs 
		select: [:m | (m isSystemWindow) not and: [m isFlapOrTab not]]! !

!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: '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: 'sw 9/12/2001 11:50'!
currentNaturalLanguage
	"Answer the natural language symbol of the current project's natural language"

	^ self project naturalLanguage

"ActiveWorld currentNaturalLanguage"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10' prior: 26034207!
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: 'ls 5/6/2003 16:51' prior: 26035118!
doOneCycle
	"see the comment in doOneCycleFor:"

	worldState doOneCycleFor: self! !

!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: 'mir 9/12/2001 15:18'!
initForProject: aWorldState

	worldState _ aWorldState.
	bounds _ Display boundingBox.
	color _ (Color r:0.937 g: 0.937 b: 0.937).
	self addHand: HandMorph new.
	self setProperty: #automaticPhraseExpansion toValue: true.
	self setProperty: #optimumExtentFromAuthor toValue: Display extent.
	self wantsMouseOverHalos: Preferences mouseOverHalos.
	self borderWidth: 0.
	model _ nil.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'JMM 12/11/2001 12:59'!
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 == nil 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:10' prior: 39522939!
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' prior: 26039478!
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: 'sw 5/7/2001 13:15'!
installFlaps
	"Get flaps installed within the bounds of the receiver"

	Project current assureFlapIntegrity.
	self addGlobalFlaps.
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringFlapTabsToFront! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/13/2001 09:44'!
installVectorVocabulary
	"Install the experimental Vector vocabulary as the default for the current project"

	self setProperty: #currentVocabularySymbol toValue: #Vector! !

!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25' prior: 26042129!
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: 'dgd 2/22/2003 19:01' prior: 26043783!
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: 'nk 7/7/2003 11:15' prior: 26045135!
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: 'nb 6/17/2003 12:25' prior: 26046252!
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: '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: 'sw 4/24/2001 10:38'!
restoreFlapsDisplay
	"Restore the display of flaps"

	(Flaps sharedFlapsAllowed and: [CurrentProjectRefactoring currentFlapsSuppressed not]) ifTrue:
		[Flaps globalFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld]].
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringFlapTabsToFront! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:59'!
restoreMorphicDisplay

	DisplayScreen startUp.
	self
		extent: Display extent;
		viewBox: Display boundingBox;
		handsDo: [:h | h visible: true; showTemporaryCursor: nil];
		restoreFlapsDisplay;
		fullRepaintNeeded.
	WorldState addDeferredUIMessage: [
		Cursor normal show.
	].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11' prior: 26050057!
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: 'nb 6/17/2003 12:25' prior: 26050430!
standardPlayerHit

	self playSoundNamed: 'peaks'.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:12' prior: 26050553!
standardSystemController
	^ScheduledControllers controllerSatisfying: 
			[:c | 
			c view subViews notEmpty and: [c view firstSubView model == self]]! !

!PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'!
privateRemoveMorph: aMorph
	backgroundMorph == aMorph ifTrue: [ backgroundMorph _ nil ].
	^super privateRemoveMorph: aMorph.
! !

!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 class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:00' prior: 26090326!
initialize

	self registerInFlapsRegistry.	! !

!PasteUpMorph class methodsFor: '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: '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: '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: '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: 'scripting' stamp: 'bf 10/2/2002 17:06'!
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.')))

(collections (
(slot cursor 'The index of the chosen element' Number readWrite Player getCursor Player setCursorWrapped:)
(slot playerAtCursor 'the object currently at the cursor' Player readWrite Player getValueAtCursor  unused unused)
(slot firstElement  'The first object in my contents' Player  readWrite Player getFirstElement  Player  setFirstElement:)
(slot numberAtCursor 'the number at the cursor' Number readWrite Player getNumberAtCursor Player setNumberAtCursor: )
(slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly Player getGraphicAtCursor  unused unused)
(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 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 arrowheadsOnAllPens  'Put arrowheads on the ends of strokes of pens on all objects.')
(command noArrowheadsOnAllPens  'Stop putting arrowheads on the ends of strokes of pens on all objects.')
(command clearTurtleTrails 'Clear all the pen trails in the interior.'))))
! !

!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 3/4/2004 10:09' prior: 39534222!
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 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.'))))
! !

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

!PasteUpMorphTest methodsFor: 'texture fills' 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! !

!PasteUpMorphTest commentStamp: '<historical>' prior: 0!
I am a TestCase for PasteUpMorph.!
!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: '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'!
up
	"Set the state of the receiver's pen to up (no drawing)."

	penDown _ false! !

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

!PenPointRecorder methodsFor: 'line drawing' stamp: 'md 11/14/2003 16:56' prior: 26118455!
drawFrom: p1 to: p2
	"Overridden to skip drawing but track bounds of the region traversed."

	points ifNil: [points _ OrderedCollection with: p1].
	points addLast: p2! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:02'!
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: 'dns 2/28/2001 14:03'!
deletePhoneme
	"Delete a phoneme specified by the user."

	| phoneme |
	phoneme _ self selectPhonemeFromMenu: 'Phoneme to delete'.
	phoneme ifNotNil: [
		phonemeRecords remove: phoneme ifAbsent: []].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'sw 9/26/2001 03:23'!
makeTile
	"Make a scripting tile to fetch the current phoneme's mouth position. Attach it to the hand, allowing the user to drop it directly into a tile script."

	| tile argTile |
	tile _ PhraseTileMorph new setSlotRefOperator: #mouthPosition type: #Number.
	argTile _ self tileToRefer.
	argTile bePossessive.
	tile firstSubmorph addMorph: argTile.
	tile enforceTileColorPolicy.
	ActiveHand attachMorph: tile
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:03'!
playPhoneme
	"Play a phoneme specified by the user."

	| phoneme |
	phoneme _ self selectPhonemeFromMenu: 'Phoneme to play'.
	phoneme ifNotNil: [phoneme play].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dgd 2/22/2003 13:46' prior: 26136108!
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.
	phonemeRecords := newPhonemes! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:04'!
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: 'private' stamp: 'nk 7/12/2003 08:59' prior: 26141948!
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: 'dns 2/28/2001 14:01'!
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 |
	phonemeRecords isEmpty ifTrue: [self inform: 'The phoneme database is empty.'. ^ nil].
	aMenu _ CustomMenu new title: title.
	phonemeRecords do: [:phoneme |
		aMenu add: phoneme name action: phoneme].
	^ aMenu startUp
! !

!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: 'tk 7/5/2001 22:09'!
species
	^PhoneticRule ! !

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

!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: 'dgd 2/22/2003 19:08' prior: 26209100!
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: '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: 'e-toy support' stamp: 'RAA 3/9/2001 18:26'!
setAsActionInButtonProperties: buttonProperties

	| tempEditor |

	tempEditor _ self morphToDropInPasteUp: nil.
	userScriptSelector ifNil: [
		buttonProperties
			target: self associatedPlayer;
			actionSelector: #evaluateUnloggedForSelf:;
			arguments: {self codeString}.
		^true
	].
	buttonProperties
		target: self objectViewed player;
		actionSelector: #perform:;
		arguments: {userScriptSelector}.
	^true

"==== or 

	buttonProperties
		target: (self morphToDropInPasteUp: nil);
		actionSelector: #tryMe;
		arguments: #().
	^true


	==="! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:40' prior: 26201671!
initialize
	"Initialize a nascent instance"

	super initialize.
	resultType _ #unknown.
	brightenedOnEnter _ false.
	self wrapCentering: #center; cellPositioning: #leftCenter.
	self hResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	self extent: 5@5.  "will grow to fit"
	justGrabbedFromViewer _ true.  "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false"
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 5/29/2001 17:28'!
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.
	self addMorphBack: (TilePadMorph new setType: argType)! !

!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: '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: 'sw 6/4/2001 16:36'!
vocabulary: aVocab
	"Set the vocabulary"

	vocabularySymbol _ (aVocab isKindOf: Symbol)
		ifTrue:
			[aVocab]
		ifFalse:
			[aVocab vocabularyName]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'gm 2/24/2003 18:06' prior: 39555378!
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 11/27/2001 12:24'!
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' target: self action: #sproutNewScriptor! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'dgd 8/30/2003 21:56' prior: 39556213!
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: '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 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: 'sw 7/18/2002 10:38'!
try
	"Evaluate the given phrase once"

	| aPlayer |
	(userScriptSelector notNil and: [userScriptSelector numArgs = 0])
		ifTrue:
			[aPlayer _ self objectViewed player.
			aPlayer perform: userScriptSelector]
		ifFalse:
			[Compiler evaluate:
				self codeString
				for: self associatedPlayer
				logged: false]! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'dgd 2/22/2003 19:07' prior: 26204647!
catchDivideByZero: aStream indent: tabCount 
	"See if I am have divide as my operator. If so, insert a test in the argument to divide."

	submorphs second type = #operator ifFalse: [^false].	"not me"
	submorphs second operatorOrExpression == #/ ifFalse: [^false].	"not me"
	aStream space.
	aStream nextPutAll: '(self beNotZero: '.
	(submorphs third) storeCodeOn: aStream indent: tabCount.
	aStream nextPut: $).
	^true! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'ar 2/9/2001 17:06'!
morphToDropInPasteUp: aPasteUp
	"Answer the morph to drop in aPasteUp, given that the receiver is the putative droppee"

	| actualObject itsSelector aScriptor pos |

	self isCommand ifFalse: [^ self].
	(actualObject _ self actualObject) ifNil: [^ 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: 'ar 12/3/2001 12:33'!
mouseDown: evt 
	"Pretend we picked up the tile and then put it down for a trial   positioning. -- The essence of ScriptEditor mouseEnter:"

	| ed guyToTake dup enclosingPhrase |
	self isPartsDonor ifTrue:
		[dup _ self duplicate.
		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: 'mouse' stamp: 'sw 6/17/2003 16:03' prior: 39559862!
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! !

!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' prior: 26222095!
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 class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 14:52'!
descriptionForPartsBin
	^ self partName:	'PianoKeyboard'
		categories:		#('Multimedia')
		documentation:	'A piano keyboard'! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:49' prior: 26225659!
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: 'note playing' stamp: 'jm 6/1/2001 01:29'!
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: 'dgd 2/22/2003 14:50' prior: 26228365!
selectFrom: selection 
	(trackIndex = selection first and: 
			[indexInTrack >= (selection second) and: [indexInTrack <= (selection third)]]) 
		ifTrue: [selected ifFalse: [self select]]
		ifFalse: [selected ifTrue: [self deselect]]! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56' prior: 26246671!
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' prior: 26246901!
cutSelection
	selection isNil ifTrue: [^self].
	self copySelection.
	self deleteSelection! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56' prior: 26247070!
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' prior: 26247864!
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' prior: 26248108!
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: 'jm 6/1/2001 01:30'!
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: 'jm 6/1/2001 01:30'!
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: '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: 'dgd 2/14/2003 21:01' prior: 26231364!
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: 'menu' stamp: 'dgd 8/30/2003 21:56' prior: 26243423!
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: 'private' stamp: 'ar 8/10/2003 18:12'!
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! !

!PianoRollScoreMorph methodsFor: 'private' stamp: 'md 11/14/2003 16:57' prior: 39573251!
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! !

!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.!
!PinMorph methodsFor: 'geometry' stamp: 'aoy 2/15/2003 21:23' prior: 26252615!
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: 'wires' stamp: 'dgd 2/22/2003 14:38' prior: 26255923!
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: 'dgd 2/22/2003 14:38' prior: 26257411!
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! !

!PinSpec methodsFor: 'variables' stamp: 'dgd 2/22/2003 19:00' prior: 26262470!
hasVariable
	^modelReadSelector notNil or: [modelWriteSelector notNil]! !

!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 7/22/2002 18:23'!
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! !

!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: '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: 'tk 8/24/2001 09:09'!
hasCostumeThatIsAWorld

	costume ifNil: [^ false].
	(costume renderedMorph isWorldMorph) ifTrue: [^ true].
	costumes ifNotNil:
		[costumes do:
			[:aCostume | (aCostume isWorldMorph) ifTrue: [^ true]]].
	^ false! !

!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 12/12/2001 12:24'!
restoreBaseGraphic
	"Restore my base graphic"

	| cos |
	((cos _ self costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[cos restoreBaseGraphic]! !

!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 7/17/2002 16:50'!
startHavingParameterFor: aSelector
	"Start having a parameter for the given selector.  After this change, the script name will change by the addition of a colon."

	self renameScript: aSelector newSelector: (aSelector, ':') asSymbol! !

!Player methodsFor: 'costume' stamp: 'tk 8/10/2001 11:33'!
tearOffButtonToFireScriptForSelector: aSelector
	"Tear off a button to fire the script for the given selector"

	| aButton props |

	Preferences useButtonProprtiesToFire ifFalse: [
		aButton _ ScriptActivationButton new target: self.
		aButton actionSelector: #runScript:.
		aButton arguments: (Array with: aSelector).
		aButton establishLabelWording.
		self currentHand attachMorph: aButton.
		^self
	].
	(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 3/11/2003 00:32' prior: 39584305!
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: '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: '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: 'menus' stamp: 'ar 2/12/2001 18:50'!
step
	"obsolete"
	^self stepAt: Time millisecondClockValue.! !

!Player methodsFor: 'misc' stamp: 'dgd 2/16/2003 21:56' prior: 26355343!
actorState
"answer the redeiver's actorState"
	^ self costume actorState! !

!Player methodsFor: 'misc' stamp: 'sw 10/15/2001 17:21'!
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: [^ self beep].

	(((aMorph isKindOf: SketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not])
		ifTrue:
			[costume acquirePlayerSimilarTo: aMorph player]
		ifFalse:
			[self beep]! !

!Player methodsFor: 'misc' stamp: 'nb 6/17/2003 12:25' prior: 39587545!
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 isKindOf: SketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not])
		ifTrue:
			[costume acquirePlayerSimilarTo: aMorph player]
		ifFalse:
			[self beep]! !

!Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:53' prior: 26355440!
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' prior: 26355862!
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: 'nb 6/17/2003 12:25'!
beep: soundName

	Preferences soundsEnabled
		ifTrue: [SampledSound playSoundNamed: soundName]
! !

!Player methodsFor: 'misc' stamp: 'gk 2/23/2004 20:51' prior: 39589448!
beep: soundName
	"Play given sound or at least beep."

	SoundService default playSoundNamedOrBeep: soundName
! !

!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 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: 'RAA 5/18/2001 09:28'!
erase

	self costume topRendererOrSelf delete! !

!Player methodsFor: 'misc' stamp: 'sw 4/24/2003 23:57' prior: 26359013!
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 |
	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 10/16/2001 07:54'!
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 isKindOf: SketchMorph) 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 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/16/2001 07:54'!
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' target: self selector: #forgetOtherCostumes]].

	aMenu add: 'expunge empty scripts' target: self action: #expungeEmptyScripts.
	aMenu addLine.
	aMenu add: 'choose vocabulary...' target: aViewer action: #chooseVocabulary.
	aMenu balloonTextForLastItem: 'Choose a different vocabulary for this Viewer.'.
	aMenu add: 'choose limit class...' 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.'.

	aMenu add: 'open standard lexicon' target: aViewer action: #openLexicon.
	aMenu balloonTextForLastItem: 'open a window that shows the code for this object in traditional programmer format'.

	aMenu add: 'open lexicon with search pane' target: aViewer action: #openSearchingProtocolBrowser.
	aMenu balloonTextForLastItem: 'open a lexicon that has a type-in pane for search (not recommended!!)'.


	aMenu addLine.
	aMenu add: 'inspect morph' target: costume selector: #inspect.
	aMenu add: 'inspect player' target: self selector: #inspect.
	self belongsToUniClass ifTrue:
		[aMenu add: 'browse class' target: self action: #browsePlayerClass.
		aMenu add: 'inspect class' target: self class action: #inspect].
	aMenu add: 'inspect this Viewer' target: aViewer selector: #inspect.
	aMenu add: 'inspect this Vocabulary' target: aViewer currentVocabulary selector: #inspect.

	aMenu addLine.
	aMenu add: 'relaunch this Viewer' target: aViewer action: #relaunchViewer.
	aMenu add: 'view morph directly' target: aViewer action: #viewMorphDirectly.
	aMenu balloonTextForLastItem: 'opens a Viewer directly on the rendered morph.'.
	(costume renderedMorph isKindOf: SketchMorph) ifTrue:
		[aMenu addLine.
		aMenu add: 'impart scripts to...' target: self action: #impartSketchScripts].

	aMenu popUpEvent: evt in: aWorld! !

!Player methodsFor: 'misc' stamp: 'dgd 9/6/2003 17:22' prior: 39592682!
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: 'view morph directly' translated target: aViewer action: #viewMorphDirectly.
	aMenu balloonTextForLastItem: 'opens a Viewer directly on the rendered morph.' translated.
	(costume renderedMorph isKindOf: SketchMorph) ifTrue:
		[aMenu addLine.
		aMenu add: 'impart scripts to...' translated target: self action: #impartSketchScripts].

	aMenu popUpEvent: evt in: aWorld! !

!Player methodsFor: 'misc' stamp: 'sw 12/11/2001 15:48'!
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."

	| aMenu aWorld  |
	(evt notNil and: [evt shiftPressed]) ifTrue:
		[^ self offerAlternateViewerMenuFor: aViewer event: evt].

	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'add a new instance variable' target: self action: #addInstanceVariable.
	aMenu balloonTextForLastItem: 'Add a new instance variable to this object and all of its siblings.  You will be asked to supply a name for it.'.
	aMenu add: 'add a new script' target: aViewer action: #newPermanentScript.
	aMenu balloonTextForLastItem: 'Add a new script that will work for this object and all of its siblings'.
	aMenu addLine.
	aMenu add: 'grab me' 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'.

	aMenu add: 'reveal me' 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'.

	aMenu addLine.
	aMenu add: 'tile representing me' action: #tearOffTileForSelf.
	aMenu add: 'add search pane' target: aViewer action: #addSearchPane.
	aMenu addLine.
	aMenu add: 'more...' target: self selector: #offerAlternateViewerMenuFor:event: argumentList: {aViewer. evt}.

	aMenu popUpEvent: evt in: aWorld
! !

!Player methodsFor: 'misc' stamp: 'dgd 9/6/2003 17:21' prior: 39597505!
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."

	| aMenu aWorld  |
	(evt notNil and: [evt shiftPressed]) ifTrue:
		[^ self offerAlternateViewerMenuFor: aViewer event: evt].

	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'add a new instance variable' translated target: self action: #addInstanceVariable.
	aMenu balloonTextForLastItem: 'Add a new instance 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.
	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.
	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/3/2004 00:21' prior: 39599128!
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]) ifTrue:
		[^ self offerAlternateViewerMenuFor: aViewer event: evt].

	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	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.
	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.
	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 9/6/2002 12:53'!
overlaps: aPlayer
	"Answer whether my costume overlaps that of another player"

	| goalCostume intersection myShadow goalShadow bb myRect goalRect |
	aPlayer ifNil: [^ false].

	goalCostume _ aPlayer costume.

	"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 at: 2) > 0]! !

!Player methodsFor: 'misc' stamp: 'dgd 2/22/2003 19:00' prior: 39603243!
overlaps: aPlayer 
	"Answer whether my costume overlaps that of another player"

	| goalCostume intersection myShadow goalShadow bb myRect goalRect |
	aPlayer ifNil: [^false].
	goalCostume := aPlayer costume.

	"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: 'dgd 2/22/2003 13:45' prior: 26363524!
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: 'di 2/23/2001 09:29'!
tearOffTileForSelf
	| tiles |
	self currentHand attachMorph: (tiles _ self tileReferringToSelf).
	(tiles isKindOf: SyntaxMorph) ifTrue:
		[Preferences tileTranslucentDrag
			ifTrue: [tiles lookTranslucent]
			ifFalse: [tiles align: tiles topLeft 
			 			with: self currentHand position + tiles cursorBaseOffset]]
! !

!Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:54' prior: 39606927!
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 5/4/2001 07:12'!
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! !

!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 7/4/2002 23:27'!
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' ifTrue: [highestThus _ highestThus max: aPair last]].
	^ ('script', (highestThus + 1) printString) asSymbol! !

!Player methodsFor: 'misc' stamp: 'dgd 9/1/2003 14:17' prior: 39609400!
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: 'pen' stamp: 'sw 10/16/2001 08:01'!
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 isKindOf: SketchMorph) 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: '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 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 3/11/2003 11:28'!
getTrailStyle
	"Answer the receiver's trailStyle"

	^ self actorState trailStyle! !

!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/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 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: 'scripting' stamp: 'sw 7/26/2001 12:03'!
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 defaultFloatPrecisionFor: aGetSelector].
	^ 1! !

!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 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: 'ar 2/12/2001 18:04'!
runAllTickingScripts: nowTick

	self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation runIfTicking: nowTick]! !

!Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:04'!
stepAt: nowTick
	self runAllTickingScripts: nowTick! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/18/2001 17:01'!
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 compileInobtrusively: aScriptEditorMorph methodString
		classified: 'scripts'.
	aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol.
	aUniclassScript currentScriptEditor: aScriptEditorMorph! !

!Player methodsFor: 'scripts-kernel' stamp: 'NS 1/28/2004 14:41' prior: 39615297!
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: 'sw 7/22/2002 18:09'!
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: 'sw 12/11/2001 10:38'!
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' action: #handTheUserACopy].

"	(slotSym == #dropShadow) ifTrue:
		[aMenu add: 'set shadow offset' action: #setShadowOffset].

	(slotSym == #useGradientFill) ifTrue:
		[aMenu add: 'set gradient origin...' action: #setGradientOffset.
		aMenu add: 'set gradient direction...' action: #setGradientDirection]."
! !

!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: 'sw 9/4/2001 06:56'!
existingScriptInstantiationForSelector: scriptName
	"Answer the existing script instantiation for the given selector, or nil if none"

	scriptName ifNil: [^ nil].
	Symbol hasInterned: scriptName ifTrue:
		[:sym |
			^ self actorState instantiatedUserScriptsDictionary at: sym ifAbsent: [nil]].
	^ nil! !

!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' prior: 26330948!
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: 'sw 9/26/2001 04:02'!
methodInterfaceForEmptyScript
	"Answer a MethodInterface representing Andreas's 'emptyScript' feature"

	| anInterface |
	anInterface _ MethodInterface new.
	anInterface receiverType: #Player.
	anInterface flagAttribute: #scripts.
	anInterface absorbTranslation: 
		(ElementTranslation new wording: (ScriptingSystem wordingForOperator: #emptyScript) helpMessage: 'an empty script; drop on desktop to get a new empty script for this object' language: #English).

	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' prior: 26333739!
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 2/17/2001 03:19'!
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.  ^ self beep].  
	"Maddeningly, without this line here the thing IS nil and the debugger is in a bad state
	(the above note dates from 1/12/99 ?!!"

	self class allInstancesDo:
		[:aPlayer | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: [].
		(aHandler _ aPlayer costume renderedMorph eventHandler) ifNotNil:
			[aHandler forgetDispatchesTo: aSymbol]]! !

!Player methodsFor: 'scripts-kernel' stamp: 'nb 6/17/2003 12:25' prior: 39622286!
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 | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: [].
		(aHandler _ aPlayer costume renderedMorph eventHandler) ifNotNil:
			[aHandler forgetDispatchesTo: aSymbol]]! !

!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 7/20/2002 12:50'!
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.'.
		^ self].

	reply _   FillInTheBlank request: 'Script Name' initialAnswer: oldSelector.
 	reply size == 0 ifTrue: [^ self].
	reply = oldSelector ifTrue:[^ self 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: 'dgd 2/22/2003 13:44' prior: 39624009!
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.'.
			^self].
	reply := FillInTheBlank request: 'Script Name' initialAnswer: oldSelector.
	reply isEmpty ifTrue: [^self].
	reply = oldSelector ifTrue: [^self 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: 'md 10/22/2003 16:17' prior: 39625212!
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.'.
			^self].
	reply := FillInTheBlank request: 'Script Name' 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: 'sw 7/18/2002 02:30'!
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 |
					anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector.
					newSelector numArgs == 0
						ifTrue:
							[anInstantiation changeSelectorTo: newSelector].
					aDict _ aPlayer costume actorState instantiatedUserScriptsDictionary.


					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 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: '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: 'sw 9/15/2002 16:51'!
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 |
	slotSym _ Utilities inherentSelectorForGetter: aGetterSymbol.
	aType _ self typeForSlotWithGetter: aGetterSymbol asSymbol.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: (slotSym asString, ' (', aType, ')').

	(typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol.

	(self slotInfo includesKey: slotSym)
		ifTrue:
			[aMenu add: 'change data type' selector: #chooseSlotTypeFor: argument: aGetterSymbol.
			typeVocab addUserSlotItemsTo: aMenu slotSymbol: slotSym.
			aMenu add: 'remove "', slotSym, '"' selector: #removeSlotNamed: argument: slotSym.
			aMenu add: 'rename  "', slotSym, '"' selector: #renameSlot: argument: slotSym.
			aMenu addLine].

	typeVocab addExtraItemsToMenu: aMenu forSlotSymbol: slotSym.  "e.g. Player type adds hand-me-tiles"

	aMenu add: 'show categories....' target: aViewer selector: #showCategoriesFor: argument: aGetterSymbol.
	self addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym.

	aMenu items size == 0 ifTrue:
		[aMenu add: 'ok' action: #yourself].

	aMenu popUpForHand: aViewer primaryHand in: aViewer world! !

!Player methodsFor: 'scripts-kernel' stamp: 'dgd 2/22/2003 13:45' prior: 39629458!
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 |
	slotSym := Utilities inherentSelectorForGetter: aGetterSymbol.
	aType := self typeForSlotWithGetter: aGetterSymbol asSymbol.
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addTitle: slotSym asString , ' (' , aType , ')'.
	(typeVocab := Vocabulary vocabularyForType: aType) 
		addWatcherItemsToMenu: aMenu
		forGetter: aGetterSymbol.
	(self slotInfo includesKey: slotSym) 
		ifTrue: 
			[aMenu 
				add: 'change data type'
				selector: #chooseSlotTypeFor:
				argument: aGetterSymbol.
			typeVocab addUserSlotItemsTo: aMenu slotSymbol: slotSym.
			aMenu 
				add: 'remove "' , slotSym , '"'
				selector: #removeSlotNamed:
				argument: slotSym.
			aMenu 
				add: 'rename  "' , slotSym , '"'
				selector: #renameSlot:
				argument: slotSym.
			aMenu addLine].
	typeVocab addExtraItemsToMenu: aMenu forSlotSymbol: slotSym.	"e.g. Player type adds hand-me-tiles"
	aMenu 
		add: 'show categories....'
		target: aViewer
		selector: #showCategoriesFor:
		argument: aGetterSymbol.
	self addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym.
	aMenu items isEmpty ifTrue: [aMenu add: 'ok' action: #yourself].
	aMenu popUpForHand: aViewer primaryHand in: aViewer world! !

!Player methodsFor: 'scripts-kernel' stamp: 'dgd 10/8/2003 19:41' prior: 39630859!
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 |
	slotSym _ Utilities inherentSelectorForGetter: aGetterSymbol.
	aType _ self typeForSlotWithGetter: aGetterSymbol asSymbol.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: (slotSym asString, ' (', aType, ')').

	(typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol.

	(self slotInfo includesKey: slotSym)
		ifTrue:
			[aMenu add: 'change data 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 3/2/2004 20:56' prior: 39632314!
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 |
	slotSym _ Utilities inherentSelectorForGetter: aGetterSymbol.
	aType _ self typeForSlotWithGetter: aGetterSymbol asSymbol.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: (slotSym asString, ' (', aType, ')').

	(typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol.

	(self slotInfo includesKey: slotSym)
		ifTrue:
			[aMenu add: 'change data 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 3/10/2004 17:52' prior: 39633785!
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 |
	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 wording].
	aMenu addTitle: (selector, ' (', (aType asString translated), ')').

	(typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol.

	(self slotInfo includesKey: slotSym)
		ifTrue:
			[aMenu add: 'change data 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 9/27/2001 13:30'!
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) documentationOrNil.
			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: 'dgd 2/22/2003 13:42' prior: 26345572!
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 class == Text or: [aPlayer class == String]) 
		ifTrue: 
			[self costume class == TextFieldMorph 
				ifTrue: [^self costume append: aPlayer]
				ifFalse: [^self]].
	(aCostume := self costume topRendererOrSelf) 
		addMorphNearBack: aPlayer costume.
	aPlayer costume goHome.	"assure it's in view"
	(aCostume isKindOf: PasteUpMorph) 
		ifTrue: [self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 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' prior: 26346478!
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: 'sw 2/5/2001 11:25'!
doButtonAction
	"Do the button action of my costume"

	self costume renderedMorph doButtonAction! !

!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: '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: 'dgd 2/22/2003 13:43' prior: 26350036!
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) owner == hisCostume owner 
		ifFalse: [hisCostume owner addMorphFront: aCostume].
	aCostume 
		position: hisCostume bounds rightCenter - (0 @ (aCostume height // 2))! !

!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 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: 'gk 2/23/2004 20:51' prior: 26351001!
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' prior: 26351215!
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: 'dgd 2/22/2003 13:44' prior: 26351892!
moveToward: aPlayer 
	"Move a standard amount in the direction of the given player.  If the object has an instance variable named 'speed', the speed of the motion will be governed by that value"

	| angle aCostume |
	(aPlayer isNil or: [aPlayer == self]) ifTrue: [^self].
	((aCostume := self costume) bounds intersects: aPlayer costume bounds) 
		ifTrue: [^self].
	angle := aCostume referencePosition 
				bearingToPoint: aPlayer costume referencePosition.
	self setHeading: angle.
	self forward: self getSpeed! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 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 2/20/2003 13:05'!
performScriptIfCan: scriptNameString
	"If I understand the given script name, perform it now"

	Symbol hasInterned: scriptNameString ifTrue:
		[:sym | (self class includesSelector: sym) ifTrue:
			[self perform: sym]]! !

!Player methodsFor: 'scripts-standard' stamp: 'ar 12/27/2001 00:03'!
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 == nil or: [aPlayer == self]) ifTrue: [^ self].
	(aPlayer class == Text or: [aPlayer class == String]) 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: 'dgd 2/22/2003 13:44' prior: 39647476!
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 class == Text or: [aPlayer class == String]) 
		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/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 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 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: 'RAA 2/11/2001 22:04'!
tellAllSiblings: aMessageSelector
	"Send the given message selector to all my sibling instances, but not to myself"

	self belongsToUniClass ifTrue:
		[(self class allSubInstances copyWithout: self) do:
			[:anInstance | anInstance perform: aMessageSelector asSymbol]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 12/20/2003 18:03' prior: 39649729!
tellAllSiblings: aMessageSelector
	"Send the given message selector to all my sibling instances, but not to myself"

	self belongsToUniClass
		ifTrue:
			[[(self class allSubInstances copyWithout: self) do:
				[:anInstance | anInstance perform: aMessageSelector asSymbol]]
					on: MessageNotUnderstood do:
						[:ex | ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName)]]
		ifFalse:
			[(aMessageSelector ~~ #emptyScript) ifTrue:
				[ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName)]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/19/2003 18:19'!
tellSelfAndAllSiblings: aMessageSelector
	"Send the given message selector to myself and to all my sibling instances"

	self belongsToUniClass ifTrue:
		[self class allSubInstances do:
			[:anInstance | anInstance perform: aMessageSelector asSymbol]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 12/20/2003 18:02' prior: 39650735!
tellSelfAndAllSiblings: aMessageSelector
	"Send the given message selector to myself and to all my sibling instances"

	self belongsToUniClass
		ifTrue:
			[[self class allSubInstances do:
				[:anInstance | anInstance perform: aMessageSelector asSymbol]]
					on: MessageNotUnderstood do:
						[:ex | ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName)]]
		ifFalse:
			[(aMessageSelector ~~ #emptyScript) ifTrue:
				[ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName)]]! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 9/4/2001 22:48'!
* aNumber
	"Treating Players like vectors, return a new Player that is myself scaled by the number"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX * aNumber asPoint x.
	new setY: self getY * aNumber asPoint y.
	newCost _ new costume.
	newCost owner privateRemoveMorph: newCost.	"Keep him out of the world"
	newCost privateOwner: nil.
	^ new
! !

!Player methodsFor: 'scripts-vector' stamp: 'ar 8/10/2003 18:18' prior: 39651707!
* aNumber
	"Treating Players like vectors, return a new Player that is myself scaled by the number"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX * aNumber asPoint x.
	new setY: self getY * aNumber asPoint y.
	newCost _ new costume.
	newCost owner removeMorph: newCost.	"Keep him out of the world"
	^ new
! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 9/4/2001 22:49'!
+ aPlayer
	"Treating Players like vectors, add aPlayer to me and return a new Player"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX + aPlayer asPoint x.
	new setY: self getY + aPlayer asPoint y.
	newCost _ new costume.
	newCost owner privateRemoveMorph: newCost.	"Keep him out of the world"
	newCost privateOwner: nil.
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'ar 8/10/2003 18:18' prior: 39652585!
+ aPlayer
	"Treating Players like vectors, add aPlayer to me and return a new Player"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX + aPlayer asPoint x.
	new setY: self getY + aPlayer asPoint y.
	newCost _ new costume.
	newCost owner removeMorph: newCost.	"Keep him out of the world"
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 9/4/2001 22:49'!
- aPlayer
	"Treating Players like vectors, subtract aPlayer from me and return a new Player"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX - aPlayer asPoint x.
	new setY: self getY - aPlayer asPoint y.
	newCost _ new costume.
	newCost owner privateRemoveMorph: newCost.	"Keep him out of the world"
	newCost privateOwner: nil.
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'ar 8/10/2003 18:19' prior: 39653433!
- aPlayer
	"Treating Players like vectors, subtract aPlayer from me and return a new Player"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX - aPlayer asPoint x.
	new setY: self getY - aPlayer asPoint y.
	newCost _ new costume.
	newCost owner removeMorph: newCost.	"Keep him out of the world"
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 9/4/2001 22:49'!
/ aNumber
	"Treating Players like vectors, return a new Player that is myself divided by the number"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX / aNumber asPoint x.
	new setY: self getY / aNumber asPoint y.
	newCost _ new costume.
	newCost owner privateRemoveMorph: newCost.	"Keep him out of the world"
	newCost privateOwner: nil.
	^ new
! !

!Player methodsFor: 'scripts-vector' stamp: 'ar 8/10/2003 18:19' prior: 39654295!
/ aNumber
	"Treating Players like vectors, return a new Player that is myself divided by the number"

	| new newCost |
	new _ costume usableSiblingInstance player.
	new setX: self getX / aNumber asPoint x.
	new setY: self getY / aNumber asPoint y.
	newCost _ new costume.
	newCost owner removeMorph: newCost.	"Keep him out of the world"
	^ new
! !

!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: '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: 'sw 12/12/2001 11:36'!
getBaseGraphic
	"Answer a form representing the receiver's base graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph baseGraphic]
		ifFalse:
			[aMorph imageForm]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 11:49'!
getBorderColor
	"Answer the border color of my costume"

	^ 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/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 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: 'sw 4/6/2001 00:20'!
getCostume
	"Answer a form representing the receiver's primary graphic.  An earlier wording, disused but may persist in preexisting scripts."

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph form]
		ifFalse:
			[aMorph imageForm]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 4/6/2001 00:20'!
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) isKindOf: SketchMorph)
				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 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 11/16/2001 07:29'!
getDropShadow
	"Getter for costume's hasDropShadow"

	^ costume hasDropShadow! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 4/5/2001 22:13'!
getFirstElement
	"Answer a player representing the receiver's costume's first submorph"

	| itsMorphs |
	^ (itsMorphs _ costume submorphs) size > 0
		ifFalse:
			[costume presenter standardPlayer]
		ifTrue:
			[itsMorphs first assuredPlayer]! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:43' prior: 39660452!
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: 'bf 10/2/2002 18:37'!
getGraphic
	"Answer a form representing the receiver's primary graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph form]
		ifFalse:
			[aMorph isPlayfieldLike
				ifTrue:
					[aMorph backgroundForm]
				ifFalse:
					[aMorph imageForm]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'bf 10/2/2002 18:38'!
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) isKindOf: SketchMorph)
				ifTrue:
					[aMorph form]
				ifFalse:
					[aMorph isPlayfieldLike
						ifTrue:
							[aMorph backgroundForm]
						ifFalse:
							[aMorph imageForm]]]! !

!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/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: '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 12/10/2001 00:39'!
getIsLocked
	"Answer whether the receiver's costume is locked"

	^ costume isLocked! !

!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 9/23/2002 22:27'!
getLength
	"Answer the length of the object"

	| aLength cost |
	((cost  _ self costume) isKindOf: PolygonMorph) "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: '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: '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 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: 'sw 11/16/2001 07:28'!
getShadowColor
	"Getter for costume's shadowColor"

	^ costume shadowColor! !

!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/16/2001 08:33'!
getUseGradientFill
	"Geter for costume's useGradientFill"

	^ costume renderedMorph fillStyle isGradientFill! !

!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: 'dgd 3/8/2004 18:26'!
getVideoFileName
	"Answer the videoFileName in my costume"
	^ costume renderedMorph getVideoFileName! !

!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 9/23/2002 22:29'!
getWidth
	"Answer the width of the object"

	| aWidth cost |
	((cost _ self costume) isKindOf: PolygonMorph) "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 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 12/12/2001 11:42'!
setBaseGraphic: aGraphic
	"Set the base graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph baseGraphic: aGraphic]! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 11/26/2001 15:33'!
setBorderColor: aColor
	"Set the border color as requested"
	costume renderedMorph borderStyle:
		(costume renderedMorph borderStyle copy baseColor: aColor).! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55' prior: 39667891!
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: 'sw 11/26/2001 11:32'!
setBorderWidth: aWidth
	"Set the border width to the given number"

	costume renderedMorph borderStyle:
		(costume renderedMorph borderStyle copy width: aWidth)! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55' prior: 39668510!
setBorderWidth: aWidth 
	"Set the border width to the given number"
	costume renderedMorph borderWidth: aWidth! !

!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 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 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: '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 4/6/2001 00:20'!
setCostume: aForm
	"Set the receiver's graphic as indicated.  An earlier wording, disused but may persist in preexisting scripts."

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph form: aForm]
		ifFalse:
			["what to do?"]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/17/2001 15:14'!
setDistance: aDistance
	"Set the object's distance from the origin to be as indicated, preserving its angle."

	self costume 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 11/16/2001 07:32'!
setDropShadow: aValue
	"Setter for costume's dropShadow"

	costume hasDropShadow ~~ aValue ifTrue: [costume toggleDropShadow]! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:45' prior: 26304571!
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: 'bf 10/2/2002 18:42'!
setGraphic: aForm
	"Set the receiver's graphic as indicated"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph)
		ifTrue:
			[aMorph form: aForm]
		ifFalse:
			[aMorph isPlayfieldLike
				ifTrue: 
					[aMorph backgroundForm: aForm]
				ifFalse:
					["what to do?"]]! !

!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/17/2002 10:17'!
setHeadingTheta: anAngle
	"Set the heading theta"

	self setHeading: (450 - anAngle)! !

!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 11/16/2001 07:34'!
setLayoutInset: aValue
	"Setter for costume's layoutInset"

	costume layoutInset: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/3/2002 02:20'!
setLength: aLength
	"Set the length of the receiver."

	| cost lengthToUse |
	((cost _ self costume) isKindOf: PolygonMorph)
		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 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: 'sw 11/29/2001 14:07'!
setScaleFactor: aNumber
	"Set the scale factor to be the given value"

	| aCostume |
	aCostume _ self costume.
	1.0 = aNumber
		ifTrue:
			[0.0 = self getHeading ifTrue:
				[aCostume isFlexMorph ifTrue: [aCostume removeFlexShell].
				^ self]]
		ifFalse:
			[aCostume isFlexMorph ifFalse: [aCostume addFlexShell]].
	costume scale: ((aNumber asFloat max: 0.1) min: 10.0)! !

!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: 'sw 11/16/2001 07:31'!
setShadowColor: aValue
	"Setter for costume's shadowColor"

	costume 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: 'sw 3/17/2001 15:13'!
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."

	self costume cartesianXY: (Point r: self getDistance degrees: aTheta)! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:25'!
setUseGradientFill: aBoolean
	"Setter for costume's useGradientFill"

	costume fillStyle isGradientFill
		ifTrue:
			[aBoolean ifFalse: [costume renderedMorph useSolidFill]]
		ifFalse:
			[aBoolean ifTrue: [costume renderedMorph useGradientFill]]! !

!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 3/8/2004 18:24'!
setVideoFileName: aString 
	"Set my costume's videoFileName as indicated"
	costume renderedMorph setVideoFileName: aString! !

!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 9/23/2002 22:34'!
setWidth: aWidth
	"Set the width"

	| cost widthToUse |
	((cost _ self costume) isKindOf: PolygonMorph)
		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-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 2/27/2001 05:39'!
categories
	"Answer a list of categories appropriate to the the receiver and its costumes"

	| aList |
	(self hasCostumeThatIsAWorld)
		ifTrue:	[^ self categoriesForWorld].

	aList _ OrderedCollection new.
	self slotNames size > 0 ifTrue:
		[aList add: #'instance variables'].
	aList addAll: costume categoriesForViewer.
	aList remove: #scripts ifAbsent: [].
	aList add: #scripts after: aList first.
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'dgd 2/22/2003 13:42' prior: 39679476!
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: #'instance variables'].
	aList addAll: costume categoriesForViewer.
	aList remove: #scripts ifAbsent: [].
	aList add: #scripts after: aList first.
	^aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 23:58' prior: 39679970!
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 9/13/2001 16:54'!
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 size > 0 ifTrue:
				[aList add: #'instance variables'].
			aList addAll: costume categoriesForViewer].
	aVocabulary addCustomCategoriesTo: aList.
	aList remove: #scripts ifAbsent: [].
	aList add: #scripts after: aList first.
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'dgd 2/22/2003 13:42' prior: 39681031!
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 notEmpty ifTrue: [aList add: #'instance variables'].
			aList addAll: costume categoriesForViewer].
	aVocabulary addCustomCategoriesTo: aList.
	aList remove: #scripts ifAbsent: [].
	aList add: #scripts after: aList first.
	^aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 00:00' prior: 39681641!
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: 'sw 3/24/2001 23:29'!
categoriesForWorld
	"Answer the list of categories given that the receiver is the Player representing a World"

	| aList |
	aList _ #(#'color & border' #'pen trails' playfield collections #'stack navigation') asOrderedCollection.
	self class scripts size > 0 ifTrue:
		[aList addFirst: #scripts].
	self slotNames size > 0 ifTrue:
		[aList addFirst: #'instance variables'].

	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'dgd 2/22/2003 13:42' prior: 39682936!
categoriesForWorld
	"Answer the list of categories given that the receiver is the Player representing a World"

	| aList |
	aList := #(#'color & border' #'pen trails' #playfield #collections #'stack navigation') 
				asOrderedCollection.
	self class scripts notEmpty ifTrue: [aList addFirst: #scripts].
	self slotNames notEmpty ifTrue: [aList addFirst: #'instance variables'].
	^aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 00:01' prior: 39683404!
categoriesForWorld
	"Answer the list of categories given that the receiver is the Player representing a World"

	| aList |
	aList _ #(#'color & border' #'pen trails' playfield collections #'stack navigation') asOrderedCollection.
	self class scripts ifNotEmpty:
		[aList addFirst: ScriptingSystem nameForScriptsCategory].
	self slotNames ifNotEmpty:
		[aList addFirst: ScriptingSystem nameForInstanceVariablesCategory].

	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 9/12/2001 12:43'!
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 absorbTranslation: 
				(ElementTranslation new wording: itsSlotName helpMessage: 'an instance variable defined by this object' language: #English).

			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/26/2003 23:31' prior: 39684380!
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 absorbTranslation: 
				(ElementTranslation new wording: itsSlotName helpMessage: 'a variable defined by this object' language: #English).

			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 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: 'sw 9/6/2002 11:33'!
typeForSlotWithGetter: aGetter
	"Answer the data type for values of the instance variable of the given name"

	| getter inherentSelector |
	(#(color:sees: touchesA: overlaps:) includes: aGetter) ifTrue: [^ #Boolean].  "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: 'ar 12/27/2001 00:05'!
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 arrowheadsOnAllPens noArrowheadsOnAllPens getMouseX getMouseY "mouseX mouseY" pauseScript: reverse roundUpStrays shuffleContents startScript: stopScript: unhideHiddenObjects getValueAtCursor "valueAtCursor"
startAll: pauseAll: stopAll:  
viewAllMessengers clobberAllMessengers openAllScriptsTool handScriptControlButtons viewAllReferencedObjects jumpToProject:)

includes: anInterface selector]].

	self hasAnyBorderedCostumes ifTrue: [^ methodInterfaceList].

	^ self hasOnlySketchCostumes
		ifTrue:
			[methodInterfaceList select: [:anInterface | (#(getColor getSecondColor getBorderColor getBorderWidth getBorderStyle  getRoundedCorners getUseGradientFill getRadialGradientFill ) includes: anInterface selector) not]]
		ifFalse:
			[methodInterfaceList select: [:anInterface | (#(getBorderColor getBorderWidth) includes: anInterface selector) not]]! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/11/2003 11:52' prior: 39687944!
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:)

includes: anInterface selector]].

	self hasAnyBorderedCostumes ifTrue: [^ methodInterfaceList].

	^ self hasOnlySketchCostumes
		ifTrue:
			[methodInterfaceList select: [:anInterface | (#(getColor 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: 'ka 6/13/2002 19:43'!
addInstanceVariable
	"Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it"

	| itsName initialValue typeChosen suggestedNames usedNames initialAnswer setterSelector originalString |
	suggestedNames _ #('cargo' 'speed' 'weight' 'mzee' 'friml' 'verp' 'znak').
	usedNames _ self class instVarNames.
	initialAnswer _ suggestedNames detect: [:aName |  (usedNames includes: aName) not] ifNone:
		[Utilities keyLike: 'var1'  satisfying: [:aKey | (usedNames includes: aKey) not]].

	originalString _ FillInTheBlank request: 'name for new inst var: ' initialAnswer: initialAnswer.
	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 class compileAccessorsFor: itsName.
	setterSelector _ Utilities setterSelectorFor: itsName.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: #'instance variables'! !

!Player methodsFor: 'slots-user' stamp: 'dgd 2/22/2003 13:42' prior: 39690945!
addInstanceVariable
	"Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it"

	| itsName initialValue typeChosen suggestedNames usedNames initialAnswer setterSelector originalString |
	suggestedNames := #('cargo' 'speed' 'weight' 'mzee' 'friml' 'verp' 'znak').
	usedNames := self class instVarNames.
	initialAnswer := suggestedNames 
				detect: [:aName | (usedNames includes: aName) not]
				ifNone: 
					[Utilities keyLike: 'var1'
						satisfying: [:aKey | (usedNames includes: aKey) not]].
	originalString := FillInTheBlank request: 'name for new inst var: '
				initialAnswer: initialAnswer.
	originalString isEmptyOrNil ifTrue: [^self].
	itsName := ScriptingSystem 
				acceptableSlotNameFrom: originalString
				forSlotCurrentlyNamed: nil
				asSlotNameIn: self
				world: self costume world.
	itsName isEmpty ifTrue: [^self].
	self assureUniClass.
	typeChosen := self initialTypeForSlotNamed: itsName.
	self slotInfo at: itsName
		put: (SlotInformation new initialize type: typeChosen).
	initialValue := self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: itsName withValue: initialValue.
	self class compileAccessorsFor: itsName.
	setterSelector := Utilities setterSelectorFor: itsName.
	(self class allSubInstances copyWithout: self) 
		do: [:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: #'instance variables'! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/3/2004 23:56' prior: 39692443!
addInstanceVariable
	"Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it"

	| itsName initialValue typeChosen suggestedNames usedNames initialAnswer setterSelector originalString |
	suggestedNames _ #('cargo' 'speed' 'weight' 'mzee' 'friml' 'verp' 'znak').
	usedNames _ self class instVarNames.
	initialAnswer _ suggestedNames detect: [:aName |  (usedNames includes: aName) not] ifNone:
		[Utilities keyLike: 'var1'  satisfying: [:aKey | (usedNames includes: aKey) not]].

	originalString _ FillInTheBlank request: 'name for new variable: ' translated initialAnswer: initialAnswer.
	originalString isEmptyOrNil ifTrue: [^ self].
	itsName _ ScriptingSystem acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: nil asSlotNameIn: self world: self costume world.

 	itsName isEmpty ifTrue: [^ self].	
	self assureUniClass.
	typeChosen _ self initialTypeForSlotNamed: itsName.
	self slotInfo at: itsName put: (SlotInformation new initialize type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: itsName withValue: initialValue.
	self class compileAccessorsFor: itsName.
	setterSelector _ Utilities setterSelectorFor: itsName.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/16/2004 14:27' prior: 39693980!
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', (usedNames size + 1) asString)  satisfying: [:aKey | (usedNames includes: aKey) not].

	originalString _ FillInTheBlank request: 'name for new variable: ' 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 class compileAccessorsFor: itsName.
	setterSelector _ Utilities setterSelectorFor: itsName.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory! !

!Player methodsFor: 'slots-user' stamp: 'sw 2/6/2003 18:04' prior: 26312371!
addInstanceVariableNamed: nameSymbol type: typeChosen value: aValue
	"Add an instance variable of the given name and type, and initialize it to have the given value"

	| initialValue setterSelector |
	self assureUniClass.
	self slotInfo at: nameSymbol put: (SlotInformation new initialize type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: nameSymbol withValue: aValue.
	self class compileAccessorsFor: nameSymbol.
	setterSelector _ Utilities setterSelectorFor: nameSymbol.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory
! !

!Player methodsFor: 'slots-user' stamp: 'NS 1/28/2004 14:47' prior: 26313153!
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 3/7/2004 15:56'!
allPossibleWatchersFromWorld
	"Answer a list of all UpdatingStringMorphs in the Active world and its hidden book pages, etc., which have any of my instances as targets"

	| a |
	a _ IdentitySet new: 400.
	ActiveWorld allMorphsAndBookPagesInto: a.
	^ a select: [:e | (e isKindOf: UpdatingStringMorph) and: [e target class == self class]]! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/16/2002 20:07'!
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 selections: typeChoices lines: #()) startUpWithCaption: 
		('Choose the TYPE
for ', slotName, '
(currently ', (self slotInfoAt: slotName) type, ')').
	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"
! !

!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: 'dgd 2/22/2003 13:43' prior: 26316091!
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: 'sw 11/16/2001 14:44'!
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 fromPhrase |

	typeChoices _ Vocabulary typeChoices.

	fromPhrase _ ' from
', self externalName, '''s ', slotName.
	typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: 'Choose the TYPE
of data to get', fromPhrase.
	typeChosen isEmptyOrNil ifTrue: [^ self].
	thePlayerThereNow _ self perform: (Utilities getterSelectorFor: slotName).
	thePlayerThereNow ifNil: [thePlayerThereNow _ self presenter standardPlayer].

	slotChoices _ thePlayerThereNow slotNamesOfType: typeChosen.
	slotChoices size == 0
		ifTrue: [^ self inform: 'sorry -- no slots of that type'].
	slotChosen _ (SelectionMenu selections: slotChoices asSortedArray) startUpWithCaption: 'Choose the datum
you want to extract from', fromPhrase.
	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 "the pad"
		acceptDroppingMorph: playerGetter event: nil. "simulate a drop"
	getterTiles makeAllTilesGreen.
	getterTiles justGrabbedFromViewer: false.
	getterTiles firstSubmorph changeTableLayout;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill.
	ActiveHand attachMorph: getterTiles
! !

!Player methodsFor: 'slots-user' stamp: 'dgd 2/22/2003 13:44' prior: 39700658!
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 fromPhrase |
	typeChoices := Vocabulary typeChoices.
	fromPhrase := ' from
' , self externalName , '''s ' , slotName.
	typeChosen := (SelectionMenu selections: typeChoices lines: #()) 
				startUpWithCaption: 'Choose the TYPE
of data to get' , fromPhrase.
	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'].
	slotChosen := (SelectionMenu selections: slotChoices asSortedArray) 
				startUpWithCaption: 'Choose the datum
you want to extract from' 
						, fromPhrase.
	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: 'sw 3/10/2003 14:54' prior: 26316975!
removeSlotNamed: 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.
	((Smalltalk allCallsOn: aSetter) size > 0 or: [(Smalltalk 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: 'dgd 2/22/2003 13:45' prior: 26317474!
renameSlot: oldSlotName 
	| reply newSlotName |
	reply := FillInTheBlank request: 'New name for "' , 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/3/2004 00:23' prior: 26317927!
renameSlot: oldSlotName newSlotName: newSlotName
	"Give an existing instance variable a new name"

	self class renameSilentlyInstVar: oldSlotName to: newSlotName.
	self updateAllViewers.
	self flag: #deferred.
	"Any scripts that formerly sent oldSlotName should now send newSlotName"

	self inform: 
'Caution!!  Any scripts that may reference this
variable by its old name may now be
broken -- you may need to fix them up manually.  
In some future release, we''ll automatically
fix those up, hopefully.' translated.

	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: oldSlotName ofPlayer: self)
			ifTrue:
				[^ aPlayer noteRenameOf: oldSlotName to: newSlotName inPlayer: self]].
	^ true! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/8/2004 22:14' prior: 39705827!
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 9/15/2002 16:48'!
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 ', places asString, ')'.
	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) isKindOf: Integer)
								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: 'gm 2/22/2003 14:54' prior: 39707327!
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 ' 
						, places asString , ')'.
	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: 'gm 2/24/2003 18:06' prior: 26319391!
slotInfoAt: slotName 
	| info |
	info := self slotInfo at: slotName ifAbsent: [nil].
	info ifNil: 
			[self slotInfo at: slotName put: (info := SlotInformation new initialize)].
	(info isKindOf: Symbol) 
		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: 'sw 11/29/2001 14:12'!
tearOffFancyWatcherFor: aGetter
	"Create 'Player3 heading = 43' as in independent entity.  It keeps up with the truth, and may be edited to change the variable."

	| aWatcher aTile aLine aColor aTower precision ms slotMsg info isNumeric anInterface watcherWording |
	info _ self slotInfoForGetter: aGetter.
	info ifNotNil:
			[isNumeric _ info type == #Number.
			watcherWording _ Utilities inherentSelectorForGetter: aGetter]
		ifNil:
			[anInterface _Vocabulary eToyVocabulary methodInterfaceAt: aGetter ifAbsent: [nil].
			isNumeric _ anInterface notNil and: [anInterface resultType == #Number].
			watcherWording _ anInterface elementWording].
	aColor _ Color r: 0.387 g: 0.581 b: 1.0.
	isNumeric
		ifTrue:	[aTile _ NumericReadoutTile new typeColor: aColor].
	aWatcher _ UpdatingStringMorph new.
	isNumeric ifTrue: [(precision _ self defaultFloatPrecisionFor: aGetter) ~= 1 
			ifTrue: [aWatcher floatPrecision: precision]].
	aWatcher growable: true;
		getSelector: aGetter;
		putSelector: (info notNil
			ifTrue:
				[ScriptingSystem setterSelectorForGetter: aGetter]
			ifFalse:
				[anInterface companionSetterSelector]).
	aWatcher target: self.
	aTile addMorphBack: aWatcher.
	aTile addArrows.
	aTile setLiteralTo: (self perform: aGetter) width: 30.
	(#(getScaleFactor "etc.") includes: aGetter) ifTrue:
		[aTile setProperty: #arrowDelta toValue: 0.1.
		(aTile findA: UpdatingStringMorph) floatPrecision: 0.1].


Preferences universalTiles 
	ifTrue: [
		ms _ MessageSend receiver: self selector: aGetter asSymbol arguments: #().
		slotMsg _ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer).
			"For CardPlayers, use 'self'.  For others, name it, and use its name."
		ms _ MessageSend receiver: 3 selector: #= asSymbol arguments: #(5).
		aLine _ ms asTilesIn: self class globalNames: false.
		aLine firstSubmorph delete.
		aLine addMorphFront: slotMsg.
		aLine lastSubmorph delete.
		aLine lastSubmorph delete.
		aLine color: aColor.
		aLine addMorphBack: aTile.
		aLine cellPositioning: #leftCenter]
	ifFalse: [
		aLine _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: aColor.
		aLine layoutInset: -1.
		aLine borderWidth: 1; borderColor: aColor darker.
		aLine addMorphBack: 
			(self tileReferringToSelf borderWidth: 0; typeColor: aColor; 
				color: aColor; bePossessive).
		aLine addTransparentSpacerOfSize: (4@0).
		aTower _ AlignmentMorph newColumn color: aColor.
		aTower addTransparentSpacerOfSize: (0 @ 1).
		aTower addMorphBack: 
			(StringMorph contents: watcherWording, ' = ' font: ScriptingSystem fontForTiles).
		aLine addMorphBack: aTower.
		aLine addMorphBack: aTile].

	aWatcher step; fitContents.
	self currentHand attachMorph: aLine.! !

!Player methodsFor: 'slots-user' stamp: 'sw 11/15/2001 09:11'!
tearOffWatcherFor: aSlotGetter
	"Tear off a watcher for the slot whose getter is provided"

	| aWatcher precision 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.
	
	isNumeric
		ifFalse:
			[aWatcher useStringFormat]
		ifTrue:
			[precision _ self defaultFloatPrecisionFor: aSlotGetter.
			precision ~= 1 ifTrue: [aWatcher floatPrecision: precision]].

	aWatcher
		growable: true;
		getSelector: aSlotGetter;
		putSelector: (info notNil
			ifTrue:
				[ScriptingSystem setterSelectorForGetter: aSlotGetter]
			ifFalse:
				[anInterface companionSetterSelector]);
		setNameTo: (info notNil
			ifTrue:
				[Utilities inherentSelectorForGetter: aSlotGetter]
			ifFalse:
				[anInterface elementWording]);
 		target: self;
		step;
		fitContents.
	self currentHand attachMorph: aWatcher! !

!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: '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 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' prior: 26316211!
hasUserDefinedSlots
	^self class slotInfo notEmpty! !

!Player methodsFor: 'viewer' stamp: 'sw 8/22/2002 13:53'!
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 "', anElement, '"' selector: #removeScriptWithSelector: argument: aSelector.
			aMenu add: 'rename  "', anElement, '"' selector: #renameScript: argument: aSelector.
			aMenu add: 'textual scripting pane'  selector: #makeIsolatedCodePaneForSelector: argument: aSelector.
			aSelector numArgs > 0
				ifTrue:
					[aMenu add: 'remove parameter' selector: #ceaseHavingAParameterFor: argument: aSelector]
				ifFalse:
					[aMenu add: 'add parameter' selector: #startHavingParameterFor: argument: aSelector.
					aMenu add: 'button to fire this script' selector: #tearOffButtonToFireScriptForSelector: argument: aSelector].
			aMenu add: 'edit balloon help' selector: #editDescriptionForSelector: argument: aSelector].
	aMenu add: 'show categories....' target: aViewer selector: #showCategoriesFor: argument: aSelector.

	aMenu items size == 0 ifTrue:  "Never 0 at the moment because of show categories addition"
		[aMenu add: 'ok' action: nil].
	aMenu addTitle: anElement asString, ' (', elementType, ')'.

	aMenu popUpInWorld: aViewer world! !

!Player methodsFor: 'viewer' stamp: 'dgd 2/22/2003 13:43' prior: 39717843!
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 "' , anElement , '"'
				selector: #removeScriptWithSelector:
				argument: aSelector.
			aMenu 
				add: 'rename  "' , anElement , '"'
				selector: #renameScript:
				argument: aSelector.
			aMenu 
				add: 'textual scripting pane'
				selector: #makeIsolatedCodePaneForSelector:
				argument: aSelector.
			aSelector numArgs > 0 
				ifTrue: 
					[aMenu 
						add: 'remove parameter'
						selector: #ceaseHavingAParameterFor:
						argument: aSelector]
				ifFalse: 
					[aMenu 
						add: 'add parameter'
						selector: #startHavingParameterFor:
						argument: aSelector.
					aMenu 
						add: 'button to fire this script'
						selector: #tearOffButtonToFireScriptForSelector:
						argument: aSelector].
			aMenu 
				add: 'edit balloon help'
				selector: #editDescriptionForSelector:
				argument: aSelector].
	aMenu 
		add: 'show categories....'
		target: aViewer
		selector: #showCategoriesFor:
		argument: aSelector.
	aMenu items isEmpty 
		ifTrue: 
			["Never 0 at the moment because of show categories addition"

			aMenu add: 'ok' action: nil].
	aMenu addTitle: anElement asString , ' (' , elementType , ')'.
	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: '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: 'dgd 2/15/2004 21:29' prior: 26352680!
play
	self sendMessageToCostume: #play! !

!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: '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 3/7/2004 14:35'!
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 hasStructureOfComplexWatcher ifTrue:
				[aWatcher owner owner traverseRowTranslateSlotOld: oldName to: newName.
				(aWatcher target labelFromWatcher: aWatcher) contents: newName, ' = '].
			wasStepping ifTrue: [aWatcher startStepping]]]! !

!Player class methodsFor: 'slots' stamp: 'sw 2/18/2001 17:01'!
compileInstVarAccessorsFor: varName
	"Compile getters and setteres for the given instance variable name"

	| nameString |
	nameString _ varName asString capitalized.
	self compileInobtrusively: ('get', nameString, '
	^ ', varName)
		classified: 'access'.
	self compileInobtrusively: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access'! !

!Player class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41' prior: 39725050!
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: '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: '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: '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 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: '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 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: 'NS 1/30/2004 13:11' prior: 26375682!
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: '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: 'namespace' stamp: 'sw 2/18/2001 17:01'!
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 compileInobtrusively: ((self referenceAccessorSelectorFor: varName), '
	^ ', varName)
		classified: 'reference'! !

!Player class methodsFor: 'namespace' stamp: 'NS 1/28/2004 14:41' prior: 39731493!
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: '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 12/18/2000 15:45'!
isUniClass
	"UnscriptedPlayer reimplements to false"

	^ self ~~ Player! !

!Player7 class methodsFor: 'as yet unclassified' stamp: 'di 6/22/97 09:14'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !

!PlayerReferenceReadout methodsFor: 'event handling' stamp: 'sw 4/5/2001 21:48'!
mouseDown: evt
	"Allow the user to respecify this by direct clicking"
	| aMorph |
	(putSelector == #unused  or: [putSelector == nil]) ifTrue: [^ self].

	Sensor waitNoButton.
	aMorph _ self world chooseClickTarget.
	aMorph ifNil: [^ self].
	objectToView perform: putSelector with: aMorph assuredPlayer.
	self changed! !

!PlayerReferenceReadout methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:58' prior: 39732944!
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! !

!PlayerType methodsFor: '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"

	aMenu add: 'tiles to get...' selector: #offerGetterTiles: argument: slotSym! !

!PlayerType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:30' prior: 39733744!
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! !

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

!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: '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)! !

!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: '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: '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: '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: '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: 'initialization' stamp: 'sw 2/17/2002 00:44'!
initialize

 	super initialize.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.	"<--so naked buttons work right"
	self vResizing: #shrinkWrap.
	self wrapCentering: #center; cellPositioning: #topCenter.
	borderWidth _ 1.
	model _ nil.
	label _ nil.
	getStateSelector _ nil.
	actionSelector _ nil.
	getLabelSelector _ nil.
	getMenuSelector _ nil.
	shortcutCharacter _ nil.
	askBeforeChanging _ false.
	triggerOnMouseDown _ false.
	color _ Color lightGreen.
	onColor _ color darker.
	offColor _ color.
	feedbackColor _ Color red.
	showSelectionFeedback _ false.
	allButtons _ nil.
	argumentsProvider _ nil.
	argumentsSelector _ nil.
	self extent: 20@15.
! !

!PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:35' prior: 39739998!
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.
	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' prior: 26436391!
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: 'private' stamp: 'dgd 2/21/2003 22:40' prior: 26442124!
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' prior: 26442745!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	^ getStateSelector isNil 
		ifTrue: [false]
		ifFalse: [model perform: getStateSelector]! !

!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
!
!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: 'accessing' stamp: 'nk 4/17/2004 19:49' prior: 26449733!
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: '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: 'private' stamp: 'BG 12/4/2003 13:26' prior: 26454038!
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 isKindOf: Form)
	  ifTrue: [label offset: 0 @ 0].
	label align: alignPt with: aPoint
! !

!PluggableButtonView methodsFor: 'private' stamp: 'nk 4/17/2004 19:49' prior: 39745697!
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 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! !

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

!PluggableFileList methodsFor: 'file list menu' stamp: 'RAA 2/22/2002 06:03'!
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, 
			(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: 'asm 8/25/2003 18:37' prior: 39747643!
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: 'BG 12/13/2002 10:00' prior: 26488315!
itemsForNoFile

   ^(OrderedCollection new: 5)
        add: self serviceSortByName;
        add: self serviceSortBySize;
        add: self serviceSortByDate;
        add: self serviceAddNewFile;
        add: self serviceAddNewDirectory;
        yourself! !

!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 class methodsFor: 'StandardFileMenu' stamp: 'BG 12/13/2002 15:31' prior: 26495710!
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' prior: 26496005!
oldFileMenu: aDirectory

	"For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult"
	^(self getFilePathNameDialog)
		resultBlock: self sfmResultBlock;
		directory: aDirectory;
		yourself! !

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

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

!PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! !

!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.!
!PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/15/2001 22:31' prior: 26504880!
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: 'drag and drop' stamp: 'ar 3/17/2001 16:19'!
acceptDroppingMorph: aMorph event: evt 
	"This message is sent when a morph is dropped onto a morph that has     
	agreed to accept the dropped morph by responding 'true' to the     
	wantsDroppedMorph:Event: message. The default implementation just     
	adds the given morph to the receiver."
	"Here we let the model do its work."

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropMorph.
	evt hand releaseMouseFocus: self.
	Cursor normal show.
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:56' prior: 39756390!
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: 'ar 3/17/2001 17:37'!
startDrag: evt
	| ddm itemMorph |
	self dragEnabled ifTrue:[
		itemMorph _ scroller submorphs 
			detect:[:any| any highlightedForMouseDown] 
			ifNone:[nil]].
	(itemMorph isNil or:[evt hand hasSubmorphs]) ifTrue: [^self].
	itemMorph highlightForMouseDown: false.
	model okToChange ifFalse: [
		Cursor normal show.
		^ self].  "No change if model is locked"
	"itemMorph ~= self selection ifTrue: [self setSelectedMorph: itemMorph]."
	ddm _ TransferMorph withPassenger: (self model dragPassengerFor: itemMorph inMorph: self) from: self.
	ddm dragTransferType: (self model dragTransferTypeForMorph: self).
	Preferences dragNDropWithAnimation
			ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
	evt hand grabMorph: ddm.
	evt hand releaseMouseFocus: self.! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 22:02' prior: 39758298!
startDrag: evt
	| ddm draggedRow draggedItemMorph |

	draggedRow := 0.
	self dragEnabled ifTrue:[ draggedRow := self rowAtLocation: evt position].
	(draggedRow = 0 or:[evt hand hasSubmorphs]) ifTrue: [^self].

	model okToChange ifFalse: [
		Cursor normal show.
		^ self].  "No change if model is locked"

	draggedItemMorph := StringMorph contents: (self getListItem: draggedRow).
	ddm _ TransferMorph withPassenger: (self model dragPassengerFor: draggedItemMorph inMorph: self) from: self.
	ddm dragTransferType: (self model dragTransferTypeForMorph: self).
	Preferences dragNDropWithAnimation
			ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm].
	evt hand grabMorph: ddm.
	evt hand releaseMouseFocus: self.! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 07:09' prior: 39759168!
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: 'nk 5/16/2003 14:38' prior: 26505727!
highlightSelection
	selectedMorph ifNotNil: [selectedMorph color: self textHighlightColor; changed]! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53' prior: 39760831!
highlightSelection! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'nk 5/16/2003 14:41' prior: 26506011!
unhighlightSelection
	selectedMorph ifNotNil: [selectedMorph color: self textColor; changed]! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53' prior: 39761132!
unhighlightSelection
! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:05'!
handlesMouseOverDragging: evt
	^self dropEnabled! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'sw 12/1/2001 16:53'!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining (versus losing) the keyboard focus"

	self changed "to redraw border feedback"! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'nk 8/6/2003 11:38' prior: 39761551!
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: 'events' stamp: 'ar 3/17/2001 15:34'!
doubleClick: event
	| aMorph |
	doubleClickSelector isNil ifTrue: [^super doubleClick: event].
	aMorph _ self itemFromPoint: event position.
	aMorph ifNil:[^super doubleClick: event].
	selectedMorph ifNil: [self setSelectedMorph: aMorph].
	^ self model perform: doubleClickSelector! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 5/16/2001 22:28' prior: 39762314!
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: 'ar 3/17/2001 16:53'!
handlesBasicKeys
	" if ya don't want the list to automatically handle non-modifier key 
	(excluding shift key) input, return false"
	^ true! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:09' prior: 39763301!
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: 'jcg 9/21/2001 13:21'!
mouseDown: evt
	| aMorph selectors |
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	aMorph _ self itemFromPoint: evt position.
	aMorph ifNil:[^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 10/14/2001 13:28' prior: 39763775!
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: 'ar 3/17/2001 17:00'!
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"
		].! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:58' prior: 39765058!
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: 'sw 12/4/2001 12:41'!
mouseLeave: event
	"The mouse has left the area of the receiver"

	super mouseLeave: event.
	Preferences mouseOverForKeyboardFocus ifTrue:
		[event hand releaseKeyboardFocus: self]! !

!PluggableListMorph methodsFor: 'events' stamp: 'nk 8/6/2003 11:25' prior: 39765966!
mouseLeave: event
	"The mouse has left the area of the receiver"

	super mouseLeave: event.
	event hand releaseKeyboardFocus: self! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 16:15'!
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"
! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:56' prior: 39766441!
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: 'ar 3/17/2001 17:00'!
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].! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:55' prior: 39767101!
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: 'sw 4/2/2001 21:08'!
mouseUp: event
	"The mouse came up within the list; take appropriate action"

	| aMorph |
	aMorph _ self itemFromPoint: event position.
	aMorph ifNotNil: [aMorph highlightForMouseDown: false].
	model okToChange ifFalse:
		[^ self].
	(autoDeselect == false and: [aMorph == nil]) ifTrue: [^ self].  "work-around the no-mans-land bug"
	"No change if model is locked"
	((autoDeselect == nil or: [autoDeselect]) and: [aMorph == selectedMorph])
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
	Cursor normal show.
! !

!PluggableListMorph methodsFor: 'events' stamp: 'dgd 2/21/2003 23:05' prior: 39767934!
mouseUp: event 
	"The mouse came up within the list; take appropriate action"

	| aMorph |
	aMorph := self itemFromPoint: event position.
	aMorph ifNotNil: [aMorph highlightForMouseDown: false].
	model okToChange ifFalse: [^self].
	(autoDeselect == false and: [aMorph isNil]) ifTrue: [^self].	"work-around the no-mans-land bug"
	"No change if model is locked"
	((autoDeselect isNil or: [autoDeselect]) and: [aMorph == selectedMorph]) 
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
	Cursor normal show! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 22:49' prior: 39768569!
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].
	(autoDeselect == false and: [row == 0]) ifTrue: [^ self].  "work-around the no-mans-land bug"
	"No change if model is locked"
	((autoDeselect == nil or: [autoDeselect]) and: [row == self selectionIndex])
		ifTrue: [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: 'ls 5/17/2001 21:00'!
extent: newExtent
	super extent: newExtent.
	self listMorph width: (self width - 7 max: 2)    "I'm not sure what exactly the -7 should be -ls"! !

!PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 15:33' prior: 39770418!
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' prior: 26516372!
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: 'ls 5/15/2001 22:21' prior: 26501793!
font

	^ self listMorph font
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21' prior: 26501890!
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' prior: 26502056!
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: 'sw 6/6/2001 13:38'!
list: listOfStrings 
	"Set the receiver's list as specified"

	| morphList h loc index converter item aSelector |
	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].
	morphList _ list collect: [:each |
		item _ each.
		item _ item perform: converter.
		item isText
			ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)]
			ifFalse: [StringMorph contents: item font: font]].
	(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: 'nk 5/16/2003 14:24' prior: 39772521!
list: listOfStrings 
	"Set the receiver's list as specified"

	| morphList h loc index converter item aSelector textColor |
	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: 'ls 2/5/2004 16:29' prior: 39774066!
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: 'ls 5/15/2001 22:31' prior: 26504187!
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: 'nk 5/16/2003 14:37'!
textColor: aColor
	"Set my default text color."
	self setProperty: #textColor toValue: aColor.
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 18:02' prior: 39778348!
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: 'sw 3/31/2002 02:40'!
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...' target: self action: #setListFont.
	aMenu add: 'copy list to clipboard' target: self action: #copyListToClipboard.
	aMenu add: 'copy selection to clipboard' target: self action: #copySelectionToClipboard! !

!PluggableListMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56' prior: 39779536!
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: 'nk 3/26/2002 08:49'!
copyListToClipboard
	"Copy my items to the clipboard as a multi-line string"

	| stream |
	stream _ WriteStream on: (String new: list 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: 'sw 6/1/2001 09:43'!
setListFont
	"set the font for the list"

	Preferences chooseFontWithPrompt: 'choose the font for this list' andSendTo: self withSelector: #font:! !

!PluggableListMorph methodsFor: 'menus' stamp: 'laza 3/25/2004 23:10' prior: 39781310!
setListFont
	"set the font for the list"

	Preferences chooseFontWithPrompt: 'choose the font for this list' andSendTo: self withSelector: #font: highlight: self listMorph font! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/23/2001 00:45' prior: 26511964!
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: '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' prior: 26513367!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getIndexSelector isNil ifTrue: [^0].
	^model perform: getIndexSelector! !

!PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05' prior: 26513595!
getList
	"Answer the list to be displayed."

	| lst |
	getListSelector isNil ifTrue: [^#()].
	lst := model perform: getListSelector.
	lst isNil ifTrue: [^#()].
	^lst! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 14:16' prior: 39783493!
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' prior: 26513845!
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: 'selection' stamp: 'ls 5/17/2001 23:06' prior: 26509827!
maximumSelection
	^ self getListSize! !

!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: 'ls 4/18/2002 00:35' prior: 26510140!
selectedMorph: aMorph
"this shouldn't be used any longer"
"self isThisEverCalled ."
Smalltalk beep.
true ifTrue: [ ^self ].
! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:29' prior: 26510351!
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' prior: 26510451!
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: 'sw 3/24/2002 23:52'!
selectionIndex: index
	"Called internally to select the index-th item."

	| theMorph range |
	(index isNil or: [index > scroller submorphs size]) ifTrue: [^ self].
	(theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: 
index])
		ifNotNil:
		[((theMorph bounds top - scroller offset y) >= 0
			and: [(theMorph bounds bottom - scroller offset y) < bounds height]) 
ifFalse:
			["Scroll into view -- should be elsewhere"
			range _ self leftoverScrollRange.
			scrollBar value: (range > 0
				ifTrue: [((index-1 * theMorph height) / self leftoverScrollRange)
									truncateTo: scrollBar scrollDelta]
				ifFalse: [0]).
			scroller offset: -3 @ (range * scrollBar value)]].
	self selectedMorph: theMorph! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:50' prior: 39789328!
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: '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' prior: 26515357!
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: 'sw 6/6/2001 14:38'!
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 listOfStrings |
	newList _ self getList.
	((list == newList) "fastest" or: [list = 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 _ selection.
	self list: newList.
	listOfStrings _ newList collect: [:el | el asStringOrText].  "the newList itself may have MethodReference objects"
	(existingSelection notNil and: [(anIndex _ listOfStrings indexOf: existingSelection asStringOrText ifAbsent: [nil]) notNil])
		ifTrue:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifFalse:
			[self changeModelSelection: 0]! !

!PluggableListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:36' prior: 39791359!
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: '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: '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 3/9/2004 15:18'!
hUnadjustedScrollRange
"Return the width of the widest item in the list"

	^self listMorph hUnadjustedScrollRange
! !

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

!PluggableListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:52' prior: 26521940!
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' prior: 26521254!
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: 'dgd 2/22/2003 13:22' prior: 26521644!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	| item |
	getIndexSelector isNil ifTrue: [^0].
	item := model perform: getIndexSelector.
	^itemList findFirst: [:x | x = item]! !

!PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:51' prior: 39795714!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil ifTrue: [^ 0].
	item _ model perform: getIndexSelector.
	^ list findFirst: [ :x | x = item]
! !

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

!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: 'tpr 10/4/2001 21:33'!
mouseDown: event
	| index oldIndex oldVal aMorph |
	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	aMorph _ self itemFromPoint: event position.
	aMorph ifNil:[^super mouseDown: event].

	model okToChange ifFalse: [^ self].  "No change if model is locked"

	index _ scroller submorphs indexOf: aMorph.
	index = 0 ifTrue: [^ self  "minimize chance of selecting with a pane border drag"].

	"Set meaning for subsequent dragging of selection"
	dragOnOrOff _ (self listSelectionAt: index) not.
	oldIndex _ self getCurrentSelectionIndex.
	oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex].

	"Set or clear new primary selection (listIndex)"
	dragOnOrOff
		ifTrue: [self setSelectedMorph: aMorph]
		ifFalse: [self setSelectedMorph: nil].

	"Need to restore the old one, due to how model works, and set new one."
	oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
	self listSelectionAt: index put: dragOnOrOff.
	event hand releaseMouseFocus: aMorph.
	aMorph changed! !

!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'ls 7/15/2002 11:16' prior: 39796971!
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: 'tpr 10/4/2001 21:33'!
mouseMove: event
	"The mouse has moved, as characterized by the event provided.  Adjust the scrollbar, and alter the selection as appropriate"

	| index oldIndex oldVal aMorph |
	event position y < self top
		ifTrue:
			[scrollBar scrollUp: 1.
			aMorph _ self itemFromPoint: scroller topLeft + (1@1)]
		ifFalse:
			[event position y > self bottom
				ifTrue:
					[scrollBar scrollDown: 1.
					aMorph _ self itemFromPoint: scroller bottomLeft + (1@-1)]
				ifFalse:
					[aMorph _ self itemFromPoint: event position]].
	aMorph ifNil: [^ super mouseDown: event].

	model okToChange ifFalse: [^ self].  "No change if model is locked"

	index _ scroller submorphs indexOf: aMorph.
	index = 0 ifTrue: [^ self  "minimize chance of selecting with a pane border drag"].
	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: index) 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 setSelectedMorph: aMorph]
		ifFalse: [self setSelectedMorph: nil].

	"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: index put: (dragOnOrOff == true).
	aMorph changed! !

!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'aoy 2/15/2003 21:42' prior: 39799087!
mouseMove: event 
	"The mouse has moved, as characterized by the event provided.  Adjust the scrollbar, and alter the selection as appropriate"

	| index oldIndex oldVal aMorph |
	event position y < self top 
		ifTrue: 
			[scrollBar scrollUp: 1.
			aMorph := self itemFromPoint: scroller topLeft + (1 @ 1)]
		ifFalse: 
			[aMorph := event position y > self bottom 
				ifTrue: 
					[scrollBar scrollDown: 1.
					self itemFromPoint: scroller bottomLeft + (1 @ -1)]
				ifFalse: [ self itemFromPoint: event position]].
	aMorph ifNil: [^super mouseDown: event].
	model okToChange ifFalse: [^self].	"No change if model is locked"
	index := scroller submorphs indexOf: aMorph.
	index = 0 
		ifTrue: [^self	"minimize chance of selecting with a pane border drag"].
	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: index) 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 setSelectedMorph: aMorph]
		ifFalse: [self setSelectedMorph: nil].

	"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: index put: dragOnOrOff == true.
	aMorph changed! !

!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'nk 10/14/2003 22:19' prior: 39800667!
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: 'ls 6/10/2001 12:27'!
itemSelectedAmongMultiple: index
	^model listSelectionAt: index! !

!PluggableListMorphOfMany methodsFor: 'model access' stamp: 'hpt 4/5/2004 11:00' prior: 39804991!
itemSelectedAmongMultiple: index
	^self listSelectionAt: index! !

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

!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: 'updating' stamp: 'BG 1/22/2004 13:15' prior: 26533057!
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.
! !

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

!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:59' prior: 26540479!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel
	self model: anObject.
	getListSelector _ getListSel.
	getIndexSelector _ getSelectionSel.
	setIndexSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	getRawListSelector _ getRawSel.
	self list: self getList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !

!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/15/2001 22:32' prior: 39811205!
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: 'dgd 2/22/2003 14:13' prior: 26539809!
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 isNil 
		ifTrue: 
			["should not happen!!"

			priorRawList := nil.
			^#()].
	model classListIndex = 0 ifTrue: [^priorRawList := Array new].
	priorRawList := model perform: getRawListSelector.
	^(Array with: ClassOrganizer allCategory) , priorRawList! !

!PluggableMessageCategoryListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 15:35' prior: 39812506!
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' prior: 26541122!
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 methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:59' prior: 26542090!
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! !

!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: 'ls 5/15/2001 22:22' prior: 26544225!
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: 'ar 3/17/2001 15:54'!
list: arrayOfLists 
	| listOfStrings arrayOfMorphs index |
	lists _ arrayOfLists.
	scroller removeAllMorphs.
	listOfStrings _ arrayOfLists == nil
				ifTrue: [Array new]
				ifFalse: [
					arrayOfLists isEmpty ifFalse: [
					arrayOfLists at: 1]].
	list _ listOfStrings
				ifNil: [Array new].
	list isEmpty
		ifTrue: [self setScrollDeltas.
			^ self selectedMorph: nil].
	arrayOfMorphs _ self createMorphicListsFrom: arrayOfLists.
	self layoutMorphicLists: arrayOfMorphs.
	arrayOfMorphs
		do: [:morphList | scroller addAllMorphs: morphList].

	index _ self getCurrentSelectionIndex.
	self
		selectedMorph: ((index = 0
					or: [index > (arrayOfMorphs at: 1) size])
				ifFalse: [(arrayOfMorphs at: 1)
						at: index]).
	self setScrollDeltas.
	scrollBar setValue: 0.0! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:22' prior: 39817018!
list: arrayOfLists 
	| listOfStrings arrayOfMorphs index |
	lists := arrayOfLists.
	scroller removeAllMorphs.
	listOfStrings := arrayOfLists isNil 
				ifTrue: [Array new]
				ifFalse: [arrayOfLists isEmpty ifFalse: [arrayOfLists first]].
	list := listOfStrings ifNil: [Array new].
	list isEmpty 
		ifTrue: 
			[self setScrollDeltas.
			^self selectedMorph: nil].
	arrayOfMorphs := self createMorphicListsFrom: arrayOfLists.
	self layoutMorphicLists: arrayOfMorphs.
	arrayOfMorphs do: [:morphList | scroller addAllMorphs: morphList].
	index := self getCurrentSelectionIndex.
	self selectedMorph: ((index = 0 or: [index > arrayOfMorphs first size]) 
				ifFalse: [arrayOfMorphs first at: index]).
	self setScrollDeltas.
	scrollBar setValue: 0.0! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/17/2001 21:16' prior: 39817898!
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: 'selection' stamp: 'sbw 2/5/2001 11:12'!
highlightSelection
	| highlightColor columnLength localIndex m properSelectedIndex totalIndex |
	highlightColor _ Color red.
	"<-- Change the highlight color here."
	selectedMorph
		ifNotNil: [selectedMorph color: highlightColor;
				 changed.
			totalIndex _ scroller submorphs asArray
						findFirst: [:mp | mp contents = selectedMorph contents].
			columnLength _ lists first size.
			properSelectedIndex _ totalIndex \\ columnLength.
			properSelectedIndex = 0 ifTrue: [properSelectedIndex _ columnLength].
			selectedIndex = properSelectedIndex
				ifFalse: [selectedIndex _ properSelectedIndex].
			"Highlight the others in the same row."
			2
				to: lists size
				do: [:columnIndex | 
					localIndex _ selectedIndex + (columnLength * (columnIndex - 1)).
					m _ scroller submorphs asArray at: localIndex.
					m color: highlightColor;
						 changed]]! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:24' prior: 39819193!
highlightSelection
^self! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'sbw 2/5/2001 11:24'!
unhighlightSelection
	| unhighlightColor columnLength localIndex m previousSelectedIndex totalIndex |
	unhighlightColor _ Color black.
	selectedMorph
		ifNotNil: [selectedMorph color: unhighlightColor;
				 changed.
			totalIndex _ scroller submorphs
						findFirst: [:mp | mp contents = selectedMorph contents].
			totalIndex = 0 ifFalse: [
			columnLength _ lists first size.
			previousSelectedIndex _ totalIndex \\ columnLength.
			previousSelectedIndex = 0
				ifTrue: [previousSelectedIndex _ columnLength].
			2
				to: lists size
				do: [:columnIndex | 
					localIndex _ previousSelectedIndex + (columnLength * (columnIndex - 1)).
					localIndex = 0
						ifFalse: [m _ scroller submorphs asArray at: localIndex.
							m color: unhighlightColor;
								 changed]]]]!
]style[(20 3 76 4 16 3 5 9 13 14 13 8 16 19 10 3 8 29 4 2 2 12 13 15 10 19 12 3 5 16 21 3 10 4 12 5 21 3 1 14 21 3 12 6 1 9 5 15 13 8 10 3 21 4 12 4 11 3 1 9 10 3 1 17 1 3 8 23 10 9 1 8 16 22)f1b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:23' prior: 39820274!
unhighlightSelection
^self! !

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

!PluggableMultiColumnListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:55' prior: 26550561!
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' prior: 26549861!
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: 'dgd 2/21/2003 22:40' prior: 26550250!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	| item |
	getIndexSelector isNil ifTrue: [^0].
	item := model perform: getIndexSelector.
	^itemList findFirst: [:x | x = item]! !

!PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:11' prior: 39823532!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil
		ifTrue: [^ 0].
	item _ model perform: getIndexSelector.

	^ list first
		findFirst: [:x | x  = item]! !

!PluggableTextAttribute methodsFor: 'initialization' stamp: 'ls 6/21/2001 18:06'!
evalBlock: aBlock
	evalBlock := aBlock! !

!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 commentStamp: '<historical>' prior: 0!
An attribute which evaluates an arbitrary block when it is selected.!
!PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'!
evalBlock: aBlock
	^super new evalBlock: aBlock! !

!PluggableTextController methodsFor: 'transcript' stamp: 'th 9/20/2002 11:26' prior: 26562558!
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: 'as yet unclassified' stamp: 'dgd 9/21/2003 17:47' prior: 26563695!
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: 'accessing-selection' stamp: 'th 9/19/2002 18:37' prior: 26564181!
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: 'ls 11/10/2002 12:26'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse:
		[view superView ifNotNil: [self deselect].
		self selectInvisiblyFrom: start to: stop].
	view superView ifNotNil: [self selectAndScroll].
	self setEmphasisHere.
! !

!PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:37' prior: 39826220!
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]! !

!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: 'sw 6/24/2002 16:39'!
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."

	^ (#(annotation searchString infoViewContents) includes: getTextSelector) not! !

!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: '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: 'geometry' stamp: 'JW 2/21/2001 22:15'!
extraScrollRange
	^ self height // 4! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'ar 6/24/2001 14:42'!
initialize
	super initialize.
	hasUnacceptedEdits _ false.
	hasEditingConflicts _ false.
	askBeforeDiscardingEdits _ true.

	"Use the dictionary #Text for gestures"
	self gestureDictionaryOrName: #Text.! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25' prior: 39830492!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	hasUnacceptedEdits _ false.
	hasEditingConflicts _ false.
	askBeforeDiscardingEdits _ true.
	"Use the dictionary #Text for gestures"
	self gestureDictionaryOrName: #Text! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:19' prior: 39830794!
initialize
	"initialize the state of the receiver"
	super initialize.
	hasUnacceptedEdits _ false.
	hasEditingConflicts _ false.
	askBeforeDiscardingEdits _ true.
! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 3/24/2002 23:55'!
accept 
	"Inform the model of text to be accepted, and return true if OK."

	| textToAccept 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?') ifFalse: [^ self flash]].
	textToAccept _ textMorph asText.

	ok _ (setTextSelector == nil) or:
		[setTextSelector numArgs = 2
			ifTrue: [model perform: setTextSelector with: textToAccept with: self]
			ifFalse: [model perform: setTextSelector with: textToAccept]].
	ok==true ifTrue:
		[self setText: self getText.
		self hasUnacceptedEdits: false.
		(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) doIfNotNil:
			[:aPane | model changed: #annotation]].

	"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 isKindOf: CodeHolder) 
			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: 'dgd 2/21/2003 23:02' prior: 39831381!
accept
	"Inform the model of text to be accepted, and return true if OK."

	"sps 8/13/2001 22:41: save selection and scroll info"

	| textToAccept ok saveSelection saveScrollerOffset |
	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?') 
					ifFalse: [^self flash]].
	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 == true 
		ifTrue: 
			[self setText: self getText.
			self hasUnacceptedEdits: false.
			(model dependents detect: 
					[:dep | 
					(dep isKindOf: PluggableTextMorph) 
						and: [dep getTextSelector == #annotation]]
				ifNone: [nil]) doIfNotNil: [:aPane | model changed: #annotation]].

	"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 isKindOf: CodeHolder) 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: 'dgd 10/8/2003 19:42' prior: 39833318!
accept 
	"Inform the model of text to be accepted, and return true if OK."

	| textToAccept 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]].
	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==true ifTrue:
		[self setText: self getText.
		self hasUnacceptedEdits: false.
		(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) doIfNotNil:
			[:aPane | model changed: #annotation]].

	"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 isKindOf: CodeHolder) 
			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: 'md 12/12/2003 16:21' prior: 39835360!
accept 
	"Inform the model of text to be accepted, and return true if OK."

	| textToAccept 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]].
	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==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 isKindOf: CodeHolder) 
			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: '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: 'md 12/12/2003 16:21' prior: 26570170!
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: '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: 'vb 7/29/2001 12:45'!
debugIt
	self handleEdit: [textMorph editor debugIt]! !

!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: 'ar 12/17/2001 13:00'!
offerFontMenu
	self handleEdit: [textMorph editor changeTextFont]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'md 12/12/2003 16:21' prior: 26576842!
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: 'sw 2/3/2002 16:33'!
yellowButtonActivity
	"Called when the shifted-menu's 'more' item is chosen"

	| menu |
	(menu _ self getMenu: false) ifNotNil:
		["Set up to use perform:orSendTo: for model/view dispatch"
		menu setInvokingView: self.
		menu invokeModal: false]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'rr 3/10/2004 09:29' prior: 39842140!
yellowButtonActivity
	"Called when the shifted-menu's 'more' item is chosen"

	| menu |
	(menu _ self getMenu: false) ifNotNil:
		["Set up to use perform:orSendTo: for model/view dispatch"
		menu setInvokingView: self.
		menu invokeModal]! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02' prior: 26567313!
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' prior: 26567557!
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: 'sw 2/6/2001 01:24'!
setTextColor: aColor
	"Set the color of my text to the given color"

	textMorph color: aColor! !

!PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'sw 2/3/2002 16:55'!
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: false]! !

!PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:30' prior: 39843528!
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: 'scroll bar events' stamp: 'sw 2/3/2002 16:29'!
yellowButtonActivity: shiftKeyState
	"Invoke the text-editing menu"

	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu invokeModal: false]! !

!PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:29' prior: 39844268!
yellowButtonActivity: shiftKeyState
	"Invoke the text-editing menu"

	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu invokeModal]! !

!PluggableTextMorph methodsFor: '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: 'unaccepted edits' stamp: 'dgd 9/21/2003 17:40' prior: 26582743!
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: 'tk 5/23/2001 12:26'!
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 ~~