[Pkg] The Trunk: EToys-nice.42.mcz
commits at source.squeak.org
commits at source.squeak.org
Sun Dec 27 19:33:21 UTC 2009
Nicolas Cellier uploaded a new version of EToys to project The Trunk:
http://source.squeak.org/trunk/EToys-nice.42.mcz
==================== Summary ====================
Name: EToys-nice.42
Author: nice
Time: 27 December 2009, 8:32:35 am
UUID: 429fbcd6-2bbc-4f9c-bdf0-91f5d7755b48
Ancestors: EToys-nice.41
Cosmetic: move or remove a few temps inside closures
=============== Diff against EToys-nice.41 ===============
Item was changed:
----- Method: SyntaxMorph>>printBlockNodeOn:indent: (in category 'printing') -----
printBlockNodeOn: strm indent: level
+ | lev inASyntaxButNotOutermost |
- | lev inASyntaxButNotOutermost subNodeClass |
lev := level.
inASyntaxButNotOutermost := owner isSyntaxMorph and: [ owner isMethodNode not].
inASyntaxButNotOutermost ifTrue: [strm nextPut: $[. lev := lev+1].
self
+ submorphsDoIfSyntax: [ :sub | | subNodeClass |
- submorphsDoIfSyntax: [ :sub |
sub printOn: strm indent: lev.
subNodeClass := sub parseNode class.
(#(BlockArgsNode ReturnNode CommentNode) includes: subNodeClass name) ifFalse: [
strm ensureNoSpace; nextPut: $.].
subNodeClass == BlockArgsNode
ifTrue: [strm space]
ifFalse: [strm crtab: lev].
]
ifString: [ :sub |
self printSimpleStringMorph: sub on: strm
].
inASyntaxButNotOutermost ifTrue: [strm nextPut: $] ].
!
Item was changed:
----- Method: EToyProjectQueryMorph class>>test1: (in category 'as yet unclassified') -----
test1: aProject
"EToyProjectQueryMorph test1: nil"
+
- | criteria clean |
(self basicNew)
project: aProject
+ actionBlock: [ :x | | criteria |
- actionBlock: [ :x |
criteria := OrderedCollection new.
+ x keysAndValuesDo: [ :k :v | | clean |
- x keysAndValuesDo: [ :k :v |
(clean := v withBlanksTrimmed) isEmpty ifFalse: [
criteria add: k,': *',clean,'*'
].
].
SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow: criteria
];
initialize;
openCenteredInWorld!
Item was changed:
----- Method: SyntaxMorph>>finalAppearanceTweaks (in category 'node to morph') -----
finalAppearanceTweaks
+ | deletes |
- | deletes lw |
SizeScaleFactor ifNil: [SizeScaleFactor := 0.15].
SizeScaleFactor := 0.0. "disable this feature. Default was for giant tiles"
self usingClassicTiles
ifTrue:
[self
allMorphsDo: [:each | (each isSyntaxMorph) ifTrue: [each lookClassic]].
^self].
deletes := OrderedCollection new.
self allMorphsDo:
+ [:each | | lw |
- [:each |
(each respondsTo: #setDeselectedColor) ifTrue: [each setDeselectedColor].
"(each hasProperty: #variableInsetSize) ifTrue: [
each layoutInset:
((each valueOfProperty: #variableInsetSize) * SizeScaleFactor) rounded]."
each isSyntaxMorph
ifTrue:
[lw := each layoutInset.
lw isPoint ifTrue: [lw := lw x].
each layoutInset: lw @ 0 "(6 * SizeScaleFactor) rounded"]].
deletes do: [:each | each delete]!
Item was changed:
----- Method: ObjectPropertiesMorph>>doEnables (in category 'as yet unclassified') -----
doEnables
+ | fs |
-
- | itsName fs |
-
fs := myTarget fillStyle.
self allMorphsDo: [ :each |
+ | itsName |
itsName := each knownName.
itsName == #pickerForColor ifTrue: [
self enable: each when: fs isSolidFill | fs isGradientFill
].
itsName == #pickerForBorderColor ifTrue: [
self enable: each when: (myTarget respondsTo: #borderColor:)
].
itsName == #pickerForShadowColor ifTrue: [
self enable: each when: myTarget hasDropShadow
].
itsName == #pickerFor2ndGradientColor ifTrue: [
self enable: each when: fs isGradientFill
].
+ ].!
- ].
- !
Item was changed:
----- Method: CardPlayer>>installPrivateMorphsInto: (in category 'card data') -----
installPrivateMorphsInto: aBackground
"The receiver is being installed as the current card in a given pasteup morph being used as a background. Install the receiver's private morphs into that playfield"
+
- | prior originToUse |
self flag: #deferred. "not robust if the background is showing a list view"
privateMorphs ifNotNil: [privateMorphs do:
+ [:aMorph | | prior originToUse |
- [:aMorph |
originToUse := aBackground topLeft.
prior := aMorph valueOfProperty: #priorMorph ifAbsent: [nil].
aMorph position: (aMorph position + originToUse).
(prior notNil and: [aBackground submorphs includes: prior])
ifTrue:
[aBackground addMorph: aMorph after: prior]
ifFalse:
[aBackground addMorphFront: aMorph].
aMorph removeProperty: #priorMorph]]!
Item was changed:
----- Method: EToyHierarchicalTextMorph>>adjustSubmorphPositions (in category 'as yet unclassified') -----
adjustSubmorphPositions
+ | w p |
- | p h w |
p := 0 at 0.
w := self width.
+ scroller submorphsDo: [ :each | | h |
- scroller submorphsDo: [ :each |
h := each position: p andWidth: w.
p := p + (0 at h)
].
self
changed;
layoutChanged;
setScrollDeltas.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>useKedamaFloatArray (in category 'private') -----
useKedamaFloatArray
+
+ arrays withIndexDo: [:array :index | | newArray |
- | newArray |
- arrays withIndexDo: [:array :index |
(array isMemberOf: FloatArray) ifTrue: [
newArray := KedamaFloatArray new: array size.
newArray replaceFrom: 1 to: array size with: array startingAt: 1.
arrays at: index put: newArray.
].
].
!
Item was changed:
----- Method: SyntaxMorph>>cleanUpString: (in category 'accessing') -----
cleanUpString: stringSubMorph
+
- | style rawData |
^ stringSubMorph
valueOfProperty: #syntacticallyCorrectContents
+ ifAbsent: [ | style rawData |
- ifAbsent: [
style := stringSubMorph valueOfProperty: #syntacticReformatting.
rawData := stringSubMorph contents.
(#(unary tempVariableDeclaration blockarg2 methodHeader1 tempVariable variable) includes: style) ifTrue: [
rawData := self unSpaceAndUpShift: rawData appending: nil.
].
style == #keywordGetz ifTrue: [
rawData := self unSpaceAndUpShift: rawData appending: 'Getz:'.
].
style == #keywordSetter ifTrue: [
rawData := self unSpaceAndUpShift: 'set ',rawData appending: ':'.
].
style == #unaryGetter ifTrue: [
rawData := self unSpaceAndUpShift: 'get ',rawData appending: nil.
].
(#(keyword2 methodHeader2) includes: style) ifTrue: [
rawData := self unSpaceAndUpShift: rawData appending: ':'.
].
rawData
]
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>setRedComponentIn:to: (in category 'player commands') -----
setRedComponentIn: aPatch to: value
+ | xArray yArray patch component |
- | pix xArray yArray patch component |
xArray := arrays at: 2.
yArray := arrays at: 3.
patch := aPatch costume renderedMorph.
value isCollection ifFalse: [
component := (value asInteger bitAnd: 16rFF) bitShift: 16.
].
+ (1 to: self size) do: [:i | | pix |
- (1 to: self size) do: [:i |
value isCollection ifTrue: [
component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 16.
].
pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
pix := (pix bitAnd: 16r00FFFF) bitOr: component.
patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
].
!
Item was changed:
----- Method: SyntaxMorph>>alanKwdIfDo:isAConditional:key:args: (in category 'node to morph') -----
alanKwdIfDo: aNode isAConditional: template key: key args: args
"(know it has more than one arg)"
+ | nodeWithNilReceiver column keywords |
- | nodeWithNilReceiver column keywords row |
nodeWithNilReceiver := aNode copy receiver: nil.
column := self addColumn: #keyword1 on: nodeWithNilReceiver.
"column borderColor: column compoundBorderColor."
keywords := key keywords.
keywords
with: (args first: keywords size)
+ do: [:kwd :arg | | row |
- do: [:kwd :arg |
(row := column addRow: #keyword2 on: nodeWithNilReceiver)
parseNode: (nodeWithNilReceiver as: MessagePartNode).
kwd = 'do:' ifTrue: [
row addMorphBack: (row transparentSpacerOfSize: 26 at 6).
] ifFalse: [
row addMorphBack: (row transparentSpacerOfSize: 10 at 6).
].
row addTokenSpecialCase: kwd
type: #keyword2
on: KeyWordNode new.
(arg asMorphicSyntaxIn: row) setConditionalPartStyle.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>setTurtlesCount:prototype:for:randomize: (in category 'add turtles') -----
setTurtlesCount: count prototype: prototype for: aKedamaWorld randomize: rondomizeFlag
+ | anInteger |
- | anInteger array |
anInteger := count.
count < 0 ifTrue: [anInteger := 0].
self size > anInteger ifTrue: [
+ info associationsDo: [:assoc | | array |
- info associationsDo: [:assoc |
array := (arrays at: assoc value).
array := array copyFrom: 1 to: anInteger.
arrays at: assoc value put: array.
].
turtleMapValid := false.
whoTableValid := false.
].
self size < anInteger ifTrue: [
self addTurtlesCount: (anInteger - self size) ofPrototype: prototype for: aKedamaWorld randomize: rondomizeFlag.
turtleMapValid := false.
whoTableValid := false.
].
!
Item was changed:
----- Method: ScriptInstantiation>>assignStatusToAllSiblings (in category 'misc') -----
assignStatusToAllSiblings
"Let all sibling instances of my player have the same status that I do. The stati affected are both the event stati and the tickingStati"
+
- | aScriptInstantiation |
(player class allInstances copyWithout: player) do:
+ [:aPlayer | | aScriptInstantiation |
- [:aPlayer |
aScriptInstantiation := aPlayer scriptInstantiationForSelector: selector.
aScriptInstantiation status: status.
aScriptInstantiation frequency: self frequency.
aScriptInstantiation tickingRate: self tickingRate.
aScriptInstantiation updateAllStatusMorphs]!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>addTurtlesCount:ofPrototype:for:positionAndColorArray: (in category 'add turtles') -----
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld positionAndColorArray: positionAndColorArray
+ | oldCount |
- | index array defaultValue newArray oldCount |
oldCount := self size.
+ info associationsDo: [:assoc | | defaultValue index newArray array |
- info associationsDo: [:assoc |
index := info at: assoc key.
array := arrays at: (info at: assoc key).
defaultValue := prototype at: index.
newArray := array class new: count.
(#(who x y heading color normal) includes: assoc key) ifFalse: [
newArray atAllPut: defaultValue.
].
assoc key = #x ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray first startingAt: 1].
assoc key = #y ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray second startingAt: 1].
assoc key = #color ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray third startingAt: 1].
assoc key = #heading ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"].
assoc key = #normal ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"].
arrays at: (assoc value) put: array, newArray.
].
#(who) do: [:name |
self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld.
].
whoTableValid := false.
turtleMapValid := false.
!
Item was changed:
----- Method: Player>>overlapsAny: (in category 'scripts-standard') -----
overlapsAny: aPlayer
"Answer true if my costume overlaps that of aPlayer, or any of its
siblings (if aPlayer is a scripted player)
or if my costume overlaps any morphs of the same class (if aPlayer is
unscripted)."
+ | possibleCostumes itsCostumeClass myShadow |
- | possibleCostumes itsCostume itsCostumeClass myShadow |
(self ~= aPlayer
and: [self overlaps: aPlayer])
ifTrue: [^ true].
possibleCostumes := IdentitySet new.
aPlayer belongsToUniClass
ifTrue: [aPlayer class
+ allSubInstancesDo: [:anInstance | | itsCostume |
+ (anInstance ~~ aPlayer
- allSubInstancesDo: [:anInstance | (anInstance ~~ aPlayer
and: [itsCostume := anInstance costume.
(itsCostume bounds intersects: costume bounds)
and: [itsCostume world == costume world]])
ifTrue: [possibleCostumes add: itsCostume]]]
ifFalse: [itsCostumeClass := aPlayer costume class.
self costume world presenter allExtantPlayers
do: [:ep | ep costume
ifNotNil: [:ea | (ea class == itsCostumeClass
and: [ea bounds intersects: costume bounds])
ifTrue: [possibleCostumes add: ea]]]].
possibleCostumes isEmpty
ifTrue: [^ false].
myShadow := costume shadowForm.
^ possibleCostumes
anySatisfy: [:m | m overlapsShadowForm: myShadow bounds: costume fullBounds]!
Item was changed:
----- Method: Player class>>addMethodReferencesTo: (in category 'user-scripted subclasses') -----
addMethodReferencesTo: aCollection
"For each extant script in the receiver, add a MethodReference object"
+
- | sel |
self scripts do:
+ [:aScript | | sel |
- [:aScript |
(sel := aScript selector) ifNotNil:
[aCollection add: (MethodReference new setStandardClass: self methodSymbol: sel)]]!
Item was changed:
----- Method: StackMorph class>>discoverSlots: (in category 'misc') -----
discoverSlots: aMorph
"Examine the parts of the morph for ones that couldHoldSeparateData. Return a pair of lists: Named morphs, and unnamed morphs (which may be labels, and non-data). Examine all submorphs."
+ | named unnamed |
- | named unnamed got sn generic |
named := OrderedCollection new.
unnamed := OrderedCollection new.
+ aMorph submorphsDo: [:direct | | got |
- aMorph submorphsDo: [:direct |
got := false.
+ direct allMorphsDo: [:sub | | generic sn |
- direct allMorphsDo: [:sub |
sub couldHoldSeparateDataForEachInstance ifTrue: [
(sn := sub knownName) ifNotNil: [
generic := (#('Number (fancy)' 'Number (mid)' 'Number (bare)')
includes: sn).
(sn beginsWith: 'shared' "label") | generic ifFalse: [
named add: sub.
got := true]]]].
got ifFalse: [unnamed add: direct]].
^ Array with: named with: unnamed
!
Item was changed:
----- Method: CardPlayer class>>setSlotInfoFromVariableDocks (in category 'variable docks') -----
setSlotInfoFromVariableDocks
"Get the slotInfo fixed up after a change in background shape. Those instance variables that are proactively added by the user will persist, whereas those that are automatically generated will be updated"
- | aDock newInfo |
-
self slotInfo copy do: "Remove old automatically-created slots"
+ [:aSlotInfo | | aDock |
+ (aDock := aSlotInfo variableDock) ifNotNil:
- [:aSlotInfo | (aDock := aSlotInfo variableDock) ifNotNil:
[slotInfo removeKey: aDock variableName]].
+ self variableDocks do: [:dock | | newInfo | "Generate fresh slots from variable docks"
- self variableDocks do: [:dock | "Generate fresh slots from variable docks"
newInfo := SlotInformation new type: dock variableType.
newInfo variableDock: dock.
slotInfo at: dock variableName asSymbol put: newInfo]!
Item was changed:
----- Method: TileMorph>>showOptions (in category 'mouse handling') -----
showOptions
"The receiver is a tile that represents an operator; a click on the
receiver's label will pop up a menu of alternative operator choices"
+ | result menuChoices |
+ menuChoices := (self options first collect: [:each | each asString translated]) collect: [:each | | word |
- | result menuChoices word |
- menuChoices := (self options first collect: [:each | each asString translated]) collect: [:each |
word := self currentVocabulary translatedWordingFor: each asSymbol.
word isEmpty
ifTrue: ['<-']
ifFalse: [word]].
result := UIManager default chooseFrom: menuChoices values: self options first.
result
ifNotNil: [self value: result.
self scriptEdited]!
Item was changed:
----- Method: StandardScriptingSystem>>customEventNamesAndHelpStringsFor: (in category '*eToys-customevents-custom events') -----
customEventNamesAndHelpStringsFor: aPlayer
+ | retval morph |
- | retval help helpStrings morph |
morph := aPlayer costume renderedMorph.
retval := SortedCollection sortBlock: [ :a :b | a first < b first ].
self customEventsRegistry
keysAndValuesDo: [ :k :v |
+ | helpStrings |
helpStrings := Array streamContents: [ :hsStream |
v keysAndValuesDo: [ :registrant :array |
(morph isKindOf: array second) ifTrue: [
+ | help |
help := String streamContents: [ :stream |
v size > 1
ifTrue: [ stream nextPut: $(;
nextPutAll: array second name;
nextPut: $);
space ].
stream nextPutAll: array first ].
hsStream nextPut: help ]]].
helpStrings isEmpty ifFalse: [retval add: { k. helpStrings } ]].
^ retval!
Item was changed:
----- Method: Player>>methodInterfacesForInstanceVariablesCategoryIn: (in category 'slots-kernel') -----
methodInterfacesForInstanceVariablesCategoryIn: aVocabulary
"Return a collection of methodInterfaces for the instance-variables category. The vocabulary parameter, at present anyway, is not used."
+ | aList |
- | aList anInterface itsSlotName |
aList := OrderedCollection new.
self slotInfo associationsDo:
+ [:assoc | | itsSlotName anInterface |
- [:assoc |
anInterface := MethodInterface new.
itsSlotName := assoc key.
anInterface
wording: itsSlotName;
helpMessage: 'a variable defined by this object' translated.
anInterface selector: (Utilities getterSelectorFor: itsSlotName) type: assoc value type setter: (Utilities setterSelectorFor: itsSlotName).
anInterface setToRefetch.
aList add: anInterface].
^ aList!
Item was changed:
----- Method: KedamaVectorizer>>getSelectorFor:fromMessageNode:for:ifFoundDo:ignoreSelectors: (in category 'player and selector look up') -----
getSelectorFor: receiver fromMessageNode: aMessageNode for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
+
- | thisPlayer key |
root ifNotNil: [^ self].
+ (Array with: aMessageNode receiver), aMessageNode arguments do: [:stmt | | key thisPlayer |
- (Array with: aMessageNode receiver), aMessageNode arguments do: [:stmt |
(stmt isMemberOf: VariableNode) ifTrue: [
thisPlayer := Compiler evaluate: stmt name for: obj logged: false.
thisPlayer == receiver ifTrue: [
key := aMessageNode selector key.
(ignoreSelectors includes: key) ifFalse: [aBlock value: key. ^ self]].
].
(stmt isMemberOf: MessageNode) ifTrue: [
self getSelectorFor: receiver fromMessageNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
].
(stmt isMemberOf: BlockNode) ifTrue: [
self getSelectorFor: receiver fromBlockNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>deleteTurtleID: (in category 'player commands') -----
deleteTurtleID: who
+ | whoArray whoIndex |
- | whoArray whoIndex newArray |
whoArray := arrays at: 1.
whoIndex := whoArray indexOf: who ifAbsent: [^ self].
deletingIndex := whoIndex - 1.
+ arrays withIndexDo: [:array :index | | newArray |
- arrays withIndexDo: [:array :index |
newArray := (array copyFrom: 1 to: whoIndex - 1), (array copyFrom: whoIndex + 1 to: array size).
arrays at: index put: newArray.
].
whoTableValid := false.
turtleMapValid := false.
!
Item was changed:
----- Method: StackMorph>>getAllText (in category 'menu') -----
getAllText
"Collect the text for each card. Just point at strings so don't have to recopy them. (Parallel array of urls for ID of cards. Remote cards not working yet.)
allText = Array (cards size) of arrays (fields in it) of strings of text.
allTextUrls = Array (cards size) of urls or card numbers."
+ | oldUrls oldStringLists allText allTextUrls |
- | oldUrls oldStringLists allText allTextUrls aUrl which |
self writeSingletonData.
oldUrls := self valueOfProperty: #allTextUrls ifAbsent: [#()].
oldStringLists := self valueOfProperty: #allText ifAbsent: [#()].
allText := self privateCards collect: [:pg | OrderedCollection new].
allTextUrls := Array new: self privateCards size.
+ self privateCards doWithIndex: [:aCard :ind | | aUrl which |
+ aUrl := aCard url. aCard isInMemory
+ ifTrue: [(allText at: ind) addAll: (aCard allStringsAfter: nil).
+ aUrl ifNil: [aUrl := ind].
+ allTextUrls at: ind put: aUrl]
+ ifFalse: ["Order of cards on server may be different. (later keep up to date?)"
+ "*** bug in this algorithm if delete a page?"
+ which := oldUrls indexOf: aUrl.
+ allTextUrls at: ind put: aUrl.
+ which = 0 ifFalse: [allText at: ind put: (oldStringLists at: which)]]].
- self privateCards doWithIndex: [:aCard :ind | aUrl := aCard url. aCard isInMemory
- ifTrue: [(allText at: ind) addAll: (aCard allStringsAfter: nil).
- aUrl ifNil: [aUrl := ind].
- allTextUrls at: ind put: aUrl]
- ifFalse: ["Order of cards on server may be different. (later keep up to date?)"
- "*** bug in this algorithm if delete a page?"
- which := oldUrls indexOf: aUrl.
- allTextUrls at: ind put: aUrl.
- which = 0 ifFalse: [allText at: ind put: (oldStringLists at: which)]]].
self setProperty: #allText toValue: allText.
self setProperty: #allTextUrls toValue: allTextUrls.
^ allText!
Item was changed:
----- Method: SearchingViewer>>doSearchFrom:interactive: (in category 'search') -----
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 useTranslations scriptNames addedMorphs |
- | 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 | | anInterface |
+ (aVocab includesSelector: aSelector forInstance: scriptedPlayer ofClass: scriptedPlayer class limitClass: ProtoObject) and:
- [: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, '"']]!
Item was changed:
----- Method: SyntaxMorph>>mouseMove: (in category 'event handling') -----
mouseMove: evt
+
- | dup selection |
owner isSyntaxMorph ifFalse: [^ self].
false ifTrue: ["for now, do not drag off a tile"
self currentSelectionDo:
+ [:innerMorph :mouseDownLoc :outerMorph | | dup selection |
- [:innerMorph :mouseDownLoc :outerMorph |
mouseDownLoc ifNotNil: [
(evt cursorPoint dist: mouseDownLoc) > 4 ifTrue:
["If drag 5 pixels, then tear off a copy of outer selection."
selection := outerMorph ifNil: [self].
selection deletePopup.
evt hand attachMorph: (dup := selection duplicate).
Preferences tileTranslucentDrag
ifTrue: [dup lookTranslucent]
ifFalse: [dup align: dup topLeft
with: evt hand position + self cursorBaseOffset].
self setSelection: nil. "Why doesn't this deselect?"
(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
ifNotNil: [:m | "Activate enclosing block."
m startStepping]]]].
].!
Item was changed:
----- Method: StandardViewer>>likelyCategoryToShow (in category 'categories') -----
likelyCategoryToShow
"Choose a category to show based on what's already showing and on some predefined heuristics"
+ | possible all currVocab |
- | possible all aCat currVocab |
all := (scriptedPlayer categoriesForViewer: self) asOrderedCollection.
possible := all copy.
currVocab := self currentVocabulary.
self categoryMorphs do:
[:m |
+ | aCat |
aCat := currVocab categoryWhoseTranslatedWordingIs: m currentCategory.
aCat ifNotNil: [possible remove: aCat wording ifAbsent: []]].
(possible includes: ScriptingSystem nameForInstanceVariablesCategory translated) ifTrue:
[^ ScriptingSystem nameForInstanceVariablesCategory].
(currVocab isEToyVocabulary)
ifTrue:
[(possible includes: ScriptingSystem nameForScriptsCategory translated)
ifTrue: [^ ScriptingSystem nameForScriptsCategory]].
{'kedama' translated. #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]!
Item was changed:
----- Method: Player>>universalTilesForInterface: (in category 'scripts-kernel') -----
universalTilesForInterface: aMethodInterface
"Return universal tiles for the given method interface. Record who self is."
+ | ms itsSelector argList makeSelfGlobal phrase aType |
- | ms argTile itsSelector aType argList makeSelfGlobal phrase |
itsSelector := aMethodInterface selector.
argList := OrderedCollection new.
aMethodInterface argumentVariables doWithIndex:
+ [:anArgumentVariable :anIndex | | argTile |
- [:anArgumentVariable :anIndex |
argTile := ScriptingSystem tileForArgType: (aType := aMethodInterface typeForArgumentNumber: anIndex).
argList add: (aType == #Player
ifTrue: [argTile actualObject]
ifFalse: [argTile literal]). "default value for each type"].
ms := MessageSend receiver: self selector: itsSelector arguments: argList asArray.
"For CardPlayers, use 'self'. For others, name me, and use my global name."
makeSelfGlobal := self class officialClass ~~ CardPlayer.
phrase := ms asTilesIn: self class globalNames: makeSelfGlobal.
makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: self].
^ phrase
!
Item was changed:
----- Method: SyntaxMorph>>tossOutArg: (in category 'pop ups') -----
tossOutArg: extras
"Remove the tiles for the last N keywords and arguments. Place the tiles beside the current window. I am a SyntaxMorph for a MessageNode."
+ | cnt |
- | cnt ctr |
cnt := 0.
+ submorphs copy reverseDo: [:sub | | ctr |
- submorphs copy reverseDo: [:sub |
ctr := sub fullBoundsInWorld center.
sub delete.
(sub isSyntaxMorph and: [sub parseNode notNil]) ifTrue: [
sub isNoun ifTrue: [
self pasteUpMorph addMorphFront: sub.
sub position: self enclosingPane fullBoundsInWorld right - 20 @ ctr y].
(cnt := cnt + 1) >= extras ifTrue: [^ self]]].!
Item was changed:
----- Method: Player class>>namedUnaryTileScriptSelectors (in category 'scripts') -----
namedUnaryTileScriptSelectors
"Answer a list of all the selectors of named unary tile scripts"
+
- | sel |
scripts ifNil: [^ OrderedCollection new].
+ ^ scripts select: [:aScript | | sel | ((sel := aScript selector) ~~ nil) and: [sel numArgs == 0]]
- ^ scripts select: [:aScript | ((sel := aScript selector) ~~ nil) and: [sel numArgs == 0]]
thenCollect: [:aScript | aScript selector]!
Item was changed:
----- Method: StackMorph>>findText:inStrings:startAt:container:cardNum: (in category 'menu') -----
findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer cardNum: cardNum
"Call once to search a card of the stack. Return true if found and highlight the text. oldContainer should be NIL.
(oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element. oldContainer is a TextMorph.)"
+ | container strings old good insideOf place start |
- | good thisWord index insideOf place container start strings old |
good := true.
start := startIndex.
strings := oldContainer ifNil:
["normal case"
rawStrings]
ifNotNil: [self currentPage allStringsAfter: oldContainer text].
keys do:
+ [:searchString | | thisWord |
- [:searchString |
"each key"
good
ifTrue:
[thisWord := false.
strings do:
+ [:longString | | index |
- [:longString |
(index := longString findWordStart: searchString startingAt: start) > 0
ifTrue:
[thisWord not & (searchString == keys first)
ifTrue:
[insideOf := longString.
place := index].
thisWord := true].
start := 1]. "only first key on first container"
good := thisWord]].
good
ifTrue:
["all are on this page"
"wasIn := (pages at: pageNum) isInMemory."
self goToCardNumber: cardNum
"wasIn ifFalse: ['search again, on the real current text. Know page is in.'.
^ self findText: keys
inStrings: ((pages at: pageNum) allStringsAfter: nil) recompute it
startAt: startIndex container: oldContainer
pageNum: pageNum]"].
(old := self valueOfProperty: #searchContainer) ifNotNil:
[(old respondsTo: #editor)
ifTrue:
[old editor selectFrom: 1 to: 0. "trying to remove the previous selection!!"
old changed]].
good
ifTrue:
["have the exact string object"
(container := oldContainer) ifNil:
[container := self
highlightText: keys first
at: place
in: insideOf]
ifNotNil:
[container userString == insideOf
ifFalse:
[container := self
highlightText: keys first
at: place
in: insideOf]
ifTrue:
[(container isTextMorph)
ifTrue:
[container editor selectFrom: place to: keys first size - 1 + place.
container changed]]].
self setProperty: #searchContainer toValue: container.
self setProperty: #searchOffset toValue: place.
self setProperty: #searchKey toValue: keys. "override later"
ActiveHand newKeyboardFocus: container.
^true].
^false!
Item was changed:
----- Method: CardPlayer>>matchNames (in category 'as template') -----
matchNames
+ | list tms stk crds |
- | list str ll tms stk crds |
"List of names of cards that matched the last template search."
tms := self class classPool at: #TemplateMatches ifAbsent: [^ #()].
list := (tms at: self ifAbsent: [#(#() 0)]) first.
stk := costume valueOfProperty: #myStack ifAbsent: [nil].
crds := stk ifNil: [#()] ifNotNil: [stk cards].
+ ^ list collect: [:cd | | str ll |
- ^ list collect: [:cd |
str := ''.
(ll := cd allStringsAfter: nil) ifNotNil: [
str := ll inject: '' into: [:strr :this | strr, this]].
(str copyFrom: 1 to: (30 min: str size)), '... (' , (crds indexOf: cd) printString, ')'].
"Maybe include a card title?"!
Item was changed:
----- Method: SyntaxMorph>>alanKwdRepeatForDoing:isAConditional:key:args: (in category 'node to morph') -----
alanKwdRepeatForDoing: aNode isAConditional: template key: key args: args
+ | nodeWithNilReceiver column keywords |
- | nodeWithNilReceiver row column keywords |
nodeWithNilReceiver := aNode copy receiver: nil.
column := self addColumn: #keyword1 on: nodeWithNilReceiver.
keywords := key keywords.
keywords
with: (args first: keywords size)
+ do: [:kwd :arg | | row |
- do: [:kwd :arg |
(row := column addRow: #keyword2 on: nodeWithNilReceiver)
parseNode: (nodeWithNilReceiver as: MessagePartNode).
row addToken: kwd
type: #keyword2
on: KeyWordNode new.
(arg asMorphicSyntaxIn: row) setConditionalPartStyle.
].
!
Item was changed:
----- Method: KedamaMorph>>delete (in category 'deleting') -----
delete
- | c |
super delete.
turtlesDict keysDo: [:k |
+ | c |
self deleteAllTurtlesOfExampler: k.
c := k costume.
c ifNotNil: [c renderedMorph delete].
].
!
Item was changed:
----- Method: Player>>pacifyScript: (in category 'customevents-scripts-kernel') -----
pacifyScript: aSymbol
"Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side"
+ | aUserScript |
- | aHandler aUserScript |
aUserScript := self class userScriptForPlayer: self selector: aSymbol.
aUserScript ifNil: [self flag: #deferred. ^ Beeper 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 | | itsCostume aHandler |
- [:aPlayer | | itsCostume |
aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: [].
itsCostume := aPlayer costume renderedMorph.
(aHandler := itsCostume eventHandler) ifNotNil:
[aHandler forgetDispatchesTo: aSymbol].
itsCostume removeEventTrigger: aSymbol ]!
Item was changed:
----- Method: KedamaVectorizer>>getPlayersMessage:for:into: (in category 'player and selector look up') -----
getPlayersMessage: aMessageNode for: obj into: aCollection
+
+ ((Array with: aMessageNode receiver), aMessageNode arguments) do: [:stmt | | thisPlayer |
- | thisPlayer |
- ((Array with: aMessageNode receiver), aMessageNode arguments) do: [:stmt |
(stmt isMemberOf: MessageNode) ifTrue: [
self getPlayersMessage: stmt for: obj into: aCollection.
].
(stmt isMemberOf: BlockNode) ifTrue: [
self getPlayersBlock: stmt for: obj into: aCollection..
].
(stmt isMemberOf: VariableNode) ifTrue: [
thisPlayer := Compiler evaluate: stmt name for: obj logged: false.
(thisPlayer isKindOf: Player) ifTrue: [aCollection add: stmt].
].
].
!
Item was changed:
----- Method: EToyProjectQueryMorph class>>onServer: (in category 'as yet unclassified') -----
onServer: aProjectServer
"EToyProjectQueryMorph onServer: SuperSwikiServer testOnlySuperSwiki"
+
- | criteria clean |
(self basicNew)
project: nil
+ actionBlock: [ :x | | criteria |
- actionBlock: [ :x |
criteria := OrderedCollection new.
+ x keysAndValuesDo: [ :k :v | | clean |
- x keysAndValuesDo: [ :k :v |
(clean := v withBlanksTrimmed) isEmpty
ifFalse: [criteria add: k,': *',clean,'*']].
aProjectServer queryProjectsAndShow: criteria];
initialize;
becomeModal;
openCenteredInWorld!
Item was changed:
----- Method: Player>>touchesA: (in category 'misc') -----
touchesA: aPrototypicalPlayer
"Answer whether the receiver overlaps any player who wears a Sketch costume and who is of the same class as the prototypicalPlayer and who is wearing the same bitmap, but who is *not that player itself*!! This is an extreme case of a function highly customized (by Bob Arning) to suit a single, idiosycratic, and narrow demo need of Alan's. Consult:
http://groups.yahoo.com/group/squeak/message/40560"
+ | envelope trueGoal trueSelf |
- | envelope trueNeighbor trueGoal trueSelf itsPlayer |
aPrototypicalPlayer ifNil: [^ false].
envelope := costume owner ifNil: [^ false].
trueSelf := costume renderedMorph.
trueGoal := aPrototypicalPlayer costume renderedMorph.
+ envelope submorphs do: [:each | | trueNeighbor itsPlayer |
- envelope submorphs do: [:each |
trueNeighbor := each renderedMorph.
(trueNeighbor == trueGoal or: [trueNeighbor == trueSelf]) ifFalse:
[(itsPlayer := each player) ifNotNil:
[(itsPlayer overlaps: self) ifTrue:
[(trueGoal appearsToBeSameCostumeAs: trueNeighbor) ifTrue: [^ true]]]]].
^ false
!
Item was changed:
----- Method: Player>>renameScript:newSelector: (in category 'scripts-kernel') -----
renameScript: oldSelector newSelector: newSelector
"Rename the given script to have the new selector"
+ | aUserScript anInstantiation |
- | aUserScript anInstantiation aDict |
oldSelector = newSelector ifTrue: [^ self].
oldSelector numArgs == 0
ifTrue:
[self class allSubInstancesDo:
+ [:aPlayer | | itsCostume aDict |
- [:aPlayer | | itsCostume |
anInstantiation := aPlayer scriptInstantiationForSelector: oldSelector.
anInstantiation ifNotNil: [
newSelector numArgs == 0
ifTrue:
[anInstantiation changeSelectorTo: newSelector].
aDict := aPlayer costume actorState instantiatedUserScriptsDictionary.
itsCostume := aPlayer costume renderedMorph.
itsCostume renameScriptActionsFor: aPlayer from: oldSelector to: newSelector.
self currentWorld renameScriptActionsFor: aPlayer from: oldSelector to: newSelector.
aDict removeKey: oldSelector.
newSelector numArgs == 0 ifTrue:
[aDict at: newSelector put: anInstantiation.
anInstantiation assureEventHandlerRepresentsStatus]]]]
ifFalse:
[newSelector numArgs == 0 ifTrue:
[self class allSubInstancesDo:
[:aPlayer |
anInstantiation := aPlayer scriptInstantiationForSelector: newSelector.
anInstantiation ifNotNil: [anInstantiation assureEventHandlerRepresentsStatus]]]].
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 existingScriptInstantiationForSelector: newSelector) notNil and:
[newSelector numArgs > 0]) ifTrue: [self error: 'ouch'].
self updateAllViewersAndForceToShow: 'scripts'!
Item was changed:
----- Method: KedamaVectorizer>>includesTurtlePlayer:for: (in category 'entry point') -----
includesTurtlePlayer: aMethodNode for: obj
+ | players |
- | players p |
players := self getAllPlayersInMethodNode: aMethodNode for: obj.
+ players do: [:e | | p |
- players do: [:e |
p := Compiler evaluate: e name for: obj logged: false.
(p isKindOf: KedamaExamplerPlayer) ifTrue: [^ true].
].
^ false.
!
Item was changed:
----- Method: Player>>changeTypesInWatchersOf: (in category 'translation') -----
changeTypesInWatchersOf: slotName
"The type of a variable has changed; adjust watchers to that fact."
+ | aGetter |
- | aGetter newWatcher |
aGetter := Utilities getterSelectorFor: slotName.
+ self allPossibleWatchersFromWorld do: [:aWatcher | | newWatcher |
- self allPossibleWatchersFromWorld do: [:aWatcher |
(aWatcher getSelector = aGetter) ifTrue:
[(aWatcher ownerThatIsA: WatcherWrapper) ifNotNil:
[:aWrapper |
newWatcher := (aWrapper submorphs size = 1)
ifTrue:
[WatcherWrapper new unlabeledForPlayer: self getter: aGetter]
ifFalse:
[WatcherWrapper new fancyForPlayer: self getter: aGetter].
newWatcher position: aWatcher position.
aWrapper owner replaceSubmorph: aWrapper by: newWatcher]]]
!
Item was changed:
----- Method: Player>>unusedScriptName (in category 'misc') -----
unusedScriptName
"answer a name of the form 'scriptN', where N is one higher than the highest-numbered similarly-named script"
+ | highestThus |
- | highestThus aPair |
highestThus := 0.
self class tileScriptNames do:
+ [:aName | | aPair |
- [:aName |
aPair := (aName copyWithout: $:) stemAndNumericSuffix.
aPair first = 'script' translated ifTrue: [highestThus := highestThus max: aPair last]].
^ ('script' translated, (highestThus + 1) printString) asSymbol!
Item was changed:
----- Method: KedamaVectorizer>>traverseMessage:in:firstPlayer:inCondition: (in category 'vectorization attribute calculation') -----
traverseMessage: aMessageNode in: obj firstPlayer: firstPlayer inCondition: inCondition
| receiver thisPlayer ret constant proto |
aMessageNode arguments do: [:argument |
(argument isMemberOf: MessageNode) ifTrue: [
self traverseMessage: argument in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(argument isMemberOf: BlockNode) ifTrue: [
self traverseBlock: argument in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(argument isMemberOf: LiteralNode) ifTrue: [
attributes setAttribute: #constant of: argument to: true.
].
(argument isMemberOf: VariableNode) ifTrue: [
thisPlayer := Compiler evaluate: argument name for: obj logged: false.
ret := (thisPlayer isKindOf: Player) and: [thisPlayer costume renderedMorph isKindOf: KedamaPatchMorph].
attributes setAttribute: #constant of: argument to: ret.
].
].
receiver := aMessageNode receiver.
(receiver isMemberOf: MessageNode) ifTrue: [
self traverseMessage: receiver in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(receiver isMemberOf: BlockNode) ifTrue: [
self traverseBlock: receiver in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(receiver isMemberOf: LiteralNode) ifTrue: [
attributes setAttribute: #constant of: receiver to: true.
].
(receiver isMemberOf: VariableNode) ifTrue: [
thisPlayer := Compiler evaluate: receiver name for: obj logged: false.
ret := thisPlayer == firstPlayer.
attributes setAttribute: #constant of: receiver to: ret.
proto := (thisPlayer isKindOf: Player) and: [thisPlayer isPrototypeTurtlePlayer].
attributes setAttribute: #isTurtle of: receiver to: proto.
attributes setAttribute: #scalar of: aMessageNode selector to:
(ret not and: [(proto and: [self isScalarizable: thisPlayer andSelector: aMessageNode selector key])]).
].
"special cases..."
(#(atRandom die getReplicated bounceOn: bounceOn:color: bounceOnColor: ifTrue: ifFalse: ifTrue:ifFalse: itFalse:ifTrue:
setPatchValueIn:to: getTurtleAt: getTurtleOf:) includes: aMessageNode selector key) ifTrue: [
attributes setAttribute: #constant of: aMessageNode to: false.
aMessageNode selector key = #die ifTrue: [
attributes setAttribute: #dieMessage of: root to: true.
].
] ifFalse: [
+ constant := (aMessageNode arguments copyWith: receiver) allSatisfy: [:t | attributes getAttribute: #constant of: t].
- constant := (aMessageNode arguments copyWith: receiver) inject: true into: [:s :t | s := s and: [attributes getAttribute: #constant of: t]].
attributes setAttribute: #constant of: aMessageNode to: constant.
].
!
Item was changed:
----- Method: Player>>renameSlotInWatchersOld:new: (in category 'translation') -----
renameSlotInWatchersOld: oldName new: newName
"A variable has been renamed; get all relevant extant watchers updated. All this assumed to be happening in the ActiveWorld"
+ | oldGetter |
- | wasStepping oldGetter |
oldGetter := Utilities getterSelectorFor: oldName.
+ self allPossibleWatchersFromWorld do: [:aWatcher | | wasStepping |
- self allPossibleWatchersFromWorld do: [:aWatcher |
(aWatcher getSelector = oldGetter) ifTrue:
[(wasStepping := aWatcher isStepping) ifTrue: [aWatcher stopStepping].
aWatcher getSelector: (Utilities getterSelectorFor: newName).
aWatcher putSelector ifNotNil:
[aWatcher putSelector: (Utilities setterSelectorFor: newName)].
((aWatcher isKindOf: UpdatingStringMorph) and: [aWatcher hasStructureOfComplexWatcher]) ifTrue: "Old style fancy watcher"
[aWatcher owner owner traverseRowTranslateSlotOld: oldName to: newName.
(aWatcher target labelFromWatcher: aWatcher) contents: newName, ' = '].
(aWatcher ownerThatIsA: WatcherWrapper) ifNotNil:
[:wrapper | wrapper player: self variableName: newName].
wasStepping ifTrue: [aWatcher startStepping]]]!
Item was changed:
----- Method: Presenter>>booleanTiles (in category 'tile support') -----
booleanTiles
"Answer some boolean-valued tiles. This dates back to very early etoy work in 1997, and presently has no sent senders"
+ | list |
- | list rcvr op arg |
list := #(#(0 #< 1) #(0 #<= 1) #(0 #= 1) #(0 #~= 1) #(0 #> 1) #(0 #>= 1)).
list := list asOrderedCollection collect:
[:entry |
+ | rcvr op arg |
rcvr := entry first.
op := (entry second) asSymbol.
arg := entry last.
self
phraseForReceiver: rcvr
op: op
arg: arg
resultType: #Boolean].
list add: (self
phraseForReceiver: Color red
op: #=
arg: Color red
resultType: #Boolean).
^list "copyWith: CompoundTileMorph new"!
Item was changed:
----- Method: KedamaVectorizer>>checkRequireVectorIn:for: (in category 'private') -----
checkRequireVectorIn: aMessageNode for: obj
+ | players playersSet playerNodes |
- | players playersSet sel playerNodes |
"self halt."
playerNodes := self getAllPlayersIn: aMessageNode for: obj.
players := playerNodes collect: [:e | Compiler evaluate: e name for: obj logged: false.].
playersSet := players asSet.
(playersSet select: [:e | e isPrototypeTurtlePlayer]) size = 0 ifTrue: [
attributes setAttribute: #firstTurtle of: aMessageNode to: (Compiler evaluate: playerNodes first name for: obj logged: false).
attributes setAttribute: #requireVector of: aMessageNode to: false.
^ self.
].
(playersSet select: [:e | e isPrototypeTurtlePlayer]) size > 0 ifTrue: [
+ playerNodes with: players do: [:n :p | | sel |
- playerNodes with: players do: [:n :p |
p isPrototypeTurtlePlayer ifTrue: [
sel := self getSelectorRootFor: p fromMessageNode: aMessageNode for: obj ignoreSelectors: #(beNotZero: setTurtleCount: getTurtleCount setGrouped: getGrouped).
sel ifNotNil: [
(self isVectorizationRequiredWithPlayer: p andSelector: sel) ifTrue: [
attributes setAttribute: #requireVector of: aMessageNode to: true.
attributes setAttribute: #firstTurtle of: aMessageNode to: p.
attributes setAttribute: #firstNode of: aMessageNode to: n.
^ self.
].
].
].
].
].
attributes setAttribute: #firstTurtle of: aMessageNode to: players first.
attributes setAttribute: #requireVector of: aMessageNode to: false.
!
Item was changed:
----- Method: MessageSend>>asTilesIn:globalNames: (in category '*eToys-tiles') -----
asTilesIn: playerClass globalNames: makeSelfGlobal
+ | code tree syn block phrase |
- | code keywords num tree syn block phrase |
"Construct SyntaxMorph tiles for me. If makeSelfGlobal is true, name the receiver and use that name, else use 'self'. (Note that this smashes 'self' into the receiver, regardless of what it was.)"
"This is really cheating!! Make a true parse tree later. -tk"
+ code := String streamContents: [:strm | | keywords num |
- code := String streamContents: [:strm |
strm nextPutAll: 'doIt'; cr; tab.
strm nextPutAll:
(makeSelfGlobal ifTrue: [self stringFor: receiver] ifFalse: ['self']).
keywords := selector keywords.
strm space; nextPutAll: keywords first.
(num := selector numArgs) > 0 ifTrue: [strm space.
strm nextPutAll: (self stringFor: arguments first)].
2 to: num do: [:kk |
strm space; nextPutAll: (keywords at: kk).
strm space; nextPutAll: (self stringFor: (arguments at: kk))]].
"decompile to tiles"
tree := Compiler new
parse: code
in: playerClass
notifying: nil.
syn := tree asMorphicSyntaxUsing: SyntaxMorph.
block := syn submorphs detect: [:mm |
(mm respondsTo: #parseNode) ifTrue: [
mm parseNode class == BlockNode] ifFalse: [false]].
phrase := block submorphs detect: [:mm |
(mm respondsTo: #parseNode) ifTrue: [
mm parseNode class == MessageNode] ifFalse: [false]].
^ phrase
!
Item was changed:
----- Method: SyntaxMorph class>>testAllMethodsOver: (in category 'as yet unclassified') -----
testAllMethodsOver: methodSize
"MessageTally spyOn: [SyntaxMorph testAllMethodsOver: 600]"
"Add up the total layout area for syntax morphs representing all
methods over the given size. This is a stress-test for SyntaxMorph
layout. A small value for the total area is also a figure of merit in the
presentation of Squeak source code in general."
"Results:
#(69 600 180820874 103700) 11/4
70% build morphs, 12% get source, 9% layout, 8% parse, 1% roundoff
Folded wide receivers, don't center keywords any more.
#(68 600 160033784 127727) 11/9
76% build morphs, 8% get source, 8% layout, 8% parse, 0% roundoff
Folded more messages, dropped extra vertical spacing in blocks.
#(68 600 109141704 137308) 11/10
79% build morphs, 6% get source, 8% layout, 7% parse
Folded more messages, dropped extra horizontal spacing.
#(68 600 106912968 132171) 11/10
80% build morphs, ??% get source, 11% layout, 7% parse
Unfolded keyword messages that will fit on one line.
#(68 600 96497372 132153) 11/10
81% build morphs, ??% get source, 8% layout, 8% parse
After alignment rewrite...
#(74 600 101082316 244799) 11/12
76% build morphs, 4% get source, 15% layout, 5% parse
After alignment rewrite...
#(74 600 101250620 204972) 11/15
74% build morphs, 6% get source, 13% layout, 7% parse
"
+ | biggies stats area |
- | tree source biggies morph stats time area |
biggies := self systemNavigation
allMethodsSelect: [:cm | cm size > methodSize].
stats := OrderedCollection new.
'Laying out all ' , biggies size printString , ' methods over ' , methodSize printString , ' bytes...'
displayProgressAt: Sensor cursorPoint
from: 1
to: biggies size
during: [:bar | biggies
+ withIndexDo: [:methodRef :i | | time |
- withIndexDo: [:methodRef :i |
bar value: i.
Utilities
setClassAndSelectorFrom: methodRef
+ in: [:aClass :aSelector | | source |
- in: [:aClass :aSelector |
source := (aClass compiledMethodAt: aSelector) getSourceFromFile.
time := Time
+ millisecondsToRun: [ | tree morph |
+ tree := Compiler new
- millisecondsToRun: [tree := Compiler new
parse: source
in: aClass
notifying: nil.
morph := tree asMorphicSyntaxUsing: SyntaxMorph.
area := morph fullBounds area]].
stats add: {methodRef. area. time}]].
^ {{biggies size. methodSize. stats
detectSum: [:a | a second]. stats
detectSum: [:a | a third]}. (stats
asSortedCollection: [:x :y | x third >= y third]) asArray}!
Item was changed:
----- Method: StandardScriptingSystem>>holderWithAlphabet (in category '*eToys-utilities') -----
holderWithAlphabet
"Answer a fully instantiated Holder that has submorphs that represent the letters of the uppercase alphabet, with each one having an 'index' slot which bears the letter's index in the alphabet -- 1 for A, 2 for B, etc. A few special characters are provided as per ack request 10/00; for these the index provided is rather arbitrarily assigned"
+ | aMorph aPlayer oneCharString aContainer aWrapper |
- | aMorph aPlayer newMorph oneCharString aContainer aWrapper |
"ScriptingSystem holderWithAlphabet openInHand"
aContainer := self prototypicalHolder useRoundedCorners.
aContainer borderColor: Color blue lighter.
aWrapper := AlignmentMorph new hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0.
aWrapper addMorphBack: (aMorph := TextMorph new contents: 'A').
aMorph beAllFont: ((TextStyle named: Preferences standardEToysFont familyName) fontOfSize: 24).
aMorph width: 14; lock.
aWrapper beTransparent; setNameTo: 'A'.
aPlayer := aWrapper assuredPlayer.
aPlayer addInstanceVariableNamed: #index type: #Number value: 1.
aContainer addMorphBack: aWrapper.
2 to: 26 do:
[:anIndex |
+ | newMorph |
newMorph := aWrapper usableSiblingInstance.
newMorph player perform: #setIndex: with: anIndex.
newMorph firstSubmorph contents: (oneCharString := ($A asciiValue + anIndex - 1) asCharacter asString).
newMorph setNameTo: oneCharString.
aContainer addMorphBack: newMorph].
#(' ' '.' '#') with: #(27 28 29) do:
[:aString :anIndex |
+ | newMorph |
newMorph := aWrapper usableSiblingInstance.
newMorph player perform: #setIndex: with: anIndex.
newMorph firstSubmorph contents: aString.
aString = ' '
ifTrue:
[newMorph setNameTo: 'space'.
newMorph color: (Color gray alpha: 0.2)]
ifFalse:
[newMorph setNameTo: aString].
aContainer addMorphBack: newMorph].
aContainer setNameTo: 'alphabet'.
aContainer isPartsBin: true.
aContainer enableDrop: false.
aContainer indicateCursor: false; width: 162.
aContainer color: (Color r: 0.839 g: 1.0 b: 1.0). "Color fromUser"
^ aContainer!
Item was changed:
----- Method: CategoryViewer>>showCategoriesFor: (in category 'categories') -----
showCategoriesFor: aSymbol
"Put up a pop-up list of categories in which aSymbol is filed; replace the receiver with a CategoryViewer for the one the user selects, if any"
+ | allCategories aVocabulary hits chosen |
- | allCategories aVocabulary hits meths chosen |
aVocabulary := self currentVocabulary.
allCategories := scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject.
hits := allCategories select:
[:aCategory |
+ | meths |
meths := aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class.
meths includes: aSymbol].
hits isEmpty ifTrue: [ ^self ].
chosen := UIManager default chooseFrom: hits values: hits.
chosen isEmptyOrNil ifFalse:
[self outerViewer addCategoryViewerFor: chosen atEnd: true]
!
Item was changed:
----- Method: ButtonProperties>>doButtonAction: (in category 'events') -----
doButtonAction: evt
-
- | arity |
target ifNil: [^self].
actionSelector ifNil: [^self].
arguments ifNil: [arguments := #()].
Cursor normal showWhile: [
+ | arity |
arity := actionSelector numArgs.
arity = arguments size ifTrue: [
target perform: actionSelector withArguments: arguments
].
arity = (arguments size + 1) ifTrue: [
target perform: actionSelector withArguments: {evt},arguments
].
arity = (arguments size + 2) ifTrue: [
target perform: actionSelector withArguments: {evt. visibleMorph},arguments
].
]!
Item was changed:
----- Method: Player class>>cleanseScripts (in category 'housekeeping') -----
cleanseScripts
"Fix up various known structure errors in the uniclass relating to the scripts dctionary. Answer the number of fixes made."
+ | errs |
- | errs ed |
scripts ifNil: [scripts := IdentityDictionary new].
errs := 0.
(scripts includesKey: nil) ifTrue: [errs := errs + 1. scripts removeKey: nil].
scripts keysAndValuesDo:
+ [:sel :uniclassScript | | ed |
- [:sel :uniclassScript |
uniclassScript
ifNil:
[errs := errs + 1.
Transcript cr; show: ' fix type 1, nil scripts key'.
scripts removeKey: sel]
ifNotNil:
[(ed := uniclassScript currentScriptEditor)
ifNil:
[errs := errs + 1.
Transcript cr; show: ' fix type 2, sel = ', sel.
self someInstance removeScriptWithSelector: uniclassScript selector.]
ifNotNil:
[uniclassScript playerClassPerSe
ifNil:
[errs := errs + 1.
Transcript cr; show: ' fix type 3, sel = ', sel.
uniclassScript playerClass: self selector: sel]
ifNotNil:
[(ed scriptName ~= uniclassScript selector) ifTrue:
[errs := errs + 1.
ed restoreScriptName: sel.
Transcript cr; show: ' fix type 4, sel = ', sel.]]]]].
^ errs!
Item was changed:
----- Method: KedamaVectorizer>>traverseBlock:in:firstPlayer:inCondition: (in category 'vectorization attribute calculation') -----
traverseBlock: aBlockNode in: obj firstPlayer: firstPlayer inCondition: inCondition
| value statements |
statements := aBlockNode statements.
statements do: [:stmt |
(stmt isMemberOf: MessageNode) ifTrue: [
self traverseMessage: stmt in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(stmt isMemberOf: BlockNode) ifTrue: [
self traverseBlock: stmt in: obj firstPlayer: firstPlayer inCondition: inCondition.
].
(stmt isMemberOf: VariableNode) ifTrue: [
attributes setAttribute: #constant of: stmt to: false
].
(stmt isMemberOf: LiteralNode) ifTrue: [
attributes setAttribute: #constant of: stmt to: true
].
].
+ value := statements allSatisfy: [:stmt | attributes getAttribute: #constant of: stmt].
- value := statements collect: [:stmt | attributes getAttribute: #constant of: stmt].
- value := value inject: true into: [:s :t | s & t].
attributes setAttribute: #constant of: aBlockNode to: value.
!
Item was changed:
----- Method: StackMorph class>>designationsExplainer (in category 'authoring prototype') -----
designationsExplainer
"Answer a morph that contains designation explanation"
+ | aMorph |
- | aMorph aSwatch aTextMorph |
aMorph := AlignmentMorph newColumn color: Color black; layoutInset: 1.
#((green
'Shared items on
Background.
Exact same item
shared by every card')
(orange
'Data items on
Background
Each card has its
own data')
(red
'Instance-specific
items
unique
to this card')) do:
[:aPair |
+ | aSwatch aTextMorph |
aSwatch := AlignmentMorph new extent: 132 @80; color: (Color perform: aPair first); lock.
aSwatch hResizing: #rigid; vResizing: #rigid; layoutInset: 0.
aSwatch borderColor: Color black.
aTextMorph := TextMorph new string: aPair second fontName: Preferences standardEToysFont familyName size: 18.
aTextMorph width: 130.
aTextMorph centered.
aSwatch addMorphBack: aTextMorph.
aMorph addMorphBack: aSwatch].
aMorph hResizing: #shrinkWrap; vResizing: #shrinkWrap.
^ aMorph
"StackMorph designationsExplainer openInHand"
!
Item was changed:
----- Method: SyntaxMorph>>selectorMenu (in category 'pop ups') -----
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."
+ | cats value catNames all ind aVocabulary limitClass |
- | cats value catNames interfaces list setter wording all words ind aVocabulary limitClass |
cats := #().
all := Set new.
value := self receiverObject.
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 | | interfaces list |
- cats := catNames collect: [:nn |
list := OrderedCollection new.
interfaces := value methodInterfacesForCategory: nn
inVocabulary: aVocabulary limitClass: limitClass.
+ interfaces do: [:mi | | setter wording words |
- interfaces do: [:mi |
(all includes: mi selector) ifFalse: [
"list add: (self aSimpleStringMorphWith: mi elementWording). Expensive"
words := mi selector.
(words beginsWith: 'get ') ifTrue: [words := words allButFirst: 4].
mi selector last == $: ifTrue: [
words := String streamContents: [:strm | "add fake args"
(words findTokens: $:) do: [:part | strm nextPutAll: part; nextPutAll: ' 5 ']].
words := words allButLast].
mi selector isInfix ifTrue: [words := words, ' 5'].
words := self splitAtCapsAndDownshifted: words.
list add: (self anUpdatingStringMorphWith: words special: true).
words = mi selector ifFalse: [
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').
wording = setter ifFalse: [
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]].
cats first addFirst: (self aSimpleStringMorphWith: ' '). "spacer"
cats first addFirst: (self aSimpleStringMorphWith: '( from ', value class name, ' )').
cats first first color: (Color green mixed: 0.25 with: Color black).
self selectorMenuAsk: cats. "The method replaceSel:menuItem: does the work.
and replaces the selector."
!
Item was changed:
----- Method: TileMorph>>test (in category 'private') -----
test
+ | pos |
- | pos hh |
"Set the position of all my submorphs. Compute my bounds. Caller must call layoutChanged or set fullBounds to nil."
fullBounds ifNil: [
pos := self topLeft.
+ self submorphsDo: [:sub | | hh |
- self submorphsDo: [:sub |
hh := (self class defaultH - sub height) // 2. "center in Y"
sub privateBounds: (pos + (2 at hh) extent: sub extent).
pos x: (sub right min: 1200)]. "2 pixels spacing on left"
bounds := bounds topLeft corner: pos + (2 @ self class defaultH).
fullBounds := bounds.
].
owner class == TilePadMorph ifTrue: [owner bounds: bounds].
^ fullBounds!
Item was changed:
----- Method: MessageSend>>asTilesIn: (in category '*eToys-tiles') -----
asTilesIn: playerClass
+ | code tree syn block phrase |
- | code keywords num tree syn block phrase |
"Construct SyntaxMorph tiles for me."
"This is really cheating!! Make a true parse tree later. -tk"
+ code := String streamContents: [:strm | | num keywords |
- code := String streamContents: [:strm |
strm nextPutAll: 'doIt'; cr; tab.
strm nextPutAll: (self stringFor: receiver).
keywords := selector keywords.
strm space; nextPutAll: keywords first.
(num := selector numArgs) > 0 ifTrue: [strm space.
strm nextPutAll: (self stringFor: arguments first)].
2 to: num do: [:kk |
strm space; nextPutAll: (keywords at: kk).
strm space; nextPutAll: (self stringFor: (arguments at: kk))]].
"decompile to tiles"
tree := Compiler new
parse: code
in: playerClass
notifying: nil.
syn := tree asMorphicSyntaxUsing: SyntaxMorph.
block := syn submorphs detect: [:mm |
(mm respondsTo: #parseNode) ifTrue: [
mm parseNode class == BlockNode] ifFalse: [false]].
phrase := block submorphs detect: [:mm |
(mm respondsTo: #parseNode) ifTrue: [
mm parseNode class == MessageNode] ifFalse: [false]].
^ phrase
!
Item was changed:
----- Method: SyntaxMorph>>selectorMenuAsk: (in category 'pop ups') -----
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 |
- | menu col |
listOfLists isEmpty ifTrue: [^ nil].
listOfLists first addFirst: (self aSimpleStringMorphWith: '( Cancel )').
listOfLists first first color: Color red.
menu := RectangleMorph new.
menu listDirection: #leftToRight; layoutInset: 3; cellInset: 1 at 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 |
- listOfLists do: [:ll |
col := Morph new.
col listDirection: #topToBottom; layoutInset: 0; cellInset: 0 at 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: #replaceKeyWord:menuItem: to: self]
].
self world addMorph: menu.
menu setConstrainedPosition: (owner localPointToGlobal: self topRight) + (10 at -30)
hangOut: false.
!
Item was changed:
----- Method: TextMorph>>setNewContentsFrom: (in category '*eToys-card & stack') -----
setNewContentsFrom: stringOrTextOrNil
"Using stringOrTextOrNil as a guide, set the receiver's contents afresh. If the input parameter is nil, the a default value stored in a property of the receiver, if any, will supply the new initial content. This method is only called when a VariableDock is attempting to put a new value. This is still messy and ill-understood and not ready for prime time."
+ | defaultValue |
- | defaultValue tt atts |
stringOrTextOrNil ifNotNil: [^ self newContents: stringOrTextOrNil
fromCard: (self valueOfProperty: #cardInstance)].
"Well, totally yuk -- emergency measure late on eve of demo"
defaultValue := self valueOfProperty: #defaultValue
+ ifAbsent: [ | atts tt |
+ atts := text attributesAt: 1. "Preserve size, emphasis"
- ifAbsent: [atts := text attributesAt: 1. "Preserve size, emphasis"
tt := text copyReplaceFrom: 1 to: text size
with: 'blankText'.
atts do: [:anAtt | tt addAttribute: anAtt].
tt].
self contents: defaultValue deepCopy wrappedTo: self width.
!
Item was changed:
----- Method: SyntaxMorph>>printBlockArgsNodeOn:indent: (in category 'printing') -----
printBlockArgsNodeOn: strm indent: level
+
- | argString |
self
+ submorphsDoIfSyntax: [ :sub | | argString |
- submorphsDoIfSyntax: [ :sub |
(argString := sub decompile) isEmpty ifFalse: [
strm
nextPut: $:;
nextPutAll: argString;
space
].
]
ifString: [ :sub |
"self printSimpleStringMorph: sub on: strm <<<< do we need this??"
].
strm nextPut: $|; crtab: level.
!
Item was changed:
----- Method: CardPlayer>>match:fields: (in category 'card data') -----
match: keys fields: docks
+
- | longString |
"see if each key occurs in my corresponding text instance."
+ keys withIndexDo: [:kk :ind | | longString |
- keys withIndexDo: [:kk :ind |
kk ifNotNil: [
longString := (self perform: (docks at: ind) playerGetSelector) string.
kk do: [:aKey |
((longString findString: aKey startingAt: 1 caseSensitive: false) > 0)
ifFalse: [^ false]]]]. "all keys must match"
^ true!
Item was changed:
----- Method: Vocabulary>>tileWordingForSelector: (in category '*eToys-queries') -----
tileWordingForSelector: aSelector
"Answer the wording to emblazon on tiles representing aSelector"
+ | anInterface |
- | anInterface inherent |
anInterface := self methodInterfaceAt: aSelector asSymbol ifAbsent:
+ [ | inherent |
+ inherent := Utilities inherentSelectorForGetter: aSelector.
- [inherent := Utilities inherentSelectorForGetter: aSelector.
^ inherent
ifNil:
[self translatedWordingFor: aSelector]
ifNotNil:
[inherent translated]].
^ anInterface wording!
Item was changed:
----- Method: CardPlayer>>allStringsAfter: (in category 'card data') -----
allStringsAfter: aText
"return an OrderedCollection of strings of text in my instance vars. If aText is non-nil, begin with that object."
+ | list ok |
- | list ok instVarValue string |
list := OrderedCollection new.
ok := aText isNil.
self class variableDocks do:
+ [:vdock | | instVarValue string |
- [:vdock |
instVarValue := self perform: vdock playerGetSelector.
ok ifFalse: [ok := instVarValue == aText]. "and do this one too"
ok
ifTrue:
[string := nil.
instVarValue isString ifTrue: [string := instVarValue].
instVarValue isText ifTrue: [string := instVarValue string].
instVarValue isNumber ifTrue: [string := instVarValue printString].
instVarValue isMorph ifTrue: [string := instVarValue userString]. "not used"
string ifNotNil:
[string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]].
privateMorphs
ifNotNil: [privateMorphs do: [:mm | list addAll: (mm allStringsAfter: nil)]].
^list!
Item was changed:
----- Method: SyntaxMorph>>mouseUp: (in category 'event handling') -----
mouseUp: evt
+
- | newSel |
self rootTile isMethodNode ifFalse: [^ self].
self currentSelectionDo:
+ [:innerMorph :mouseDownLoc :outerMorph | | newSel |
- [:innerMorph :mouseDownLoc :outerMorph |
newSel := outerMorph
ifNil: [self "first click"]
ifNotNil: [(outerMorph firstOwnerSuchThat:
[:m | m isSyntaxMorph and: [m isSelectable]]) ifNil: [self]].
newSel isMethodNode ifTrue: [^ self setSelection: nil].
self setSelection: {self. nil. newSel}]
!
Item was changed:
----- Method: StandardScriptingSystem>>reinvigorateThumbnailsInViewerFlapTabs (in category '*eToys-utilities') -----
reinvigorateThumbnailsInViewerFlapTabs
"It has happened that the thumbnail in a viewer flap tab will go solid gray because it got associated with some passing and disused player temporarily created during the initial painting process. This method takes a sledge hammer to repair such thumbnails. At its genesis, this method is called only from the postscript of its defining fileout."
- | vwr thumbnail |
ViewerFlapTab allInstancesDo:
[:aTab |
+ | vwr thumbnail |
vwr := aTab referent findA: StandardViewer.
thumbnail := aTab findA: ThumbnailMorph.
(vwr notNil and: [thumbnail notNil]) ifTrue:
[thumbnail objectToView: vwr scriptedPlayer]]
"ScriptingSystem reinvigorateThumbnailsInViewerFlapTabs"!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>setBlueComponentIn:to: (in category 'player commands') -----
setBlueComponentIn: aPatch to: value
+ | xArray yArray patch component |
- | pix xArray yArray patch component |
xArray := arrays at: 2.
yArray := arrays at: 3.
patch := aPatch costume renderedMorph.
value isCollection ifFalse: [
component := value asInteger bitAnd: 16rFF.
].
+ (1 to: self size) do: [:i | | pix |
- (1 to: self size) do: [:i |
value isCollection ifTrue: [
component := (value at: i) asInteger bitAnd: 16rFF.
].
pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
pix := (pix bitAnd: 16rFFFF00) bitOr: component.
patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
].
!
Item was changed:
----- Method: Presenter>>allExtantPlayers (in category 'intialize') -----
allExtantPlayers
"The initial intent here was to produce a list of Player objects associated with any Morph in the tree beneath the receiver's associatedMorph. whether it is the submorph tree or perhaps off on unseen bookPages. We have for the moment moved away from that initial intent, and in the current version we only deliver up players associated with the submorph tree only. <-- this note dates from 4/21/99
Call #flushPlayerListCache; to force recomputation."
+ | fullList |
- | fullList objectsReferredToByTiles |
playerList ifNotNil:
[^ playerList].
fullList := associatedMorph allMorphs select:
[:m | m player ~~ nil] thenCollect: [:m | m player].
fullList copy do:
[:aPlayer |
aPlayer class scripts do:
[:aScript | aScript isTextuallyCoded ifFalse:
[aScript currentScriptEditor ifNotNil: [:ed |
+ | objectsReferredToByTiles |
objectsReferredToByTiles := ed allMorphs
select:
[:aMorph | (aMorph isKindOf: TileMorph) and: [aMorph type == #objRef]]
thenCollect:
[:aMorph | aMorph actualObject].
fullList addAll: objectsReferredToByTiles]]]].
^ playerList := (fullList asSet asSortedCollection:
[:a :b | a externalName < b externalName]) asArray!
Item was changed:
----- Method: SyntaxMorph class>>testAll (in category 'as yet unclassified') -----
testAll
+ | systNav total count|
- | source tree total count systNav|
"
SyntaxMorph testAll
"
systNav := self systemNavigation.
count := total := 0.
systNav allBehaviorsDo: [ :aClass | total := total + 1].
'Testing all behaviors'
displayProgressAt: Sensor cursorPoint
from: 0 to: total
during: [ :bar |
systNav allBehaviorsDo: [ :aClass |
bar value: (count := count + 1).
+ aClass selectorsDo: [ :aSelector | | source tree |
- aClass selectorsDo: [ :aSelector |
source := (aClass compiledMethodAt: aSelector) getSourceFromFile.
tree := Compiler new
parse: source
in: aClass
notifying: nil.
tree asMorphicSyntaxUsing: SyntaxMorph.
].
]. ].
!
Item was changed:
----- Method: Player>>setPrecisionFor: (in category 'slots-user') -----
setPrecisionFor: slotName
"Set the precision for the given slot name"
+ | aList reply aGetter places |
- | aList reply val aGetter places |
aGetter := Utilities getterSelectorFor: slotName.
places := Utilities
decimalPlacesForFloatPrecision: (self defaultFloatPrecisionFor: aGetter).
aList := #('0' '1' '2' '3' '4' '5' '6').
reply := UIManager default
chooseFrom: aList
values: (aList collect: [:m | m asNumber])
title: ('How many decimal places? (currently {1})' translated
format: {places}).
reply ifNotNil:
[(self slotInfo includesKey: slotName)
ifTrue:
["it's a user slot"
(self slotInfoAt: slotName)
floatPrecision: (Utilities floatPrecisionForDecimalPlaces: reply).
self class allInstancesDo:
+ [:anInst | | val |
- [:anInst |
reply == 0
ifFalse:
[((val := anInst instVarNamed: slotName asString) isInteger)
ifTrue: [anInst instVarNamed: slotName asString put: val asFloat]].
anInst updateAllViewers]]
ifFalse:
["it's specifying a preference for precision on a system-defined numeric slot"
self noteDecimalPlaces: reply forGetter: aGetter.
self updateAllViewers]]!
Item was changed:
----- Method: StackMorph>>findText: (in category 'menu') -----
findText: wants
"Turn to the next card that has all of the strings mentioned on it. Highlight where it is found. allText and allTextUrls have been set. Case insensitive search.
Resuming a search. If container's text is still in the list and secondary keys are still in the page, (1) search rest of that container. (2) search rest of containers on that page (3) pages till end of book, (4) from page 1 to this page again."
"Later sort wants so longest key is first"
+ | allText here fromHereOn startToHere oldContainer oldIndex otherKeys strings good |
- | allText good thisWord here fromHereOn startToHere oldContainer oldIndex otherKeys strings |
allText := self valueOfProperty: #allText ifAbsent: [#()].
here := self privateCards identityIndexOf: self currentCard ifAbsent: [1].
fromHereOn := here+1 to: self privateCards size.
startToHere := 1 to: here. "repeat this page"
(self valueOfProperty: #searchKey ifAbsent: [#()]) = wants ifTrue: [
"does page have all the other keys? No highlight if found!!"
otherKeys := wants allButFirst.
strings := allText at: here.
good := true.
+ otherKeys do: [:searchString | | thisWord | "each key"
- otherKeys do: [:searchString | "each key"
good ifTrue: [thisWord := false.
strings do: [:longString |
(longString findWordStart: searchString startingAt: 1) > 0 ifTrue: [
thisWord := true]].
good := thisWord]].
good ifTrue: ["all are on this page. Look in rest for string again."
oldContainer := self valueOfProperty: #searchContainer.
oldIndex := self valueOfProperty: #searchOffset.
(self findText: (OrderedCollection with: wants first) inStrings: strings
startAt: oldIndex+1 container: oldContainer
cardNum: here) ifTrue: [
self setProperty: #searchKey toValue: wants.
^ true]]]
ifFalse: [fromHereOn := here to: self privateCards size]. "do search this page"
"other pages"
fromHereOn do: [:cardNum |
(self findText: wants inStrings: (allText at: cardNum) startAt: 1 container: nil
cardNum: cardNum)
ifTrue: [^ true]].
startToHere do: [:cardNum |
(self findText: wants inStrings: (allText at: cardNum) startAt: 1 container: nil
cardNum: cardNum)
ifTrue: [^ true]].
"if fail"
self setProperty: #searchContainer toValue: nil.
self setProperty: #searchOffset toValue: nil.
self setProperty: #searchKey toValue: nil.
^ false!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>setGreenComponentIn:to: (in category 'player commands') -----
setGreenComponentIn: aPatch to: value
+ | xArray yArray patch component |
- | pix xArray yArray patch component |
xArray := arrays at: 2.
yArray := arrays at: 3.
patch := aPatch costume renderedMorph.
value isCollection ifFalse: [
component := (value asInteger bitAnd: 16rFF) bitShift: 8.
].
+ (1 to: self size) do: [:i | | pix |
- (1 to: self size) do: [:i |
value isCollection ifTrue: [
component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 8.
].
pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
pix := (pix bitAnd: 16rFF00FF) bitOr: component.
patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer>>addTurtlesCount:ofPrototype:for:randomize: (in category 'add turtles') -----
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld randomize: randomizeFlag
+ | oldCount |
- | index array defaultValue newArray oldCount |
oldCount := self size.
+ info associationsDo: [:assoc | | array defaultValue newArray index |
- info associationsDo: [:assoc |
index := info at: assoc key.
array := arrays at: index.
defaultValue := prototype at: index.
newArray := array class new: count.
newArray atAllPut: defaultValue.
arrays at: index put: (array, newArray).
].
self setInitialValueOf: #who from: oldCount + 1 to: self size for: aKedamaWorld.
randomizeFlag ifTrue: [
#(x y heading) do: [:name |
self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld.
].
].
whoTableValid := false.
!
More information about the Packages
mailing list