'From Cuis 2.3 of 22 March 2010 [latest update: #472] on 29 April 2010 at 5:14:45 pm'!

!LightWidget methodsFor: 'accessing' stamp: 'jmv 4/27/2010 10:45'!
morphsAt: aPoint behind: aMorph unlocked: aBool 
	"Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."

	| isBack all |
	all _ (aMorph isNil or: [owner isNil]) 
				ifTrue: ["Traverse down"

					(bounds containsPoint: aPoint) ifFalse: [^#()].
					(aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()].
					nil]
				ifFalse: ["Traverse up"
					all _ owner 
								morphsAt: (self externalizePositionFromOwner: aPoint to: owner)
								behind: self
								unlocked: aBool.
					WriteStream with: all].
	isBack _ aMorph isNil.
	(isBack and: [self containsPoint: aPoint]) 
		ifTrue: 
			[all ifNil: [^Array with: self].
			all nextPut: self].
	^all ifNil: [#()] ifNotNil: [all contents]! !

!LightWidget methodsFor: 'change reporting' stamp: 'jmv 4/27/2010 11:28'!
invalidRect: aRectangle from: aMorph
	| damageRect |
	aRectangle hasPositiveExtent ifFalse: [ ^self ].
	damageRect _ aRectangle.
	aMorph == self ifFalse:[
		"Clip to receiver's clipping bounds if the damage came from a child"
		damageRect _ aRectangle intersect: bounds].
	owner ifNotNil: [owner invalidRect: damageRect from: self]! !

!LightWidget methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:26'!
fullDrawOn: aCanvas
	"Draw the full Morphic structure on the given Canvas"
	
	self visible ifFalse: [^ self].
	(aCanvas isVisible: self fullDisplayBounds) ifFalse:[^self].
	
	self isKnownFailing ifTrue: [^self drawErrorOn: aCanvas].

	aCanvas drawMorph: self! !

!LightWidget methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:46'!
shadowForm
	"Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero."
	| canvas |
	canvas _ Display defaultCanvasClass forShadowOver: bounds.
	canvas fullDrawMorph: self.
	^ canvas formWithOffset! !

!LightWidget methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:38'!
displayBounds
	^bounds! !

!LightWidget methodsFor: 'geometry' stamp: 'jmv 4/27/2010 10:25'!
fullDisplayBounds

	self revisar.
	"^self bounds: self fullBounds in: self world"
	^bounds! !

!LightWidget methodsFor: 'geometry' stamp: 'jmv 4/27/2010 10:46'!
position: aPoint
	"Change the position of this morph and and all of its submorphs."

	| delta box |
	delta _ aPoint - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	box _ bounds.
	self privateFullMoveBy: delta.
	(delta dotProduct: delta) > 100 ifTrue:[
		"e.g., more than 10 pixels moved"
		self invalidRect: box.
		self invalidRect: (box translateBy: delta).
	] ifFalse:[
		self invalidRect: (box merge: (box translateBy: delta)).
	].
	owner ifNotNil:[owner layoutChanged].! !

!LightWidget methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:28'!
referencePosition
	"Return the current reference position of the receiver"

	^bounds center
! !

!LightWidget methodsFor: 'geometry' stamp: 'jmv 4/27/2010 10:21'!
worldBoundsForHalo
	"Answer the rectangle to be used as the inner dimension of my halos.
	Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."

"Incluir transformaciones hacia owners"

	| r |
	r _ (Preferences haloEnclosesFullBounds)
		ifFalse: [ self displayBounds ]
		ifTrue: [ self fullDisplayBounds ].
	Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 1 ].
	^r! !

!LightWidget methodsFor: 'geometry testing' stamp: 'jmv 4/27/2010 10:45'!
fullContainsPoint: aPoint
	(bounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"
	(self containsPoint: aPoint) ifTrue: [^ true].  "quick acceptance"
	^ false! !

!LightWidget methodsFor: 'updating' stamp: 'jmv 4/27/2010 10:45'!
changed
	"Report that the area occupied by this morph should be redrawn."
	^self invalidRect: bounds! !


!CompositeLW methodsFor: 'change reporting' stamp: 'jmv 4/27/2010 10:52'!
privateInvalidateMorph: aMorph
	"Private. Invalidate the given morph after adding or removing.
	This method is private because a) we're invalidating the morph 'remotely'
	and b) it forces a fullBounds computation which should not be necessary
	for a general morph c) the morph may or may not actually invalidate
	anything (if it's not in the world nothing will happen) and d) the entire
	mechanism should be rewritten."
	aMorph changed! !

!CompositeLW methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:27'!
drawSubmorphsOn: aCanvas 
	"Display submorphs back to front"

	submorphs isEmpty ifTrue: [^self].
	aCanvas clipBy: bounds during: [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]]! !

!CompositeLW methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:25'!
fullDrawOn: aCanvas
	"Draw the full Morphic structure on the given Canvas"
	
	self visible ifFalse: [^ self].
	(aCanvas isVisible: self fullDisplayBounds) ifFalse:[^self].
	
	self isKnownFailing ifTrue: [^self drawErrorOn: aCanvas].
	
	aCanvas drawMorph: self.
	self drawSubmorphsOn: aCanvas! !

