'From Cuis 2.0 of 4 January 2010 [latest update: #393] on 12 January 2010 at 12:56:42 pm'!
!classDefinition: #ImageMorph category: #'Morphic-Basic'!
Morph subclass: #ImageMorph
	instanceVariableNames: 'image opaque '
	classVariableNames: 'DefaultForm '
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!AbstractFont methodsFor: 'measuring' stamp: 'jmv 1/12/2010 10:55'!
widthOfStringOrText: aStringOrText
    aStringOrText ifNil:[^0].
    ^(aStringOrText is: #Text)
        ifTrue: [ self approxWidthOfText: aStringOrText ]
        ifFalse: [ self widthOfString: aStringOrText ] ! !


!BitBlt methodsFor: 'copying' stamp: 'jmv 1/12/2010 12:11'!
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 is: #Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm is: #Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm is: #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 roundVariables. ^self copyBitsAgain].

	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	self roundVariables.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'jmv 1/12/2010 12:10'!
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 is: #Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((destForm is: #Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((halftoneForm is: #Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].

	self primitiveFailed  "Later do nicer error recovery -- share copyBits recovery"! !


!Canvas methodsFor: 'drawing-images' stamp: 'jmv 1/12/2010 12:30'!
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: [ :c |
		^self stencil: aForm at: aPoint sourceRect: sourceRect color: c ].
	(self depth < 32 or: [ aForm mightBeTranslucent not]) 
		ifTrue: [ ^self paintImage: aForm at: aPoint sourceRect: sourceRect].
	self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form blend! !


!ChangeSet methodsFor: 'accessing' stamp: 'jmv 1/12/2010 11:00'!
editPostscript
	"edit the receiver's postscript, in a separate window.  "

	| deps found |
	self assurePostscriptExists.
	deps := postscript dependents 
				select: [ :m | m is: #SystemWindow].
	deps size > 0 
		ifTrue: [
			found := deps detect: [:obj | (obj is: #SystemWindow) and: [obj world == self currentWorld]] ifNone: [nil].
			found ifNotNil: [^found activate].

			self 
				inform: 'Caution -- there' , (deps size isOrAreStringWith: 'other window') 
						, '
already open on this postscript elsewhere'].
	postscript openLabel: 'Postscript for ChangeSet named ' , name! !


!Color methodsFor: 'equality' stamp: 'jmv 1/12/2010 12:03'!
= aColor
	"Return true if the receiver equals the given color. This method handles TranslucentColors, too."

	(aColor is: #Color) ifFalse: [^ false].
	^ aColor privateRGB = rgb and:
		[aColor privateAlpha = self privateAlpha]
! !

!Color methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:02'!
is: aSymbol
	^aSymbol = #Color or: [ super is: aSymbol ]! !


!CompiledMethod methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:01'!
is: aSymbol
	^aSymbol = #CompiledMethod or: [ super is: aSymbol ]! !


!DisplayScanner methodsFor: 'scanning' stamp: 'jmv 1/12/2010 11:02'!
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 is: #Morph) 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! !


!Form methodsFor: 'color mapping' stamp: 'jmv 1/12/2010 12:03'!
bitPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	(aColor is: #Color) ifFalse:[^aColor bitPatternForDepth: self depth].
	self hasNonStandardPalette
		ifTrue:[^Bitmap with: (self pixelWordFor: aColor)]
		ifFalse:[^aColor bitPatternForDepth: self depth]! !

!Form methodsFor: 'fileIn/Out' stamp: 'jmv 1/12/2010 12:10'!
unhibernate
	"If my bitmap has been compressed into a ByteArray,
	then expand it now, and return true."
	| resBits |
	(bits is: #Form) 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: 'resources' stamp: 'jmv 1/12/2010 12:12'!
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 is: #ColorForm) and: [ self is: #ColorForm ]) ifTrue:[
		| cc |
		cc := img colors.
		img colors: nil.
		img displayOn: self.
		img colors: cc.
	] ifFalse:[
		img displayOn: self.
	].
	img _ nil.! !

!Form methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:10'!
is: aSymbol
	^ aSymbol = #Form or: [ super is: aSymbol ]! !

!Form methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:28'!
mightBeTranslucent
	"Answer whether this form may be translucent"
	^self depth = 32! !


!ColorForm methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:11'!
is: aSymbol
	^ aSymbol = #ColorForm or: [ super is: aSymbol ]! !

!ColorForm methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:28'!
mightBeTranslucent
	"Answer whether this form may be translucent"
	^true! !


!FormCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 1/12/2010 12:31'!
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 isOpaque not]) 
			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: 'jmv 1/12/2010 12:31'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	| rect |
	rect _ r translateBy: origin.
	"draw the border of the rectangle"
	borderColor isTransparent ifFalse:[
		self setFillColor: borderColor.
		(r area > 10000 or: [fillColor isOpaque not]) ifTrue: [
			port frameRect: rect borderWidth: borderWidth.
		] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle
					than to compute and fill the border rects"
					port fillRect: rect offset: origin]].

	"fill the inside"
	fillColor isTransparent ifFalse:
		[self setFillColor: fillColor.
		port fillRect: (rect insetBy: borderWidth) offset: origin].! !

!FormCanvas methodsFor: 'private' stamp: 'jmv 1/12/2010 12:03'!
setClearColor: aColor
	"Install a new clear color - e.g., a color is used for clearing the background"
	| clearColor |
	clearColor _ aColor ifNil:[Color transparent].
	(clearColor is: #Color) 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: 'jmv 1/12/2010 12:32'!
setFillColor: aColor
	"Install a new color used for filling."
	| screen patternWord fillColor |
	fillColor _ self shadowColor ifNil:[aColor].
	fillColor ifNil: [ fillColor _ Color transparent].
	(fillColor is: #Color) 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 isOpaque ifTrue: [
		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].

	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: 'jmv 1/12/2010 12:32'!
setPaintColor: aColor
	"Install a new color used for filling."
	| paintColor screen patternWord |
	paintColor _ self shadowColor ifNil:[aColor].
	paintColor ifNil: [ paintColor _ Color transparent].
	(paintColor is: #Color) 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 isOpaque) ifTrue: [
		port fillPattern: paintColor.
		port combinationRule: Form paint.
		self depth = 8 ifTrue:[
			port fillColor: (form balancedPatternFor: paintColor)].
		^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
! !


!GIFReadWriter methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:12'!
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 is: #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 is: #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.
! !


!ImageSegment methodsFor: 'testing' stamp: 'jmv 1/12/2010 11:02'!
findOwnersOutPtrs

| ow ff |
ow _ Smalltalk at: #Owners ifAbsent: [^ self].
ow ifNil: [^ self].
outPointers do: [:oo | 
	(oo is: #Morph) ifTrue: [
		ow _ ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']].
ff _ FileStream fileNamed: 'Owners log'.
ff nextPutAll: ow; close.
Smalltalk at: #Owners put: ow.
ff edit.! !

!ImageSegment methodsFor: 'testing' stamp: 'jmv 1/12/2010 11:05'!
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 pointIn xRoots |
	Smalltalk garbageCollect.
	inSeg := IdentitySet new: 200.
	arrayOfRoots := rootArray.
	testRoots := rootArray.
	xRoots := testRoots.
	xRoots do: 
			[:obj | 
			"root is a project"

			(obj is: #Morph)
				ifTrue: 
					[obj allMorphs do: 
							[:mm | 
							inSeg add: mm].
					]].
	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 is: #Morph) 
				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"]]].
			].
	"*** presenter playerlist"
	self halt: 'Examine local variables pointIn and inSeg'.
	^pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'jmv 1/12/2010 11:02'!
findRogueRootsImSeg: rootArray
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) Break all owner pointers in submorphs and all scripts.
2) Create the segment and look at outPointers.
3) Remove those we expect.
4) Remember to quit without saving -- the owner pointers are smashed."

| suspects bag1 bag2 |
arrayOfRoots _ rootArray.
self findRogueRootsPrep.	"and free that context!!"
Smalltalk forgetDoIts.
Smalltalk garbageCollect.
self copyFromRoots: arrayOfRoots sizeHint: 0.

suspects _ outPointers select: [:oo | oo is: #Morph].
suspects size > 0 ifTrue: [suspects inspect].
bag1 _ Bag new.  bag2 _ Bag new.
outPointers do: [:key | 
	(key isKindOf: Class) 
		ifTrue: [bag2 add: key class name]
		ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name)
			ifTrue: [bag2 add: key class name]
			ifFalse: [bag1 add: key class name]]].
"(bag sortedCounts) is the SortedCollection"
(StringHolder new contents: bag1 sortedCounts printString, '

', bag2 sortedCounts printString) 
	openLabel: 'Objects pointed at by the outside'.
self halt: 'Examine local variables pointIn and inSeg'.

"Use this in inspectors:
	outPointers select: [:oo | oo class == <a Class>].		"

! !

!ImageSegment methodsFor: 'testing' stamp: 'jmv 1/12/2010 11:06'!
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 morphs |
wld _ arrayOfRoots detect: [:obj | 
	(obj is: #Morph) ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil].
wld ifNil: [ wld _ arrayOfRoots detect: [ :obj | obj is: #Morph ] 
				ifNone: [^ self error: 'can''t find a root morph']].
morphs _ IdentitySet new: 400.
wld allMorphsDo: [ :m |  morphs add: m ].
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]].
]].
(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: 'jmv 1/12/2010 11:03'!
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 is: #Morph) 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].
! !


!InfiniteForm methodsFor: 'displaying' stamp: 'jmv 1/12/2010 12:10'!
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 is: #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: 'jmv 1/12/2010 12:11'!
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 is: #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: 'jmv 1/12/2010 12:11'!
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 is: #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: 'testing' stamp: 'jmv 1/12/2010 12:29'!
mightBeTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !


!Matrix methodsFor: 'aritmethic' stamp: 'jmv 12/5/2009 20:03'!
* aMatrixOrNumber

	| result |
	(aMatrixOrNumber is: #Matrix) ifTrue: [
		self width = aMatrixOrNumber height ifFalse: [ ^self error: 'Matrix sizes do not match' ].
		result _ self appropriateResultClass newHeight: self height width: aMatrixOrNumber width.
		result fillResultOfMultiply: self by: aMatrixOrNumber ]
	ifFalse: [
		result _ self copy.
		result replaceValues: [ :value | value * aMatrixOrNumber ] ].
	^result
	! !

!Matrix methodsFor: 'aritmethic' stamp: 'jmv 12/5/2009 20:03'!
+ aMatrixOrNumber

	| result |
	(aMatrixOrNumber is: #Matrix) ifTrue: [
		(self width = aMatrixOrNumber width) & (self height = aMatrixOrNumber height)
			ifFalse: [ ^self error: 'Matrix sizes do not match' ].
		result _ self appropriateResultClass newHeight: self height width: self width.
		result fillResultOfSum: self by: aMatrixOrNumber ]
	ifFalse: [
		result _ self copy.
		result replaceValues: [ :value | value + aMatrixOrNumber ] ].
	^result
	! !

!Matrix methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:02'!
is: aSymbol
	^aSymbol = #Matrix or: [ super is: aSymbol ]! !


!MessageSend methodsFor: 'testing' stamp: 'jmv 12/5/2009 20:28'!
is: aSymbol
	^ aSymbol = #MessageSend or: [ super is: aSymbol ]! !


!MethodContext methodsFor: 'initialize-release' stamp: 'jmv 1/12/2010 11:48'!
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."

	(aCompiledMethod is: #CompiledMethod) ifFalse: [
		self error: 'method can only be set to aCompiledMethod'].
	method := aCompiledMethod.
	self assert: closureOrNil == nil.
	"was: receiverMap := nil."
	self privRefresh! !


!MethodFinder methodsFor: 'initialize' stamp: 'jmv 1/12/2010 12:04'!
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" initialInstance  newFrom: readCarefullyFrom:
"accessing" at: basicAt: basicSize size yourself 
"testing" ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isFloat isFraction isInMemory isInteger isNil isNumber isPoint isPseudoContext isTransparent notNil pointsTo: wantsSteps 
"comparing" = == closeTo: hash identityHash 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: isMemberOf: respondsTo: xxxClass 
"error handling" 
"user interface" defaultLabelForInspector initialExtent modelWakeUp 
"system primitives" instVarAt: instVarNamed: 
"private" 
"associating" -> 
"converting" as: asOrderedCollection asString 
"casing" caseOf: caseOf:otherwise: 
"binding" bindingOf: 
"macpal" contentsChanged currentHand currentWorld flash 
"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" 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" soleInstance
"copying" "instance creation" "instance variables"  "pool variables" "class hierarchy"  "compiling"
"fileIn/Out"  nonTrivial ) do: [:sel | Approved add: sel].

"Context, BlockContext"
	#(receiver client method receiver tempAt: 
"debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues
"controlling"  "printing" "system simulation" 
"initialize-release" 
"accessing" hasMethodReturn home numArgs
"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
"controlling"  "scheduling"  "instruction decoding"  "printing" "private"  "system simulation" ) do: [:sel | Approved add: sel].
	#(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].

"Message"
	#("inclass, instance creation" selector: selector:argument: selector:arguments:
"accessing" argument argument: arguments sends:
"printing" "sending" ) do: [:sel | Approved add: sel].
	#("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].

"Magnitude"
	#("comparing" < <= > >= between:and:
"testing" max: min: min:max: ) do: [:sel | Approved add: sel].

