'From Squeak3.1alpha of 5 February 2001 [latest update: #3536] on 7 February 2001 at 12:59:31 am'!
"Change Set:		buttonFire
Date:			7 February 2001
Author:			Scott Wallace

¥ Adds 'fire' to the vocabulary of any morph/player; for those morphs that constitute our (overlarge) library of Buttons (this includes MenuItemMorphs), in every case this will actually trigger the button's action.  #fire also provides glue to two other button-programming mechanisms also available in Morphic, namely Bob Arning's mouseUpCodeToRun mechanism, and the player-scripting ability to associate scripts with mouse-down and mouse-up actions.  It is conceivable that a morph could have all three kinds of firing code!!
¥ Adds, to the menu next to every user-defined script in a Viewer, a command allowing you directly to tear off a button to fire that script, access to which formerly required that you open up the Scriptor first.
¥ Fixes a few buglets and gets the scripting system's structures reinitialized."!


!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:09'!
doButtonAction
	"If the receiver has a button-action defined, do it now.  The default button action of any morph is, well, to do nothing.  Note that there are several ways -- too many ways -- for morphs to have button-like actions.  This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism.  Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"! !

!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:22'!
fire
	"If the receiver has any kind of button-action defined, fire that action now.   Any morph can have special, personal mouseUpCodeToRun, and that will be triggered by this.  Additionally, some morphs have specific buttonness, and these get sent the #doButtonAction message to carry out their firing.  Finally, some morphs have mouse behaviors associated with one or more Player scripts.
	For the present, we'll try out doing *all* the firings this object can do. "

	self firedMouseUpCode.   	"This will run the mouseUpCodeToRun, if any"

	self player ifNotNil:		
		[self player fireOnce].  "Run mouseDown and mouseUp scripts"

	self doButtonAction			"Do my native button action, if any"! !

!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 22:41'!
firedMouseUpCode
	"If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false"

	| evt |
	(self world == nil or: [self mouseUpCodeOrNil == nil]) ifTrue: [^ false].

	evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self programmedMouseUp: evt for: self.
	^ true
	

! !

!Morph methodsFor: 'debug and other' stamp: 'sw 2/6/2001 22:35'!
mouseUpCodeOrNil
	"If the receiver has a mouseUpCodeToRun, return it, else return nil"

	^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]! !


!MenuItemMorph methodsFor: 'events' stamp: 'sw 2/7/2001 00:03'!
doButtonAction
	"Called programattically, this should trigger the action for which the receiver is programmed"

	self invokeWithEvent: nil! !


