'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6550] on 22 February 2005 at 10:16:41 pm'! "Change Set: ScriptEditorImageSegmentFix-nk Date: 22 Feb 2005 Author: Ned Konz Fixes a bug in ImageSegment where some ScriptEditorMorph instances could be incorrectly skipped because it was changing a collection it was iterating over. Changes invocations of 'isKindOf: Player' to use the pre-existing method #isPlayerLike. Changes invocations of 'isKindOf: EToyVocabulary' to use the new method #isEToyVocabulary. "! !ButtonProperties methodsFor: 'accessing' stamp: 'nk 8/29/2004 17:16'! isTileScriptingElement actionSelector == #runScript: ifFalse: [^false]. arguments isEmptyOrNil ifTrue: [^false]. ^target isPlayerLike! ! !EToyVocabulary methodsFor: 'category list' stamp: 'nk 8/29/2004 17:17'! categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass "Answer the category list for the given object, considering only code implemented in aClass and lower" ^ (anObject isPlayerLike) ifTrue: [self flag: #deferred. "The bit commented out on next line is desirable but not yet workable, because it delivers categories that are not relevant to the costume in question" "#(scripts #'instance variables'), (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass)]" self translatedWordingsFor: ((mostGenericClass == aClass) ifFalse: [anObject categoriesForVocabulary: self] ifTrue: [{ScriptingSystem nameForScriptsCategory. ScriptingSystem nameForInstanceVariablesCategory}])] ifFalse: [super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass]! ! !ImageSegment methodsFor: 'testing' stamp: 'nk 2/22/2005 22:13'! findRogueRootsAllMorphs: rootArray "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1) assemble all objects should be in seg: morph tree, presenter, scripts, player classes, metaclasses. Put in a Set. 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." | inSeg testRoots scriptEditors pointIn wld xRoots | Smalltalk garbageCollect. inSeg := IdentitySet new: 200. arrayOfRoots := rootArray. (testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray]. testRoots do: [:obj | (obj isKindOf: Project) ifTrue: [inSeg add: obj. wld := obj world. inSeg add: wld presenter]. (obj isKindOf: Presenter) ifTrue: [inSeg add: obj]]. xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)]. xRoots do: [:obj | "root is a project" obj isMorph ifTrue: [obj allMorphs do: [:mm | inSeg add: mm. mm player ifNotNil: [inSeg add: mm player]]. obj isWorldMorph ifTrue: [inSeg add: obj presenter]]]. scriptEditors := IdentitySet new. inSeg do: [:obj | obj isPlayerLike ifTrue: [scriptEditors addAll: (obj class tileScriptNames collect: [:nn | obj scriptEditorFor: nn])]]. scriptEditors do: [:se | inSeg addAll: se allMorphs]. testRoots do: [:each | inSeg remove: each ifAbsent: []]. "want them to be pointed at from outside" pointIn := IdentitySet new: 400. inSeg do: [:ob | pointIn addAll: (PointerFinder pointersTo: ob except: inSeg)]. testRoots do: [:each | pointIn remove: each ifAbsent: []]. pointIn remove: inSeg array ifAbsent: []. pointIn remove: pointIn array ifAbsent: []. inSeg do: [:obj | obj isMorph ifTrue: [pointIn remove: (obj instVarAt: 3) ifAbsent: ["submorphs" ]. "associations in extension" pointIn remove: obj extension ifAbsent: []. obj extension ifNotNil: [obj extension otherProperties ifNotNil: [obj extension otherProperties associationsDo: [:ass | pointIn remove: ass ifAbsent: [] "*** and extension actorState" "*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]]. obj isPlayerLike ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]]. "*** presenter playerlist" self halt: 'Examine local variables pointIn and inSeg'. ^pointIn! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'nk 8/29/2004 17:17'! currentVocabularyFor: aScriptableObject "Answer the Vocabulary object to be applied when scripting an object in the world." | vocabSymbol vocab aPointVocab | 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 isPlayerLike) ifTrue: [^Vocabulary eToyVocabulary]. (aScriptableObject isNumber) ifTrue: [^Vocabulary numberVocabulary]. (aScriptableObject isKindOf: Time) ifTrue: [^Vocabulary vocabularyForClass: Time]. (aScriptableObject isString) ifTrue: [^Vocabulary vocabularyForClass: String]. (aScriptableObject isPoint) ifTrue: [(aPointVocab := Vocabulary vocabularyForClass: Point) ifNotNil: [^aPointVocab]]. (aScriptableObject isKindOf: Date) ifTrue: [^Vocabulary vocabularyForClass: Date]. "OrderedCollection and Holder??" ^Vocabulary fullVocabulary]! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'nk 8/29/2004 17:18'! 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 | 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 notNil]]. 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 isNumber) ifTrue: [^#Number]. (value isKindOf: Boolean) ifTrue: [^#Boolean]. (value isForm) ifTrue: [^#Graphic]. value class == String ifTrue: [(SoundService default sampledSoundChoices includes: value) ifTrue: [^#Sound]]. (value isPlayerLike) ifTrue: [^#Player]. ^value class name asLowercase "asSymbol (not needed)"! ! !ThumbnailMorph methodsFor: 'scripting' stamp: 'nk 8/29/2004 17:18'! tearOffTile (objectToView isPlayerLike) ifTrue: [^ objectToView tearOffTileForSelf]. objectToView ifNil: [^ nil]. ^ objectToView isMorph ifTrue: [objectToView] ifFalse: [objectToView costume] ! ! !ThumbnailMorph methodsFor: 'what to view' stamp: 'nk 8/29/2004 17:18'! 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 isPlayerLike) 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: 'nk 8/29/2004 17:18'! formOrMorphToView "Answer the form to be viewed, or the morph to be viewed, or nil" | actualViewee | (objectToView isForm) ifTrue: [^objectToView]. actualViewee := viewSelector ifNil: [objectToView] ifNotNil: [objectToView perform: viewSelector]. ^actualViewee == 0 ifTrue: [nil "valueAtCursor result for an empty HolderMorph"] ifFalse: [(actualViewee isPlayerLike) ifTrue: [actualViewee costume] ifFalse: [actualViewee]]! ! !ThumbnailMorph methodsFor: 'what to view' stamp: 'nk 8/29/2004 17:18'! morphToView "If the receiver is viewing some object, answer a morph can be thought of as being viewed; A gesture is made toward generalizing this beyond the morph/player regime, in that a plain blue rectangle is returned rather than simply failing if the referent is not itself displayable." objectToView ifNil: [^ nil]. ^ objectToView isMorph ifTrue: [objectToView] ifFalse: [(objectToView isPlayerLike) ifTrue: [objectToView costume] ifFalse: [RectangleMorph new color: Color blue]] ! ! !TileMorph methodsFor: 'misc' stamp: 'nk 8/29/2004 17:22'! currentEToyVocabulary "Answer the etoy vocabulary that pertains" | aVocab | ^ (aVocab := self currentVocabulary) isEToyVocabulary ifTrue: [aVocab] ifFalse: [Vocabulary eToyVocabulary]! ! !Viewer methodsFor: 'e-toy support' stamp: 'nk 8/29/2004 17:18'! objectViewed "Answer the graphical object to which the receiver's phrases apply" ^ (scriptedPlayer isPlayerLike) ifTrue: [scriptedPlayer costume] ifFalse: [scriptedPlayer]! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'nk 8/29/2004 17:17'! makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | argType := selectorAndTypePair second. actualGetter := selectorAndTypePair first asSymbol. m := PhraseTileMorph new setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue := self scriptedPlayer perform: selectorAndTypePair first asSymbol. (argValue isPlayerLike) ifTrue: [argTile := argValue tileReferringToSelf] ifFalse: [argTile := ScriptingSystem tileForArgType: argType. (argType == #Number and: [argValue isNumber]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile := self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m openInHand! ! !SearchingViewer methodsFor: 'search' stamp: 'nk 8/29/2004 17:21'! doSearchFrom: aSource interactive: isInteractive "Perform the search operation. If interactive is true, this actually happened because a search button was pressed; if false, it was triggered some other way for which an informer would be inappropriate." | searchFor aVocab aList all anInterface useTranslations scriptNames addedMorphs | searchString _ (aSource isKindOf: PluggableTextMorph) ifFalse: [aSource] ifTrue: [aSource text string]. searchFor _ searchString asString asLowercase withBlanksTrimmed. aVocab _ self outerViewer currentVocabulary. (useTranslations _ (scriptedPlayer isPlayerLike) and: [aVocab isEToyVocabulary]) ifTrue: [all _ scriptedPlayer costume selectorsForViewer. all addAll: (scriptNames _ scriptedPlayer class namedTileScriptSelectors)] ifFalse: [all _ scriptNames _ scriptedPlayer class allSelectors]. aList _ all select: [:aSelector | (aVocab includesSelector: aSelector forInstance: scriptedPlayer ofClass: scriptedPlayer class limitClass: ProtoObject) and: [(useTranslations and: [(anInterface _ aVocab methodInterfaceAt: aSelector ifAbsent: [nil]) notNil and: [anInterface wording includesSubstring: searchFor caseSensitive: false]]) or: [((scriptNames includes: aSelector) or: [useTranslations not]) and: [aSelector includesSubstring: searchFor caseSensitive: false]]]]. aList _ aList asSortedArray. self removeAllButFirstSubmorph. "that being the header" self addAllMorphs: ((addedMorphs _ scriptedPlayer tilePhrasesForSelectorList: aList inViewer: self)). self enforceTileColorPolicy. self secreteCategorySymbol. self world ifNotNil: [self world startSteppingSubmorphsOf: self]. self adjustColorsAndBordersWithin. owner ifNotNil: [owner isStandardViewer ifTrue: [owner fitFlap]. (isInteractive and: [addedMorphs isEmpty]) ifTrue: [self inform: ('No matches found for "' translated), searchFor, '"']]! ! !StandardViewer methodsFor: 'categories' stamp: 'nk 8/29/2004 17:21'! likelyCategoryToShow "Choose a category to show based on what's already showing and on some predefined heuristics" | possible all aCat currVocab | all := (scriptedPlayer categoriesForViewer: self) asOrderedCollection. possible := all copy. currVocab := self currentVocabulary. self categoryMorphs do: [:m | aCat := currVocab categoryWhoseTranslatedWordingIs: m currentCategory. aCat ifNotNil: [possible remove: aCat wording ifAbsent: []]]. (currVocab isEToyVocabulary) ifTrue: ["hateful!!" ((possible includes: ScriptingSystem nameForInstanceVariablesCategory translated) and: [scriptedPlayer hasUserDefinedSlots]) ifTrue: [^ ScriptingSystem nameForInstanceVariablesCategory]. ((possible includes: ScriptingSystem nameForScriptsCategory translated) and: [scriptedPlayer hasUserDefinedScripts]) ifTrue: [^ ScriptingSystem nameForScriptsCategory]]. {#basic translated} do: [:preferred | (possible includes: preferred) ifTrue: [^preferred]]. ((scriptedPlayer isPlayerLike) and: [scriptedPlayer hasOnlySketchCostumes]) ifTrue: [(possible includes: #tests translated) ifTrue: [^#tests translated]]. {#'color & border' translated. #tests translated. #color translated. #flagging translated. #comparing translated.} do: [:preferred | (possible includes: preferred) ifTrue: [^preferred]]. ^possible isEmpty ifFalse: [possible first] ifTrue: [all first]! ! !StandardViewer methodsFor: 'initialization' stamp: 'nk 8/29/2004 17:18'! switchToVocabulary: aVocabulary "Make the receiver show categories and methods as dictated by aVocabulary. If this constitutes a switch, then wipe out existing category viewers, which may be showing the wrong thing." self adoptVocabulary: aVocabulary. "for benefit of submorphs" self setProperty: #currentVocabularySymbol toValue: aVocabulary vocabularyName. ((scriptedPlayer isPlayerLike) and: [self isUniversalTiles not]) ifTrue: [scriptedPlayer allScriptEditors do: [:aScriptEditor | aScriptEditor adoptVocabulary: aVocabulary]]! ! !StandardViewer methodsFor: 'initialization' stamp: 'nk 8/29/2004 17:18'! viewsMorph "Answer whether the receiver views a morph. Traditional viewers up until late 2000 *all* viewed morphs (as per the morph/player architecture), but viewers on non-morph/players have now become possible" ^ scriptedPlayer isPlayerLike! !