'From Squeak3.1alpha of 5 February 2001 [latest update: #3641] on 18 February 2001 at 6:51:25 pm'! "Change Set: scriptors-sw Date: 19 February 2001 Author: Scott Wallace ¥ Makes scriptors better able deal properly both with universal tiles and classic tiles. ¥ Defines MethodWithInterface as a MethodInterface bound to a particular class -- a layer of hierarchy between MethodInterface and UniclassScript. UniclassScript is now only used for scriptors involved with Classic tiles, where the ScriptEditorMorph must be held on to. ¥ Sets up two preferences, largeTiles and universalTiles, to be of the local-to-project variety. Removes the mechanisms that formerly dealt with these via the world's Project menu. Fixes up all senders of universalTiles so they now obtain it from the Preference. Caution: order in this update has been hand-jimmied. ¥ Much more..."! MethodInterface subclass: #MethodWithInterface instanceVariableNames: 'playerClass ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting'! !MethodWithInterface commentStamp: '' prior: 0! A MethodInterface bound to an actual class. selector A symbol - the selector being described argumentSpecifications A list of specifications for the formal arguments of the method resultSpecification A characterization of the return value of the method userLevel attributeKeywords A list of symbols, comprising keywords that the user wishes to associate with this method defaultStatus The status to apply to new instances of the class by default defaultFiresPerTick How many fires per tick, by default, should be allowed if ticking. playerClass The actual class with which this script is associated! MethodWithInterface subclass: #UniclassScript instanceVariableNames: 'currentScriptEditor formerScriptingTiles isTextuallyCoded ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting'! !UniclassScript commentStamp: 'sw 2/17/2001 03:35' prior: 0! Represents a tile script of uniclass. Holds the ScriptEditorMorph structures for the current version of a user-defined tile script, as well as previous versions thereof. In addition to the instance variables of my superclass, my instance variables are: currentScriptEditor The current version of the ScriptEditorMorph for the script formerScriptingTiles A collection of pairs, ( (list of morphs)) each pair characterizing a prior tile version isTextuallyCoded A boolean. If true, then a hand-crafted user coding supersedes the tale of the tiles. This architecture is in transition, perhaps.! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2001 03:54'! comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form." | mapFakeClassesToReal ccFixups receiverClasses rootsToUnhiberhate myProject | self flag: #bobconv. RecentlyRenamedClasses _ nil. "in case old data hanging around" mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." ccFixups _ self remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream. ccFixups ifFalse: [^ self error: 'A class in the file is not compatible']. endMarker _ segment nextObject. "for enumeration of objects" endMarker == 0 ifTrue: [endMarker _ 'End' clone]. arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers. "Can't use install. Not ready for rehashSets" mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. receiverClasses _ self restoreEndianness. "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [self declare: importedObject]]. arrayOfRoots do: [:importedObject | (importedObject isKindOf: Project) ifTrue: [ myProject _ importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. ScriptEditorMorph writingUniversalTiles: ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]]. rootsToUnhiberhate _ arrayOfRoots select: [:importedObject | importedObject respondsTo: #unhibernate "ScriptEditors and ViewerFlapTabs" ]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keys do: [:aFake | aFake indexIfCompact > 0 ifTrue: [aFake becomeUncompact]. aFake removeFromSystemUnlogged]. SystemOrganization removeEmptyCategories]. "^ self"! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/30/2001 11:37'! convertFromUserScript: aUserScript "The argument represents an old UserScript object. convert it over" defaultStatus _ aUserScript status.! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:44'! initialize "Initialize the receiver by setting its inst vars to default values" super initialize. defaultStatus _ #normal! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/23/2001 18:28'! playerClass: aPlayerClass selector: aSelector "Set the playerClass and selector of the receiver" playerClass _ aPlayerClass. selector _ aSelector! ! !MethodWithInterface methodsFor: 'rename' stamp: 'sw 2/17/2001 04:10'! okayToRename "Answer whether the receiver is in a state to be renamed." ^ true! ! !MethodWithInterface methodsFor: 'rename' stamp: 'sw 2/17/2001 03:16'! renameScript: newSelector fromPlayer: aPlayer "the receiver's selector has changed to the new selector. get various things right, including the physical appearance of any Scriptor open on this method" self allScriptEditors do: [:aScriptEditor | aScriptEditor renameScriptTo: newSelector]. selector _ newSelector asSymbol. self bringUpToDate. playerClass atSelector: selector putScript: self. ! ! !MethodWithInterface methodsFor: 'updating' stamp: 'sw 2/17/2001 01:27'! bringUpToDate "Bring all scriptors related to this method up to date. Note that this will not change the senders of this method if the selector changed -- that's something still ahead." (ScriptEditorMorph allInstances select: [:m | (m playerScripted isMemberOf: playerClass) and: [m scriptName == selector]]) do: [:m | m bringUpToDate]! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 2/17/2001 03:10'! allScriptEditors "Answer all the script editors that exist for the class and selector of this interface" ^ ScriptEditorMorph allInstances select: [:aScriptEditor | aScriptEditor playerScripted class == playerClass and: [aScriptEditor scriptName == selector]]! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 2/17/2001 03:28'! currentScriptEditor: anEditor "Set the receiver's currentScriptEditor as indicated, if I care. MethodWithInterface does not care, since it does not hold on to a ScriptEditor. A subclass of mine, however does, or did, care"! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 1/29/2001 22:02'! instantiatedScriptEditorForPlayer: aPlayer "Return a new script editor for the player and selector" | aScriptEditor | aScriptEditor _ (playerClass includesSelector: selector) ifTrue: [ScriptEditorMorph new fromExistingMethod: selector forPlayer: aPlayer] ifFalse: [ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector]. defaultStatus == #ticking ifTrue: [aPlayer costume arrangeToStartStepping]. ^ aScriptEditor! ! !Morph methodsFor: 'naming' stamp: 'sw 2/18/2001 18:41'! renameTo: aName "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix References. New tiles: recompile, and recreate open scripts. If coming in from disk, and have name conflict, References will already have new name." | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName | oldName _ self knownName. (renderer _ self topRendererOrSelf) setNameTo: aName. putInViewer _ false. ((aPresenter _ self presenter) isNil or: [renderer player isNil]) ifFalse: [putInViewer _ aPresenter currentlyViewing: renderer player. putInViewer ifTrue: [renderer player viewerFlapTab hibernate]]. "empty it temporarily" (aPasteUp _ self topPasteUp) ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]. "Fix References dictionary. See restoreReferences to know why oldKey is already aName, but oldName is the old name." oldKey _ References keyAtIdentityValue: renderer player ifAbsent: [nil]. oldKey ifNotNil: [assoc _ References associationAt: oldKey. oldKey = aName ifFalse: ["normal rename" assoc key: aName asSymbol. References rehash]]. putInViewer ifTrue: [aPresenter viewMorph: self]. "recreate my viewer" oldKey ifNil: [^ aName]. "Force strings in tiles to be remade with new name. New tiles only." Preferences universalTiles ifFalse: [^ aName]. classes _ (Smalltalk allCallsOn: assoc) collect: [:classAndMethod | (classAndMethod findTokens: Character separators) first asSymbol]. (classes asSet) do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName]. "replace in text body of all methods. Can be wrong!!" "Redo the tiles that are showing. This is also done in caller in unhibernate." aPasteUp ifNotNil: [ aPasteUp allTileScriptingElements do: [:mm | "just ScriptEditorMorphs". (mm isKindOf: ScriptEditorMorph) ifTrue: [((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc) ifTrue: [mm hibernate; unhibernate]]]]. ^ aName! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 2/14/2001 18:00'! shiftedYellowButtonMenu "Answer the menu to be presented when the yellow button is pressed while the shift key is down" ^ SelectionMenu fromArray: #( ('set font... (k)' offerFontMenu) ('set style... (K)' changeStyle) ('set alignment...' chooseAlignment) - ('explain' explain) ('pretty print' prettyPrint) ('pretty print with color' prettyPrintWithColor) ('file it in (G)' fileItIn) ('tiles from it' selectionAsTiles) ('recognizer (r)' recognizeCharacters) ('spawn (o)' spawn) - ('definition of word' wordDefinition) ('verify spelling of word' verifyWordSpelling) " ('spell check it' spellCheckIt) " ('translate it' translateIt) ('choose language' languagePrefs) - ('browse it (b)' browseIt) ('senders of it (n)' sendersOfIt) ('implementors of it (m)' implementorsOfIt) ('references to it (N)' referencesToIt) ('selectors containing it (W)' methodNamesContainingIt) ('method strings with it (E)' methodStringsContainingit) ('method source with it' methodSourceContainingIt) - ('save contents to file...' saveContentsInFile) ('send contents to printer' sendContentsToPrinter) ('printer setup' printerSetup) - ('special menu...' presentSpecialMenu) ('more...' yellowButtonActivity))! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/18/2001 17:01'! acceptScript: aScriptEditorMorph for: aSelector "Accept the tile code in the script editor as the code for the given selector. This branch is only for the classic-tile system, 1997-2001" | aUniclassScript | self class compileInobtrusively: aScriptEditorMorph methodString classified: 'scripts'. aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol. aUniclassScript currentScriptEditor: aScriptEditorMorph! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/15/2001 17:14'! isUniversalTiles "Return true if I (my world) uses universal tiles. This message can be called in places where the current World is not known, such as when writing out a project." ^ costume world ifNil: [ScriptEditorMorph writingUniversalTiles == true "only valid during a project write"] ifNotNil: [Preferences universalTiles]! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/16/2001 01:41'! newScriptorAround: aPhraseTileMorph "Sprout a scriptor around aPhraseTileMorph, thus making a new script" | aScriptEditor aUniclassScript tw blk | aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self. aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self. Preferences universalTiles ifTrue: [aScriptEditor install. "to get a default script there" aScriptEditor insertUniversalTiles. tw _ aScriptEditor findA: TwoWayScrollPane. aPhraseTileMorph ifNotNil: [blk _ tw scroller firstSubmorph "MethodNode" lastSubmorph "BlockNode". blk addMorphFront: aPhraseTileMorph. "aPhraseTileMorph position: self topLeft + (7@14)" aPhraseTileMorph accept]. aScriptEditor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft] ifFalse: [aPhraseTileMorph ifNotNil: [aScriptEditor phrase: aPhraseTileMorph] "does an install" ifNil: [aScriptEditor install]]. self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector]. "The above assures the presence of a ScriptInstantiation for the new selector in all siblings" self updateAllViewersAndForceToShow: #scripts. ^ aScriptEditor! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 04:01'! newTextualScriptorFor: aSelector "Sprout a scriptor for aSelector, opening up in textual mode. Rather special-purpose, consult my lone sender" | aMethodWithInterface aScriptEditor | (self class selectors includes: aSelector) ifTrue: [self error: 'selector already exists']. aMethodWithInterface _ self class permanentUserScriptFor: aSelector player: self. aScriptEditor _ aMethodWithInterface instantiatedScriptEditorForPlayer: self. aScriptEditor install. aScriptEditor showSourceInScriptor. self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aMethodWithInterface selector]. "The above assures the presence of a ScriptInstantiation for the new selector in all siblings" self updateAllViewersAndForceToShow: #scripts. ^ aScriptEditor! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 03:19'! pacifyScript: aSymbol "Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side" | aHandler aUserScript | aUserScript _ self class userScriptForPlayer: self selector: aSymbol. aUserScript ifNil: [self flag: #deferred. ^ self beep]. "Maddeningly, without this line here the thing IS nil and the debugger is in a bad state (the above note dates from 1/12/99 ?!!" self class allInstancesDo: [:aPlayer | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: []. (aHandler _ aPlayer costume renderedMorph eventHandler) ifNotNil: [aHandler forgetDispatchesTo: aSymbol]]! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/18/2001 18:13'! renameScript: oldSelector "The user has asked to rename the script formerly known by oldSelector; obtain a new selector from the user, check it out, and if all is well, ascribe the new name as appropriate" | reply newSelector aUserScript | self flag: #deferred. "Relax the restriction below, before too long" aUserScript _ self class userScriptForPlayer: self selector: oldSelector. aUserScript okayToRename ifFalse: [self inform: 'Sorry, we do not permit you to rename classic-tiled scripts that are currently textually coded. Go back to tile scripts and try again. Humble apologies.'. ^ self]. reply _ FillInTheBlank request: 'Script Name' initialAnswer: oldSelector. reply size == 0 ifTrue: [^ self]. reply = oldSelector ifTrue:[^ self beep]. newSelector _ ScriptingSystem acceptableScriptNameFrom: reply forScriptCurrentlyNamed: oldSelector asScriptNameIn: self world: costume world. Preferences universalTiles ifTrue: ["allow colons" (reply copyWithout: $:) = newSelector ifTrue: [newSelector _ reply asSymbol] ifFalse: [self inform: 'name will be modified']]. self renameScript: oldSelector newSelector: newSelector ! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 03:17'! renameScript: oldSelector newSelector: newSelector "Rename the given script to have the new selector" | aUserScript anInstantiation | aUserScript _ self class userScriptForPlayer: self selector: oldSelector. aUserScript renameScript: newSelector fromPlayer: self. "updates all script editors, and inserts the new script in my scripts directory" self class removeScriptNamed: oldSelector. self class allSubInstancesDo: [:aPlayer | anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector. anInstantiation changeSelectorTo: newSelector. aPlayer costume actorState instantiatedUserScriptsDictionary removeKey: oldSelector; at: newSelector put: anInstantiation. anInstantiation assureEventHandlerRepresentsStatus]. self updateAllViewersAndForceToShow: 'scripts' ! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 01:05'! scriptEditorFor: aSelector "Answer the receiver's script editor for aSelector" | aScriptEditor | aScriptEditor _ (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditorForPlayer: self. aScriptEditor updateToPlayer: self. aScriptEditor bringUpToDate. ^ aScriptEditor! ! !Player methodsFor: 'misc' stamp: 'sw 2/14/2001 18:04'! tileReferringToSelf "answer a tile that refers to the receiver" | aTile nn tile | Preferences universalTiles ifTrue: [nn _ self externalName. "name it, if necessary, and put in References" (References includesKey: nn asSymbol) ifFalse: [ References at: nn asSymbol put: self]. tile _ SyntaxMorph new parseNode: (VariableNode new name: nn key: nn code: nil). tile layoutInset: 1; addMorph: (tile addString: nn). tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setObjectRef: nil "disused parm" actualObject: self; typeColor: (ScriptingSystem colorForType: #player). aTile enforceTileColorPolicy. ^ aTile! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 03:44'! assuredMethodInterfaceFor: aSelector "Answer the method interface object for aSelector, creating it if it does not already exist." | selSym aMethodInterface | selSym _ aSelector asSymbol. aMethodInterface _ self scripts at: selSym ifAbsent: [scripts at: selSym put: (self nascentUserScriptInstance playerClass: self selector: selSym)]. ^ aMethodInterface! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 02:50'! atSelector: aSelector putScript: aMethodWithInterface "Place the given method interface in my directory of scripts, at the given selector" self scripts at: aSelector asSymbol put: aMethodWithInterface! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/18/2001 18:42'! nascentUserScriptInstance "Answer a new script object of the appropriate class" | classToUse | classToUse _ Preferences universalTiles ifTrue: [MethodWithInterface] ifFalse: [UniclassScript]. ^ classToUse new! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 00:59'! permanentUserScriptFor: aSelector player: aPlayer "Create and answer a suitable script object for the given player (who will be an instance of the receiver) and selector. Save that script-interface object in my (i.e. the class's) directory of scripts" | entry | scripts ifNil: [scripts _ IdentityDictionary new]. entry _ self nascentUserScriptInstance playerClass: aPlayer class selector: aSelector. scripts at: aSelector put: entry. ^ entry! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 01:01'! userScriptForPlayer: aPlayer selector: aSelector "Answer the user script for the player (one copy for all instances of the uniclass) and selector" | newEntry existingEntry | scripts ifNil: [scripts _ IdentityDictionary new]. existingEntry _ scripts at: aSelector ifAbsent: [nil]. "Sorry for all the distasteful isKindOf: and isMemberOf: stuff here, folks; it arises out of concern for preexisting content saved on disk from earlier stages of this architecture. Someday much of it could be cut loose" Preferences universalTiles ifTrue: [(existingEntry isMemberOf: MethodWithInterface) ifTrue: [^ existingEntry]. newEntry _ (existingEntry isKindOf: UniclassScript) ifTrue: [existingEntry as: MethodWithInterface] "let go of extra stuff if it was UniclassScript" ifFalse: [MethodWithInterface new playerClass: aPlayer selector: aSelector]. scripts at: aSelector put: newEntry] ifFalse: [(existingEntry isKindOf: UniclassScript) ifTrue: [^ existingEntry] ifFalse: [newEntry _ UniclassScript new playerClass: aPlayer class selector: aSelector. scripts at: aSelector put: newEntry. existingEntry ifNotNil: "means it is a grandfathered UserScript that needs conversion" [newEntry convertFromUserScript: existingEntry]. ^ newEntry]]! ! !Presenter methodsFor: 'viewer' stamp: 'sw 2/18/2001 18:05'! cacheSpecs: aMorph "For SyntaxMorph's type checking, cache the list of all viewer command specifications." aMorph world ifNil: [^ true]. Preferences universalTiles ifFalse: [^ true]. Preferences eToyFriendly ifFalse: [^ true]. "not checking" self flag: #noteToTed. "I'm confused about what to do about #fullCheck." (Project current projectPreferenceAt: #fullCheck ifAbsent: [false]) ifFalse: [^ true]. "not checking" SyntaxMorph initialize.! ! !ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/14/2001 18:16'! repelsMorph: aMorph event: ev "Answer whether the receiver shoul repel the given morph" ^ Preferences universalTiles ifTrue: [(aMorph respondsTo: #parseNode) not] ifFalse: [aMorph isTileLike not]! ! !ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/14/2001 18:33'! addYesNoToHand "Place a test/yes/no complex in the hand of the beloved user" | ms messageNodeMorph | Preferences universalTiles ifTrue: [ms _ MessageSend receiver: true selector: #ifTrue:ifFalse: arguments: {['do nothing']. ['do nothing']}. messageNodeMorph _ ms asTilesIn: playerScripted class. "messageNodeMorph setProperty: #whoIsSelf toValue: playerScripted." self primaryHand attachMorph: messageNodeMorph] ifFalse: [self primaryHand attachMorph: CompoundTileMorph new]! ! !ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/17/2001 03:12'! install "Accept the current classic tiles as the new source code for the script" Preferences universalTiles ifFalse: [self removeSpaces. scriptName ifNotNil: [playerScripted acceptScript: self topEditor for: scriptName asSymbol]]! ! !ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/15/2001 20:04'! showSourceInScriptor "Remove tile panes, if any, and show textual source instead" | aCodePane | self isTextuallyCoded ifFalse: [self becomeTextuallyCoded]. "Mostly to fix up grandfathered ScriptEditors" self removeAllButFirstSubmorph. aCodePane _ MethodHolder isolatedCodePaneForClass: playerScripted class selector: scriptName. aCodePane hResizing: #spaceFill; vResizing: #spaceFill; minHeight: 100. self hResizing: #shrinkWrap; vResizing: #shrinkWrap. self addMorphBack: aCodePane. self fullBounds. self listDirection: #topToBottom; hResizing: #rigid; vResizing: #rigid; rubberBandCells: true; minWidth: self width. showingMethodPane _ true. self currentWorld startSteppingSubmorphsOf: self! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/16/2001 00:39'! becomeTextuallyCoded "If the receiver is not currently textually coded, make it become so now, and show its source in place in the Scriptor" self isTextuallyCoded ifTrue: [^ self]. self saveScriptVersion. Preferences universalTiles ifFalse: [self userScriptObject becomeTextuallyCoded]. (submorphs copyFrom: 2 to: submorphs size) do: [:m | m delete]! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/14/2001 18:13'! hibernate "Possibly delete the tiles, but only if using universal tiles." Preferences universalTiles ifTrue: [submorphs size > 1 ifTrue: [submorphs second delete]]! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/15/2001 16:09'! insertUniversalTiles "Insert universal tiles for the method at hand" self insertUniversalTilesForClass: playerScripted class selector: scriptName! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/15/2001 15:51'! insertUniversalTilesForClass: aClass selector: aSelector "Add a submorph which holds the universal-tiles script for the given class and selector" | source tree syn widget | source _ aClass sourceCodeAt: aSelector. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. widget _ syn inAScrollPane. widget color: Color transparent; setProperty: #hideUnneededScrollbars toValue: true; setProperty: #maxAutoFitSize toValue: 300@200. self addMorphBack: widget. widget extent: (self width - 10 @ 150). ! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/18/2001 18:45'! offerScriptorMenu "Put up a menu in response to the user's clicking in the menu-request area of the scriptor's heaer" | aMenu count | self modernize. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: scriptName asString. count _ self savedTileVersionsCount. Preferences universalTiles ifFalse: [self showingMethodPane ifFalse: "currently showing tiles" [aMenu add: 'show code textually' action: #showSourceInScriptor. count > 0 ifTrue: [aMenu add: 'revert to tile version...' action: #revertScriptVersion]. aMenu add: 'save this version' action: #saveScriptVersion] ifTrue: "current showing textual source" [count >= 1 ifTrue: [aMenu add: 'revert to tile version' action: #revertToTileVersion]]]. aMenu addList: #( - ('destroy this script' destroyScript) ('rename this script' renameScript) ('button to fire this script' tearOfButtonToFireScript) ('edit balloon help for this script' editMethodDescription) - ('fires per tick...' chooseFrequency) ('explain status alternatives' explainStatusAlternatives) - ('hand me a tile for self' tileForSelf) ('hand me a "random number" tile' handUserRandomTile) ('hand me a "button down?" tile' handUserButtonDownTile) ('hand me a "button up?" tile' handUserButtonUpTile) ). aMenu popUpInWorld: self currentWorld. " ('add parameter to this script' addParameter)" ! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/15/2001 17:08'! removeAllButFirstSubmorph "Remove all of the receiver's submorphs other than the first one. Not particular to ScriptEditorMorph in principle but placed here for now because there are no other users." self submorphs allButFirst do: [:m | m delete] ! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/15/2001 20:04'! toggleWhetherShowingTiles "Toggle between showing the method pane and showing the tiles pane" self showingMethodPane ifFalse: "currently showing tiles" [self showSourceInScriptor] ifTrue: "current showing textual source" [(Preferences universalTiles or: [self savedTileVersionsCount >= 1]) ifTrue: [self revertToTileVersion] ifFalse: [self beep]]! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/15/2001 16:10'! unhibernate "Recreate my tiles from my method if I have new universal tiles." self world ifNil: [(playerScripted == nil or: [playerScripted isUniversalTiles not]) ifTrue: [^ self]] ifNotNil: [Preferences universalTiles ifFalse: [^ self]]. self insertUniversalTiles. self hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft.! ! !ScriptEditorMorph methodsFor: 'drawing' stamp: 'sw 2/14/2001 18:12'! drawOn: aCanvas "may need to unhibernate the script lazily here." (Preferences universalTiles and: [self submorphs size < 2]) ifTrue: [WorldState addDeferredUIMessage: [self unhibernate] fixTemps]. ^ super drawOn: aCanvas! ! !ScriptableButton methodsFor: 'script' stamp: 'sw 2/17/2001 04:02'! editButtonsScript "The user has touched my Scriptor halo-handle. Bring up a Scriptor on the script of the button." | cardsPasteUp cardsPlayer anEditor | cardsPasteUp _ self pasteUpMorph. (cardsPlayer _ cardsPasteUp assuredPlayer) assureUniClass. anEditor _ scriptSelector ifNil: [scriptSelector _ cardsPasteUp scriptSelectorToTriggerFor: self. cardsPlayer newTextualScriptorFor: scriptSelector] ifNotNil: [(cardsPlayer class selectors includes: scriptSelector) ifTrue: [cardsPlayer scriptEditorFor: scriptSelector] ifFalse: ["Method somehow got removed; I guess we start aftresh" scriptSelector _ nil. ^ self editButtonsScript]]. self currentHand attachMorph: anEditor. ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/18/2001 18:30'! morphToDropInPasteUp: aPasteUp "If property #beScript is true, create a scriptor around me." | actualObject itsSelector aScriptor adjustment handy tw blk | (self valueOfProperty: #beScript ifAbsent: [false]) ifFalse: [^ self]. self removeProperty: #beScript. (actualObject _ self actualObject) ifNil: [^ self]. actualObject assureUniClass. itsSelector _ self userScriptSelector. aScriptor _ itsSelector isEmptyOrNil ifFalse: [adjustment _ 0@0. actualObject scriptEditorFor: itsSelector] ifTrue: ["It's a system-defined selector; construct an anonymous scriptor around it" adjustment _ 60 @ 20. actualObject newScriptorAround: self]. handy _ aPasteUp primaryHand. aScriptor ifNotNil: [aScriptor position: handy position - adjustment. aPasteUp addMorphFront: aScriptor. "do this early so can find World" aScriptor showingMethodPane ifFalse: [(tw _ aScriptor findA: TwoWayScrollPane) ifNil: [ aScriptor insertUniversalTiles. itsSelector ifNil: ["blank script" tw _ aScriptor findA: TwoWayScrollPane. blk _ tw scroller firstSubmorph "MethodNode" lastSubmorph "BlockNode". blk addMorphFront: self. "self position: self topLeft + (7@14)"]]. aScriptor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft]]. (aScriptor isKindOf: ScriptEditorMorph) ifTrue: [aScriptor playerScripted expungeEmptyUnRenamedScripts]. ^ aScriptor ifNil: [self] ! ! !TheWorldMenu methodsFor: 'construction' stamp: 'sw 2/14/2001 17:55'! projectMenu "Build the project menu for the world." | menu | self flag: #bob0302. menu _ self menu: 'projects...'. self fillIn: menu from: { { 'save on server (also makes a local copy)' . { #myProject . #storeOnServer } }. { 'save to a different server' . { #myProject . #saveAs } }. { 'save project on local file only' . { #myWorld . #saveOnFile } }. { 'see if server version is more recent...' . { #myProject . #loadFromServer } }. { 'load project from file...' . { self . #loadProject } }. nil. }. self fillIn: menu from: {{'show project hierarchy'. {Project. #showProjectHierarchyInWindow}. 'Opens a window that shows names and relationships of all the projects in your system.'}. nil}. self mvcProjectsAllowed ifTrue: [ self fillIn: menu from: { { 'create new mvc project'. { self . #openMVCProject } }. } ]. self fillIn: menu from: { { 'create new morphic project' . { self . #openMorphicProject } }. nil. { 'go to previous project' . { Project . #returnToPreviousProject } }. { 'go to next project' . { Project . #advanceToNextProject } }. { 'jump to project...' . { #myWorld . #jumpToProject } }. }. Preferences simpleMenus ifFalse: [ self fillIn: menu from: { nil. { 'save for future revert' . { #myProject . #saveForRevert } }. { 'revert to saved copy' . { #myProject . #revert } }. }. ]. ^ menu! ! !UniclassScript methodsFor: 'textually coded' stamp: 'sw 2/17/2001 04:09'! okayToRename "Answer whether the receiver is in a state to be renamed." ^ self isTextuallyCoded not! ! !UniclassScript methodsFor: 'versions' stamp: 'sw 2/16/2001 00:46'! revertToLastSavedTileVersionFor: anEditor "revert to the last saved tile version" Preferences universalTiles ifFalse: [formerScriptingTiles isEmptyOrNil ifFalse: [anEditor reinsertSavedTiles: formerScriptingTiles last second]] ifTrue: [anEditor removeAllButFirstSubmorph. anEditor insertUniversalTiles]. anEditor showingMethodPane: false. isTextuallyCoded _ false! ! !UniclassScript methodsFor: 'versions' stamp: 'sw 2/18/2001 18:27'! saveScriptVersion: timeStamp "Save the tile script version by appending a pair of the form