!CompositeLW methodsFor: 'submorphs-accessing' stamp: 'jmv 4/27/2010 10:44'!
morphsAt: aPoint behind: aMorph unlocked: aBool 
	"Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."

	| isBack found all |
	all _ (aMorph isNil or: [owner isNil]) 
				ifTrue: ["Traverse down"

					(bounds containsPoint: aPoint) ifFalse: [^#()].
					(aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()].
					nil]
				ifFalse: ["Traverse up"
					all _ owner 
								morphsAt: (self externalizePositionFromOwner: aPoint to: owner)
								behind: self
								unlocked: aBool.
					WriteStream with: all].
	isBack _ aMorph isNil.
	self submorphsDo: 
			[:m | 
			isBack 
				ifTrue: [
					found _ m 
								morphsAt: (m internalizePositionToOwner: aPoint from: self)
								behind: nil
								unlocked: aBool.
					found notEmpty 
						ifTrue: 
							[all ifNil: [all _ WriteStream on: #()].
							all nextPutAll: found]].
			m == aMorph ifTrue: [isBack _ true]].
	(isBack and: [self containsPoint: aPoint]) 
		ifTrue: 
			[all ifNil: [^Array with: self].
			all nextPut: self].
	^all ifNil: [#()] ifNotNil: [all contents]! !

!CompositeLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 4/27/2010 10:44'!
removeAllMorphs
	| oldMorphs myWorld |
	myWorld _ self world.
	myWorld ifNotNil: [ self invalidRect: bounds].
	submorphs do: [:m | m privateOwner: nil].
	oldMorphs _ submorphs.
	submorphs _ EmptyArray.
	oldMorphs do: [ :m | self removedMorph: m ].
	self layoutChanged! !


!ListLW methodsFor: 'focus handling' stamp: 'jmv 4/27/2010 11:38'!
focused: aSubmorph
	"Default is to do nothing."
	
	| delta |
	delta _ aSubmorph displayBounds amountToTranslateWithin: bounds.
	delta = (0@0) ifFalse: [
		submorphs do: [ :m |
			m privateFullMoveBy: delta].
		self changed]! !

!ListLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 4/27/2010 11:39'!
addMorph: aMorph
	| p |
	p _ submorphs isEmpty 
		ifFalse: [submorphs last displayBounds bottomLeft]
		ifTrue: [bounds topLeft].
	self addMorphBack: aMorph.
	aMorph position: p! !

!ListLW methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:39'!
scrollInterval
	"Answer an interval to draw the proportional thumb of a scroll bar"

	| b top bottom subTop subBottom thumbTop thumbBottom scale |
	top _ bounds top.
	bottom _ bounds bottom.
	subTop _ top.
	subBottom _ bottom.
	self submorphsDo:[:m |
		b _ m displayBounds.
		subTop _ subTop min: b top.
		subBottom _ subBottom max: b bottom ].
	scale _ 1.0 /  (subBottom - subTop) * (bottom - top ).
	thumbTop _ 1.0 * top - subTop * scale + top.
	thumbBottom _ 1.0 * bottom - subTop * scale + top.
	^ Interval from: thumbTop rounded to: thumbBottom rounded! !


!ListOldLW methodsFor: 'focus handling' stamp: 'jmv 4/27/2010 11:39'!
focused: aSubmorph
	"Default is to do nothing."
	
	| delta |
	delta _ aSubmorph displayBounds amountToTranslateWithin: bounds.
	delta = (0@0) ifFalse: [
		submorphs do: [ :m |
			m privateFullMoveBy: delta].
		self changed]! !

!ListOldLW methodsFor: 'submorphs-add/remove' stamp: 'jmv 4/27/2010 11:39'!
addMorph: aMorph
	| p |
	p _ submorphs isEmpty 
		ifFalse: [submorphs last displayBounds bottomLeft]
		ifTrue: [bounds topLeft].
	self addMorphBack: aMorph.
	aMorph position: p! !

!ListOldLW methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:39'!
scrollInterval
	"Answer an interval to draw the proportional thumb of a scroll bar"

	| b top bottom subTop subBottom thumbTop thumbBottom scale |
	top _ bounds top.
	bottom _ bounds bottom.
	subTop _ top.
	subBottom _ bottom.
	self submorphsDo:[:m |
		b _ m displayBounds.
		subTop _ subTop min: b top.
		subBottom _ subBottom max: b bottom ].
	scale _ 1.0 /  (subBottom - subTop) * (bottom - top ).
	thumbTop _ 1.0 * top - subTop * scale + top.
	thumbBottom _ 1.0 * bottom - subTop * scale + top.
	^ Interval from: thumbTop rounded to: thumbBottom rounded! !


!Morph methodsFor: 'change reporting' stamp: 'jmv 4/27/2010 11:06'!
privateInvalidateMorph: aMorph
	"Private. Invalidate the given morph after adding or removing.
	This method is private because a) we're invalidating the morph 'remotely'
	and b) it forces a fullBounds computation which should not be necessary
	for a general morph c) the morph may or may not actually invalidate
	anything (if it's not in the world nothing will happen) and d) the entire
	mechanism should be rewritten."
	aMorph doLayoutIfNeeded.
	aMorph changed! !

!Morph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:29'!
areasRemainingToFill: aRectangle

	(self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [
		^aRectangle areasOutside: bounds ].
	^ Array with: aRectangle! !

!Morph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:30'!
drawOn: aCanvas

	aCanvas fillRectangle: bounds fillStyle: self fillStyle! !

!Morph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:30'!
fullDrawOn: aCanvas
	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].		"Needs fullBounds 'in owner' if inside a scroller"
	self isKnownFailing ifTrue: [^self drawErrorOn: aCanvas].

	"Draw receiver itself"
	(aCanvas isVisible: bounds) ifTrue:[aCanvas drawMorph: self].	"Needs bounds 'in owner' if inside a scroller"
	self drawSubmorphsOn: aCanvas.
	self drawDropHighlightOn: aCanvas.
	self drawMouseDownHighlightOn: aCanvas! !

!Morph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:30'!
ownShadowForm
	"Return a form representing the 'shadow' of the receiver, without including submorphs 
	regardless of clipping"
	| canvas |
	canvas _ Display defaultCanvasClass forShadowOver: bounds.
	canvas drawMorph: self.
	^ canvas formWithOffset! !

!Morph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:29'!
displayBounds
	^self bounds: bounds in: self world! !

!Morph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 10:20'!
fullDisplayBounds
	^self bounds: self fullBounds in: self world! !

!Morph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:30'!
innerBounds
	"Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."

	^ bounds! !

!Morph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:31'!
setConstrainedPosition: aPoint hangOut: partiallyOutside
	"Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds.  Let me go within two pixels of completely outside if partiallyOutside is true."

	| trialRect delta boundingMorph bRect |
	owner ifNil:[^self].
	trialRect _ aPoint extent: bounds extent.
	boundingMorph _ self owner.
	delta _ boundingMorph
			ifNil:    [0@0]
			ifNotNil: [
				bRect _ partiallyOutside 
					ifTrue: [boundingMorph bounds insetBy: 
								self extent negated + boundingMorph borderWidth + (2@2)]
					ifFalse: [boundingMorph bounds].
				trialRect amountToTranslateWithin: bRect].
	self position: aPoint + delta.
	self layoutChanged  "So that, eg, surrounding text will readjust"
! !

!Morph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 10:22'!
worldBoundsForHalo
	"Answer the rectangle to be used as the inner dimension of my halos.
	Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."

	| r |
	r _ (Preferences haloEnclosesFullBounds)
		ifFalse: [ self displayBounds ]
		ifTrue: [ self fullDisplayBounds ].
	Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 1 ].
	^r! !

!Morph methodsFor: 'geometry eToy' stamp: 'jmv 4/27/2010 11:30'!
referencePosition
	"Return the current reference position of the receiver"

	^bounds origin + (0.5@0.5 * bounds extent).
! !

!Morph methodsFor: 'geometry testing' stamp: 'jmv 4/27/2010 11:29'!
containsPoint: aPoint
	| shadow |
	"Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..."
	self isOrthoRectangularMorph ifTrue: [
		^ bounds containsPoint: aPoint ].
	
	"...But for those who not, provide correct albeit expensive behavior."
	shadow _ self ownShadowForm.
	^(shadow pixelValueAt: aPoint - shadow offset) > 0! !

!Morph methodsFor: 'initialization' stamp: 'jmv 4/27/2010 11:06'!
openCenteredInWorld

	self 
		doLayoutIfNeeded;
		position: Display extent - self extent // 2;
		openInWorld.! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:29'!