!Morph class methodsFor: 'scripting' stamp: 'sw 2/6/2001 23:50'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
		(#basic (
			(slot x 'The x coordinate' number readWrite player getX player setX:)
			(slot y  	'The y coordinate' number readWrite	player 	getY player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' number)
			(command turn: 'Change the heading of the object by the specified amount' number)
			(command beep: 'Make the specified sound' sound)))

		"note: if you change the thing below you also need to change #tileScriptCommands."
		(#scripts (
			(command emptyScript 'an empty script'))
		)
		(#'color & border' (
			(slot color 'The color of the object' color readWrite player getColor  player  setColor:)
			(slot colorUnder 'The color under the center of the object' color readOnly player getColorUnder unused  unused )
			(slot luminanceUnder 'The luminance under the center of the object' number readOnly player getLuminanceUnder unused unused)
			(slot saturationUnder 'The saturation under the center of the object' number readOnly player getSaturationUnder unused unused)
			(slot brightnessUnder 'The brightness under the center of the object' number readOnly player getBrightnessUnder unused unused)
			(slot borderColor 'The color of the object''s border' color readWrite player getBorderColor player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' number readWrite player getBorderWidth player setBorderWidth:)
			(slot roundedCorners 'Whether corners should be rounded' boolean readWrite player getRoundedCorners player setRoundedCorners:)))

		(geometry (
			(slot  scaleFactor 'The factor by which the object is magnified' number readWrite player getScaleFactor player setScaleFactor:)
			(slot  left   'The left edge' number readWrite player getLeft  player  setLeft:)
			(slot right  'The right edge' number readWrite player getRight  player  setRight:)
			(slot  top  'The top edge' number readWrite player getTop  player  setTop:) 
			(slot  bottom  'The bottom edge' number readWrite player getBottom  player  setBottom:) 
			(slot  width  'The width' number readWrite player getWidth  player  setWidth:)
			(slot  height  'The height' number readWrite player getHeight  player  setHeight:) 
			(slot x   'The x coordinate' number readWrite player  getX   player setX:)
			(slot y   'The y coordinate' number readWrite player  getY  player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading  player setHeading:)))

		(miscellaneous (
			(command doMenuItem: 'do the menu item' menu)
			(command show 'make the object visible')
			(command hide 'make the objhect invisible')
			(command wearCostumeOf: 'wear the costume of...' player)
			(command startScript: 'start the given script ticking' string)
			(command stopScript: 'make the given script be "normal"' string)
			(command pauseScript: 'make the given script be "paused"' string)
			(command tellAllSiblings: 'send a message to all siblings' string)
			(command fire 'trigger any and all of this object''s button actions')
			(slot copy 'returns a copy of this object' player readOnly player getNewClone	 unused unused)
			(slot elementNumber 'my index in my container' number readWrite player getIndexInOwner player setIndexInOwner:)))

		(motion (
			(slot x 'The x coordinate' number readWrite player getX player setX:)
			(slot y  	'The y coordinate' number readWrite	player 	getY player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' number)
			(slot obtrudes 'whether the object sticks out over its container''s edge' boolean readOnly player getObtrudes unused unused) 
			(command moveToward: 'move toward the given object' player) 
			(command turn: 'Change the heading of the object by the specified amount' number)
			(command bounce: 'bounce off the edge if hit' sound) 
			(command wrap 'wrap off the edge if appropriate') 
			(command followPath 'follow the yellow brick road') 
			(command goToRightOf: 'place this object to the right of another' player)))

		(#'pen use' (
			(slot penColor 'the color of ink used by the pen' color readWrite player getPenColor player setPenColor:) 
			(slot penSize 'the width of the pen' number readWrite player getPenSize player setPenSize:) 
			(slot penDown 'whether the pen is currently down' boolean readWrite player getPenDown player setPenDown:)))

		(#tests (
			(slot isOverColor 'whether any part of the object is over the given color' boolean	readOnly player seesColor: unused unused) 
			(slot isUnderMouse 'whether the object is under the current mouse position' boolean readOnly	player getIsUnderMouse unused unused)
			(slot colorSees	'whether the given color sees the given color' boolean readOnly	player color:sees:	unused	unused)
			(slot touchesA	'whether I touch something that looks like...' boolean readOnly player touchesA:	unused	unused)
			(slot obtrudes 'whether the object sticks out over its container''s edge' boolean readOnly player getObtrudes unused unused))))! !

!Morph class methodsFor: 'scripting' stamp: 'sw 2/6/2001 23:46'!
helpContributions
	"Answer a list of pairs of the form (<symbol> <help message> ) to contribute to the system help dictionary"
	
