'From Squeak3.1alpha of 28 February 2001 [latest update: #4231] on 4 August 2001 at 3:58:20 pm'! "Change Set: UniTile4-tk Date: 4 August 2001 Author: Ted Kaehler Continue to improve uniTile scripting. Vocabulary for the class Time. Uses Scott's changes in 4030vocabEnhance-sw. Menu of replacement selectors are shown in user's language, not Squeak selectors. Bob's controls for how tiles look are now in pale colors and at the bottom of the method."! !PasteUpMorph methodsFor: 'scripting' stamp: 'tk 8/3/2001 20:12'! currentVocabularyFor: aScriptableObject "Answer the Vocabulary object to be applied when scripting an object in the world." | vocabSymbol vocab | vocabSymbol _ self valueOfProperty: #currentVocabularySymbol ifAbsent: [nil]. vocabSymbol ifNil: [vocab _ self valueOfProperty: #currentVocabulary ifAbsent: [nil]. vocab ifNotNil: [vocabSymbol _ vocab vocabularyName. self removeProperty: #currentVocabulary. self setProperty: #currentVocabularySymbol toValue: vocabSymbol]]. vocabSymbol ifNotNil: [^ Vocabulary vocabularyNamed: vocabSymbol] ifNil: [(aScriptableObject isKindOf: Player) ifTrue: [^ Vocabulary eToyVocabulary]. (aScriptableObject isKindOf: Number) ifTrue: [^ Vocabulary numberVocabulary]. (aScriptableObject isKindOf: Time) ifTrue: [^ Vocabulary vocabularyForClass: Time]. (aScriptableObject isKindOf: String) ifTrue: [^ Vocabulary vocabularyForClass: String]. (aScriptableObject isKindOf: Point) ifTrue: [^ Vocabulary vocabularyForClass: Point]. (aScriptableObject isKindOf: Date) ifTrue: [^ Vocabulary vocabularyForClass: Date]. "OrderedCollection and Holder??" ^Vocabulary fullVocabulary]! ! !Player methodsFor: 'scripts-kernel' stamp: 'tk 8/3/2001 11:08'! newScriptorAround: aPhrase "Sprout a scriptor around aPhrase, thus making a new script. aPhrase may either be a PhraseTileMorph (classic tiles 1997-2001) or a SyntaxMorph (2001 onward)" | aScriptEditor aUniclassScript tw blk | aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self. aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self. Preferences universalTiles ifTrue: [ aScriptEditor install. "aScriptEditor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft; setProperty: #autoFitContents toValue: true." aScriptEditor insertUniversalTiles. "Gets an empty SyntaxMorph for a MethodNode" tw _ aScriptEditor findA: TwoWayScrollPane. aPhrase ifNotNil: [blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode. blk addMorphFront: aPhrase. aPhrase accept. ]. SyntaxMorph setSize: nil andMakeResizable: aScriptEditor. ] ifFalse: [ aPhrase ifNotNil: [aScriptEditor phrase: aPhrase] "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! ! !ScriptEditorMorph methodsFor: 'other' stamp: 'tk 7/30/2001 22:44'! extent: x | newExtent tw menu | newExtent _ x max: self minWidth@self minHeight. (tw _ self findA: TwoWayScrollPane) ifNil: ["This was the old behavior" ^ super extent: newExtent]. (self hasProperty: #autoFitContents) ifTrue: [ menu _ MenuMorph new defaultTarget: self. menu addUpdating: #autoFitString target: self action: #autoFitOnOff. menu addTitle: 'To resize the script, uncheck the box below'. menu popUpEvent: nil in: self world . ^ self]. "Allow the user to resize to any size" tw extent: ((newExtent x max: self firstSubmorph width) @ (newExtent y - self firstSubmorph height)) - (borderWidth*2) + (-4@-4). "inset?" ^ super extent: newExtent! ! !StringMorph methodsFor: 'drawing' stamp: 'tk 8/1/2001 14:15'! lookTranslucent "keep the text the same color (black)"! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'tk 7/31/2001 16:53'! fillStyle: aFillStyle aFillStyle isColor ifTrue: [self color: aFillStyle] "so we will process it" ifFalse: [super fillStyle: aFillStyle]. ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 8/3/2001 11:08'! 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: [adjustment _ 60 @ 20. actualObject newScriptorAround: self]. aScriptor ifNil: [^self]. handy _ aPasteUp primaryHand. aScriptor position: handy position - adjustment. aPasteUp addMorphFront: aScriptor. "do this early so can find World" aScriptor showingMethodPane ifFalse: [ (tw _ aScriptor findA: TwoWayScrollPane) ifNil: [itsSelector ifNil: ["blank script" tw _ aScriptor findA: TwoWayScrollPane. blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode. blk addMorphFront: self]]. SyntaxMorph setSize: nil andMakeResizable: aScriptor. ]. ^ aScriptor ! ! !SyntaxMorph methodsFor: 'selection' stamp: 'tk 7/31/2001 17:18'! scaleColorByUserPref: aColor | myRoot underLyingColor | myRoot _ self rootTile. underLyingColor _ myRoot ifNil: [Color transparent] ifNotNil: [myRoot color]. [underLyingColor isTransparent and: [(myRoot _ myRoot owner) notNil]] whileTrue: [ underLyingColor _ myRoot color. ]. "rude hack to get the desired effect before we have an owner" underLyingColor isTransparent ifTrue: [underLyingColor _ Color r: 0.903 g: 1.0 b: 0.903]. ^aColor mixed: (ContrastFactor ifNil: [0.3]) with: underLyingColor "Would like to be able to make MethodNode and outer Block be transparent. This method does not allow that. Consider (^ myRoot color) inside the whileTrue. Consider setting underLyingColor to (myRoot valueOfProperty: #deselectedBorderColor ifAbsent: [myRoot color]) in second line."! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/1/2001 13:06'! removeReturnNode | blk | "If last line is ^ self, remove it. I am a methodNode. Keep if no other tiles in the block." blk _ self findA: BlockNode. blk submorphs last decompile string = '^self ' ifTrue: [ (blk submorphs count: [:ss | ss isSyntaxMorph]) > 1 ifTrue: [ blk submorphs last delete]].! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/1/2001 17:42'! replaceSel: evt menuItem: stringMorph "I rep a SelectorNode. Replace my selector with new one that was just chosen from a menu" | menu new old newSel ms | (menu _ stringMorph owner owner) class == RectangleMorph ifTrue: [ menu delete]. new _ stringMorph contents. new first = $( ifTrue: [^ self]. "Cancel" new first = $ ifTrue: [^ self]. "nothing" (new endsWith: ' 5') ifTrue: [new _ new allButLast: 2]. newSel _ stringMorph valueOfProperty: #syntacticallyCorrectContents. newSel ifNil: [newSel _ new]. old _ (ms _ self findA: StringMorph) valueOfProperty: #syntacticallyCorrectContents. old ifNil: [old _ (self findA: StringMorph) contents]. old numArgs = newSel numArgs ifTrue: [ ms contents: new. ms setProperty: #syntacticallyCorrectContents toValue: newSel. self acceptIfInScriptor].! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/4/2001 15:24'! selectorMenu "Put up a menu of all selectors that my receiver could be sent. Replace me with the one chosen. (If fewer args, put the tiles for the extra arg to the side, in script's owner (world?).) Go ahead and eval receiver to find out its type. Later, mark selectors for side effects, and don't eval those. Put up a table. Each column is a viewer category." | rec cats value catNames interfaces list setter wording all words ind aVocabulary limitClass | rec _ owner receiverNode. rec ifNil: [rec _ owner owner receiverNode]. rec ifNil: [rec _ owner owner owner receiverNode]. cats _ #(). all _ Set new. value _ rec ifNotNil: [rec try]. value class == Error ifTrue: [value _ Vocabulary instanceWhoRespondsTo: self selector]. value class == Error ifTrue: [^ nil]. aVocabulary _ self vocabularyToUseWith: value. limitClass _ self limitClassToUseWith: value vocabulary: aVocabulary. catNames _ value categoriesForVocabulary: aVocabulary limitClass: limitClass. cats _ catNames collect: [:nn | list _ OrderedCollection new. interfaces _ value methodInterfacesForCategory: nn inVocabulary: aVocabulary limitClass: limitClass. interfaces do: [:mi | (all includes: mi selector) ifFalse: [ "list add: (self aSimpleStringMorphWith: mi elementWording). Expensive" words _ self splitAtCapsAndDownshifted: mi selector. (words beginsWith: 'get ') ifTrue: [words _ words allButFirst: 4]. mi selector numArgs > 0 ifTrue: [words _ words, ' 5']. list add: (self anUpdatingStringMorphWith: words special: true). list last setProperty: #syntacticallyCorrectContents toValue: mi selector. all add: mi selector]. setter _ mi companionSetterSelector asString. (setter = 'nil') | (all includes: setter) ifFalse: ["need setters also" wording _ (self translateToWordySetter: setter). list add: (self aSimpleStringMorphWith: wording, ' 5'). list last setProperty: #syntacticallyCorrectContents toValue: setter. all add: setter]]. list]. (ind _ catNames indexOf: 'scripts') > 0 ifTrue: [ (cats at: ind) first contents = 'empty script' ifTrue: [ (cats at: ind) removeFirst]]. self selectorMenuAsk: cats. "The method replaceSel:menuItem: does the work. Replaces the selector." ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/3/2001 20:51'! selectorMenuAsk: listOfLists "I represent a SelectorNode to be replaced by one of the selectors in one of the category lists. Each list has pre-built StringMorphs in it." | menu col | listOfLists isEmpty ifTrue: [^ nil]. listOfLists first addFirst: (self aSimpleStringMorphWith: ' '). "spacer" listOfLists first addFirst: (self aSimpleStringMorphWith: '( Cancel )'). listOfLists first first color: Color red. menu _ RectangleMorph new. menu listDirection: #leftToRight; layoutInset: 3; cellInset: 1@0. menu layoutPolicy: TableLayout new; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: (Color r: 0.767 g: 1.0 b: 0.767); useRoundedCorners. listOfLists do: [:ll | col _ Morph new. col listDirection: #topToBottom; layoutInset: 0; cellInset: 0@0. col layoutPolicy: TableLayout new; hResizing: #shrinkWrap. col color: Color transparent; vResizing: #shrinkWrap. menu addMorphBack: col. ll do: [:ss | col addMorphBack: ss. ss on: #mouseUp send: #replaceSel:menuItem: to: self] ]. self world addMorph: menu. menu setConstrainedPosition: (owner localPointToGlobal: self topRight) + (10@-30) hangOut: false. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/31/2001 17:27'! addTemporaryControls | row stdSize | stdSize _ 8@8. row _ AlignmentMorph newRow color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self addMorphBack: row. { Morph new extent: stdSize; color: Color paleBlue darker; setBalloonText: 'Change the contrast'; on: #mouseUp send: #controlContrast2: to: self; on: #mouseMove send: #controlContrast2: to: self; on: #mouseDown send: #controlContrast2: to: self. "Removed because it's default is giant tiles, which no one wants. --tk Morph new extent: stdSize; color: Color green; setBalloonText: 'Change basic spacing'; on: #mouseUp send: #controlSpacing2: to: self; on: #mouseMove send: #controlSpacing2: to: self; on: #mouseDown send: #controlSpacing2: to: self. " Morph new extent: stdSize; color: Color lightRed; setBalloonText: 'Change basic style'; on: #mouseUp send: #changeBasicStyle to: self. } do: [ :each | row addMorphBack: each. row addMorphBack: (self transparentSpacerOfSize: stdSize). ]. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/31/2001 17:37'! methodNodeOuter: aNode | block | self borderWidth: 0. aNode asMorphicSyntaxIn: self. self alansTest1 ifTrue: [self addTemporaryControls]. self finalAppearanceTweaks. "self setProperty: #deselectedColor toValue: Color transparent." block _ self findA: BlockNode. "block setProperty: #deselectedColor toValue: Color transparent." block submorphs size = 1 ifTrue: [^ self]. "keep '^ self' if that is the only thing in method" block submorphs last decompile string = '^ self ' ifTrue: [ block submorphs last delete]. ^ self! ! !SyntaxMorph methodsFor: 'vocabulary' stamp: 'tk 8/4/2001 15:38'! vocabularyToUseWith: aValue "Answer a vocabulary to use with the given value" (aValue isKindOf: Number) ifTrue: [^ Vocabulary numberVocabulary]. (aValue isKindOf: Time) ifTrue: [^ Vocabulary vocabularyForClass: Time]. (aValue class isUniClass) ifTrue: [^ Vocabulary eToyVocabulary]. ^ self currentVocabulary ! ! !SyntaxUpdatingStringMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/31/2001 17:56'! drawOn: aCanvas | tempForm scanner strm where chars wid spaceWidth putLigature topOfLigature sizeOfLigature colorOfLigature dots noDot1 noDot2 | tempForm _ Form extent: self extent depth: aCanvas depth. scanner _ DisplayScanner quickPrintOn: tempForm box: tempForm boundingBox font: self fontToUse. spaceWidth _ scanner stringWidth: ' '. strm _ ReadStream on: contents. noDot1 _ noDot2 _ -1. contents size = 0 ifTrue: [^ self]. "so #first will be happy" contents first = $' ifTrue: [(contents beginsWith: '''s ') ifTrue: [noDot1 _ 3]]. contents last = $_ ifTrue: [(contents endsWith: ' _') ifTrue: [noDot2 _ contents size -1]]. contents last = $5 ifTrue: [(contents endsWith: ' 5') ifTrue: [noDot2 _ contents size -1]]. where _ 0@0. topOfLigature _ self height // 2 - 1. sizeOfLigature _ (spaceWidth-2)@(spaceWidth-2). colorOfLigature _ Color black alpha: 0.3 "veryLightGray". dots _ OrderedCollection new. putLigature _ [ (strm position ~= noDot1) & (strm position ~= noDot2) ifTrue: [ dots add: ((where x + 1) @ topOfLigature extent: sizeOfLigature)]. where _ where + (spaceWidth@0). ]. [strm atEnd] whileFalse: [ [strm peek = $ ] whileTrue: [ strm next. putLigature value. ]. chars _ strm upTo: $ . wid _ scanner stringWidth: chars. scanner drawString: chars at: where. where _ where + (wid@0). strm atEnd ifFalse: [putLigature value]. ]. aCanvas paintImage: tempForm at: self topLeft. dots do: [ :each | aCanvas fillRectangle: (each translateBy: self topLeft) fillStyle: colorOfLigature. ]. ! ! !Vocabulary class methodsFor: 'class initialization' stamp: 'tk 8/4/2001 15:27'! initializeStandardVocabularies "Initialize a few standard vocabularies and place them in the AllVocabularies list." AllVocabularies _ OrderedCollection new. AllMethodInterfaces _ IdentityDictionary new. self addVocabulary: EToyVocabulary new. self addVocabulary: self newPublicVocabulary. self addVocabulary: FullVocabulary new. self addVocabulary: self newQuadVocabulary. self addKiswahiliVocabulary. self addGermanVocabulary. self wonderlandVocabulary. "creates it and adds it" self numberVocabulary. "ditto" self vocabularyForClass: Time. "ditto" "Vocabulary initialize" ! ! !Vocabulary class methodsFor: 'access' stamp: 'tk 8/3/2001 20:50'! addVocabulary: aVocabulary "Add a vocabulary to the list of standard vocabularies" self allVocabularies. "Assures initialization" self removeVocabularyNamed: aVocabulary vocabularyName. AllVocabularies add: aVocabulary! ! !Vocabulary class methodsFor: 'access' stamp: 'tk 8/1/2001 18:20'! instanceWhoRespondsTo: aSelector "Find the most likely class that responds to aSelector. Return an instance of it. Look in vocabularies to match the selector." "Most eToy selectors are for Players" | mthRefs | ((self vocabularyNamed: #eToy) includesSelector: aSelector) ifTrue: [ ^ Player new]. "Numbers are a problem" ((self vocabularyNamed: #Number) includesSelector: aSelector) ifTrue: [ ^ 1]. "Is a Float any different?" #("String Point Time Date") do: [:nn | ((self vocabularyNamed: nn) includesSelector: aSelector) ifTrue: [ "Ask Scott how to get a prototypical instance" ^ (Smalltalk at: nn) new]]. mthRefs _ Smalltalk allImplementorsOf: aSelector. "every one who implements the selector" mthRefs sortBlock: [:a :b | (Smalltalk at: a classSymbol) superclasses size < (Smalltalk at: b classSymbol) superclasses size]. mthRefs size > 0 ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new]. ^ Error new! ! !Vocabulary class methodsFor: 'type vocabularies' stamp: 'tk 8/4/2001 15:05'! newNumberVocabulary "Answer a Vocabulary object representing the Number vocabulary to the list of AllVocabularies" | aVocabulary aMethodCategory aMethodInterface | "Vocabulary newNumberVocabulary" "Vocabulary addVocabulary: Vocabulary newNumberVocabulary" aVocabulary _ self new vocabularyName: #Number. aVocabulary documentation: 'Numbers are things that can do arithmetic, have their magnitudes compared, etc.'. #((arithmetic 'Basic numeric operation' (* + - / // \\ abs negated quo: rem:)) (comparing 'Determining which of two numbers is larger' (= < > <= >= ~= ~~)) (testing 'Testing a number' (even isDivisibleBy: negative odd positive sign)) (#'mathematical functions' 'Trigonometric and exponential functions' (cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:)) (converting 'Converting a number to another form' (@ asInteger asPoint degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees)) (#'truncation and round off' 'Making a real number (with a decimal point) into an integer' (ceiling floor roundTo: roundUpTo: rounded truncateTo: truncated)) ) do: [:item | aMethodCategory _ ElementCategory new categoryName: item first. aMethodCategory documentation: item second. item third do: [:aSelector | aMethodInterface _ MethodInterface new conjuredUpFor: aSelector class: (Number whichClassIncludesSelector: aSelector). aVocabulary atKey: aSelector putMethodInterface: aMethodInterface. aMethodCategory elementAt: aSelector put: aMethodInterface]. aVocabulary addCategory: aMethodCategory]. ^ aVocabulary " (('truncation and round off' ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated) ('testing' basicType even isDivisibleBy: isInf isInfinite isNaN isNumber isZero negative odd positive sign strictlyPositive) ('converting' @ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees) ('intervals' to: to:by: to:by:do: to:do:) ('printing' defaultLabelForInspector isOrAreStringWith: newTileMorphRepresentative printOn: printStringBase: storeOn: storeOn:base: storeStringBase: stringForReadout) ('comparing' closeTo:) ('filter streaming' byteEncode:) ('as yet unclassified' reduce)" ! ! !Vocabulary class methodsFor: 'type vocabularies' stamp: 'tk 8/3/2001 20:46'! newTimeVocabulary "Answer a Vocabulary object representing me" | aVocabulary aMethodCategory aMethodInterface | "Vocabulary newTimeVocabulary" "Vocabulary addVocabulary: Vocabulary newTimeVocabulary" aVocabulary _ self new vocabularyName: #Time. aVocabulary documentation: 'Time knows about hours, minutes, and seconds. For long time periods, use Date'. #((accessing 'The basic info' (hours minutes seconds)) (arithmetic 'Basic numeric operations' (addTime: subtractTime: max: min: min:max:)) (comparing 'Determining which is larger' (= < > <= >= ~= between:and:)) (testing 'Testing' (ifNil: ifNotNil:)) (printing 'Return a string for this Time' (hhmm24 intervalString print24 printMinutes printOn:)) (converting 'Converting it to another form' (asSeconds asString)) (copying 'Make another one like me' (copy)) ) do: [:item | aMethodCategory _ ElementCategory new categoryName: item first. aMethodCategory documentation: item second. item third do: [:aSelector | aMethodInterface _ MethodInterface new initializeFor: aSelector. aVocabulary atKey: aSelector putMethodInterface: aMethodInterface. aMethodCategory elementAt: aSelector put: aMethodInterface]. aVocabulary addCategory: aMethodCategory]. ^ aVocabulary ! ! !Vocabulary class methodsFor: 'type vocabularies' stamp: 'tk 8/4/2001 15:28'! vocabularyForClass: aClass "Answer the standard vocabulary for that class. Create it if not present and init message exists" | initMsgName aVocab | ^ self allVocabularies detect: [:aVocabulary | aVocabulary vocabularyName == aClass name] ifNone: [ initMsgName _ 'new', aClass name, 'Vocabulary'. Symbol hasInterned: initMsgName ifTrue: [:symb | aVocab _ self perform: symb. self addVocabulary: aVocab]. aVocab]! ! !UpdatingStringMorph reorganize! ('initialization' initWithContents:font:emphasis: initialize) ('accessing' autoAcceptOnFocusLoss autoAcceptOnFocusLoss: fitContents floatPrecision floatPrecision: getSelector getSelector: growable growable: maximumWidth minimumWidth minimumWidth: putSelector putSelector: target target:) ('drawing' lookTranslucent) ('stepping' step stepTime stepTime: updateContentsFrom: wantsSteps) ('formats' useDefaultFormat useStringFormat) ('target access' acceptValue: acceptValueFromTarget: checkTarget informTarget readFromTarget valueFromContents) ('editing' acceptContents addCustomMenuItems:hand: doneWithEdits handlerForMouseDown: handlesMouseDown: lostFocusWithoutAccepting mouseDown: setFontSize setFontStyle setPrecision toggleGrowability wouldAcceptKeyboardFocus) ('copying' veryDeepFixupWith: veryDeepInner:) ('object fileIn') ! SyntaxMorph removeSelector: #chooseSelectorFrom:! "Postscript: " Vocabulary initialize.!