computeFullBounds
	"Private. Compute the actual full bounds of the receiver"

	(submorphs isEmpty or: [ self clipsSubmorphs ]) ifTrue: [  bounds ].
	^ bounds quickMerge: self submorphBounds! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:03'!
doLayoutIfNeeded
	"Return self. Recompute the layout if necessary."
	fullBounds ifNotNil: [ ^self ].
	"Errors at this point can be critical so make sure we catch 'em all right"
	[self doLayoutIn: self layoutBounds] on: Error do: [ :ex |
		"This should do it unless you don't screw up the bounds"
		fullBounds _ bounds.
		ex pass]! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:08'!
fullBounds
	"Return the bounding box of the receiver and all its children. Recompute the layout if necessary."
	self doLayoutIfNeeded.
	^fullBounds! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:30'!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Note: written so that #layoutBounds can be changed without touching this method"
	| outer inner |
	outer _ bounds.
	inner _ self layoutBounds.
	bounds _ aRectangle origin + (outer origin - inner origin) corner:
				aRectangle corner + (outer corner - inner corner).! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:35'!
layoutInBounds: cellBounds
	"Layout specific. Apply the given bounds to the receiver after being layed out in its owner."
	| box delta |
	fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds."
		
		self flag: #jmvRemove.
		"Leer el comentario. Entender. Simplificar!! (no hay mas shrinkWrap!!)"
		
		cellBounds origin = bounds origin ifFalse:[
			box _ bounds.
			delta _ cellBounds origin - bounds origin.
			self invalidRect: (box merge: (box translateBy: delta)).
			self privateFullMoveBy: delta]. "sigh..."
		"Compute inset of layout bounds"
		box _ box origin - (bounds origin - self layoutBounds origin) corner:
					box corner - (bounds corner - self layoutBounds corner).
		"And do the layout within the new bounds"
		self layoutBounds: box.
		self doLayoutIn: box].
	cellBounds = self fullBounds ifTrue:[^self]. "already up to date"
	cellBounds extent = self fullBounds extent "nice fit"
		ifTrue:[^self position: cellBounds origin].
	box _ bounds.
	"match #spaceFill constraints"
	box _ box origin extent: cellBounds width @ cellBounds height.
	"align accordingly"
	box _ box align: box center with: cellBounds center.
	"and install new bounds"
	self bounds: box.! !

!Morph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:34'!
layoutProportionallyIn: newBounds
	"Layout specific. Apply the given bounds to the receiver."
	| box frame |
	frame _ self layoutFrame ifNil:[^self].
	"before applying the proportional values make sure the receiver's layout is computed"
	self doLayoutIfNeeded. "sigh..."
	"compute the cell size the receiver has given its layout frame"
	box _ frame layout: bounds in: newBounds.
	(box = bounds) ifTrue:[^self]. "no change"
	^self layoutInBounds: box.! !

!Morph methodsFor: 'menus' stamp: 'jmv 4/27/2010 10:22'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #fillStyle:;
		originalColor: self color;
		putUpFor: self near: self fullDisplayBounds! !

!Morph methodsFor: 'meta-actions' stamp: 'jmv 4/27/2010 10:22'!
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 fullDisplayBounds]]);
		yourself! !

!Morph methodsFor: 'meta-actions' stamp: 'jmv 4/27/2010 11:31'!
resizeMorph: evt 
	| handle |
	handle := HandleMorph new 
				forEachPointDo: [:newPoint | self extent: newPoint - bounds topLeft].
	evt hand attachMorph: handle.
	handle startStepping! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 4/27/2010 10:22'!
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
	"Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)."
	self submorphsDo:[:m|
		m == someMorph ifTrue:["Try getting out quickly"
			owner ifNil:[^self].
			^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
		(m fullDisplayBounds intersects: aRectangle)
			ifTrue:[aBlock value: m]].
	owner ifNil:[^self].
	^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.! !

!Morph methodsFor: 'updating' stamp: 'jmv 4/27/2010 11:29'!
changed
	"Report that the area occupied by this morph should be redrawn."
	^fullBounds 
		ifNil:[self invalidRect: bounds]
		ifNotNil:[self invalidRect: fullBounds]! !


!BorderedMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:25'!
drawOn: aCanvas

	aCanvas fillRectangle: bounds fillStyle: self fillStyle borderStyle: self borderStyle.
! !

!BorderedMorph methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:26'!
innerBounds
	"Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."

	^ bounds insetBy: self borderWidth! !


!HaloMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:27'!
drawOn: aCanvas 
	"Draw this morph only if it has no target."

	target ifNil: [^super drawOn: aCanvas].
	Preferences showBoundsInHalo 
		ifTrue: [
			aCanvas 
				frameAndFillRectangle: bounds
				fillColor: Color transparent
				borderWidth: 1
				borderColor: Color blue]! !

!HaloMorph methodsFor: 'stepping' stamp: 'jmv 4/27/2010 11:27'!
step
	| newBounds |
	target
		ifNil: [^ self].
	newBounds _ target isWorldMorph
				ifTrue: [target bounds]
				ifFalse: [target worldBoundsForHalo truncated].
	newBounds = bounds
		ifTrue: [^ self].
	newBounds extent = bounds extent
		ifTrue: [^ self position: newBounds origin].
	growingOrRotating
		ifFalse: [submorphs size > 1
				ifTrue: [self addHandles]].
	"adjust halo bounds if appropriate"
	self bounds: newBounds! !

!HaloMorph methodsFor: 'updating' stamp: 'jmv 4/27/2010 10:44'!
changed
	"Quicker to invalidate handles individually if target is large (especially the world)"

	self extent > (200@200)
		ifTrue: [(target notNil and: [target ~~ self world]) ifTrue:
					["Invalidate 4 outer strips first, thus subsuming separate damage."
					(self fullDisplayBounds areasOutside: target bounds) do:
						[:r | self invalidRect: r]].
				self submorphsDo: [:m | m changed]]
		ifFalse: [super changed].
! !


!HandMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:26'!
fullDrawOn: aCanvas 
	"A HandMorph has unusual drawing requirements:
		1. the hand itself (i.e., the cursor) appears in front of its submorphs
		2. morphs being held by the hand cast a shadow on the world/morphs below
	The illusion is that the hand plucks up morphs and carries them above the world."

	self visible ifFalse: [^self].
	(aCanvas isVisible: self fullDisplayBounds) ifFalse: [^self].
	self nonCachingFullDrawOn: aCanvas.
! !

!HandMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:16'!
savePatchFrom: aCanvas 
	"Save the part of the given canvas under this hand as a Form and return its bounding rectangle."

	"Details: The previously used patch Form is recycled when possible to reduce the burden on storage management."

	| damageRect myBnds |
	damageRect := myBnds := self fullDisplayBounds.
	savedPatch ifNotNil: 
			[damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)].
	(savedPatch isNil or: [savedPatch extent ~= myBnds extent]) 
		ifTrue: 
			["allocate new patch form if needed"

			savedPatch := aCanvas form allocateForm: myBnds extent].
	aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin)
		into: savedPatch.
	savedPatch offset: myBnds topLeft.
	^damageRect! !

!HandMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:52'!
shadowForm
	"Return a 1-bit shadow of my submorphs.  Assumes submorphs is not empty"
	| bnds canvas |
	bnds _ Rectangle merging: (submorphs collect: [:m | m fullDisplayBounds]).
	canvas _ Display defaultCanvasClass forShadowOver: bnds.
	self drawSubmorphsOn: canvas.
	^ canvas formWithOffset! !

!HandMorph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:09'!
fullBounds
	"Extend my bounds by the shadow offset when carrying morphs."

	self doLayoutIfNeeded.
	submorphs isEmpty
		ifTrue: [^ fullBounds ]
		ifFalse: [^ fullBounds topLeft corner: fullBounds bottomRight + self shadowOffset].
! !


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

!LazyListMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:27'!
drawBackgroundForMulti: row on: aCanvas
	| selectionDrawBounds |
	"shade the background darker, if this row is selected"

	selectionDrawBounds := self drawBoundsForRow: row.
	selectionDrawBounds := selectionDrawBounds intersect: bounds.
	aCanvas fillRectangle: selectionDrawBounds color:  self color muchLighter! !

!LazyListMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:27'!
drawSelectionOn: aCanvas
	| selectionDrawBounds |
	selectedRow ifNil: [ ^self ].
	selectedRow = 0 ifTrue: [ ^self ].
	selectionDrawBounds := self drawBoundsForRow: selectedRow.
	selectionDrawBounds := selectionDrawBounds intersect: bounds.
	aCanvas fillRectangle: selectionDrawBounds color: (
		Display depth = 1 
			ifTrue: [Color lightGray] 
			ifFalse: [
				Display depth = 2 
					ifTrue: [Color black] 
					ifFalse: [Color lightGray alpha: 0.45]])! !

!LazyListMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:28'!
highlightPotentialDropRow: row  on: aCanvas
	| drawBounds  |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: bounds.
	aCanvas frameRectangle: drawBounds color: Color blue! !


!MenuMorph methodsFor: 'control' stamp: 'jmv 4/27/2010 11:44'!
popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem
	"Present this menu at the given point under control of the given hand."

	| delta tryToPlace selectedOffset |

	hand world startSteppingSubmorphsOf: self.
	popUpOwner _ sourceItem.
	selectedOffset := (selectedItem ifNil:[self items first]) position - self position.

	tryToPlace :=
		[ :where :mustFit |
		self position: where - selectedOffset.
		delta _ self fullDisplayBounds amountToTranslateWithin: sourceItem world bounds.
		(delta x = 0 or: [mustFit]) ifTrue:
			[delta = (0@0) ifFalse: [self position: self position + delta].
			sourceItem owner owner addMorphFront: self.
			^ self]].
	tryToPlace 
		value: rightOrLeftPoint first value: false;
		value: rightOrLeftPoint last  - (self width @ 0) value: false;
		value: rightOrLeftPoint first value: true

	! !

!MenuMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:29'!
drawOn: aCanvas
	"Draw the menu.  Add keyboard-focus feedback if appropriate"

	super drawOn: aCanvas.
	(self hasKeyboardFocus and: [self rootMenu hasProperty: #hasUsedKeyboard]) ifTrue: [
		aCanvas
			frameRectangle: bounds 
			width: Preferences focusIndicatorWidth 
			color: Preferences focusIndicatorColor ]! !

!MenuMorph methodsFor: 'private' stamp: 'jmv 4/27/2010 11:44'!
positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld
	"Note: items may not be laid out yet (I found them all to be at 0@0),  
	so we have to add up heights of items above the selected item."

	| i yOffset sub delta |
	self adjustSubmorphsLayout.
	i _ 0.
	yOffset _ 0.
	[(sub _ self submorphs at: (i _ i + 1)) == aMenuItem]
		whileFalse: [yOffset _ yOffset + sub height].

	self position: aPoint - (2 @ (yOffset + 8)).

	"If it doesn't fit, show it to the left, not to the right of the hand."
	self right > aWorld world bounds right
		ifTrue:
			[self right: aPoint x + 1].

	"Make sure that the menu fits in the world."
	delta _ bounds amountToTranslateWithin:
		(aWorld world bounds withHeight: ((aWorld world bounds height - 18) max: (ActiveHand position y) + 1)).
	delta = (0 @ 0) ifFalse: [self position: self position + delta]! !


!NewParagraph methodsFor: 'editing' stamp: 'jmv 4/27/2010 10:19'!
clickAt: clickPoint for: model
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action target range boxes box |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex) do: [ :att | 
		att mayActOnClick ifTrue:
				[(target _ model) ifNil: [ target _ editor morph].
				range _ text rangeOf: att startingAt: startBlock stringIndex.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+1).
				box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: nil.
				box ifNotNil: [
					box _ editor morph displayBounds.
					editor morph allOwnersDo: [ :m | box _ box intersect: (m displayBounds) ].
					Utilities
						awaitMouseUpIn: box
						repeating: nil
						ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]].
					Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show].
				]]].
	^ action! !


!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 4/27/2010 11:31'!
invalidRect: damageRect from: aMorph
        "Clip damage reports to my bounds, since drawing is clipped to my bounds."

        self == self outermostWorldMorph 
                ifTrue: [worldState recordDamagedRect: (damageRect intersect: bounds)]
                ifFalse: [super invalidRect: damageRect from: aMorph]
! !

!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:31'!
drawOn: aCanvas 
	"Draw in order:
	- background color
	- grid, if any
	- background sketch, if any
	- Update and draw the turtleTrails form. See the comment in updateTrailsForm.
	- cursor box if any

	Later (in drawSubmorphsOn:) I will skip drawing the background sketch."

	"draw background fill"
	(self isWorldMorph and: [aCanvas form == Display] and: [(color := self fillStyle) class == TranslucentColor])
		ifTrue: [
			(BitBlt current toForm: Display)
				clipRect: aCanvas clipRect;
				copy: bounds
				from: 0@0 in: nil
				fillColor: color rule: Form over]
		ifFalse: [ super drawOn: aCanvas]. 

	"draw background sketch."
	backgroundMorph ifNotNil: [
		self clipsSubmorphs ifTrue: [
			aCanvas clipBy: self clippingBounds
				during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]]
			ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]]! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 4/27/2010 11:31'!
acceptDroppingMorph: dropped event: evt 
	"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"

	| aMorph |
	aMorph := self morphToDropFrom: dropped.
	self isWorldMorph 
		ifTrue: 
			["Add the given morph to this world and start stepping it if it wants to be."

			self addMorphFront: aMorph.
			(aMorph fullDisplayBounds intersects: self viewBox) 
				ifFalse: 
					[Beeper beep.
					aMorph position: bounds center]]
		ifFalse: [super acceptDroppingMorph: aMorph event: evt].
	aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
	self world startSteppingSubmorphsOf: aMorph! !

