'From Squeak3.1alpha [latest update: #''Squeak3.1alpha'' of 28 February 2001 update 3905] on 5 April 2001 at 6:16:56 pm'! "Change Set: foosCostume-sw Date: 5 April 2001 Author: Scott Wallace Adds, for SketchMorphs, a virtual #costume slot and a corresponding #graphic data type, thus allowing scripting commands such as foo's costume _ bar's costume"! TileMorph subclass: #GraphicTile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting Tiles'! !GraphicTile commentStamp: '' prior: 0! A tile representing a graphic image.! !Object methodsFor: 'viewer' stamp: 'sw 4/2/2001 00:51'! tileForArgType: typeSymbol inViewer: aViewer "Answer a tile to represent an argument of the given type; the viewer argument is actually used, but nowadays in only a vacuous sense that should be excised, since the viewer does not use anything about itself in its subsequent code" | aColor aPlayer | typeSymbol == #player ifTrue: [aPlayer _ self presenter ifNotNil: [self presenter standardPlayer] ifNil: "It happens, if costume is not currently in a world" [self]. ^ aViewer tileForPlayer: aPlayer]. aColor _ ScriptingSystem colorForType: typeSymbol. typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor]. typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor]. typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor]. typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor]. typeSymbol == #graphic ifTrue: [^ GraphicTile new typeColor: aColor]. typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor]. typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor]. typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative]. typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType: typeSymbol]. self error: 'Unrecognized type'! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 4/5/2001 17:51'! readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector "Answer a readout morph for the given part" | readout | (partType == #player) ifTrue: [readout _ PlayerReferenceReadout new objectToView: scriptedPlayer viewSelector: getSelector putSelector: putSelector]. (partType == #graphic) ifTrue: [readout _ ThumbnailMorph new objectToView: scriptedPlayer viewSelector: getSelector. readout extent: 21@21]. (partType == #color) ifTrue: [readout _ UpdatingRectangleMorph new. readout getSelector: (ScriptingSystem getterSelectorFor: partName); target: scriptedPlayer; borderWidth: 1; extent: 22@22. putSelector == #unused ifFalse: [readout putSelector: (ScriptingSystem setterSelectorFor: partName)]]. readout ifNil: "player, graphic, and color types handled above, the rest fall here" [readout _ scriptedPlayer updatingTileForArgType: partType partName: partName getSelector: getSelector putSelector: putSelector]. readout step. ^ readout! ! !GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:40'! initialize "Initialize the receiver, giving it a default graphic" super initialize. type _ #literal. self useForm: (ScriptingSystem formAtKey: #Menu). ! ! !GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:52'! setLiteral: anObject "Set the receiver's literal to be anObject. No readout morph here." type _ #literal. self setLiteralInitially: anObject. ! ! !GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:40'! useForm: aForm "Set the receiver to represent the given form" | thumbnail | self removeAllMorphs. literal _ aForm. thumbnail _ ThumbnailMorph new objectToView: self viewSelector: #literal. self addMorphBack: thumbnail. thumbnail extent: 16 @ 16.! ! !GraphicTile methodsFor: 'compilation' stamp: 'sw 4/2/2001 23:09'! storeCodeOn: aStream indent: tabCount "Write code that will reconstitute the receiver" aStream nextPutAll: literal uniqueNameForReference! ! !GraphicTile methodsFor: 'queries' stamp: 'sw 4/3/2001 15:41'! resultType "Answer the result type of the argument represented by the receiver" ^ #graphic! ! !PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 4/3/2001 18:14'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ # ( (playfield ( (command initiatePainting 'Initiate painting of a new object in the standard playfield.') (slot mouseX 'The x coordinate of the mouse pointer' number readWrite player getMouseX unused unused) (slot mouseY 'The y coordinate of the mouse pointer' number readWrite player getMouseY unused unused) (command roundUpStrays 'Bring all out-of-container subparts back into view.') (slot numberAtCursor 'the number at the cursor' number readWrite player getNumberAtCursor player setNumberAtCursor: ) (slot playerAtCursor 'the object currently at the cursor' player readWrite player getValueAtCursor unused unused) (slot costumeAtCursor 'the graphic worn by the object at the cursor' graphic readOnly player getCostumeAtCursor unused unused) (command unhideHiddenObjects 'Unhide all hidden objects.'))) (collections ( (slot cursor 'The index of the chosen element' number readWrite player getCursor player setCursorWrapped:) (slot playerAtCursor 'the object currently at the cursor' player readWrite player getValueAtCursor unused unused) (slot firstElement 'The first object in my contents' player readWrite player getFirstElement player setFirstElement:) (slot numberAtCursor 'the number at the cursor' number readWrite player getNumberAtCursor player setNumberAtCursor: ) (slot costumeAtCursor 'the graphic worn by the object at the cursor' graphic readOnly player getCostumeAtCursor unused unused) (command removeAll 'Remove all elements from the playfield') (command shuffleContents 'Shuffle the contents of the playfield') (command append: 'Add the object to my content' player))) (#'stack navigation' ( (command goToNextCardInStack 'Go to the next card') (command goToPreviousCardInStack 'Go to the previous card') (command goToFirstCardInBackground 'Go to the first card of the current background') (command goToFirstCardOfStack 'Go to the first card of the entire stack') (command goToLastCardInBackground 'Go to the last card of the current background') (command goToLastCardOfStack 'Go to the last card of the entire stack') (command deleteCard 'Delete the current card') (command insertCard 'Create a new card'))) (viewing ( (slot viewingNormally 'whether contents are viewed normally' boolean readWrite player getViewingByIcon player setViewingByIcon: ))) (#'pen trails' ( (command liftAllPens 'Lift the pens on all the objects in my interior.') (command lowerAllPens 'Lower the pens on all the objects in my interior.') (command clearTurtleTrails 'Clear all the pen trails in the interior.')))) ! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 4/2/2001 00:55'! tileForArgType: typeSymbol "Anwer a default tile to represent a datum of the given argument type" | aColor | typeSymbol == #player ifTrue: [^ self tileForPlayer: self presenter standardPlayer]. aColor _ ScriptingSystem colorForType: typeSymbol. typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor]. typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor]. typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor]. typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor]. typeSymbol == #graphic ifTrue: [^ GraphicTile new typeColor: aColor]. typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor]. typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor]. typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative]. typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType: typeSymbol]. self error: 'Unrecognized type'! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 4/2/2001 01:18'! tileForArgType: typeSymbol inViewer: aViewer "Answer a tile to represent a value of the given type in the given viewer" | aColor aPlayer | typeSymbol == #player ifTrue: [aPlayer _ self presenter ifNotNil: [self presenter standardPlayer] ifNil: "It happens, if costume is not currently in a world" [self]. ^ self tileForPlayer: aPlayer]. aColor _ ScriptingSystem colorForType: typeSymbol. typeSymbol == #point ifTrue: [^ TileMorph new setLiteral: 0@0; typeColor: aColor]. typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor]. typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor]. typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor]. typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor]. typeSymbol == #graphic ifTrue: [^ GraphicTile new typeColor: aColor]. typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor]. typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor]. typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative]. typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType: typeSymbol]. typeSymbol == #text ifTrue: [^ ("(TextMorph new contents: 'setup')" 'aborning' newTileMorphRepresentative) typeColor: aColor]. self error: 'Unrecognized type'! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 4/5/2001 17:50'! getCostume "Answer a form representing the receiver's primary graphic" | aMorph | ^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph) ifTrue: [aMorph form] ifFalse: [aMorph imageForm]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 4/3/2001 18:11'! getCostumeAtCursor "Answer the form representing the object at the current cursor" | anObject aMorph | anObject _ self getValueFromCostume: #valueAtCursor. ^ anObject == 0 "weird return from GraphMorph" ifTrue: [ScriptingSystem formAtKey: #Paint] ifFalse: [((aMorph _ anObject renderedMorph) isKindOf: SketchMorph) ifTrue: [aMorph form] ifFalse: [anObject imageForm]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 4/3/2001 17:58'! setCostume: aForm "Set the receiver's graphic as indicated" | aMorph | ^ ((aMorph _ costume renderedMorph) isKindOf: SketchMorph) ifTrue: [aMorph form: aForm] ifFalse: ["what to do?"]! ! !Player methodsFor: 'slots-user' stamp: 'sw 4/2/2001 13:24'! chooseSlotTypeFor: slotName "Let the user designate a type for the given slot" | typeChoices typeChosen | self flag: #deferred. "sound should be reinstated but too much difficulty at present" typeChoices _ #(number player boolean color string graphic sound "point costume"). typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: 'Choose the TYPE for ', slotName. typeChosen isEmptyOrNil ifTrue: [^ self]. (self typeForSlot: slotName) = typeChosen ifTrue: [^ self]. (self slotInfoAt: slotName) type: typeChosen. self class allInstancesDo: "allSubInstancesDo:" [:anInst | anInst instVarNamed: slotName asString put: (anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName)). anInst updateAllViewers] ! ! !Player methodsFor: 'slots-user' stamp: 'sw 4/3/2001 14:27'! initialValueForSlotOfType: aType "Answer the default initial value to ascribe to a slot of the given type" aType == #number ifTrue: [^ (1 to: 9) atRandom]. aType == #boolean ifTrue: [^ true]. aType == #player ifTrue: [^ self costume presenter standardPlayer]. aType == #color ifTrue: [^ Color random]. aType == #string ifTrue: [^ 'abc']. aType == #sound ifTrue: [^ 'croak']. aType == #graphic ifTrue: [^ ScriptingSystem formAtKey: #PaintTab]. aType == #point ifTrue: [^ 20 @ 30]. aType == #buttonPhase ifTrue: [^ #buttonUp]. ^ nil! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 4/3/2001 15:33'! updatingTileForArgType: typeSymbol partName: partName getSelector: getSelector putSelector: putSelector "Answer a readout tile representing the given part's value, given the putter, getter, and type information" | aColor aTile displayer | aColor _ Color lightGray lighter. typeSymbol == #number ifTrue: [aTile _ NumericReadoutTile new typeColor: aColor]. typeSymbol == #sound ifTrue: [aTile _ SoundReadoutTile new typeColor: aColor]. typeSymbol == #buttonPhase ifTrue: [aTile _ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType: typeSymbol]. aTile ifNil: [aTile _ StringReadoutTile new typeColor: aColor]. displayer _ UpdatingStringMorph new getSelector: getSelector; target: self; growable: true; minimumWidth: 24; putSelector: ((putSelector == #unused) ifTrue: [nil] ifFalse: [putSelector]). "Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details" typeSymbol == #string ifTrue: [displayer useStringFormat. displayer growable: true] ifFalse: [(typeSymbol == #sound) ifTrue: [displayer useStringFormat] ifFalse: [displayer useDefaultFormat]]. aTile addMorphBack: displayer. ((putSelector ~~ #unused) and: [#(number sound boolean buttonPhase) includes: typeSymbol]) ifTrue: [aTile addArrows]. getSelector numArgs == 0 ifTrue: [aTile setLiteralInitially: (self perform: getSelector)]. ^ aTile! ! !SketchMorph class methodsFor: 'scripting' stamp: 'sw 4/3/2001 17:59'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((graphics ( (slot costume 'The picture currently being worn' graphic readWrite player getCostume player setCostume:)))) ! ! !StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 4/3/2001 15:35'! initializeTypeColors "Initialize the list of hard-coded type colors. The list of types is nascent and there are some not-yet-deployed types mentioned. Think of nothing here as sacred." "ScriptingSystem initializeTypeColors" TypeColorDictionary _ IdentityDictionary new. #((command (0.065 0.258 1.0) (0.065 0.258 1.0)) (number (0.8 0.4 0.2) (1.0 0.6 0.2)) (boolean (0.94 1.0 0.06) (0.94 1.0 0.06)) "some kind of yellowish" (player (1.0 0 0.065) (1.0 0 0.065)) (string (0.0 0.0 1.0) (0.0 0.0 1.0)) "not in use" (color (1.0 0 0.065) (0.806 1.0 0.806)) "some damn dark red" (sound (1.0 0.06 0.84) (1.0 0.06 0.84)) "a kind of magenta" (buttonPhase (0.806 1.0 0.806) (0.806 1.0 0.806)) "arbitrary" (menu (0.4 0.4 0.4) (0.4 0.4 0.4)) "arbitrary" (graphic (0.806 1.0 0.806) (0.806 1.0 0.806)) "arbitrary" (object (1.0 0.26 0.98) (1.0 0.26 0.98)) "backstop" (rotationStyle (1.0 0.26 0.98) (1.0 0.26 0.98)) "future" (group (0.0 0.0 1.0) (0.0 0.0 1.0)) "not in use" (costume (0.806 1.0 0.806) (0.806 1.0 0.806)) "not in use" ) do: [:triplet | TypeColorDictionary at: triplet first put: (Array with: ((Color fromRgbTriplet: triplet second) mixed: self colorFudge with: ScriptingSystem uniformTileInteriorColor) with: (Color fromRgbTriplet: triplet third))]! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'sw 4/2/2001 00:56'! resultType "Look up my result type. If I am a constant, use that class. If I am a message, look up the selector." | list value soundChoices | parseNode class == BlockNode ifTrue: [^ #blockContext]. parseNode class == AssignmentNode ifTrue: [^ #command]. parseNode class == ReturnNode ifTrue: [^ #command]. "Need more restriction than this" list _ submorphs select: [:ss | ss isSyntaxMorph and: [ss parseNode ~~ nil]]. list size > 1 ifTrue: [^ self resultTypeFor: self selector]. list size = 1 ifTrue: ["test for levels that are just for spacing in layout" (list first isSyntaxMorph and: [list first nodeClassIs: MessageNode]) ifTrue: [ ^ list first resultType]]. "go down one level" value _ self try. value class == Error ifTrue: [^ #unknown]. (value isKindOf: Number) ifTrue: [^ #number]. (value isKindOf: Boolean) ifTrue: [^ #boolean]. (value isKindOf: Form) ifTrue: [^ #graphic]. value class == String ifTrue: [ soundChoices _ #('silence'). "default, if no SampledSound class" Smalltalk at: #SampledSound ifPresent: [:sampledSound | soundChoices _ sampledSound soundNames]. (soundChoices includes: value) ifTrue: [^ #sound]]. (value isKindOf: Player) ifTrue: [^ #player]. ^ value class name asLowercase "asSymbol (not needed)"! ! !ThumbnailMorph methodsFor: 'display' stamp: 'sw 4/3/2001 00:11'! drawForForm: aForm on: aCanvas "Draw a small view of the given form on the canvas" | scale shrunkForm viewedObjectBox interimCanvas | viewedObjectBox _ aForm boundingBox. scale _ self innerBounds width / (viewedObjectBox width max: viewedObjectBox height). interimCanvas _ Display defaultCanvasClass extent: viewedObjectBox extent depth: aCanvas depth. interimCanvas translateBy: viewedObjectBox topLeft negated during: [:tempCanvas | tempCanvas drawImage: aForm at: 0@0]. shrunkForm _ interimCanvas form magnify: interimCanvas form boundingBox by: scale smoothing: 1. lastFormShown _ shrunkForm. aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox center! ! !ThumbnailMorph methodsFor: 'display' stamp: 'sw 4/3/2001 15:55'! drawMeOn: aCanvas "Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside. Now also works if the thing to draw is a plain Form rather than a morph." | viewedMorphBox myBox scale c shrunkForm aWorld aFormOrMorph | super drawOn: aCanvas. ((aFormOrMorph _ self formOrMorphToView) isKindOf: Form) ifTrue: [^ self drawForForm: aFormOrMorph on: aCanvas]. (((aFormOrMorph ~~ nil and: [(aWorld _ aFormOrMorph world) ~~ nil]) and: [aWorld ~~ aFormOrMorph or: [lastFormShown == nil]]) and: [RecursionDepth + 1 < RecursionMax]) ifTrue: [RecursionDepth _ RecursionDepth + 1. viewedMorphBox _ aFormOrMorph fullBounds. myBox _ self innerBounds. scale _ myBox width / (viewedMorphBox width max: viewedMorphBox height). c _ Display defaultCanvasClass extent: viewedMorphBox extent depth: aCanvas depth. c translateBy: viewedMorphBox topLeft negated "recursion happens here" during:[:tempCanvas| tempCanvas fullDrawMorph: aFormOrMorph]. shrunkForm _ c form magnify: c form boundingBox by: scale smoothing: 1. lastFormShown _ shrunkForm. RecursionDepth _ RecursionDepth - 1] ifFalse: "This branch used if we've recurred, or if the thumbnail views a World that's already been rendered once, or if the referent is not in a world at the moment" [lastFormShown ifNotNil: [shrunkForm _ lastFormShown]]. shrunkForm ifNotNil: [aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox center] "sw 12/20/1999 13:35 special-case code for SketchMorph commented out, since it seems to have done more harm than good: ((aFormOrMorph isKindOf: SketchMorph) and: [false]) ifTrue: [diag _ aFormOrMorph form extent asInteger. viewedMorphBox _ (aFormOrMorph bounds center - (diag // 2)) extent: diag@diag] ifFalse: [viewedMorphBox _ aFormOrMorph fullBounds]."! ! !ThumbnailMorph methodsFor: 'what to view' stamp: 'sw 4/3/2001 00:13'! actualViewee "Return the actual morph to be viewed, or nil if there isn't an appropriate morph to view." | aMorph actualViewee | aMorph _ self morphToView ifNil: [^ nil]. aMorph isInWorld ifFalse: [^ nil]. actualViewee _ viewSelector ifNil: [aMorph] ifNotNil: [objectToView perform: viewSelector]. actualViewee == 0 ifTrue: [^ nil]. "valueAtCursor result for an empty HolderMorph" actualViewee ifNil: [actualViewee _ objectToView]. (actualViewee isKindOf: Player) ifTrue: [actualViewee _ actualViewee costume]. (actualViewee isMorph and: [actualViewee isFlexMorph and: [actualViewee submorphs size = 1]]) ifTrue: [actualViewee _ actualViewee firstSubmorph]. ^ actualViewee! ! !ThumbnailMorph methodsFor: 'what to view' stamp: 'sw 4/3/2001 16:03'! formOrMorphToView "Answer the form to be viewed, or the morph to be viewed, or nil" | actualViewee | (objectToView isKindOf: Form) ifTrue: [^ objectToView]. actualViewee _ viewSelector ifNil: [objectToView] ifNotNil: [objectToView perform: viewSelector]. ^ actualViewee == 0 ifTrue: [nil] "valueAtCursor result for an empty HolderMorph" ifFalse: [(actualViewee isKindOf: Player) ifTrue: [actualViewee costume] ifFalse: [actualViewee]]! ! !ThumbnailMorph reorganize! ('copying' veryDeepFixupWith: veryDeepInner:) ('display' drawForForm:on: drawMeOn: drawOn:) ('stepping' step stepTime) ('what to view' actualViewee formOrMorphToView morphToView) ('miscellaneous' installAsWonderlandTextureOn: tearOffTile) ('initialization' initialize objectToView: objectToView:viewSelector: releaseCachedState) ! !SketchMorph class reorganize! ('scripting' additionsToViewerCategories) ('new morph menu' includeInNewMorphMenu) ('instance creation' fromFile: fromStream: withForm:) ! "Postscript:" StandardScriptingSystem initialize. ScriptingSystem initializeTypeColors. Vocabulary initialize. !