"Date, Time"
	#("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
	"in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
"accessing" day leap monthIndex monthName weekday year
"arithmetic" addDays: subtractDate: subtractDays:
"comparing"
"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
"converting" asSeconds
"printing" mmddyyyy printFormat: 
"private" weekdayIndex 
	"in class, instance creation" fromSeconds: now 
	"in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
"accessing" hours minutes seconds
"arithmetic" addTime: subtractTime:
"comparing"
"printing" intervalString print24 
"converting") do: [:sel | Approved add: sel].
	#("private" hours:  ) 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: 'jmv 1/12/2010 12:32'!
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" 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 asFileName asLegalSelector asPacked asText asTime capitalized compressWithTable: contractTo: correctAgainst: 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].

"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:	) 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
"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 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (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: 'jmv 1/12/2010 11:42'!
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: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
   "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:)
		do: [:sel | Dangerous add: sel].

"CompiledMethod"
	#(defaultSelector)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !


!Model methodsFor: 'dependents' stamp: 'jmv 1/12/2010 10:59'!
topView
	"Find the first top view on me. Is there any danger of their being two with the same model?  Any danger from ungarbage collected old views?  Ask if schedulled?"

	dependents ifNil: [^nil].
	dependents 
				do: [:v | ((v is: #SystemWindow) and: [ v isInWorld ]) ifTrue: [^v]].
		^nil! !


!CodeHolder methodsFor: 'commands' stamp: 'jmv 1/12/2010 11:02'!
makeSampleInstance
	| aClass nonMetaClass anInstance |
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ self].
	nonMetaClass _ aClass theNonMetaClass.
	anInstance _ self sampleInstanceOfSelectedClass.
	(anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue: 
		[^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name].

	(anInstance is: #Morph)
		ifTrue: [
			self currentHand attachMorph: anInstance]
		ifFalse: [
			anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]! !

!CodeHolder methodsFor: 'controls' stamp: 'jmv 1/12/2010 10:59'!
buttonWithSelector: aSelector 
	"If receiver has a control button with the given action selector answer it, else answer nil.  morphic only at this point"

	| aWindow |
	((aWindow := self containingWindow) is: #SystemWindow) 
		ifFalse: [^nil].
	^aWindow 
		findDeepSubmorphThat: 
			[ :m | (m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]]
		ifAbsent: [ ^nil ]! !

!CodeHolder methodsFor: 'misc' stamp: 'jmv 12/5/2009 19:48'!
refreshAnnotation
	"If the receiver has an annotation pane that does not bear unaccepted edits, refresh it"

	(self dependents detect: [ :m | 
		(m is: #HasTextSelector) and: [
			m getTextSelector == #annotation]] ifNone: [nil]) 
				ifNotNil: [ :aPane | 
		aPane hasUnacceptedEdits ifFalse: [
			aPane update: #annotation]]! !


!FileList methodsFor: 'initialization' stamp: 'jmv 1/12/2010 10:59'!
updateButtonRow
	"Dynamically update the contents of the button row, if any."

	| window row |
	window _ self dependents 
				detect: [:m | (m is: #SystemWindow) and: [ m model == self ]]
				ifNone: [^self].
	row _ window 
		findDeepSubmorphThat: [:m | m hasProperty: #buttonRow]
		ifAbsent: [^self].
		
	self updateButtonRow: row! !


!Morph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:04'!
color: aColor
	"Set the receiver's color.  Directly set the color if appropriate, else go by way of fillStyle"

	((aColor is: #Color) or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor].
	color = aColor ifFalse: [
		self removeProperty: #fillStyle.
		color _ aColor.
		self changed]! !

!Morph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:05'!
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 is: #Color) and: [ color isTransparent and: [ owner notNil]]) ifTrue:[^owner colorForInsets].
	^ color colorForInsets
! !

!Morph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:05'!
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 is: #Color)
			and: [color isTransparent
					and: [owner notNil]])
		ifTrue: [^ owner raisedColor].
	^ color asColor raisedColor! !

!Morph methodsFor: 'menus' stamp: 'jmv 1/12/2010 11:21'!
addStandardHaloMenuItemsTo: aMenu hand: aHandMorph
	"Add standard halo items to the menu"

	| unlockables |

	self isWorldMorph ifTrue:
		[^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph].

	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 addHaloActionsTo: aMenu.
	(owner is: #TextMorph) ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph].
	aMenu addLine.
	self addToggleItemsToHaloMenu: aMenu.
	aMenu addLine.
	self addCopyItemsTo: aMenu.
	self addExportMenuItems: aMenu hand: aHandMorph.
	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: 'meta-actions' stamp: 'jmv 1/12/2010 11:03'!
changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand
	"Put up a color picker for changing some kind of color.  May be modal or modeless, depending on #modalColorPickers setting"
	self flag: #arNote. "Simplify this due to anObject == self for almost all cases"
	^ ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: aHand;
		target: anObject;
		selector: aSymbol;
		originalColor: aColor;
		putUpFor: anObject near: ((anObject is: #Morph)
					ifTrue:	 [Rectangle center: self position extent: 20]
					ifFalse: [anObject == self world
								ifTrue: [anObject viewBox bottomLeft + (20@-20) extent: 200]
								ifFalse: [anObject fullBoundsInWorld]]);
		yourself! !

!Morph methodsFor: 'structure' stamp: 'jmv 1/12/2010 11:16'!
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 isWorldMorph or: [ owner is: #HandMorph ] ]) ifTrue: [ ^self ].
	^owner root! !

!Morph methodsFor: 'testing' stamp: 'jmv 12/5/2009 20:30'!
is: aSymbol
	^ aSymbol = #Morph or: [ super is: aSymbol ]! !

!Morph methodsFor: 'text-anchor' stamp: 'jmv 1/12/2010 11:21'!
changeDocumentAnchor
	"Change the anchor from/to document anchoring"

	| newType |
	newType := self textAnchorType == #document 
		ifTrue: [#paragraph]
		ifFalse: [ #document].
	(owner is: #TextMorph) 
		ifTrue: [
			owner 
				anchorMorph: self
				at: self position
				type: newType]! !

!Morph methodsFor: 'text-anchor' stamp: 'jmv 1/12/2010 11:21'!
changeInlineAnchor
	"Change the anchor from/to line anchoring"

	| newType |
	newType := self textAnchorType == #inline 
				ifTrue: [#paragraph]
				ifFalse: [#inline]. 
	(owner is: #TextMorph)
		ifTrue: [
			owner
				anchorMorph: self
				at: self position
				type: newType]! !

!Morph methodsFor: 'text-anchor' stamp: 'jmv 1/12/2010 11:22'!
changeParagraphAnchor
	"Change the anchor from/to paragraph anchoring"

	| newType |
	newType := self textAnchorType == #paragraph 
		ifTrue: [#document]
		ifFalse: [#paragraph].
	(owner is: #TextMorph)
		ifTrue: [
			owner 
				anchorMorph: self
				at: self position
				type: newType]! !


!BorderedMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:02'!
borderColor: colorOrSymbolOrNil
	self doesBevels ifFalse:[
		(colorOrSymbolOrNil is: #Color) ifFalse: [^self]].
	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor _ colorOrSymbolOrNil.
		self changed].
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:02'!
borderStyle
	"Work around the borderWidth/borderColor pair"

	| style |
	borderColor ifNil: [^BorderStyle default].
	borderWidth isZero ifTrue: [^BorderStyle default].
	style := borderStyle ifNil: [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 is: #Color)
				ifTrue: [BorderStyle width: borderWidth color: borderColor]
				ifFalse: [(BorderStyle perform: borderColor) width: borderWidth	"argh."].
			borderStyle _ style].
	^style trackColorFrom: self! !

!BorderedMorph methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:28'!
isOpaqueMorph
	"Any submorph that answers true to #isOrthoRectangularMorph (to optimize #containsPoint:)
	but is not an opaque rectangle covering bounds MUST answer false to this message"
	((color is: #Color) and: [ color isOpaque not ]) ifTrue: [
		^false ].
	self borderWidth > 0 ifTrue: [
		((self borderColor is: #Color) and: [ self borderColor  isOpaque not]) ifTrue: [
			^false ]].
	^true! !


!AlignmentMorph methodsFor: 'classification' stamp: 'jmv 12/5/2009 20:09'!
is: aSymbol
	^ aSymbol = #AlignmentMorph or: [ super is: aSymbol ]! !


!ColorPickerMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:03'!
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 is: #Color) 
				ifTrue: [colorOrSymbol]
				ifFalse: [Color lightGreen].
	originalForm fill: RevertBox fillColor: originalColor.
	selectedColor := originalColor.
	self locationIndicator 
		center: self topLeft + (self positionOfColor: originalColor)! !

!ColorPickerMorph methodsFor: 'other' stamp: 'jmv 1/12/2010 11:02'!
putUpFor: aMorph near: aRectangle
	"Put the receiver up on the screen.   Note highly variant behavior depending on the setting of the #modalColorPickers preference"
	| layerNumber |
	(aMorph is: #Morph) ifTrue: [
		layerNumber _ aMorph morphicLayerNumber.
		aMorph allOwnersDo:[:m|
			layerNumber _ layerNumber min: m morphicLayerNumber].
		self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
	].

	isModal == true "backward compatibility"
		ifTrue: [
			self pickUpColorFor: aMorph]
		ifFalse: [
			self addToWorld:
				((aMorph notNil and: [aMorph world notNil])
					ifTrue:
						[aMorph world]
					ifFalse:
						[self currentWorld])
		  		near:
					(aRectangle ifNil:
						[aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]! !

!ColorPickerMorph methodsFor: 'private' stamp: 'jmv 1/12/2010 12:23'!
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 is: #Color) and: [ selectedColor isOpaque not ])
						ifTrue: [ pickedColor alpha: selectedColor alpha ]
						ifFalse: [ pickedColor ]
		)
		feedbackColor: pickedColor! !


!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 1/12/2010 12:03'!
setDefaultParameters
	"change the receiver's appareance parameters"
	| colorFromMenu worldColor menuColor menuBorderColor |
	colorFromMenu := Preferences menuColorFromWorld
				and: [Display depth > 4]
				and: [(worldColor := self currentWorld color) is: #Color].
	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 := #raised.
	self
		setColor: menuColor
		borderWidth: Preferences menuBorderWidth
		borderColor: menuBorderColor! !


!HaloMorph methodsFor: 'handles' stamp: 'jmv 1/12/2010 11:14'!
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
		ifNil: [ ^self ]	"nil happens, amazingly"
		ifNotNil: [ :to |
			(to isWorldMorph or: [ to is: #HandMorph ])
				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: 'jmv 1/12/2010 11:21'!
addFontEmphHandle: haloSpec 
	(innerTarget is: #TextMorph) 
		ifTrue: [
			self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseEmphasisOrAlignment
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'jmv 1/12/2010 11:21'!
addFontSizeHandle: haloSpec 
	(innerTarget is: #TextMorph) 
		ifTrue: [
			self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseFont
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'jmv 1/12/2010 11:21'!
addFontStyleHandle: haloSpec 
	(innerTarget is: #TextMorph) 
		ifTrue: [
			self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseStyle
				to: innerTarget]! !


!HandMorph methodsFor: 'classification' stamp: 'jmv 12/5/2009 20:17'!
is: aSymbol
	^ aSymbol = #HandMorph or: [ super is: aSymbol ]! !


!HandleMorph methodsFor: 'event handling' stamp: 'jmv 1/12/2010 11:08'!
keyStroke: evt
	"Check for cursor keys"
	| keyValue |
	(owner is: #HandMorph) ifFalse: [ ^self ].
	keyValue _ evt keyValue.
	keyValue = 28 ifTrue:[^self position: self position - (1@0)].
	keyValue = 29 ifTrue:[^self position: self position + (1@0)].
	keyValue = 30 ifTrue:[^self position: self position - (0@1)].
	keyValue = 31 ifTrue:[^self position: self position + (0@1)].
	"Special case for return"
	keyValue = 13 ifTrue:[
		"Drop the receiver and be done"
	self flag: #arNote. "Probably unnecessary"
		owner releaseKeyboardFocus: self.
		self delete].
! !


!ImageMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:04'!
color: aColor
        super color: aColor.
        (image depth = 1 and: [aColor is: #Color]) ifTrue: [
                image colors: {Color transparent. aColor}.
                self changed]! !

!ImageMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:40'!
opaque
	"Return true if the receiver is marked as being completely opaque"
	^ opaque! !

!ImageMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 12:40'!
opaque: aBool
	"Mark the receiver as being completely opaque or not"
	opaque _ aBool.
	self changed! !

!ImageMorph methodsFor: 'drawing' stamp: 'jmv 1/12/2010 12:41'!
drawOn: aCanvas

	self opaque
		ifTrue: [ aCanvas drawImage: image at: self innerBounds origin]
		ifFalse: [ aCanvas translucentImage: image at: self innerBounds origin]! !

!ImageMorph methodsFor: 'initialization' stamp: 'jmv 1/12/2010 12:40'!
initialize

	super initialize.
	opaque _ false.
	self image: DefaultForm.
! !

!ImageMorph methodsFor: 'menu' stamp: 'jmv 1/12/2010 12:41'!
changeOpacity
	self opaque: self opaque not! !

!ImageMorph methodsFor: 'menu' stamp: 'jmv 1/12/2010 12:42'!
opacityString
	^ (self opaque
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'opaque' translated! !

!ImageMorph methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:41'!
isOpaqueMorph
	"Cheap optimization here"
	^self opaque! !


!LazyListMorph methodsFor: 'drawing' stamp: 'jmv 1/12/2010 10:55'!
display: item  atRow: row on: canvas
	"display the given item at row row"
	| drawBounds f |
	drawBounds _ self drawBoundsForRow: row.
	drawBounds _ drawBounds intersect: self bounds.
	f _ (item is: #Text) ifTrue: [ font emphasized: (item emphasisAt: 1) ] ifFalse: [ font ].
	canvas drawString: item in: drawBounds font: f color: (self colorForRow: row)! !


!MenuMorph methodsFor: 'initialization' stamp: 'jmv 1/12/2010 12:04'!
setDefaultParameters
	| colorFromMenu worldColor menuColor menuBorderColor |
	colorFromMenu := Preferences menuColorFromWorld
				and: [Display depth > 4]
				and: [(worldColor := self currentWorld color) is: #Color].
	""
	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 := #raised.
	""
	self
		setColor: menuColor
		borderWidth: Preferences menuBorderWidth
		borderColor: menuBorderColor! !

!MenuMorph methodsFor: 'menu' stamp: 'jmv 12/5/2009 20:09'!
removeStayUpBox
	| box |
	submorphs isEmpty ifTrue: [^self].
	(submorphs first is: #AlignmentMorph) ifFalse: [^self].
	box := submorphs first submorphs first.
	(box isKindOf: IconicButton) 
		ifTrue: [
			box
				labelGraphic: (Form extent: box extent depth: 8);
				shedSelvedge;
				borderWidth: 0;
				lock]! !

!MenuMorph methodsFor: 'menu' stamp: 'jmv 1/12/2010 11:09'!
target: anObject
	"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."

	defaultTarget == anObject 
		ifTrue: [ ^self ].
		
	defaultTarget _ anObject.
	"re-target all existing items"
	self items do: [ :item | 
		(item target is: #HandMorph)
			ifFalse: [ item target: defaultTarget ]]! !


!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 10:56'!
contents: newContents 
	contents _ (newContents is: #Text)
		ifTrue: [
			emphasis := newContents emphasisAt: 1.
			 newContents string]
		ifFalse: [
			contents = newContents ifTrue: [^self].	"no substantive change"
			newContents].
	self fitContents! !


!MorphicEvent methodsFor: 'comparing' stamp: 'jmv 12/5/2009 20:37'!
= anEvent
	(anEvent is: #MorphicEvent) ifFalse: [^false].
	^self type = anEvent type! !

!MorphicEvent methodsFor: 'testing' stamp: 'jmv 12/5/2009 20:36'!
is: aSymbol
	^ aSymbol = #MorphicEvent or: [ super is: aSymbol ]! !


!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 1/12/2010 12:12'!
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 is: #ColorForm) ifTrue: [
		f _ aFormOrCursor deepCopy.
		map _ aFormOrCursor colors.
	] ifFalse: [
		f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.
		f copyBits: aFormOrCursor boundingBox
			from: aFormOrCursor
			at: 0@0
			clippingBox: aFormOrCursor boundingBox
			rule: Form over
			fillColor: nil.
		map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].
	map _ map collect: [:c |
		c = Color white ifTrue: [Color transparent] ifFalse: [c]].
	f colors: map.
	^ f
! !


!Compiler class methodsFor: 'accessing' stamp: 'jmv 1/12/2010 11:51'!
couldEvaluate: anObject
	"Answer true if anObject can be passed to my various #evaluate: methods."
	^anObject isString or: [ (anObject is: #Text) or: [ anObject is: #Stream ]]! !


!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'jmv 1/12/2010 10:56'!
from: aPopupMenu title: titleStringOrNil
	"Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world."

	| menu items lines selections labelString j emphasis |
	menu _ self new.
	titleStringOrNil ifNotNil: [
		titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]].
	labelString _ aPopupMenu labelString.
	items _ labelString asString findTokens: String cr.
	(labelString is: #Text) ifTrue: [
		"Pass along text emphasis if present"
		j _ 1.
		items _ items collect:
			[:item | j _ labelString asString findString: item startingAt: j.
			emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j).
			item asText addAttribute: emphasis]].
	lines _ aPopupMenu lineArray.
	lines ifNil: [lines _ #()].
	menu cancelValue: 0.
	menu defaultTarget: menu.
	selections _ (1 to: items size) asArray.
	1 to: items size do: [:i |
		menu add: (items at: i) selector: #selectMVCItem: argument: (selections at: i).
		(lines includes: i) ifTrue: [menu addLine]].
	^ menu
! !


!MimeConverter class methodsFor: 'convenience' stamp: 'jmv 1/12/2010 11:52'!
mimeDecode: aStringOrStream to: outStream
	self new
		mimeStream: ((aStringOrStream is: #Stream)
			ifTrue: [aStringOrStream]
			ifFalse: [ReadStream on: aStringOrStream]);
		dataStream: outStream;
		mimeDecode! !

!MimeConverter class methodsFor: 'convenience' stamp: 'jmv 1/12/2010 11:52'!
mimeEncode: aCollectionOrStream to: outStream
	self new
		dataStream: ((aCollectionOrStream is: #Stream)
			ifTrue: [aCollectionOrStream]
			ifFalse: [ReadStream on: aCollectionOrStream]);
		mimeStream: outStream;
		mimeEncode! !


!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 10:56'!
contents: newContents 
	contents _ (newContents is: #Text)
		ifTrue: [
			emphasis := newContents emphasisAt: 1.
			 newContents string]
		ifFalse: [
			contents = newContents ifTrue: [^self].	"no substantive change"
			newContents].
	editor _ nil.
	self fitContents! !


!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 1/12/2010 12:12'!
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 is: #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: 'jmv 1/12/2010 12:12'!
writePLTEChunkOn: aStream
	"Write the PLTE chunk"
	| r g b colors |
	aStream nextPutAll: 'PLTE' asByteArray.
	(form is: #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.
	].! !


!Parser methodsFor: 'expression types' stamp: 'jmv 1/12/2010 11:34'!
primaryExpression 
	hereType == #word 
		ifTrue: [
			parseNode _ self variable.
			
			"
			(parseNode isUndefTemp and: [self interactive] and: [
				((requestor isKindOf: Editor) or: [ requestor is: #Morph ])])
			"
			"If the requestor is of an exotic kind (like a telnet server) we might not be
			 allowed to open a PupUpMenu for querying the user"
				
			(parseNode isUndefTemp and: [ self interactive ])
				ifTrue: [self queryUndefined].
			parseNode nowHasRef.
			^ true].
	hereType == #leftBracket
		ifTrue: [
			self advance.
			self blockExpression.
			^true].
	hereType == #leftBrace
		ifTrue: [
			self braceExpression.
			^true].
	hereType == #leftParenthesis
		ifTrue: [
			self advance.
			self expression ifFalse: [^self expected: 'expression'].
			(self match: #rightParenthesis)
				ifFalse: [^self expected: 'right parenthesis'].
			^true].
	(hereType == #string or: [hereType == #number or: [hereType == #literal]])
		ifTrue: [
			parseNode := encoder encodeLiteral: self advance.
			^true].
	(here == #- and: [tokenType == #number])
		ifTrue: [
			self advance.
			parseNode := encoder encodeLiteral: self advance negated.
			^true].
	^false! !

!Parser methodsFor: 'error correction' stamp: 'jmv 1/12/2010 11:35'!
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."

	| correctSelector userSelection |
	"If we can't ask the user, assume that the keyword will be defined later"
	self interactive ifFalse: [^proposedKeyword asSymbol].
	
	"If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user"
	"
	((requestor isKindOf: Editor) or: [ requestor is: #Morph ])
		ifFalse: [ ^ proposedKeyword asSymbol ].
	"

	userSelection := requestor selectionInterval.
	requestor selectFrom: spots first first to: spots last last.

	correctSelector := UnknownSelector name: proposedKeyword.
	correctSelector ifNil: [^abortAction value].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	self substituteSelector: correctSelector keywords wordIntervals: spots.
	^(proposedKeyword last ~~ $:
	   and: [correctSelector last == $:])
		ifTrue: [abortAction value]
		ifFalse: [correctSelector]! !

!Parser methodsFor: 'error correction' stamp: 'jmv 1/12/2010 11:38'!
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. "

	"Check if this is an i-var, that has been corrected already (ugly)"

	"Display the pop-up menu"

	| tempIvar binding userSelection action |
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: 
		[^InstanceVariableNode new 
			name: proposedVariable
			index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)].

	"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].
	
	"If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user"
	"
	((requestor isKindOf: Editor) or: [ requestor is: #Morph ])
		ifFalse: [ ^encoder undeclared: proposedVariable ].
	"
	userSelection := requestor selectionInterval.
	requestor selectFrom: spot first to: spot last.

	"Build the menu with alternatives"
	action := UndeclaredVariable 
				signalFor: self
				name: proposedVariable
				inRange: spot.
	action ifNil: [^self fail].

	"Execute the selected action"
	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	^action value! !


!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/12/2010 10:59'!
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) is: #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: 'jmv 1/12/2010 10:59'!
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 is: #SystemWindow 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 popUpInWorld: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/12/2010 10:59'!
allNonFlapRelatedSubmorphs
	"Answer all non-window submorphs that are not flap-related"

	^submorphs 
		select: [:m | (m is: #SystemWindow) not ]! !


!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jmv 1/12/2010 12:05'!
mouseUp: evt

	showSelectionFeedback _ false.
	(borderColor is: #Color) ifFalse:[borderColor _ #raised].
	allButtons ifNil: [^ self].
	allButtons do: [:m |
		(m containsPoint: evt cursorPoint) ifTrue: [m performAction]].
	allButtons _ nil.
	self changed.
! !

!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 1/12/2010 12:05'!
updateFeedbackForEvt: evt

	| newState |
	newState _ self containsPoint: evt cursorPoint.
	newState = showSelectionFeedback ifFalse: [
		(borderColor is: #Color)
			ifTrue:[showSelectionFeedback _ newState]
			ifFalse:[borderColor _ newState ifTrue:[#inset] ifFalse:[#raised]].
		self changed].
! !


!PointerFinder methodsFor: 'application' stamp: 'jmv 1/12/2010 11:48'!
buildList
	| list obj parent object key |
	list := OrderedCollection new.
	obj := goal.
	
	[list addFirst: obj.
	obj := parents at: obj ifAbsent: [].
	obj == nil] whileFalse.
	list removeFirst.
	parent := Smalltalk.
	objectList := OrderedCollection new.
	pointerList := OrderedCollection new.
	[list isEmpty]
		whileFalse: 
			[object := list removeFirst.
			key := nil.
			(parent isKindOf: Dictionary)
				ifTrue: [list size >= 2
						ifTrue: 
							[key := parent keyAtValue: list second ifAbsent: [].
							key == nil
								ifFalse: 
									[object := list removeFirst; removeFirst.
									pointerList add: key printString , ' -> ' , object class name]]].
			key == nil
				ifTrue: 
					[parent class == object ifTrue: [key := 'CLASS'].
					key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
									== object ifTrue: [key := parent class allInstVarNames at: i]]]].
					key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
									== object ifTrue: [key := i printString]]]].
					key == nil ifTrue: [((parent is: #Morph) and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
					key == nil ifTrue: [((parent is: #CompiledMethod) and: [object isVariableBinding]) ifTrue: [key := 'literals?']].
					key == nil ifTrue: [key := '???'].
					pointerList add: key , ': ' , object class name].
			objectList add: object.
			parent := object]! !

!PointerFinder methodsFor: 'application' stamp: 'jmv 1/12/2010 11:48'!
follow: anObject from: parentObject
	anObject == goal
		ifTrue: 
			[parents at: anObject put: parentObject.
			^ true].
	anObject isLiteral ifTrue: [^ false].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	(anObject class isPointers or: [anObject is: #CompiledMethod]) ifFalse: [^ false].
	anObject class isWeak ifTrue: [^ false].
	(parents includesKey: anObject)
		ifTrue: [^ false].
	parents at: anObject put: parentObject.
	toDoNext add: anObject.
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'jmv 1/12/2010 11:49'!
followObject: anObject
	(self follow: anObject class from: anObject)
		ifTrue: [^ true].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	(anObject is: #CompiledMethod) ifTrue: [
		1 to: anObject numLiterals do:
			[:i |
			(self follow: (anObject literalAt: i) from: anObject)
				ifTrue: [^ true]].
		^false].
	1 to: anObject class instSize do:
		[:i |
		(self follow: (anObject instVarAt: i) from: anObject)
			ifTrue: [^ true]].
	1 to: anObject basicSize do:
		[:i |
		(self follow: (anObject basicAt: i) from: anObject)
			ifTrue: [^ true]].
	^ false! !


!PolygonMorph methodsFor: 'access' stamp: 'jmv 1/12/2010 12:23'!
borderColor: aColor 

	super borderColor: aColor.
	((borderColor is: #Color) and: [ borderColor isOpaque ]) 
		== ((aColor is: #Color) and: [ aColor isOpaque ]) 
			ifFalse: [
				"Need to recompute fillForm and borderForm
					if translucency of border changes."

				self releaseCachedState]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'jmv 1/12/2010 12:05'!
drawDashedBorderOn: aCanvas usingEnds: anArray 
	"Display my border on the canvas. NOTE: mostly copied from  
	drawBorderOn:"

	| lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset |
	(borderColor isNil 
		or: [(borderColor is: #Color) and: [borderColor isTransparent]]) ifTrue: [^self].
	lineColor := borderColor.
	bevel := false.
	"Border colors for bevelled effects depend on CW ordering of  
	vertices"
	borderColor == #raised 
		ifTrue: 
			[topLeftColor := color lighter.
			bottomRightColor := color darker.
			bevel := true].
	borderColor == #inset 
		ifTrue: 
			[topLeftColor := owner colorForInsets darker.
			bottomRightColor := owner colorForInsets lighter.
			bevel := true].
	bigClipRect := aCanvas clipRect expandBy: (self borderWidth + 1) // 2.
	segmentOffset := self borderDashOffset.
	self lineSegmentsDo: 
			[:p1 :p2 | 
			p1i := p1 asIntegerPoint.
			p2i := p2 asIntegerPoint.
			(arrows ~= #none and: [closed not]) 
				ifTrue: 
					["Shorten line ends so as not to interfere with tip  
					of arrow."

					((arrows == #back or: [arrows == #both]) and: [p1 = vertices first]) 
						ifTrue: [p1i := anArray first asIntegerPoint].
					((arrows == #forward or: [arrows == #both]) and: [p2 = vertices last]) 
						ifTrue: [p2i := anArray last asIntegerPoint]].
			(closed or: 
					["bigClipRect intersects: (p1i rect: p2i) optimized:"

					((p1i min: p2i) max: bigClipRect origin) 
						<= ((p1i max: p2i) min: bigClipRect corner)]) 
				ifTrue: 
					[bevel 
						ifTrue: 
							[lineColor := (p1i quadrantOf: p2i) > 2 
										ifTrue: [topLeftColor]
										ifFalse: [bottomRightColor]].
					segmentOffset := aCanvas 
								line: p1i
								to: p2i
								width: borderWidth
								color: lineColor
								dashLength: borderDashSpec first
								secondColor: borderDashSpec third
								secondDashLength: borderDashSpec second
								startingOffset: segmentOffset]]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'jmv 1/12/2010 12:05'!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line segments."
	| lineColor bevel topLeftColor bottomRightColor bigClipRect brush p1i p2i |
	vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
	closed & color isTransparent not ifTrue:
		[self filledForm colors: (Array with: Color transparent with: color).
		aCanvas image: self filledForm at: bounds topLeft-1].
	lineColor _ borderColor.  bevel _ false.
	"Border colors for bevelled effects depend on CW ordering of vertices"
	borderColor == #raised ifTrue: [topLeftColor _ color lighter.
						bottomRightColor _ color darker.  bevel _ true].
	borderColor == #inset ifTrue: [topLeftColor _ owner colorForInsets darker.
						bottomRightColor _ owner colorForInsets lighter.  bevel _ true].
	bigClipRect _ aCanvas clipRect expandBy: self borderWidth+1//2.
	brush _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | p1i _ p1 asIntegerPoint.  p2i _ p2 asIntegerPoint.
		(closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:"
					((p1i min: p2i) max: bigClipRect origin) <=
					((p1i max: p2i) min: bigClipRect corner)]) ifTrue:
			[bevel ifTrue: [((p1i quadrantOf: p2i) > 2)
						ifTrue: [lineColor _ topLeftColor]
						ifFalse: [lineColor _ bottomRightColor]].
			(borderWidth > 3 and: [borderColor is: #Color])
			ifTrue: [brush == nil ifTrue:
						[brush _ (ColorForm dotOfSize: borderWidth)
								colors: (Array with: Color transparent with: borderColor)].
					aCanvas line: p1i to: p2i brushForm: brush]
			ifFalse: [aCanvas line: p1i to: p2i
							width: borderWidth color: lineColor]]].
	self arrowForms ifNotNil:
		[self arrowForms do:
			[:f | f colors: (Array with: Color transparent with: borderColor).
			aCanvas image: f at: f offset]]
! !

!PolygonMorph methodsFor: 'menu' stamp: 'jmv 1/12/2010 12:06'!
specifyDashedLine

	| executableSpec newSpec |
	executableSpec _ FillInTheBlank
		request:
'Enter a dash specification as
{ major dash length. minor dash length. minor dash color }
The major dash will have the normal border color.
A blank response will remove the dash specification.
[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
where the 4th ityem is zero, and the 5th is the number of pixels
by which the dashes will move in each step of animation]'
		initialAnswer: '{ 10. 5. Color red }'.
	executableSpec isEmpty ifTrue:
		[^ self stopStepping; dashedBorder: nil].
	newSpec _ [Smalltalk actualCompilerClass evaluate: executableSpec] ifError:
		[^ self stopStepping; dashedBorder: nil].
	newSpec first isNumber & newSpec second isNumber & (newSpec third is: #Color) ifFalse:
		[^ self stopStepping; dashedBorder: nil].
	newSpec size = 3 ifTrue:
		[^ self stopStepping; dashedBorder: newSpec].
	(newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue:
		[^ self dashedBorder: newSpec; startStepping].
! !

!PolygonMorph methodsFor: 'private' stamp: 'jmv 1/12/2010 12:25'!
filledForm
	"Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form.  This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside.  Computation of the filled form is done only on demand."
	| bb origin |
	closed ifFalse: [^ filledForm _ nil].
	filledForm ifNotNil: [^ filledForm].
	filledForm _ ColorForm extent: bounds extent+2.

	"Draw the border..."
	bb _ (BitBlt current toForm: filledForm) sourceForm: nil; fillColor: Color black;
			combinationRule: Form over; width: 1; height: 1.
	origin _ bounds topLeft asIntegerPoint-1.
	self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
										to: p2 asIntegerPoint-origin].

	"Fill it in..."
	filledForm _ ColorForm mappingWhiteToTransparentFrom: filledForm anyShapeFill.

	((borderColor is: #Color) and: [ borderColor isOpaque not ]) ifTrue: [
		"If border is stored as a form, then erase any overlap now."
		filledForm
			copy: self borderForm boundingBox
			from: self borderForm
			to: 1@1
			rule: Form erase ].

	^ filledForm! !


!BalloonMorph class methodsFor: 'private' stamp: 'jmv 1/12/2010 11:01'!
getTextMorph: aStringOrMorph for: balloonOwner
	"Construct text morph."
	| m text fontToUse |
	(aStringOrMorph is: #Morph)
		ifTrue: [ m _ aStringOrMorph ]
		ifFalse: [
			text _ Text string: aStringOrMorph attribute: TextAlignment centered.
			(fontToUse _ balloonOwner balloonFont)
				ifNotNil: [
					text initialFont: fontToUse ].
			m _ TextMorph new contents: text].
	^ m! !


!ScrollPane methodsFor: 'event handling' stamp: 'jmv 1/12/2010 11:00'!
mouseEnter: event
	hasFocus _ true.
	(owner is: #SystemWindow) ifTrue: [ owner paneTransition: event ].
	retractableScrollBar ifTrue:[ self hideOrShowScrollBars ].
! !

!ScrollPane methodsFor: 'event handling' stamp: 'jmv 1/12/2010 11:00'!
mouseLeave: event
	hasFocus _ false.
	retractableScrollBar ifTrue: [
		self
			vHideScrollBar;
			hHideScrollBar].
	(owner is: #SystemWindow) ifTrue: [ owner paneTransition: event ]
! !


!PluggableTextMorph methodsFor: 'drawing' stamp: 'jmv 12/5/2009 19:53'!
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"

	| bw bc |
	super drawOn: aCanvas.
	bw _ Preferences focusIndicatorWidth.
	bc _ nil.
	self wantsFrameAdornments ifTrue: [
		((model is: #CodeHolder) and: [model refusesToAcceptCode])
			ifTrue: [  "Put up feedback showing that code cannot be submitted in this state"
				bc _ Color tan]
			ifFalse: [
				self hasEditingConflicts
					ifTrue: [
						bw _ 3.
						bc _ Color red ] 
					ifFalse: [
						self hasUnacceptedEdits
							ifTrue: [
								model wantsDiffFeedback
									ifTrue: [
										bw _ 4.
										bc _ Color green]
									ifFalse: [
										bc _ Color red]]
							ifFalse: [
								model wantsDiffFeedback
									ifTrue: [
										bc _ Color green]
									ifFalse: []]]]].
					
	textMorph hasKeyboardFocus ifTrue: [
		bc ifNil: [
			bc _ Preferences focusIndicatorColor ]]
	ifFalse: [
		bc ifNotNil: [
			bc _ bc alphaMixed: 0.4 with: Color white ]].
	bc notNil ifTrue: [
		aCanvas frameRectangle: self focusIndicatorRectangle width: bw color: bc ]! !

!PluggableTextMorph methodsFor: 'testing' stamp: 'jmv 12/5/2009 19:47'!
is: aSymbol
	^aSymbol = #HasTextSelector or: [ super is: aSymbol ]! !


!SelectionMorph methodsFor: '*connectors-halo commands' stamp: 'jmv 1/12/2010 11:25'!
addOrRemoveItems: handOrEvent 
	"Make a new selection extending the current one."

	| oldOwner hand |
	hand := (handOrEvent is: #MorphicEvent) 
				ifFalse: [ handOrEvent ]
				ifTrue: [ handOrEvent hand ].
	hand 
		addMorphBack: ((self class 
				newBounds: (hand lastEvent cursorPoint extent: 16 @ 16)) 
					setOtherSelection: self).
	oldOwner := owner.
	self world deleteAllHalos.	"Will delete me"
	oldOwner addMorph: self! !


!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 11:17'!
lineColor
	"Answer a good color to use for drawing the lines that connect members of the hierarchy view.
	Used the cached color, or derive it if necessary by finding the first owner (up to my root) that is not transparent, then picking a contrasting color.
	Fall back to veryLightGray if all my owners are transparent."

	| coloredOwner targetLuminance ownerColor darken |
	lineColor ifNotNil: [ ^lineColor ].
	coloredOwner _ self firstOwnerSuchThat: [ :o |
		(o isWorldMorph not and: [ (o is: #HandMorph) not ]) and: [ o color isTransparent not ]].
	coloredOwner ifNil: [ ^Color veryLightGray ].
	ownerColor _ coloredOwner color.
	darken _ ownerColor luminance > 0.5.
	targetLuminance _ ownerColor luminance + (darken ifTrue: [ -0.2 ] ifFalse: [ 0.2 ]).
	^darken
		ifTrue: [ ownerColor atMostAsLuminentAs: targetLuminance ]
		ifFalse: [ ownerColor atLeastAsLuminentAs: targetLuminance ]
	
! !


!Stream methodsFor: 'testing' stamp: 'jmv 1/12/2010 11:51'!
is: aSymbol
	"Return true if the receiver responds to the stream protocol (if that's what's asked)"
	^ aSymbol = #Stream or: [ super is: aSymbol ]! !


!InflateStream methodsFor: 'initialize' stamp: 'jmv 1/12/2010 11:51'!
on: aCollectionOrStream
	(aCollectionOrStream is: #Stream)
		ifTrue: [	aCollectionOrStream binary.
				sourceStream _ aCollectionOrStream.
				self getFirstBuffer]
		ifFalse: [ source _ aCollectionOrStream].
	^self on: source from: 1 to: source size.! !


!String methodsFor: 'comparing' stamp: 'jmv 1/12/2010 10:57'!
= aString 
	"Answer whether the receiver sorts equally as aString.
	The collation order is simple ascii (with case differences)."

	aString species == String ifFalse: [
		(aString is: #Text) ifTrue: [^ self = aString string].
		^ false].

	^ (self compare: self with: aString collated: AsciiOrder) = 2! !


!StringMorph methodsFor: 'accessing' stamp: 'jmv 1/12/2010 10:57'!
contents: newContents
	contents _ (newContents is: #Text)
		ifTrue: [
			emphasis _ newContents emphasisAt: 1.
			 newContents string ]
		ifFalse: [
			contents = newContents ifTrue: [ ^self ].	"no substantive change"
			newContents].
	self fitContents! !


!SystemWindow methodsFor: 'menu' stamp: 'jmv 12/5/2009 20:39'!
makeSecondTopmost
	| aWorld nextWindow |
	aWorld := self world.
	nextWindow := aWorld submorphs 
				detect: [:m | (m is: #SystemWindow) and: [m ~~ self]]
				ifNone: [^self].
	nextWindow activate.
	aWorld addMorph: self behind: nextWindow! !

!SystemWindow methodsFor: 'menu' stamp: 'jmv 12/5/2009 20:39'!
sendToBack
	| aWorld nextWindow |
	aWorld := self world.
	nextWindow := aWorld submorphs 
				detect: [:m | (m is: #SystemWindow) and: [m ~~ self]]
				ifNone: [^self].
	nextWindow activate.
	aWorld addMorphBack: self! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 1/12/2010 11:09'!
spawnReframeHandle: event 
	"The mouse has crossed a pane border.  Spawn a reframe handle."

	| resizer localPt pt ptName newBounds cursor |
	owner ifNil: [^self	"Spurious mouseLeave due to delete"].
	self isCollapsed ifTrue: [^self].
	((self world ifNil: [^self]) firstSubmorph isKindOf: NewHandleMorph) 
		ifTrue: [^self	"Prevent multiple handles"].
	pt := event cursorPoint.
	"prevent spurios mouse leave when dropping morphs"
	owner 
		morphsInFrontOf: self
		overlapping: (pt - 2 extent: 4 @ 4)
		do: [:m | (m is: #HandMorph) ifFalse: [(m fullContainsPoint: pt) ifTrue: [^self]]].
	self bounds forPoint: pt
		closestSideDistLen: [ :side :dist :len | 
			"Check for window side adjust"

			dist <= 2 ifTrue: [ptName := side]].
	ptName ifNil: ["Check for pane border adjust"

			^self spawnPaneFrameHandle: event].
	#(#topLeft #bottomRight #bottomLeft #topRight) do: [ :corner | 
			"Check for window corner adjust"

			(pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName := corner]].
	cursor := Cursor resizeForEdge: ptName.
	resizer := (NewHandleMorph new)
				sensorMode: self fastFramingOn;
				followHand: event hand
					forEachPointDo: 
						[:p | 
						localPt := self pointFromWorld: p.
						newBounds := self bounds 
									withSideOrCorner: ptName
									setToPoint: localPt
									minExtent: self minimumExtent.
						self fastFramingOn 
							ifTrue: 
								[Cursor currentCursor == cursor 
									ifFalse: 
										[(event hand)
											visible: false;
											refreshWorld;
											visible: true.
										cursor show].
								self doFastWindowReframe: ptName]
							ifFalse: 
								[self bounds: newBounds]]
					lastPointDo: [:p | ]
					withCursor: cursor.
	event hand world addMorphInLayer: resizer.
	resizer startStepping! !

!SystemWindow methodsFor: 'testing' stamp: 'jmv 12/5/2009 20:37'!
is: aSymbol
	^ aSymbol = #SystemWindow or: [ super is: aSymbol ]! !


!SystemWindow class methodsFor: 'top window' stamp: 'jmv 12/5/2009 20:39'!
windowsIn: aWorld satisfying: windowBlock 
	| windows |
	windows := OrderedCollection new.
	aWorld ifNil: [^windows].	"opening MVC in Morphic - WOW!!"
	aWorld submorphs do: [ :m | 
			((m is: #SystemWindow) and: [windowBlock value: m]) 
				ifTrue: [windows addLast: m]].
	^windows! !


!Text methodsFor: 'accessing' stamp: 'jmv 1/12/2010 11:04'!
embeddedMorphs
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs withStartStopAndValueDo: 
			[:start :stop :attribs | 
			attribs 
				do: [:attrib | attrib anchoredMorph ifNotNil: [morphs add: attrib anchoredMorph]]].
	^morphs select: [ :m | m is: #Morph ]! !

!Text methodsFor: 'accessing' stamp: 'jmv 1/12/2010 11:04'!
embeddedMorphsFrom: start to: stop 
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs 
		runsFrom: start
		to: stop
		do: 
			[:attribs | 
			attribs 
				do: [:attr | attr anchoredMorph ifNotNil: [morphs add: attr anchoredMorph]]].
	^morphs select: [ :m | m is: #Morph ]! !

!Text methodsFor: 'comparing' stamp: 'jmv 12/5/2009 20:44'!
= other
	"Am I equal to the other Text or String?  
	***** Warning ***** Two Texts are considered equal if they have the same characters in them.  They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs.  If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])."

	(other is: #Text) ifTrue: [ "This is designed to run fast even for megabytes"
		^ string == other string or: [string = other string]].
	other isString ifTrue: [^ string == other or: [string = other]].
	^ false! !

!Text methodsFor: 'comparing' stamp: 'jmv 12/5/2009 20:40'!
is: aSymbol
	^ aSymbol = #Text or: [ super is: aSymbol ]! !


!TextEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 1/12/2010 10:57'!
forwardDelete: aKeyboardEvent
	"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 markIndex.
	startIndex > paragraph text size ifTrue: [
		^ false].
	self hasSelection ifTrue: [
		"there was a selection"
		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.
	(aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ])
		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 is: #Text) 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! !


!TextMorph methodsFor: 'classification' stamp: 'jmv 12/5/2009 20:20'!
is: aSymbol
	^ aSymbol = #TextMorph or: [ super is: aSymbol ]! !

!TextMorph methodsFor: 'testing' stamp: 'jmv 1/12/2010 12:35'!
isOpaqueMorph
	"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
	(backgroundColor isNil or: [ backgroundColor isOpaque not ])
		ifTrue: [^ false].
		
		
	self borderWidth > 0 ifTrue: [
		((self borderColor is: #Color) and: [ self borderColor isOpaque not]) ifTrue: [
			^false ]].
	^true! !


!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 1/12/2010 12:07'!
myMenuColor

	| c |
	c _ myWorld color.
	(c is: #Color) ifTrue: [^c atLeastAsLuminentAs: 0.2].
	^Color white! !


!ThreePhaseButtonMorph methodsFor: 'button' stamp: 'jmv 1/12/2010 11:04'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: [
			Cursor normal 
				showWhile: [ target perform: actionSelector withArguments: arguments ].
			(target is: #Morph) ifTrue: [ target changed ]]! !


!WarpBlt methodsFor: 'primitives' stamp: 'jmv 1/12/2010 12:11'!
warpBitsSmoothing: n sourceMap: sourceMap
	| deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps |
	<primitive: 'primitiveWarpBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	((sourceForm is: #Form) and: [sourceForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((destForm is: #Form) and: [destForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((halftoneForm is: #Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].

	(width < 1) | (height < 1) ifTrue: [^ self].
	fixedPtOne _ 16384.  "1.0 in fixed-pt representation"
	n > 1 ifTrue:
		[(destForm depth < 16 and: [colorMap == nil])
			ifTrue: ["color map is required to smooth non-RGB dest"
					^ self primitiveFail].
		pix _ Array new: n*n].

	nSteps _ height-1 max: 1.
	deltaP12 _ (self deltaFrom: p1x to: p2x nSteps: nSteps)
			@ (self deltaFrom: p1y to: p2y nSteps: nSteps).
	pA _ (self startFrom: p1x to: p2x offset: nSteps*deltaP12 x)
		@ (self startFrom: p1y to: p2y offset: nSteps*deltaP12 y).
	deltaP43 _ (self deltaFrom: p4x to: p3x nSteps: nSteps)
			@ (self deltaFrom: p4y to: p3y nSteps: nSteps).
	pB _ (self startFrom: p4x to: p3x offset: nSteps*deltaP43 x)
		@ (self startFrom: p4y to: p3y offset: nSteps*deltaP43 y).

	picker _ BitBlt current bitPeekerFromForm: sourceForm.
	poker _ BitBlt current bitPokerToForm: destForm.
	poker clipRect: self clipRect.
	nSteps _ width-1 max: 1.
	destY to: destY+height-1 do:
		[:y |
		deltaPAB _ (self deltaFrom: pA x to: pB x nSteps: nSteps)
				@ (self deltaFrom: pA y to: pB y nSteps: nSteps).
		sp _ (self startFrom: pA x to: pB x offset: nSteps*deltaPAB x)
			@ (self startFrom: pA y to: pB y offset: nSteps*deltaPAB x).
		destX to: destX+width-1 do:
			[:x | 
			n = 1
			ifTrue:
				[poker pixelAt: x@y
						put: (picker pixelAt: sp // fixedPtOne asPoint)]
			ifFalse:
				[0 to: n-1 do:
					[:dx | 0 to: n-1 do:
						[:dy |
						pix at: dx*n+dy+1 put:
								(picker pixelAt: sp
									+ (deltaPAB*dx//n)
									+ (deltaP12*dy//n)
										// fixedPtOne asPoint)]].
				poker pixelAt: x@y put: (self mixPix: pix
										sourceMap: sourceMap
										destMap: colorMap)].
			sp _ sp + deltaPAB].
		pA _ pA + deltaP12.
		pB _ pB + deltaP43]! !


!WarpBlt class methodsFor: 'form rotation' stamp: 'jmv 1/12/2010 12:13'!
rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize
	"Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original."

	| srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc |
	srcRect _ srcForm boundingBox.
	center _ srcRect center.
	radians _ angleInDegrees degreesToRadians.
	dstOrigin _ dstCorner _ center.
	srcRect corners do: [:corner |
		"find the limits of a rectangle that just encloses the rotated
		 original; in general, this rectangle will be larger than the
		 original (e.g., consider a square rotated by 45 degrees)"
		p _ ((corner - center) scaleBy: scalePoint) + center.
		p _ (p rotateBy: radians about: center) rounded.
		dstOrigin _ dstOrigin min: p.
		dstCorner _ dstCorner max: p].

	"rotate the enclosing rectangle back to get the source quadrilateral"
	dstRect _ dstOrigin corner: dstCorner.
	inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y).
	quad _ dstRect innerCorners collect: [:corner |
		p _ corner rotateBy: radians negated about: center.
		((p - center) scaleBy: inverseScale) + center].

	"make a Form to hold the result and do the rotation"
	warpSrc _ srcForm.
	(srcForm is: #ColorForm)
		ifTrue: [
			cellSize > 1 | true "ar 12/27/2001: Always enable - else sketches won't work"
				ifTrue: [
					warpSrc _ Form extent: srcForm extent depth: 16.
					srcForm displayOn: warpSrc.
					dstForm _ Form extent: dstRect extent depth: 16]  "use 16-bit depth to allow smoothing"
				ifFalse: [
					dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]]
		ifFalse: [
			dstForm _ srcForm class extent: dstRect extent depth: srcForm depth].

	(WarpBlt toForm: dstForm)
		sourceForm: warpSrc;
		colorMap: (warpSrc colormapIfNeededFor: dstForm);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint;
		copyQuad: quad toRect: dstForm boundingBox.

	(dstForm is: #ColorForm) ifTrue: [ dstForm colors: srcForm colors copy ].
	newCenter _ (center rotateBy: radians about: aPoint) truncated.
	^ Array with: dstForm with: dstRect origin + (newCenter - center)
! !


!WeakMessageSend methodsFor: 'comparing' stamp: 'jmv 12/5/2009 20:29'!
= anObject
	"Compare equal to equivalent MessageSend"
	^ (anObject is: #MessageSend)
		and: [self receiver == anObject receiver
		and: [selector == anObject selector
		and: [(Array withAll: arguments) = (Array withAll: anObject arguments)]]]
! !

!WeakMessageSend methodsFor: 'testing' stamp: 'jmv 12/5/2009 20:28'!
is: aSymbol
	^ aSymbol = #MessageSend or: [ super is: aSymbol ]! !


!WorldState methodsFor: 'stepping' stamp: 'jmv 1/12/2010 11:05'!
cleanseStepListForWorld: aWorld
	"Remove morphs from the step list that are not in this World.  Often were in a flap that has moved on to another world."

	| deletions morphToStep |
	deletions _ nil.
	stepList do: [:entry |
		morphToStep _ entry receiver.
		morphToStep world == aWorld ifFalse:[
			deletions ifNil: [deletions _ OrderedCollection new].
			deletions addLast: entry]].

	deletions ifNotNil:[
		deletions do: [:entry|
			self stopStepping: entry receiver]].

	self alarms copy do:[:entry|
		morphToStep _ entry receiver.
		((morphToStep is: #Morph) and: [ morphToStep world == aWorld ]) 
			ifFalse: [ self removeAlarm: entry selector for: entry receiver ]].! !

!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/12/2010 11:05'!
displayWorldSafely: aWorld
	"Update this world's display and keep track of errors during draw methods."

	[aWorld displayWorld] ifError: [:err :rcvr |
		"Handle a drawing error"
		| errCtx errMorph |
		errCtx _ thisContext.
		[
			errCtx _ errCtx sender.
			"Search the sender chain to find the morph causing the problem"
			[errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] 
				whileTrue:[errCtx _ errCtx sender].
			"If we're at the root of the context chain then we have a fatal drawing problem"
			errCtx ifNil:[^self handleFatalDrawingError: err].
			errMorph _ errCtx receiver.
			"If the morph causing the problem has already the #drawError flag set,
			then search for the next morph above in the caller chain."
			errMorph isKnownFailing
		] whileTrue.
		errMorph drawingFails.
		"Install the old error handler, so we can re-raise the error"
		rcvr error: err.
	].! !


!ZipArchive methodsFor: 'reading' stamp: 'jmv 1/12/2010 11:52'!
readFrom: aStreamOrFileName
	| stream name eocdPosition |
	stream _ (aStreamOrFileName is: #tream)
		ifTrue: [name _ aStreamOrFileName name. aStreamOrFileName]
		ifFalse: [StandardFileStream readOnlyFileNamed: (name _ aStreamOrFileName)].
	stream binary.
	eocdPosition _ self class findEndOfCentralDirectoryFrom: stream.
	eocdPosition <= 0 ifTrue: [self error: 'can''t find EOCD position'].
	self readEndOfCentralDirectoryFrom: stream.
	stream position: eocdPosition - centralDirectorySize.
	self readMembersFrom: stream named: name! !


!ZipArchive class methodsFor: 'file format' stamp: 'jmv 1/12/2010 11:52'!
isZipArchive: aStreamOrFileName
	"Answer whether the given filename represents a valid zip file."

	| stream eocdPosition |
	stream _ (aStreamOrFileName is: #Stream)
		ifTrue: [aStreamOrFileName]
		ifFalse: [StandardFileStream oldFileNamed: aStreamOrFileName].
	stream ifNil: [^ false].
	"nil happens sometimes somehow"
	stream size < 22 ifTrue: [^ false].
	stream binary.
	eocdPosition _ self findEndOfCentralDirectoryFrom: stream.
	stream ~= aStreamOrFileName ifTrue: [stream close].
	^ eocdPosition > 0! !


!ZipEncoder methodsFor: 'initialize-release' stamp: 'jmv 1/12/2010 11:52'!
on: aCollectionOrStream
	(aCollectionOrStream is: #tream)
		ifTrue:[encodedStream _ aCollectionOrStream]
		ifFalse:[	encodedStream _ WriteStream on: aCollectionOrStream].
	encodedStream isBinary
		ifTrue:[super on: (ByteArray new: 4096)]
		ifFalse:[super on: (String new: 4096)].
	bitPosition _ bitBuffer _ 0.! !

WeakMessageSend removeSelector: #isMessageSend!
Utilities class removeSelector: #addSampleWindowsTo:!
Utilities class removeSelector: #isObject:memberOfOneOf:!
Utilities class removeSelector: #keyLike:satisfying:!
TranslucentColor removeSelector: #isTranslucent!
TranslucentColor removeSelector: #isTranslucentColor!
TextMorph removeSelector: #isTextMorph!
Text removeSelector: #isText!
SystemWindow removeSelector: #isSystemWindow!
String removeSelector: #putOn:!
Stream removeSelector: #isStream!
Object class removeSelector: #releaseExternalSettings!
MorphicEvent removeSelector: #isMorphicEvent!
ImageMorph removeSelector: #isOpaque!
ImageMorph removeSelector: #isOpaque:!
!classDefinition: #ImageMorph category: #'Morphic-Basic'!
Morph subclass: #ImageMorph
	instanceVariableNames: 'image opaque'
	classVariableNames: 'DefaultForm'
	poolDictionaries: ''
	category: 'Morphic-Basic'!
HandMorph removeSelector: #isHandMorph!
AlignmentMorph removeSelector: #isAlignmentMorph!
Morph removeSelector: #isAlignmentMorph!
Morph removeSelector: #isHandMorph!
Morph removeSelector: #isMorph!
Morph removeSelector: #isTextMorph!
Morph removeSelector: #isWorldOrHandMorph!
Morph removeSelector: #playSoundNamed:!
MessageSend removeSelector: #isMessageSend!
LightWidget removeSelector: #isHandMorph!
LightWidget removeSelector: #isTextMorph!
LightWidget removeSelector: #isWorldOrHandMorph!
InfiniteForm removeSelector: #isTranslucent!

!InfiniteForm reorganize!
('accessing' asColor asForm dominantColor offset)
('displaying' colorForInsets displayOn:at:clippingBox:rule:fillColor: displayOnPort:at: displayOnPort:offsetBy: raisedColor)
('display box access' computeBoundingBox)
('private' form:)
('fillstyle protocol' bitPatternForDepth: direction form isBitmapFill isGradientFill isSolidFill isTiled normal origin)
('testing' mightBeTranslucent)
!

ColorForm removeSelector: #isColorForm!
ColorForm removeSelector: #isTranslucent!
Form removeSelector: #isForm!
Form removeSelector: #isTranslucent!
DisplayObject removeSelector: #isTransparent!
CompiledMethod removeSelector: #isCompiledMethod!
Color removeSelector: #isColor!
Color removeSelector: #isTranslucent!
Color removeSelector: #isTranslucentColor!

!Color reorganize!
('access' alpha blue brightness green hue luminance red saturation)
('equality' = diff: hash)
('queries' isBitmapFill isBlack isGradientFill isGray isOpaque isSolidFill isTransparent)
('transformations' * + - / adjustBrightness: adjustSaturation:brightness: alpha: alphaMixed:with: atLeastAsLuminentAs: atMostAsLuminentAs: blacker dansDarker darker duller lighter mixed:with: muchDarker muchLighter negated orColorUnlike: paler quiteBlacker quiteWhiter slightlyDarker slightlyLighter slightlyWhiter twiceDarker twiceLighter veryMuchDarker veryMuchLighter whiter)
('groups of shades' darkShades: lightShades: mix:shades: wheel:)
('printing' printOn: shortPrintString storeArrayOn: storeArrayValuesOn: storeOn:)
('other' colorForInsets display name raisedColor rgbTriplet)
('conversions' asColor asColorref asNontranslucentColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: makeForegroundColor pixelValue32 pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32)
('private' attemptToMutateError flushCache privateAlpha privateBlue privateGreen privateRGB privateRed setHue:saturation:brightness: setPrivateRed:green:blue: setRGB: setRed:green:blue: setRed:green:blue:range:)
('copying' veryDeepCopyWith:)
('Morphic menu' changeColorIn:event:)
('testing' is:)
!

Object removeSelector: #currentEvent!
Object removeSelector: #defaultFloatPrecisionFor:!
Object removeSelector: #dragAnimationFor:transferMorph:!
Object removeSelector: #dragTransferType!
Object removeSelector: #inheritsFromAnyIn:!
Object removeSelector: #instanceVariableValues!
Object removeSelector: #isColor!
Object removeSelector: #isColorForm!
Object removeSelector: #isCompiledMethod!
Object removeSelector: #isForm!
Object removeSelector: #isMessageSend!
Object removeSelector: #isMorph!
Object removeSelector: #isMorphicEvent!
Object removeSelector: #isStream!
Object removeSelector: #isSystemWindow!
Object removeSelector: #isText!
Object removeSelector: #isTransparent!
Object removeSelector: #playSoundNamed:!
Object removeSelector: #putOn:!
Object removeSelector: #refusesToAcceptCode!