!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 4/27/2010 10:23'!
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
	"Include hands if the receiver is the World"
	self handsDo:[:m|
		m == someMorph ifTrue:["Try getting out quickly"
			owner ifNil:[^self].
			^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
		"The hand only overlaps if it's not the hardware cursor"
		m needsToBeDrawn ifTrue:[
			(m fullDisplayBounds intersects: aRectangle)
				ifTrue:[aBlock value: m]]].
	^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock! !

!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 4/27/2010 10:54'!
addMorph: aMorph centeredNear: aPoint
	"Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world."

	| trialRect delta |
	trialRect _ Rectangle center: aPoint extent: aMorph fullDisplayBounds extent.
	delta _ trialRect amountToTranslateWithin: bounds.
	aMorph position: trialRect origin + delta.
	self addMorph: aMorph.
! !


!PolygonMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:31'!
drawClippedBorderOn: aCanvas usingEnds: anArray 
	aCanvas clipBy: bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! !


!BalloonMorph methodsFor: 'initialization' stamp: 'jmv 4/27/2010 11:25'!
popUpForHand: aHand
	"Pop up the receiver as balloon help for the given hand"

	self lock.
	self doLayoutIfNeeded. "force layout"
	self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber.
	aHand world addMorphFront: self.
	aHand balloonHelp: self.
! !


!BalloonMorph class methodsFor: 'instance creation' stamp: 'jmv 4/27/2010 11:25'!
string: str for: morph corner: cornerName 
	"Make up and return a balloon for morph. Find the quadrant that 
	clips the text the least, using cornerName as a tie-breaker. tk 9/12/97"
	| tm vertices instance |
	tm _ self getTextMorph: str for: morph.
	vertices _ self getVertices: tm displayBounds.
	vertices _ self
				getBestLocation: vertices
				for: morph
				corner: cornerName.
	instance _ self new
		color: morph balloonColor;
		 setVertices: vertices;
		 addMorph: tm;
		 setTarget: morph.
	tm center: instance adjustedCenter.
	^instance! !


!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 4/27/2010 11:20'!
setupMorphs
	|  x w y h |

	w _ ((labelMorph width max: subLabelMorph width) max: progress width) + 2.
	x _ w // 2.
	y _ 0.
	h _ labelMorph height + subLabelMorph height + progress height + 1.
	labelMorph position: x - (labelMorph width // 2)@y.
	y _ y + labelMorph height.
	subLabelMorph position: x - (subLabelMorph width // 2)@y.
	y _ y + subLabelMorph height.
	progress position: x - (progress width //2)@y.
	self bounds: (0@0 extent: w@h).

	self borderWidth: 2.
	self borderColor: Color black.

	self color: Color veryLightGray.
	self align: self fullDisplayBounds center with: Display boundingBox center
! !


!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 4/27/2010 11:40'!
initialFrameFor: aView initialExtent: initialExtent world: aWorld 
	"Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen."

	| allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames |
	Preferences reverseWindowStagger 
		ifTrue: 
			[^self 
				strictlyStaggeredInitialFrameFor: aView
				initialExtent: initialExtent
				world: aWorld].
	allowedArea := self maximumUsableAreaInWorld: aWorld.
	screenRight := allowedArea right.
	screenBottom := allowedArea bottom.
	otherFrames := (SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not]) 
						collect: [:w | w displayBounds].
	allOrigins := otherFrames collect: [:f | f origin].
	(self standardPositionsInWorld: aWorld) do: 
			[:aPosition | 
			"First see if one of the standard positions is free"

			(allOrigins includes: aPosition) 
				ifFalse: 
					[^(aPosition extent: initialExtent) 
						translatedAndSquishedToBeWithin: allowedArea]].
	staggerOrigin := (self standardPositionsInWorld: aWorld) first.	"Fallback: try offsetting from top left"
	putativeOrigin := staggerOrigin.
	
	[putativeOrigin := putativeOrigin + StaggerOffset.
	putativeFrame := putativeOrigin extent: initialExtent.
	putativeFrame bottom < screenBottom 
		and: [putativeFrame right < screenRight]] 
			whileTrue: 
				[(allOrigins includes: putativeOrigin) 
					ifFalse: 
						[^(putativeOrigin extent: initialExtent) 
							translatedAndSquishedToBeWithin: allowedArea]].
	^(self scrollBarSetback @ self screenTopSetback extent: initialExtent) 
		translatedAndSquishedToBeWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 4/27/2010 11:40'!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld 
	"This method implements a staggered window placement policy that I (di) like.
	Basically it provides for up to 4 windows, staggered from each of the 4 corners.
	The windows are staggered so that there will always be a corner visible."

	| allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel |
	allowedArea := (self maximumUsableAreaInWorld: aWorld) 
				insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0 @ 0).
	"Number to be staggered at each corner (less on small screens)"
	maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
	"Amount by which to stagger (less on small screens)"
	grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
	initialFrame := 0 @ 0 extent: initialExtent.
	"min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))))
							min: 600@400"
	otherFrames := (SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not]) 
						collect: [:w | w displayBounds].
	0 to: maxLevel
		do: 
			[:level | 
			1 to: 4
				do: 
					[:ci | 
					cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci.
					corner := allowedArea perform: cornerSel.
					"The extra grid//2 in delta helps to keep title tabs distinct"
					delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid).
					1 to: ci - 1 do: [:i | delta := delta rotateBy: #right centerAt: 0 @ 0].	"slow way"
					putativeCorner := corner + delta.
					free := true.
					otherFrames 
						do: [:w | free := free & ((w perform: cornerSel) ~= putativeCorner)].
					free 
						ifTrue: 
							[^(initialFrame align: (initialFrame perform: cornerSel)
								with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]].
	"If all else fails..."
	^(self scrollBarSetback @ self screenTopSetback 
		extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! !


!SelectionMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:31'!
drawOn: aCanvas

	| canvas form1 form2 box |
	super drawOn: aCanvas.
	box _ bounds.
	selectedItems do: [:m | box _ box merge: m fullDisplayBounds].
	box _ box expandBy: 1.
	canvas _ Display defaultCanvasClass depth: 8 over: box.
	selectedItems do: [:m | canvas fullDrawMorph: m].
	form1 _ (Form extent: box extent) copyBits: (0@0 extent: box extent) from: canvas form at: 0@0 colorMap: (Color maskingMap: 8).
	form2 _ Form extent: box extent.
	(0@0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under].
	form1 displayOn: form2 at: 0@0 rule: Form erase.
	aCanvas stencil: form2
		at: box topLeft
		sourceRect: form2 boundingBox
		color: self borderColor
! !

!SelectionMorph methodsFor: 'private' stamp: 'jmv 4/27/2010 11:40'!
doneExtending

	otherSelection ifNotNil:
		[selectedItems _ otherSelection selectedItems , selectedItems.
		otherSelection delete.
		self setOtherSelection: nil].
	self changed; layoutChanged.
	super privateBounds:
		((Rectangle merging: (selectedItems collect: [:m | m displayBounds]))
			expandBy: 8).
	self changed.
	self addHalo.! !

!SelectionMorph methodsFor: 'private' stamp: 'jmv 4/27/2010 10:56'!
selectSubmorphsOf: aMorph

	| newItems removals |
	newItems _ aMorph submorphs select:
		[:m | (bounds containsRect: m fullDisplayBounds) 
					and: [m~~self
					and: [(m isKindOf: HaloMorph) not]]].
	otherSelection ifNil: [^ selectedItems _ newItems].

	removals _ newItems intersection: itemsAlreadySelected.
	otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
	selectedItems _ (newItems copyWithoutAll: removals).
! !


!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 10:42'!
drawLinesOn: aCanvas 
	| lColor clippedCanvas |
	lColor _ self lineColor.
	clippedCanvas _ aCanvas
		copyOffset: scroller txOffset negated truncated
		clipRect: scroller innerBounds.
	scroller submorphs do:
		[ : submorph | 
		(submorph isExpanded or:
			[ (clippedCanvas isVisible: submorph fullBounds) or:		"needs #fullBounds 'in Owner'"
				"strange!! #isVisible expects a rectangle, and #nextSibling answers a Morph... Looks like it never gets here!! (jmv)"
				[ submorph nextSibling notNil and: [ clippedCanvas isVisible: submorph nextSibling ] ] ]) ifTrue:
			[ submorph
				drawLinesOn: clippedCanvas
				lineColor: lColor ] ]! !


!SketchMorph methodsFor: 'geometry testing' stamp: 'jmv 4/27/2010 11:32'!
containsPoint: aPoint

	^ (bounds containsPoint: aPoint) and: [
		(originalForm isTransparentAt: aPoint - bounds origin) not ]
! !


!ColorPickerMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:27'!
drawOn: aCanvas
	aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: bounds color: Color white].
	Display depth = originalForm depth ifFalse: [self buildChartForm].
	super drawOn: aCanvas! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jmv 4/27/2010 11:16'!
pickUpColorFor: aMorph
	"Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle"

      | aHand localPt |
	aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand].
	aHand ifNil: [aHand _ self currentHand].
	self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullDisplayBounds.
	self owner ifNil: [^ self].

	aHand showTemporaryCursor: (FormsAndHelpsRepository formAtKey: #Eyedropper) 
			hotSpotOffset: 6 negated @ 4 negated.    "<<<< the form was changed a bit??"

	self updateContinuously: false.
	[Sensor anyButtonPressed]
		whileFalse: 
			 [self trackColorUnderMouse].
	self deleteAllBalloons.

	localPt _ Sensor cursorPoint - self topLeft.
	self inhibitDragging ifFalse: [
		(DragBox containsPoint: localPt) ifTrue:
			["Click or drag the drag-dot means to anchor as a modeless picker"
			^ self anchorAndRunModeless: aHand].
	].
	(clickedTranslucency _ TransparentBox containsPoint: localPt)
		ifTrue: [selectedColor _ originalColor].

	self updateContinuously: true.
	[Sensor anyButtonPressed]
		whileTrue:
			 [self updateTargetColorWith: self indicateColorUnderMouse].
	aHand newMouseFocus: nil;
		showTemporaryCursor: nil;
		flushEvents.
	self delete.
		 
 ! !

!ColorPickerMorph methodsFor: 'other' stamp: 'jmv 4/27/2010 11:37'!
addToWorld: world near: box
	| goodLocation |
	goodLocation _ self bestPositionNear: box inWorld: world.
	world allMorphsDo:
		[:p | (p isMemberOf: ColorPickerMorph) ifTrue:
		[(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue:
			[(p selector == selector and: [p argument == argument])
				ifTrue: [^ p comeToFront  "uncover existing picker"]
				ifFalse: ["place second picker relative to first"
						goodLocation _ self bestPositionNear: p displayBounds inWorld: world]]]].
	self position: goodLocation.
	world addMorphFront: self.
	self changed
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'jmv 4/27/2010 11:34'!
bestPositionNear: box inWorld: world
	| points b |
	points _ #(topCenter rightCenter bottomCenter leftCenter).  "possible anchors"
	1 to: 4 do:
		[:i |  "Try the four obvious anchor points"
		b _ bounds align: (bounds perform: (points at: i))
					with: (box perform: (points atWrap: i + 2)).
		(world viewBox containsRect: b) ifTrue:
			[^ b topLeft"  Yes, it fits"]].

	^ 20@20  "when all else fails"
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'jmv 4/27/2010 10:21'!
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 fullDisplayBounds]])]! !


