'From etoys2.2 of 27 September 2007 [latest update: #1780] on 16 November 2007 at 10:59:23 am'!
"Change Set:		PopUpCaret-tak
Date:			14 November 2007
Author:			Takashi Yamamiya

Show pop up arrows (caret) when you mouse over a tile.
"
ScriptingSystem formDictionary at: #LargeUpArrow put: (
(GIFReadWriter on: (Base64MimeConverter mimeDecodeToBytes: 'R0lGODlhFwAYAJEAAFLOUv///////wAAACH5BAUUAAIALAAAAAAXABgAAAI3lI8CyY3r4gFU
Sgotw1UnnnkKGGpkeZ2oo65b6z6wBWNpHdUcq3dfb/sBS8PdpOhDGpU2pvNUAAA7' readStream) readStream) nextImage).

ScriptingSystem formDictionary at: #LargeDownArrow put: (
(GIFReadWriter on: (Base64MimeConverter mimeDecodeToBytes: 'R0lGODlhFwAYAJEAAFLOUv///////wAAACH5BAUUAAIALAAAAAAXABgAAAI3hI+pyw3iooCx
TVrTxflsnn1gJY5W2T2lqaxT6LJeLBv0y9z4ou9I75sBNcBg8SI8JpXHj8pVAAA7' readStream) readStream) nextImage).

ScriptingSystem formDictionary at: #LargeRightArrow put: (
(GIFReadWriter on: (Base64MimeConverter mimeDecodeToBytes: 'R0lGODlhGAAXAJEAAFLOUv///////wAAACH5BAUUAAIALAAAAAAYABcAAAI2BISpy2LW4npP
Skotw1gnznkgaI1jZJpbqn5sirzyTDp05t7rjMolK2oFQ55cpajAIZOHJaMAADs=' readStream) readStream) nextImage).

ScriptingSystem formDictionary at: #LargeLeftArrow put: (
(GIFReadWriter on: (Base64MimeConverter mimeDecodeToBytes: 'R0lGODlhGAAXAJEAAFLOUv///////wAAACH5BAUUAAIALAAAAAAYABcAAAI4lI+pArCfWoNQ
SqqsxUdr7nlUGD4kmZ1op55GC8fqK5dsfUW4s+BjDGpxaKshw2Yk5pI3HhPRKAAAOw==' readStream) readStream) nextImage).
!


!TileMorph commentStamp: 'tak 11/16/2007 10:43' prior: 0!
A tile with up, down and suffix arrows.

To install new Forms for the arrows, just nil out UpPicture, DownPicture,
or SuffixPicture.
Create actors with the picture you want and write it out with these file names:
'tile inc arrow.morph' 'tile dec arrow.morph' 'tile suffix
arrow.morph'.  Make sure that file is in the same directory as the image.
Open an EToy.


Properties for pop up arrow
  #previousLiteral : Object -- last literal.
  #previousPoint : Point -- last mouse position to use dragging arrow.
  #isPopArrowNeeded : Boolean -- true if arrows are needed.
  #popArrows (of HandMorph) : An array of Morph -- It points arrows for each hand.
!


!TileMorph methodsFor: 'arrows' stamp: 'tak 11/15/2007 17:57'!
addArrows
	"#isPopArrowNeeded is a flag to know whether this tile has arrows or not. Showing pop arrows depends on this flag."
	self setProperty: #isPopArrowNeeded toValue: true.
	(self class addArrowsOn: self)
		in: [:array | 
			upArrow := array first.
			downArrow := array second]! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/16/2007 00:31'!
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 white alpha: 0.7).
	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: #popArrowShowSuffixChoices:
		to: self.
	^ panel! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/16/2007 09:47'!
buildVPopArrows
	| panel up down |
	panel := Morph new.
	panel cornerStyle: #rounded.
	up := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeUpArrow).
	down := SketchMorph new
				form: (ScriptingSystem formAtKey: #LargeDownArrow).
	panel
		color: (Color white alpha: 0.7).
	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: #popArrowMouseDown:
		to: self.
	up
		on: #mouseMove
		send: #mouseMove:
		to: self.
	down
		on: #mouseDown
		send: #popArrowMouseDown:
		to: self.
	down
		on: #mouseMove
		send: #mouseMove:
		to: self.
	^ panel! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/16/2007 10:37'!
hidePopArrows: evt 
	| panels |
	panels := evt hand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	panels
		do: [:each | each
				ifNotNil: [each delete]].
	evt hand removeProperty: #popArrows! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/6/2007 12:49'!
popArrowClick: evt 
	self arrowAction: self arrowDelta! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/15/2007 17:49'!
popArrowMouseDown: evt 
	self setProperty: #previousLiteral toValue: self literalFromContents.
	self setProperty: #previousPoint toValue: evt position.
	self currentHand releaseKeyboardFocus.
	evt hand
		waitForClicksOrDrag: self
		event: evt
		selectors: {#popArrowClick:. nil. nil. nil}
		threshold: 5.
! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/15/2007 17:45'!
popArrowRetractArrowHit: evt 
	self retractArrowHit.
	self showPopArrows: evt! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/15/2007 17:45'!
popArrowShowSuffixChoices: evt 
	self showSuffixChoices.
	self showPopArrows: evt! !

!TileMorph methodsFor: 'arrows popup' stamp: 'tak 11/16/2007 10:38'!
showPopArrows: evt 
	| vpanel hpanel |
	self hidePopArrows: evt.
	(self hasProperty: #isPopArrowNeeded)
		ifFalse: [^ self].
	vpanel := self buildVPopArrows.
	hpanel := self buildHPopArrows.
	evt hand setProperty: #popArrows toValue: {vpanel. hpanel}.
	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]! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 11/15/2007 18:00'!
handlesMouseOver: evt 
	^ (self hasProperty: #isPopArrowNeeded)
		or: [super handlesMouseOver: evt]! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 11/6/2007 11:25'!
mouseEnter: evt
	self showPopArrows: evt! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 11/16/2007 10:37'!
mouseLeave: evt 
	"When the mouse is leaving and next object is not a pop arrow, remove pop arrows. "
	| popArrows |
	popArrows := evt hand
				valueOfProperty: #popArrows
				ifAbsent: [^ self].
	popArrows
		detect: [:each | each notNil
				and: [each containsPoint: evt position]]
		ifNone: [self hidePopArrows: evt]! !


!TileMorph reorganize!
('accessing' abandonLabelFocus associatedPlayer downArrow labelMorph lastTile literal literalFromContents literal: operatorOrExpression options playerBearingCode receiverType resultType retractArrow slotName suffixArrow type upArrow updatingStringMorph value value:)
('arrows' addArrows addCaretsAsAppropriate: addRetractArrow addRetractArrowAnyway addSuffixArrow addSuffixIfCan arrowAction: couldAddSuffixArrow couldRetract deleteSuffixArrow phraseForOp:arg:resultType: rescindRetractArrow rescindSuffixArrow retractArrowHit setVisibilityOfUpDownCarets: showSuffixChoices variableDelay: wrapPhraseInFunction)
('arrows popup' buildHPopArrows buildVPopArrows hidePopArrows: popArrowClick: popArrowMouseDown: popArrowRetractArrowHit: popArrowShowSuffixChoices: showPopArrows:)
('as yet unclassified' fixLayoutOfSubmorphsNotIn: fixUponLoad:seg: unhibernate)
('change reporting' colorChangedForSubmorph: ownerChanged)
('code generation' acceptNewLiteral codeString parseNodeWith: precedingTileType scriptEdited sexpWith: storeCodeOn:indent:)
('copying' veryDeepFixupWith: veryDeepInner:)
('dropping/grabbing' justGrabbedFrom:)
('event handling' grabMorph: handlesMouseDown: handlesMouseOver: handlesMouseStillDown: morphToDropInPasteUp: mouseDown: mouseEnter: mouseLeave: mouseMove: mouseStillDown: mouseUp: wantsKeyboardFocusFor:)
('events-processing' handlerForMouseDown:)
('e-toy support' adoptVocabulary: isCandidateForAutomaticViewing localeChanged)
('initialization' actualObject bePossessive bringUpToDate defaultBorderWidth emblazonPlayerNameOnReferenceTile emblazonPlayerNameOnReferenceTileWithin: initialize isPossessive rawVocabulary: referToSimilarObject: referTo: retargetFrom:to: setExpression:label: setLiteral: setOperatorAndUseArrows: setOperator: setOperator:andUseWording: setSlotRefOperator: setToReferTo: updateWordingToMatchVocabulary)
('macpal' currentVocabulary scriptPerformer)
('misc' addCustomMenuItems:hand: basicWidth currentEToyVocabulary handReferentMorph minimumWidth numericValue setLiteralInitially: soundChoices typeColor:)
('mouse handling' arrowDelta presentOperatorAlternatives: showOptions)
('player viewer' updateLiteralLabel)
('printing' printOn:)
('scripting' isTileLike isTileScriptingElement restoreTypeColor useUniformTileColor)
('testing' isTileMorph)
('tiles from method' selectorTile:in:)
('*connectors-commands' playerRepresented)
('*connectors-dropping/grabbing' justDroppedInto:event:)
('private' convertAlignment line1: test)
!