"NB: Many of the items here are not needed any more since they're specified as part of command definitions now.  Someone needs to take the time to go through the list and remove items no longer needed.  But who's got that kind of time?"

	^ #(
		(acceptScript:for:
			'submit the contents of the given script editor as the code defining the given selector')
		(actorState
			'return the ActorState object for the receiver, creating it if necessary')
		(addInstanceVariable
			'start the interaction for adding a new instance variable to the receiver')
		(addPlayerMenuItemsTo:hand:
			'add player-specific menu items to the given menu, on behalf of the given hand.  At present, these are only commands relating to the turtle')
		(addYesNoToHand
			'Press here to tear off a  TEST/YES/NO unit which you can drop into your script')
		(allScriptEditors
			'answer a list off the extant ScriptEditors for the receiver')
		(amount
			'The amount of displacement')
		(angle	
			'The angular displacement')
		(anonymousScriptEditorFor:
			'answer a new ScriptEditor object to serve as the place for scripting an anonymous (unnamed, unsaved) script for the receiver')
		(append:
			'add an object to this container')
		(assignDecrGetter:setter:amt:
			'evaluate the decrement variant of assignment')
		(assignGetter:setter:amt:
			'evaluate the vanilla variant of assignment')
		(assignIncrGetter:setter:amt:
			'evalute the increment version of assignment')
		(assignMultGetter:setter:amt:
			'evaluate the multiplicative version of assignment')
		(assureEventHandlerRepresentsStatus
			'make certain that the event handler associated with my current costume is set up to conform to my current script-status')
		(assureExternalName
			'If I do not currently have an external name assigned, get one now')
		(assureUniClass
			'make certain that I am a member a uniclass (i.e. a unique subclass); if I am not, create one now and become me into an instance of it')
		(availableCostumeNames
			'answer a list of strings representing the names of all costumes currently available for me')
		(availableCostumesForArrows
			'answer a list of actual, instantiated costumes for me, which can be cycled through as the user hits a next-costume or previous-costume button in a viewer')
		(beep:
			'make the specified sound')
		(borderColor
			'The color of the object''s border')
		(borderWidth
			'The width of the object''s border')
		(bottom
			'My bottom edge, measured downward from the top edge of the world')
		(bounce:
			'If object strayed beyond the boundaries of its container, make it reflect back into it, making the specified noise while doing so.')
		(bounce
			'If object strayed beyond the boundaries of its container, make it reflect back into it')
		(chooseTrigger
'When this script should run.
"normal" means "only when called"')
		(clearTurtleTrails
			'Clear all the pen trails in the interior.')
		(color	
			'The object''s interior color')
		(colorSees
			'Whether a given color in the object is over another given color')
		(colorUnder
			'The color under the center of the object')
		(copy
			'Return a new object that is very much like this one')
		(cursor	
			'The index of the chosen element')
		(deleteCard
			'Delete the current card.')
		(dismiss
			'Click here to dismiss me')
		(doMenuItem:
			'Do a menu item, the same way as if it were chosen manually')
		(elementNumber
			'My element number as seen by my owner')
		(fire
			'Run any and all button-firing scripts of this object')
		(firstPage
			'Go to first page of book')
		(followPath
				'Retrace the path the object has memorized, if any.')
		(forward:
			'Moves the object forward in the direction it is heading') 
		(goto:
			'Go to the specfied book page')
		(goToNextCardInStack
			'Go to the next card')
		(goToPreviousCardInStack
			'Go to the previous card.')
		(goToRightOf:
			'Align the object just to the right of any specified object.')
		(heading
			'Which direction the object is facing.  0 is straight up') 
		(height	
			'The distance between the top and bottom edges of the object')
		(hide
			'Make the object so that it does not display and cannot handle input')
		(initiatePainting	
			'Initiate painting of a new object in the standard playfield.')
		(initiatePaintingIn:
			'Initiate painting of a new object in the given place.')
		(isOverColor
			'Whether any part of this object is directly over the specified color')
		(isUnderMouse
			'Whether any part of this object is beneath the current mouse-cursor position')
		(lastPage
			'Go to the last page of the book.')
		(left
			'My left edge, measured from the left edge of the World')
		(leftRight
			'The horizontal displacement')
		(liftAllPens
			'Lift the pens on all the objects in my interior.')
		(lowerAllPens
			'Lower the pens on all the objects in my interior.')
		(mouseX
			'The x coordinate of the mouse pointer')
		(mouseY
			'The y coordinate of the mouse pointer')
		(moveToward:
			'Move in the direction of another object.')
		(insertCard
			'Create a new card.')
		(nextPage
			'Go to next page.')
		(numberAtCursor
			'The number held by the object at the chosen element')
		(objectNameInHalo
			'Object''s name -- To change: click here, edit, hit ENTER')
		(obtrudes
			'Whether any part of the object sticks out beyond its container''s borders')
		(offerScriptorMenu
			'Scriptee and script name.
Press to get a menu')
		(pauseScript:
			'Make a running script become paused.')
		(penDown
			'Whether the object''s pen is down (true) or up (false)')
		(penColor
			'The color of the object''s pen')
		(penSize	
			'The size of the object''s pen')
		(playerSeeingColorPhrase
			'The player who "sees" a given color')
		(previousPage
			'Go to previous page')

		(show
			'If object was hidden, make it show itself again.')
		(startScript:
			'Make a script start running.')
		(stopScript:
			'Make a script stop running.')
		(top
			'My top edge, measured downward from the top edge of the world')
		(right
			'My right edge, measured from the left edge of the world')
		(roundUpStrays
			'Bring all out-of-container subparts back into view.')
		(scaleFactor
			'The amount by which the object is scaled')
		(stopScript:
			'make the specified script stop running')
		(tellAllSiblings:
			'send a message to all of my sibling instances')
		(try
			'Run this command once.')
		(tryMe
			'Click here to run this script once; hold button down to run repeatedly')
		(turn:				
			'Change the heading of the object by the specified amount')
		(unhideHiddenObjects
			'Unhide all hidden objects.')
		(upDown
			'The vertical displacement')
		(userScript
			'This is a script defined by you.')
		(userSlot
			'This is an instance variable defined by you.  Click here to change its type')
		(valueAtCursor
			'The chosen element')
		(wearCostumeOf:
			'Wear the same kind of costume as the other object')
		(width	
			'The distance between the left and right edges of the object')
		(wrap
			'If object has strayed beond the boundaries of its container, make it reappear from the opposite edge.')
		(x
			'The x coordinate, measured from the left of the container')
		(y
			'The y-coordinate, measured upward from the bottom of the container')

		)
! !


!MenuItemMorph class methodsFor: 'class initialization' stamp: 'sw 2/7/2001 00:04'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions'))))
! !


!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:04'!
editDescriptionForSelector:  aSelector
	"Allow the user to edit the balloon-help description for the given selector"

	(self class userScriptForPlayer: self selector: aSelector) editDescription.
	self updateAllViewers! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:06'!
infoFor: anElement inViewer: aViewer
	"The user made a gesture asking for info/menu relating"

	| aMenu elementType aSelector |
	elementType _ self elementTypeFor: anElement.
	((elementType = #systemSlot) | (elementType == #userSlot))
		ifTrue:	[^ self slotInfoButtonHitFor: anElement inViewer: aViewer].
	
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu defaultTarget: self.
	aSelector _ anElement asSymbol.
	(elementType == #userScript)
		ifTrue:
			[aMenu add: 'destroy "', anElement, '"' selector: #removeScriptWithSelector: argument: aSelector.
			aMenu add: 'rename  "', anElement, '"' selector: #renameScript: argument: aSelector.
			aMenu add: 'textual scripting pane'  selector: #makeIsolatedCodePaneForSelector: argument: aSelector.
			aMenu add: 'button to fire this script' selector: #tearOffButtonToFireScriptForSelector: argument: aSelector.
			aMenu add: 'edit balloon help' selector: #editDescriptionForSelector: argument: aSelector.
			"aMenu add: 'pacify this script' selector: #pacifyScript: argument: aSelector"].
	aMenu items size == 0 ifTrue:
		[aMenu add: 'ok' action: nil].
	aMenu addTitle: anElement asString, ' (', elementType, ')'.

	aMenu popUpInWorld: aViewer world! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:03'!
makeIsolatedCodePaneForSelector: aSelector
	"make an isolated code pane for the given selector"

	MethodHolder makeIsolatedCodePaneForClass: self class selector: aSelector
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:01'!
removeScriptWithSelector: aSelector
	"Remove the given script, and get the display right"

	self removeScript: aSelector fromWorld:  self currentWorld
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:10'!
tearOffButtonToFireScriptForSelector: aSelector
	"Tear off a button to fire the script for the given selector"

	| aButton |
	aButton _ ScriptActivationButton new target: self.
	aButton actionSelector: #runScript:.
	aButton arguments: (Array with: aSelector).
	aButton establishLabelWording.
	self currentHand attachMorph: aButton! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 2/6/2001 23:21'!
fireOnce
	"If the receiver has any script armed to be triggered on mouse down and/or mouse-up, run those scripts now -- first the mouseDown ones, then the mouseUp ones."

	self instantiatedUserScriptsDo:
		[:aScriptInst |
			aScriptInst status == #mouseDown ifTrue: [aScriptInst fireOnce]].
	self instantiatedUserScriptsDo:
		[:aScriptInst |
			aScriptInst status == #mouseUp ifTrue: [aScriptInst fireOnce]].
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/5/2001 11:25'!
doButtonAction
	"Do the button action of my costume"

	self costume renderedMorph doButtonAction! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/6/2001 21:13'!
fire
	"Do the button action of my costume"

	self costume renderedMorph fire! !


!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/5/2001 14:11'!
tearOfButtonToFireScript
	"Tear off a button to fire this script"

	playerScripted tearOffButtonToFireScriptForSelector: scriptName! !


!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 2/6/2001 23:16'!
fireOnce
	"Run this script once"

	player perform: selector! !


!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'sw 2/6/2001 23:54'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions'))))
! !


!ScriptActivationButton class methodsFor: 'viewer' stamp: 'sw 2/6/2001 23:24'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions')
			(slot color 'The color of the object' color readWrite player getColor  player  setColor:)
			(slot height  'The height' number readWrite player getHeight  player  setHeight:) 
			(slot borderColor 'The color of the object''s border' color readWrite player getBorderColor player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' number readWrite player getBorderWidth player setBorderWidth:)
			(slot roundedCorners 'Whether corners should be rounded' boolean readWrite player getRoundedCorners player setRoundedCorners:) 
			(slot actWhen 'When the script should fire' buttonPhase  readWrite player getActWhen player setActWhen: ))))! !


!ScriptableButton class methodsFor: 'viewer' stamp: 'sw 2/6/2001 23:25'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions')

			(slot label 'The wording on the button' string readWrite player getLabel player setLabel:)
			(slot color 'The color of the object' color readWrite player getColor  player  setColor:)
			(slot height  'The height' number readWrite player getHeight  player  setHeight:) 
			(slot borderColor 'The color of the object''s border' color readWrite player getBorderColor player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' number readWrite player getBorderWidth player setBorderWidth:)
			(slot  height  'The height' number readWrite player getHeight  player  setHeight:)
			(slot roundedCorners 'Whether corners should be rounded' boolean readWrite player getRoundedCorners player setRoundedCorners:) 
			(slot actWhen 'When the script should fire' buttonPhase  readWrite player getActWhen player setActWhen: ))))! !


"Postscript:"
StandardScriptingSystem initialize.
!