!StringMorph methodsFor: 'editing' stamp: 'jmv 4/27/2010 11:32'!
launchMiniEditor: evt 
	| textMorph |
	hasFocus := true.	"Really only means edit in progress for this morph"
	textMorph := StringMorphEditor new contentsAsIs: 
		(Text initialFont: self fontToUse stringOrText: contents).
	textMorph bounds: (bounds expandBy: 0 @ 2).
	self addMorphFront: textMorph.
	evt hand newMouseFocus: textMorph.
	self flag: #arNote.	"Why???"
"
	evt hand newKeyboardFocus: textMorph."
	textMorph editor selectFrom: 1 to: textMorph paragraph text string size! !


!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:29'!
drawOn: aCanvas 
	| stringColor stringBounds leftEdge |

	stringColor := color.
	isSelected & isEnabled
		ifTrue: [
			aCanvas fillRectangle: bounds color: (
				Display depth < 8
					ifTrue: [ Color veryLightGray ]
					ifFalse: [ Color lightBlue ])].
	leftEdge := 0.
	self hasIcon
		ifTrue: [| iconForm | 
			iconForm := isEnabled ifTrue:[self icon] ifFalse:[self icon asGrayScale].
			aCanvas paintImage: iconForm at: self left @ (self top + (self height - iconForm height // 2)).
			leftEdge := iconForm width + 2].

	self hasMarker
		ifTrue: [ leftEdge := leftEdge + self submorphBounds width + 8 ].

	stringBounds := bounds left: bounds left + leftEdge.

	aCanvas
		drawString: contents
		in: stringBounds
		font: self fontToUse
		color: stringColor.
	subMenu
		ifNotNil: [aCanvas paintImage: SubMenuMarker at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! !

!MenuItemMorph methodsFor: 'grabbing' stamp: 'jmv 4/27/2010 11:29'!
aboutToBeGrabbedBy: aHand
	"Don't allow the receiver to act outside a Menu"
	| menu box |
	(owner notNil and:[owner submorphs size = 1]) ifTrue:[
		"I am a lonely menuitem already; just grab my owner"
		owner stayUp: true.
		^owner aboutToBeGrabbedBy: aHand].
	box _ bounds.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: self.
	menu bounds: box.
	menu stayUp: true.
	self isSelected: false.
	^menu! !

!MenuItemMorph methodsFor: 'grabbing' stamp: 'jmv 4/27/2010 11:29'!
duplicateMorph: evt
	"Make and return a duplicate of the receiver's argument"
	| dup menu |
	dup _ self duplicate isSelected: false.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: dup.
	menu bounds: bounds.
	menu stayUp: true.
	evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here"
	^menu! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 4/27/2010 11:34'!
select: evt
	self isSelected: true.
	owner activeSubmenu: subMenu.
	subMenu ifNotNil: [
		subMenu delete.
		subMenu
			popUpAdjacentTo: (Array with: bounds topRight + (10@0)
									with: bounds topLeft)
			forHand: evt hand
			from: self.
		subMenu selectItem: nil event: evt].! !


!SystemWindow methodsFor: 'drawing' stamp: 'jmv 4/29/2010 08:59'!
makeMeVisible 

	self world extent > (0@0) ifFalse: [^ self].

	(self position >= (0@0) and: [ self position < (self world extent-self labelHeight)]) ifTrue: [
		^ self "OK -- at least my top left is visible"].

	"window not on screen (probably due to reframe) -- move it now"
	self isCollapsed
		ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)]
		ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft].

