'From etoys2.2 of 27 September 2007 [latest update: #1793] on 28 November 2007 at 1:11:45 am'!
"Change Set:		PopUpCaretFixLayout-tak
Date:			28 November 2007
Author:			Takashi Yamamiya

Fix bugs about pop up arrow's mouse hold down behavior and layout malfunction.

Trac #5126: New arrow doesn't handle mouse hold down.
Trac #5148: New arrow's strange behavior with 'forward by' and 'turn by' tile.
"!


!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 16:35'!
buildHPopArrows
	| panel left right |
	self outmostScriptEditor
		ifNil: [^ nil].
	(retractArrow isNil
			and: [suffixArrow isNil])
		ifTrue: [^ nil].
	panel := Morph new.
	panel cornerStyle: #rounded.
	left := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeLeftArrow).
	right := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeRightArrow).
	panel
		color: color.
	panel sticky: true.
	panel layoutPolicy: TableLayout new.
	panel listDirection: #leftToRight.
	panel hResizing: #shrinkWrap.
	panel vResizing: #shrinkWrap.
	panel cellInset: 4.
	panel layoutInset: 2.
	retractArrow
		ifNotNil: [panel addMorphBack: left].
	suffixArrow
		ifNotNil: [panel addMorphBack: right].
	panel
		on: #mouseLeave
		send: #hidePopArrows
		to: self.
	left
		on: #mouseUp
		send: #popArrowRetractArrowHit:
		to: self.
	right
		on: #mouseUp
		send: #popArrowSuffixArrowHit:
		to: self.
	^ panel! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/28/2007 01:06'!
buildVPopArrows
	| panel up down |
	upArrow
		ifNil: [^ nil].
	panel := Morph new.
	panel cornerStyle: #rounded.
	up := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeUpArrow).
	down := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeDownArrow).
	panel color: color.
	panel sticky: true.
	panel layoutPolicy: TableLayout new.
	panel listDirection: #topToBottom.
	panel hResizing: #shrinkWrap.
	panel vResizing: #shrinkWrap.
	panel cellInset: 4.
	panel layoutInset: 2.
	panel addMorphBack: up.
	panel addMorphBack: down.
	panel
		on: #mouseLeave
		send: #hidePopArrows
		to: self.
	up
		on: #mouseDown
		send: #popArrowUp:
		to: self.
	up
		on: #mouseMove
		send: #popArrowMouseMove:
		to: self.
	down
		on: #mouseDown
		send: #popArrowDown:
		to: self.
	down
		on: #mouseMove
		send: #popArrowMouseMove:
		to: self.
	^ panel! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 16:30'!
hidePopArrows
	| popArrows |
	popArrows := self activeHand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	popArrows second
		ifNotNil: [popArrows second delete].
	popArrows third
		ifNotNil: [popArrows third delete].
	self activeHand removeProperty: #popArrows! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/28/2007 01:07'!
popArrowDown: evt 
	self setProperty: #previousLiteral toValue: self literalFromContents.
	self setProperty: #previousPoint toValue: evt position.
	evt handler
		ifNotNil: [evt handler
				on: #mouseStillDown
				send: #popArrowDown:
				to: self].
	self currentHand releaseKeyboardFocus.
	self arrowAction: self arrowDelta negated! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 17:39'!
popArrowMouseMove: evt 
	| popArrows vpanel |
	popArrows := self activeHand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	vpanel := popArrows second.
	vpanel
		ifNotNil: [vpanel submorphs
				do: [:each | each
						on: #mouseStillDown
						send: nil
						to: nil]].
	self mouseMove: evt! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 16:35'!
popArrowSuffixArrowHit: evt 
	self showSuffixChoices.
	self showPopArrows! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 17:43'!
popArrowUp: evt 
	self setProperty: #previousLiteral toValue: self literalFromContents.
	self setProperty: #previousPoint toValue: evt position.
	evt handler
		ifNotNil: [evt handler
				on: #mouseStillDown
				send: #popArrowUp:
				to: self].
	self currentHand releaseKeyboardFocus.
	self arrowAction: self arrowDelta! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/27/2007 16:25'!
showPopArrows
	| vpanel hpanel |
	self hidePopArrows.
	self isPopArrowNeeded
		ifFalse: [^ self].
	vpanel := self buildVPopArrows.
	hpanel := self buildHPopArrows.
	self activeHand setProperty: #popArrows toValue: {self. vpanel. hpanel}.
	self layoutChanged! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 11/27/2007 16:32'!
mouseLeave: evt 
	"When the mouse is leaving and next object is not a pop arrow, remove
	pop arrows."
	| popArrows vpanel hpanel |
	popArrows := evt hand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	vpanel := popArrows second.
	hpanel := popArrows third.
	(vpanel notNil
			and: [vpanel containsPoint: evt position])
		ifTrue: [^ self].
	(hpanel notNil
			and: [hpanel containsPoint: evt position])
		ifTrue: [^ self].
	self hidePopArrows! !

!TileMorph methodsFor: 'layout' stamp: 'tak 11/27/2007 16:33'!
layoutChanged
	| vpanel hpanel popArrows |
	super layoutChanged.
	self labelMorph
		ifNil: [^ self].
	popArrows := self activeHand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	popArrows first == self
		ifFalse: [^ self].
	vpanel := popArrows second.
	hpanel := popArrows third.
	vpanel
		ifNotNil: [vpanel openInWorld.
			vpanel center: self labelMorph center.
			vpanel right: self labelMorph left - 2].
	hpanel
		ifNotNil: [hpanel openInWorld.
			hpanel center: self labelMorph center.
			hpanel left: self labelMorph right + 2]! !