'From Squeak3.1alpha of 28 February 2001 [latest update: #4259] on 18 August 2001 at 9:45:35 am'! "Change Set: UniTile5-tk Date: 10 August 2001 Author: Ted Kaehler More Uni Tile cleanup. -- define protocol for class String -- reorganize protocol in Vocabulary class for Number and Time. -- Make protocol (message) menu be lined up at the top. -- 'Give me a button to fire this script' looks better and has a thinner border. -- Wait cursor while making tiles. -- Make Protocol browsers be blue with a green button. -- someone left a halt in ParagraphEditor explainClass: -- Allow temp vars to be defined by dropping in a temp var tile (was broken). -- Expand the places where 'Use' appears in front of temp vars."! !Lexicon methodsFor: 'control buttons' stamp: 'tk 8/5/2001 11:33'! mostGenericButton "Answer a button that reports on, and allow the user to modify, the most generic class to show" | aButton | aButton _ UpdatingSimpleButtonMorph newWithLabel: 'All'. aButton setNameTo: 'limit class'. aButton target: self; wordingSelector: #limitClassString; actionSelector: #chooseLimitClass. aButton setBalloonText: 'Governs which classes'' methods should be shown. If this is the same as the viewed class, then only methods implemented in that class will be shown. If it is ProtoObject, then methods of all classes in the vocabulary will be shown.'. aButton actWhen: #buttonDown. aButton color: (Color r: 0.806 g: 1.0 b: 0.806). aButton borderColor: Color black. ^ aButton! ! !InstanceBrowser methodsFor: 'initialization' stamp: 'tk 8/5/2001 11:34'! defaultBackgroundColor "Answer the default background color for the window" ^ Color r: 0.806 g: 1.0 b: 1.0 "Color fromUser " "23 haveFullProtocolBrowsed"! ! !MethodNode methodsFor: 'tiles' stamp: 'tk 8/5/2001 11:40'! asMorphicSyntaxUsing: aClass ^ Cursor wait showWhile: [ (aClass methodNodeOuter: self) finalAppearanceTweaks] ! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tk 8/6/2001 13:32'! explainClass: symbol "Is symbol a class variable or a pool variable?" | class reply classes | (model respondsTo: #selectedClassOrMetaClass) ifFalse: [^ nil]. (class _ model selectedClassOrMetaClass) ifNil: [^ nil]. "no class is selected" (class isKindOf: Metaclass) ifTrue: [class _ class soleInstance]. classes _ (Array with: class) , class allSuperclasses. "class variables" reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] ifNone: []) ~~ nil] ifNone: []. reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').']. "pool variables" classes do: [:each | (each sharedPools detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]] ifNone: []) ~~ nil]. reply ifNil: [(Undeclared includesKey: symbol) ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'Smalltalk browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']] ifNotNil: [classes _ WriteStream on: Array new. Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes nextPut: each]]. "Perhaps not print whole list of classes if too long. (unlikely)" ^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' associationAt: #' , symbol , ').']. ^ nil! ! !Player methodsFor: 'costume' stamp: 'tk 8/10/2001 11:33'! tearOffButtonToFireScriptForSelector: aSelector "Tear off a button to fire the script for the given selector" | aButton props | Preferences useButtonProprtiesToFire ifFalse: [ aButton _ ScriptActivationButton new target: self. aButton actionSelector: #runScript:. aButton arguments: (Array with: aSelector). aButton establishLabelWording. self currentHand attachMorph: aButton. ^self ]. (aButton _ RectangleMorph new) useRoundedCorners; color: Color yellow. props _ aButton ensuredButtonProperties. props target: self; actionSelector: #runScript:; arguments: {aSelector}; delayBetweenFirings: 80; actWhen: #mouseUp; mouseDownHaloWidth: 8; wantsRolloverIndicator: true; mouseOverHaloWidth: 5; establishEtoyLabelWording. aButton width: aButton submorphs first width + 20; height: 20. self currentHand attachMorph: aButton. ! ! !Player methodsFor: 'slots-kernel' stamp: 'tk 8/13/2001 09:27'! methodInterfacesForScriptsCategoryIn: aVocabulary "Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool. The vocabulary argument is not presently used." | myScripts | myScripts _ self class scripts values collect: [:us | (us isKindOf: UserScript) ifTrue: [us as: MethodWithInterface] ifFalse: [us]]. ^ {self methodInterfaceForEmptyScript}, myScripts! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/7/2001 23:45'! addTempVar: aMorph "know we are a block inside a MethodNode" "(aMorph nodeClassIs: TempVariableNode) is known to be true." | tempHolder ii tt var nn | tempHolder _ nil. (ii _ owner submorphIndexOf: self) = 1 ifFalse: [ tt _ owner submorphs at: ii - 1. tt isSyntaxMorph ifTrue: [ (tt nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ tt]. (tt nodeClassIs: UndefinedObject) ifTrue: [tempHolder _ tt findA: MethodTempsNode]]]. nn _ aMorph parseNode key. "name" tempHolder ifNil: [ tempHolder _ owner addRow: #tempVariable on: MethodTempsNode new. tempHolder addNoiseString: self noiseBeforeBlockArg. owner addMorph: tempHolder inFrontOf: self. aMorph parseNode name: nn key: nn code: nil. aMorph parseNode asMorphicSyntaxIn: tempHolder. tempHolder cleanupAfterItDroppedOnMe. ^ true]. tempHolder submorphsDo: [:m | m isSyntaxMorph and: [m parseNode key = nn ifTrue: [^ false]]]. aMorph parseNode name: nn key: nn code: nil. "tempHolder addNoiseString: self noiseBeforeBlockArg." "tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4)." var _ tempHolder addColumn: #tempVariable on: aMorph parseNode. var layoutInset: 1. var addMorphBack: (self addString: nn special: false). var cleanupAfterItDroppedOnMe. ^ true! ! !SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/10/2001 09:57'! addTextRow: aStringLikeItem | row tt | (row _ self class row: #text on: nil) borderWidth: 1. (tt _ TextMorph new) contents: aStringLikeItem. row addMorph: tt. "row addMorph: (self addString: (aStringLikeItem copyWithout: Character cr) special: false)." self addMorphBack: row. ^row! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/6/2001 17:48'! 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; cellPositioning: #topLeft. 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 8/7/2001 23:16'! addTemporaries: temporaries | tempMorph outerMorph w2 | temporaries size > 0 ifFalse: [^self]. self alansTest1 ifFalse: [ tempMorph _ self addRow: #tempVariable on: (MethodTempsNode new). temporaries do: [:temp | temp asMorphicSyntaxIn: tempMorph ] separatedBy: [tempMorph addMorphBack: (tempMorph transparentSpacerOfSize: 4@4)]. ^self ]. outerMorph _ self addRow: #tempVariable on: nil. outerMorph setSpecialTempDeclarationFormat1. outerMorph addMorphBack: (w2 _ self noiseStringMorph: self noiseBeforeBlockArg). w2 emphasis: 1. tempMorph _ outerMorph addRow: #tempVariable on: (MethodTempsNode new). tempMorph setSpecialTempDeclarationFormat2. temporaries do: [:temp | tempMorph addToken: temp name type: #tempVariableDeclaration on: temp] separatedBy: [tempMorph addMorphBack: self tokenVerticalSeparator]. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 8/7/2001 23:16'! blockNodeCollect: aNode arguments: arguments statements: statements | row column c2 r2 r3 | column _ self addColumn: #blockCollectOnly on: aNode. self alansTest1 ifFalse: [column layoutInset: 5@-1]. aNode addCommentToMorph: column. arguments size > 0 ifTrue: [ row _ column addRow: #blockarg1 on: (BlockArgsNode new). row addNoiseString: 'collect using' emphasis: 1. r3 _ row addRow: #blockarg1b on: nil "aNode". r3 setConditionalPartStyle. arguments do: [:arg | r3 addToken: arg name type: #blockarg2 on: arg ] ]. r2 _ column addRow: #block on: aNode. r2 setProperty: #ignoreNodeWhenPrinting toValue: true. r2 addNoiseString: self noiseBeforeBlockArg emphasis: 1. c2 _ r2 addColumn: #block on: aNode. c2 setProperty: #ignoreNodeWhenPrinting toValue: true. statements do: [ :each | (each asMorphicSyntaxIn: c2) borderWidth: 1. each addCommentToMorph: c2 ]. ^ column! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 8/7/2001 23:15'! noiseBeforeBlockArg ^ self alansTest1 ifTrue: [' Use'] ifFalse: [' from']! ! !SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 8/7/2001 23:12'! noiseWordBeforeVariableNode: aNode string: aString (#('self' 'nil') includes: aString) ifFalse: [ aNode code ifNil: [^'my']. aNode type < 4 ifTrue: [^'my'] ]. ^nil! ! !SyntaxMorph methodsFor: 'vocabulary' stamp: 'tk 8/8/2001 00:14'! 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 isKindOf: String) ifTrue: [^ Vocabulary vocabularyForClass: String]. (aValue class isUniClass) ifTrue: [^ Vocabulary eToyVocabulary]. ^ self currentVocabulary ! ! !TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'tk 8/10/2001 10:09'! xScrollerHeight (submorphs includes: xScrollBar) "Sorry the logic is reversed :( " ifTrue: [^ 0 @ 0] "already included" ifFalse: [^ 0 @ xScrollBar height] "leave space for it" ! ! !Vocabulary class methodsFor: 'access' stamp: 'tk 8/8/2001 07:34'! 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) allSuperclasses size < (Smalltalk at: b classSymbol) allSuperclasses size]. mthRefs size > 0 ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new]. ^ Error new! ! !Vocabulary class methodsFor: 'type vocabularies' stamp: 'tk 8/6/2001 22:24'! 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.'. #((comparing 'Determining which of two numbers is larger' (= < > <= >= ~= ~~)) (arithmetic 'Basic numeric operation' (* + - / // \\ abs negated quo: rem:)) (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/8/2001 00:12'! newStringVocabulary "Answer a Vocabulary object representing me" | aVocabulary aMethodCategory aMethodInterface | "Vocabulary newStringVocabulary" "Vocabulary addVocabulary: Vocabulary newStringVocabulary" aVocabulary _ self new vocabularyName: #String. aVocabulary documentation: 'A piece of text with many letters in it'. #((accessing 'The basic info' (at: at:put: size endsWithDigit findString: findTokens: includesSubString: indexOf: indexOf:startingAt: indexOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: startsWithDigit numArgs)) (more accessing 'More basic info' (allButFirst allButFirst: allButLast allButLast: at:ifAbsent: atAllPut: atPin: atRandom: atWrap: atWrap:put: fifth first first: fourth from:to:put: last last: lastIndexOf: lastIndexOf:ifAbsent: middle replaceAll:with: replaceFrom:to:with: replaceFrom:to:with:startingAt: second sixth third)) (comparing 'Determining which comes first alphabeticly' (< <= = > >= beginsWith: endsWith: endsWithAnyOf: howManyMatch: match:)) (testing 'Testing' (includes: isEmpty ifNil: ifNotNil: isAllDigits isAllSeparators isString lastSpacePosition)) (converting 'Converting it to another form' (asCharacter asDate asInteger asLowercase asNumber asString asStringOrText asSymbol asText asTime asUppercase asUrl capitalized keywords numericSuffix romanNumber reversed splitInteger surroundedBySingleQuotes withBlanksTrimmed withSeparatorsCompacted withoutTrailingBlanks withoutTrailingDigits asSortedCollection)) (copying 'Make another one like me' (copy copyFrom:to: copyUpTo: copyUpToLast: shuffled)) (enumerating 'Passing over the letters' (collect: collectWithIndex: do: from:to:do: reverseDo: select: withIndexDo: detect: detect:ifNone:)) ) 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/6/2001 22:24'! 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 print24 intervalString 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 ! ! UpdatingStringMorph removeSelector: #lookTranslucent!