! !

!SystemWindow methodsFor: 'events' stamp: 'jmv 4/27/2010 10:19'!
doFastFrameDrag: grabPoint
	"Do fast frame dragging from the given point"
	"modified from doFastFrameDrag."

	| offset newBounds outerWorldBounds |
	outerWorldBounds _ self displayBounds.
	offset _ outerWorldBounds origin - grabPoint.
	newBounds _ outerWorldBounds newRectFrom: [:f | 
		Sensor cursorPoint + offset extent: outerWorldBounds extent].
	self position: (self internalizePositionToOwner: newBounds topLeft from: nil); comeToFront! !

!SystemWindow methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:32'!
extent: aPoint 
	"Set the receiver's extent to value provided. Respect my minimumExtent."

	| newExtent |
	newExtent _ self isCollapsed
		ifTrue: [aPoint]
		ifFalse: [aPoint max: self minimumExtent].
	newExtent = self extent ifTrue: [^ self].

	isCollapsed
		ifTrue: [super extent: newExtent x @ (self labelHeight + 2)]
		ifFalse: [super extent: newExtent].
	isCollapsed
		ifTrue: [collapsedFrame _ bounds]
		ifFalse: [fullFrame _ bounds]! !

!SystemWindow methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:33'!
justDroppedInto: aMorph event: anEvent
	isCollapsed
		ifTrue: [
			self position: ((self position max: 0@0) grid: 8@8).
			collapsedFrame _ bounds]
		ifFalse: [
			fullFrame _ bounds.
			TopWindow ~~ self ifTrue: [self activate]].
	^super justDroppedInto: aMorph event: anEvent! !

!SystemWindow methodsFor: 'geometry' stamp: 'jmv 4/27/2010 11:33'!
position: newPos
	super position: newPos.
	isCollapsed
		ifTrue: [collapsedFrame _ bounds]
		ifFalse: [fullFrame _ bounds].
! !

!SystemWindow methodsFor: 'menu' stamp: 'jmv 4/27/2010 10:23'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu.  This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self color;
		putUpFor: self near: self fullDisplayBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'jmv 4/27/2010 11:19'!
setWindowColor
	"Allow the user to select a new basic color for the window"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self paneColorToUse;
		putUpFor: self
			near: self fullDisplayBounds! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 4/27/2010 11:41'!
collapseOrExpand
	"Collapse or expand the window, depending on existing state"
	| cf |
	isCollapsed
		ifTrue: [
			"Expand -- restore panes to morphics structure"
			isCollapsed _ false.
			self activate.  "Bring to frint first"
			Preferences collapseWindowsInPlace
				ifTrue: [
					fullFrame := fullFrame align: fullFrame topLeft with: bounds topLeft]
				ifFalse: [
					collapsedFrame _ bounds].
			self bounds: fullFrame.
			paneMorphs reverseDo: [ :m |  
				self addMorph: m.
				self world startSteppingSubmorphsOf: m]]
		ifFalse: [
			"Collapse -- remove panes from morphics structure"
			isCollapsed _ true.
			fullFrame _ bounds.
			"First save latest fullFrame"
			paneMorphs do: [:m | m delete; releaseCachedState].
			model modelSleep.
			cf := self getCollapsedFrame.
			(collapsedFrame isNil and: [Preferences collapseWindowsInPlace not]) ifTrue:
				[collapsedFrame _ cf].
			self bounds: cf].
	self layoutChanged! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 4/27/2010 11:32'!
doFastWindowReframe: ptName

	| newBounds |
	"For fast display, only higlight the rectangle during loop"
	newBounds _ bounds newRectButtonPressedDo: [:f | 
		f 
			withSideOrCorner: ptName
			setToPoint: (self internalizePositionFromWorld: Sensor cursorPoint)
			minExtent: self minimumExtent].
	self bounds: newBounds! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 4/27/2010 11:33'!
spawnPaneFrameHandle: event 
	| resizer localPt side growingPane newBounds adjoiningPanes limit cursor |
	(self world firstSubmorph isKindOf: NewHandleMorph) 
		ifTrue: [^self	"Prevent multiple handles"].
	((self innerBounds withHeight: self labelHeight + 4) 
		containsPoint: event cursorPoint) 
			ifTrue: [^self	"in label or top of top pane"].
	growingPane _ self paneWithLongestSide: [:s | side _ s]
				near: event cursorPoint.
	growingPane ifNil: [^self].
	"don't resize pane side coincident with window side - RAA 5 jul 2000"
	(growingPane perform: side) = (self innerBounds perform: side) 
		ifTrue: [^self].
	(side == #top and: [growingPane top = self panelRect top]) ifTrue: [^self].
	adjoiningPanes _ paneMorphs 
				select: [:pane | pane bounds bordersOn: growingPane bounds along: side].
	limit _ adjoiningPanes isEmpty 
				ifFalse: 
					[(adjoiningPanes collect: [:pane | pane bounds perform: side]) 
						perform: ((#(#top #left) includes: side) ifTrue: [#max] ifFalse: [#min])]
				ifTrue: [ bounds perform: side].
	cursor _ Cursor resizeForEdge: side.
	resizer _ (NewHandleMorph new)
				sensorMode: self fastFramingOn;
				followHand: event hand
					forEachPointDo: 
						[:p | 
						localPt _ self internalizePositionFromWorld: p.
						newBounds _ growingPane bounds 
									withSideOrCorner: side
									setToPoint: localPt
									minExtent: 40 @ self minPaneHeightForReframe
									limit: limit.
						self fastFramingOn 
							ifTrue: 
								["For fast display, only higlight the rectangle during loop"

								Cursor currentCursor == cursor 
									ifFalse: 
										[(event hand)
											visible: false;
											refreshWorld;
											visible: true.
										cursor show].
								newBounds _ growingPane bounds newRectButtonPressedDo: 
												[:f | 
												growingPane bounds 
													withSideOrCorner: side
													setToPoint: (self internalizePositionFromWorld: Sensor cursorPoint)
													minExtent: 40 @ self minPaneHeightForReframe
													limit: limit].].
								self 
									reframePanesAdjoining: growingPane
									along: side
									to: newBounds.
]
					lastPointDo: [:p | ]
					withCursor: cursor.
	event hand world addMorphInLayer: resizer.
	resizer startStepping! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 4/27/2010 11:36'!
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]]].
	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: (bounds perform: corner)) < 20 ifTrue: [ptName _ corner]].
	cursor _ Cursor resizeForEdge: ptName.
	resizer _ (NewHandleMorph new)
				sensorMode: self fastFramingOn;
				followHand: event hand
					forEachPointDo: 
						[:p | 
						localPt _ self internalizePositionFromWorld: p.
						newBounds _ 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! !


!TextEditor methodsFor: 'editing keys' stamp: 'jmv 4/27/2010 10:23'!
chooseColor
	"Make a new Text Color Attribute, let the user pick a color, and return the attribute"

	| attribute |
	(ColorPickerMorph new)
		choseModalityFromPreference;
		sourceHand: morph activeHand;
		target: (attribute := TextColor color: Color black);
		selector: #color:;
		originalColor: Color black;
		putUpFor: morph near: morph fullDisplayBounds.	"default"
	^attribute! !


!TextMorph methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:33'!
drawOn: aCanvas
	"Draw the receiver on a canvas"

	| fauxBounds |
	self setDefaultContentsIfNil.
	super drawOn: aCanvas.  "Border and background if any"
	false ifTrue: [self debugDrawLineRectsOn: aCanvas].  "show line rects for debugging"
	text size = 0
		ifTrue: [self drawNullTextOn: aCanvas].
	"Hack here:  The canvas expects bounds to carry the location of the text, but we also need to communicate clipping."
	fauxBounds _ bounds topLeft corner: self innerBounds bottomRight.
	aCanvas paragraph: self paragraph bounds: fauxBounds color: color! !


!StringMorphEditor methodsFor: 'drawing' stamp: 'jmv 4/27/2010 11:32'!
drawOn: aCanvas

	aCanvas fillRectangle: bounds color: Color yellow muchLighter.
	^ super drawOn: aCanvas! !


!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jmv 4/27/2010 11:33'!
offImage: aForm
	offImage _ aForm.
	self invalidRect: bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jmv 4/27/2010 11:33'!
onImage: aForm
	image _ aForm.
	self invalidRect: bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jmv 4/27/2010 11:33'!
pressedImage: aForm
	pressedImage _ aForm.
	self invalidRect: bounds.! !


!TransformMorph methodsFor: 'layout' stamp: 'jmv 4/27/2010 11:03'!
doLayoutIfNeeded
	"Overridden to do nothing, just as #fullBounds"! !


!WorldState methodsFor: 'hands' stamp: 'jmv 4/27/2010 11:19'!
selectHandsToDrawForDamage: damageList
	"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."

	| result hBnds |
	result _ OrderedCollection new.
	hands do: [:h |
		h needsToBeDrawn ifTrue: [
			h hasChanged
				ifTrue: [result add: h]
				ifFalse: [
					hBnds _ h fullDisplayBounds.
					(damageList detect: [:r | r intersects: hBnds] ifNone: nil)
						ifNotNil: [result add: h]]]].
	^ result
! !

!WorldState methodsFor: 'update cycle' stamp: 'jmv 4/27/2010 11:07'!
displayWorld: aWorld submorphs: submorphs
	"Update this world's display."

	| deferredUpdateMode worldDamageRects handsToDraw handDamageRects allDamage |

	submorphs do: [:m | m doLayoutIfNeeded].  "force re-layout if needed"
	self checkIfUpdateNeeded ifFalse: [^ self].  "display is already up-to-date"

	deferredUpdateMode _ self doDeferredUpdatingFor: aWorld.
	deferredUpdateMode ifFalse: [self assuredCanvas].

	worldDamageRects _ self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas.  "repair world's damage on canvas"
	"self handsDo:[:h| h noticeDamageRects: worldDamageRects]."
	handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects.
	handDamageRects _ handsToDraw collect: [:h | h savePatchFrom: canvas].
	allDamage _ worldDamageRects, handDamageRects.

	handsToDraw reverseDo: [:h | canvas fullDrawMorph: h].  "draw hands onto world canvas"

	"*make this true to flash damaged areas for testing*"
	Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].

	canvas finish.
	"quickly copy altered rects of canvas to Display:"
	deferredUpdateMode
		ifTrue: [self forceDamageToScreen: allDamage]
		ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage].
	handsToDraw do: [:h | h restoreSavedPatchOn: canvas].  "restore world canvas under hands"
	Display deferUpdates: false; forceDisplayUpdate.
! !

!WorldState methodsFor: 'update cycle' stamp: 'jmv 4/27/2010 11:19'!
drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas 
	"Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
were redrawn."

	| rectList c i n mm morphs rects rectToFill remnants rect validList |
	rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox.
	"sort by areas to draw largest portions first"
	rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area].
	damageRecorder reset.
	n := submorphs size.
	morphs := OrderedCollection new: n * 2.
	rects := OrderedCollection new: n * 2.
	validList := OrderedCollection new: n * 2.
	rectList do: 
			[:dirtyRect | 
			dirtyRect allAreasOutsideList: validList
				do: 
					[:r | 
					"Experimental top-down drawing --
			Traverses top to bottom, stopping if the entire area is filled.
			If only a single rectangle remains, then continue with the reduced rectangle."

					rectToFill := r.
					i := 1.
					[rectToFill isNil or: [i > n]] whileFalse: 
							[mm := submorphs at: i.
							((mm fullDisplayBounds intersects: r) and: [mm visible]) 
								ifTrue: 
									[morphs addLast: mm.
									rects addLast: rectToFill.
									remnants := mm areasRemainingToFill: rectToFill.
									remnants size = 1 ifTrue: [rectToFill := remnants first].
									remnants isEmpty ifTrue: [rectToFill := nil]].
							i := i + 1].

					"Now paint from bottom to top, but using the reduced rectangles."
					rectToFill 
						ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)].
					[morphs isEmpty] whileFalse: 
							[(rect := rects removeLast) == rectToFill 
								ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)].
							c fullDrawMorph: morphs removeLast].
					morphs reset.
					rects reset.
					validList add: r]].
	^validList! !

PasteUpMorph removeSelector: #modelWakeUp!
Morph removeSelector: #boundsInWorld!
Morph removeSelector: #fullBoundsInWorld!
Morph removeSelector: #worldBounds!
LightWidget removeSelector: #fullBoundsInWorld!
