[Pkg] The Trunk: EToys-tfel.213.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Aug 30 12:17:07 UTC 2016
Tim Felgentreff uploaded a new version of EToys to project The Trunk:
http://source.squeak.org/trunk/EToys-tfel.213.mcz
==================== Summary ====================
Name: EToys-tfel.213
Author: tfel
Time: 30 August 2016, 2:15:24.324946 pm
UUID: 98194016-f9bb-9d48-8478-d24947da6f66
Ancestors: EToys-tfel.212
convert underscore assignments to :=
=============== Diff against EToys-tfel.212 ===============
Item was changed:
----- Method: AllPlayersTool class>>allPlayersToolForActiveWorld (in category '*Etoys-Squeakland-parts bin') -----
allPlayersToolForActiveWorld
"Launch an AllPlayersTool to view the scripted objects of the active world"
| aTool |
+ aTool := self newStandAlone.
- aTool _ self newStandAlone.
aTool center: ActiveWorld center.
^ aTool
"
AllPlayersTool allPlayersToolForActiveWorld
"!
Item was changed:
----- Method: AllPlayersTool>>addHeaderRow (in category 'initialization') -----
addHeaderRow
"Add the header morph at the top of the tool"
| aRow aButton |
+ aRow := AlignmentMorph newRow.
- aRow _ AlignmentMorph newRow.
aRow listCentering: #justified; color: Color transparent.
+ aButton := self tanOButton.
- aButton _ self tanOButton.
aRow addMorphFront: aButton.
aRow addMorphBack: (StringMorph contents: 'Players in this Project' translated font: ScriptingSystem fontForTiles).
aRow addMorphBack: self helpButton.
self addMorphFront: aRow.
!
Item was changed:
----- Method: AllPlayersTool>>initializeFor: (in category 'initialization') -----
initializeFor: aPresenter
"Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter"
| placeHolder |
self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
self useRoundedCorners.
self layoutInset: 0.
self borderStyle: BorderStyle complexAltInset; borderWidth: 4; borderColor: (Color r: 0.452 g: 0.839 b: 1.0). "Color fromUser"
self addHeaderRow.
+ placeHolder := Morph new beTransparent.
- placeHolder _ Morph new beTransparent.
placeHolder extent: 200 at 0.
self addMorphBack: placeHolder.
self setProperty: #ExplicitStepTime toValue: 5000. "5 seconds"
WorldState addDeferredUIMessage:
[self updateScrollbar.
self reinvigorate]
!
Item was changed:
----- Method: AllPlayersTool>>presentHelp (in category 'menus') -----
presentHelp
"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"
| aFlapTab aString |
+ aString := '
- aString _ '
Each row represents an object, or "player" in the project.
Click on the menu icon to get a menu of options concerning the player.
Click on a player''s picture to reveal its location.
Click on the turquoise eye to open the player''s viewer.
Click on a player''s name to obtain a tile representing it.'
translated.
aFlapTab := ScriptingSystem assureFlapOfLabel: 'Players' translated withContents: aString.
aFlapTab showFlap!
Item was changed:
----- Method: AllScriptsTool>>addSecondLineOfControls (in category 'initialization') -----
addSecondLineOfControls
"Add the second line of controls"
| aRow outerButton aButton worldToUse |
+ aRow := AlignmentMorph newRow listCentering: #center; color: Color transparent.
+ outerButton := AlignmentMorph newRow.
- aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent.
- outerButton _ AlignmentMorph newRow.
outerButton wrapCentering: #center; cellPositioning: #leftCenter.
outerButton color: Color transparent.
outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
- outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self;
actionSelector: #toggleWhetherShowingOnlyActiveScripts;
getSelector: #showingOnlyActiveScripts.
outerButton addTransparentSpacerOfSize: (4 at 0).
outerButton addMorphBack: (StringMorph contents: 'tickers only' translated font: ScriptingSystem fontForEToyButtons) lock.
outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown' translated.
aRow addMorphBack: outerButton.
aRow addTransparentSpacerOfSize: 20 at 0.
aRow addMorphBack: self helpButton.
aRow addTransparentSpacerOfSize: 20 at 0.
+ outerButton := AlignmentMorph newRow.
- outerButton _ AlignmentMorph newRow.
outerButton wrapCentering: #center; cellPositioning: #leftCenter.
outerButton color: Color transparent.
outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
- outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self;
actionSelector: #toggleWhetherShowingAllInstances;
getSelector: #showingAllInstances.
outerButton addTransparentSpacerOfSize: (4 at 0).
outerButton addMorphBack: (StringMorph contents: 'all instances' translated font: ScriptingSystem fontForEToyButtons) lock.
outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown. Consult the help available by clicking on the purple ? for more information.' translated.
aRow addMorphBack: outerButton.
self addMorphBack: aRow.
+ worldToUse := self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld].
- worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld].
worldToUse presenter reinvigorateAllScriptsTool: self.
self layoutChanged.!
Item was changed:
----- Method: AllScriptsTool>>initializeFor: (in category 'initialization') -----
initializeFor: ignored
"Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter"
| aRow aButton |
+ showingOnlyActiveScripts := true.
+ showingAllInstances := true.
+ showingOnlyTopControls := true.
- showingOnlyActiveScripts _ true.
- showingAllInstances _ true.
- showingOnlyTopControls _ true.
self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
self useRoundedCorners.
self borderWidth: 4; borderColor: Color brown darker.
+ aRow := AlignmentMorph newRow.
- aRow _ AlignmentMorph newRow.
aRow listCentering: #justified; color: Color transparent.
+ aButton := self tanOButton.
- aButton _ self tanOButton.
aRow addMorphFront: aButton.
aRow addTransparentSpacerOfSize: 10.
aRow addMorphBack: ScriptingSystem scriptControlButtons.
aRow addTransparentSpacerOfSize: 10.
aRow addMorphBack: self openUpButton.
self addMorphFront: aRow.
!
Item was changed:
----- Method: AnonymousSoundMorph class>>fromFileName: (in category 'fileIn/Out') -----
fromFileName: fullName
"Create an instance of the receiver from the given file path."
| newPlayer aSound ext aName |
+ newPlayer := self new initialize.
- newPlayer _ self new initialize.
('*aif*' match: fullName)
ifTrue: [aSound := SampledSound fromAIFFfileNamed: fullName].
('*wav' match: fullName)
ifTrue: [aSound := SampledSound fromWaveFileNamed: fullName].
newPlayer := self new.
ext := FileDirectory extensionFor: fullName.
aName := (FileDirectory on: fullName) pathParts last.
ext size > 0 ifTrue:
[aName := aName copyFrom: 1 to: (aName size - (ext size + 1))].
newPlayer sound: aSound interimName: aName.
newPlayer openInWorld; position: ActiveWorld center!
Item was changed:
----- Method: AnonymousSoundMorph>>addMorphsTo:pianoRoll:eventTime:betweenTime:and: (in category 'piano roll') -----
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime
"Custom piano-roll processing. Consult my sender for more info."
| startX lengthInTicks endX |
startTimeInScore > rightTime ifTrue: [^ self].
+ lengthInTicks := pianoRoll scorePlayer ticksForMSecs: sound duration * 1000.0.
- lengthInTicks _ pianoRoll scorePlayer ticksForMSecs: sound duration * 1000.0.
startTimeInScore + lengthInTicks < leftTime ifTrue: [^ self].
+ startX := pianoRoll xForTime: startTimeInScore.
+ endX := pianoRoll xForTime: startTimeInScore + lengthInTicks.
- startX _ pianoRoll xForTime: startTimeInScore.
- endX _ pianoRoll xForTime: startTimeInScore + lengthInTicks.
morphList add:
(self left: startX; width: endX - startX).
!
Item was changed:
----- Method: AnonymousSoundMorph>>addToSoundLibrary (in category 'menu') -----
addToSoundLibrary
"Add the receiver's sound to the library, and hand the user a tile representing it."
| aName tile |
aName := FillInTheBlank request: 'kindly give the sound a name: ' translated initialAnswer: (interimName ifNil: ['']).
aName isEmptyOrNil ifTrue: [^ self].
aName := SampledSound unusedSoundNameLike: aName.
SampledSound
addLibrarySoundNamed: aName
samples: sound samples
samplingRate: sound originalSamplingRate.
+ tile := SoundTile new literal: aName.
- tile _ SoundTile new literal: aName.
tile bounds: tile fullBounds.
tile center: self fullBoundsInWorld center.
(ScriptingTileHolder around: tile) center: self fullBoundsInWorld center;
openInWorld.
self delete!
Item was changed:
----- Method: AnonymousSoundMorph>>justDroppedIntoPianoRoll:event: (in category 'piano roll') -----
justDroppedIntoPianoRoll: newOwner event: evt
"The receiver was just dropped into a piano roll... respond accordingly."
| startX lengthInTicks endX |
super justDroppedIntoPianoRoll: newOwner event: evt.
submorphs size > 1 ifTrue: [submorphs last delete].
self hResizing: #rigid; clipSubmorphs: true.
+ startTimeInScore := newOwner timeForX: self left.
+ lengthInTicks := newOwner scorePlayer ticksForMSecs: sound duration * 1000.0.
+ endTimeInScore := startTimeInScore + lengthInTicks.
- startTimeInScore _ newOwner timeForX: self left.
- lengthInTicks _ newOwner scorePlayer ticksForMSecs: sound duration * 1000.0.
- endTimeInScore _ startTimeInScore + lengthInTicks.
endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
[newOwner scorePlayer updateDuration].
+ startX := newOwner xForTime: startTimeInScore.
+ endX := newOwner xForTime: endTimeInScore.
- startX _ newOwner xForTime: startTimeInScore.
- endX _ newOwner xForTime: endTimeInScore.
self width: endX - startX!
Item was changed:
----- Method: AnonymousSoundMorph>>releaseCachedState (in category 'caching') -----
releaseCachedState
"If the sound is not currently compressed, compress it with the GSM codec"
super releaseCachedState.
sound isCompressed
+ ifFalse: [sound := sound compressWith: GSMCodec].
- ifFalse: [sound _ sound compressWith: GSMCodec].
!
Item was changed:
----- Method: AnonymousSoundMorph>>sound:interimName: (in category 'initialization') -----
sound: aSampledSound interimName: anInterimName
"Establish the sound object and an interim name."
| aStringMorph |
self removeAllMorphs.
self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ borderWidth := 2.
- borderWidth _ 2.
self listDirection: #topToBottom.
sound := aSampledSound.
interimName := anInterimName.
aStringMorph := StringMorph contents: interimName font: ScriptingSystem fontForEToyButtons.
self addMorphBack: aStringMorph.
self addButtonRow.
self balloonTextSelector: #soundMorphHelpString.
self setNameTo: interimName!
Item was changed:
----- Method: AssignmentNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
+ childNode = variable ifTrue: [variable := newNode. ^ self].
+ childNode = value ifTrue: [value := newNode. ^ self].
- childNode = variable ifTrue: [variable _ newNode. ^ self].
- childNode = value ifTrue: [value _ newNode. ^ self].
!
Item was changed:
----- Method: AssignmentTileMorph>>operatorForSexpAssignmentSuffix: (in category '*Etoys-Squeakland-code generation') -----
operatorForSexpAssignmentSuffix: aString
"Answer the operator associated with the receiver, assumed to be one of the compound assignments"
| toTest |
+ toTest := aString asString.
- toTest _ aString asString.
#( ('Incr:' #Incr:)
('Decr:' #Decr:)
('Mult:' #Mult:)
(':' ''))
do:
[:pair | toTest = pair first ifTrue: [^ pair second]].
^ toTest
"AssignmentTileMorph new operatorForTreeAssignmentSuffix: 'Incr:'"!
Item was changed:
----- Method: AttributeSemanticRule>>inputSpecs: (in category 'all') -----
inputSpecs: inputs
+ inputSpecs := inputs.
- inputSpecs _ inputs.
!
Item was changed:
----- Method: AttributeSemanticRule>>output: (in category 'all') -----
output: attr
+ output := attr.
- output _ attr.
!
Item was changed:
----- Method: AttributeSemanticRule>>printOn: (in category 'all') -----
printOn: aStream
aStream nextPutAll: 'Rule(';
nextPutAll: output grammarClass name;
nextPut: $.;
nextPutAll: output attributeName;
+ nextPutAll: ' := ';
- nextPutAll: ' _ ';
nextPutAll: (selector ifNil: ['nil']);
nextPut: $(.
inputSpecs do: [:in |
in printOn: aStream
].
aStream nextPutAll: '))'.
!
Item was changed:
----- Method: AttributeSemanticRule>>ruleText: (in category 'all') -----
ruleText: text
+ ruleText := text.
- ruleText _ text.
!
Item was changed:
----- Method: AttributeSemanticRule>>selector: (in category 'all') -----
selector: aSymbol
+ selector := aSymbol.
- selector _ aSymbol.
!
Item was changed:
----- Method: AttributeVisitor>>newWith:for: (in category 'all') -----
newWith: aParseTree for: anEvaluator
+ attributes := IdentityDictionary new.
+ allOccurences := WriteStream on: (Array new: 1000).
+ tree := aParseTree.
+ evaluator := anEvaluator.
- attributes _ IdentityDictionary new.
- allOccurences _ WriteStream on: (Array new: 1000).
- tree _ aParseTree.
- evaluator _ anEvaluator.
tree visitBy: self.
!
Item was changed:
----- Method: AttributeVisitor>>visit: (in category 'all') -----
visit: node
| defs occurence ocs |
+ defs := evaluator attributeDefinitionsOf: node class.
+ ocs := OrderedCollection new.
- defs _ evaluator attributeDefinitionsOf: node class.
- ocs _ OrderedCollection new.
defs do: [:def |
+ occurence := ParseNodeAttributeOccurence new
- occurence _ ParseNodeAttributeOccurence new
attributeName: def attributeName;
rawGetter: def rawGetter;
setter: def setter;
grammarClass: node class;
addRules: def rules;
type: def type;
node: node.
node perform: def setter with: occurence.
ocs add: occurence.
allOccurences nextPut: occurence.
].
node xxxOccurences: ocs.!
Item was changed:
----- Method: BalloonMorph class>>getBestLocation:for:corner:force: (in category '*Etoys-Squeakland-private') -----
getBestLocation: vertices for: morph corner: cornerName force: forceFlag
"Try four rel locations of the balloon for greatest unclipped area. 12/99 sma"
| rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea |
+ rect := vertices first rect: (vertices at: 5).
+ maxArea := -1.
+ verts := vertices.
+ usableArea := (morph world ifNil: [self currentWorld]) viewBox.
- rect _ vertices first rect: (vertices at: 5).
- maxArea _ -1.
- verts _ vertices.
- usableArea _ (morph world ifNil: [self currentWorld]) viewBox.
1 to: 4 do: [:i |
+ dir := #(vertical horizontal) atWrap: i.
+ verts := verts collect: [:p | p flipBy: dir centerAt: rect center].
+ rectCorner := #(bottomLeft bottomRight topRight topLeft) at: i.
+ morphPoint := #(topCenter topCenter bottomCenter bottomCenter) at: i.
+ a := ((rect
- dir _ #(vertical horizontal) atWrap: i.
- verts _ verts collect: [:p | p flipBy: dir centerAt: rect center].
- rectCorner _ #(bottomLeft bottomRight topRight topLeft) at: i.
- morphPoint _ #(topCenter topCenter bottomCenter bottomCenter) at: i.
- a _ ((rect
align: (rect perform: rectCorner)
+ with: (mbc := morph boundsForBalloon perform: morphPoint))
- with: (mbc _ morph boundsForBalloon perform: morphPoint))
intersect: usableArea) area.
((forceFlag and: [rectCorner = cornerName]) or: [
(a > maxArea or: [a = rect area and: [rectCorner = cornerName]])]) ifTrue:
+ [maxArea := a.
+ bestVerts := verts.
+ mp := mbc].
- [maxArea _ a.
- bestVerts _ verts.
- mp _ mbc].
(forceFlag and: [rectCorner = cornerName]) ifTrue: [
^ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
]].
+ result := bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
- result _ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
^ result!
Item was changed:
----- Method: BalloonMorph class>>string:for:corner:force: (in category '*Etoys-Squeakland-instance creation') -----
string: str for: morph corner: cornerName force: forceFlag
"Make up and return a balloon for morph. Find the quadrant that
clips the text the least, using cornerName as a tie-breaker. tk 9/12/97"
| tm vertices |
+ tm := self getTextMorph: str for: morph.
+ vertices := self getVertices: tm bounds.
+ vertices := self
- tm _ self getTextMorph: str for: morph.
- vertices _ self getVertices: tm bounds.
- vertices _ self
getBestLocation: vertices
for: morph
corner: cornerName
force: forceFlag.
^ self new color: morph balloonColor;
setVertices: vertices;
addMorph: tm;
setTarget: morph!
Item was changed:
----- Method: Behavior>>basicCompile:notifying:trailer:ifFail:for: (in category '*Etoys-Squeakland-private') -----
basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock for: anInstance
"Compile code without logging the source in the changes file"
| methodNode |
+ methodNode := self compilerClass new
- methodNode _ self compilerClass new
compile: code
in: self
notifying: requestor
ifFail: failBlock for: anInstance.
methodNode encoder requestor: requestor.
^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.!
Item was changed:
----- Method: Behavior>>selectorAtMethod:setClass: (in category '*Etoys-Squeakland-private') -----
selectorAtMethod: method setClass: classResultBlock
"Answer both the message selector associated with the compiled method
and the class in which that selector is defined."
| sel |
+ sel := self methodDict keyAtIdentityValue: method
- sel _ self methodDict keyAtIdentityValue: method
ifAbsent:
[superclass == nil
ifTrue:
[classResultBlock value: self.
^method defaultSelector].
+ sel := superclass selectorAtMethod: method setClass: classResultBlock.
- sel _ superclass selectorAtMethod: method setClass: classResultBlock.
"Set class to be self, rather than that returned from
superclass. "
sel == method defaultSelector ifTrue: [classResultBlock value: self].
^sel].
classResultBlock value: self.
^sel!
Item was changed:
----- Method: BlockNode>>getElderSiblingOf: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
getElderSiblingOf: node
| index |
temporaries ifNotNil: [
+ ((index := temporaries indexOf: node) > 1) ifTrue: [^ temporaries at: index - 1].
- ((index _ temporaries indexOf: node) > 1) ifTrue: [^ temporaries at: index - 1].
index = 1 ifTrue: [
arguments size > 0 ifTrue: [^ arguments last].
].
].
+ ((index := arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
- ((index _ arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
index = 1 ifTrue: [
statements size > 0 ifTrue: [^ statements last].
].
+ ((index := statements indexOf: node) > 1) ifTrue: [^ statements at: index - 1].
- ((index _ statements indexOf: node) > 1) ifTrue: [^ statements at: index - 1].
^ nil.
!
Item was changed:
----- Method: BlockNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
| index |
+ (index := arguments indexOf: childNode) > 0
- (index _ arguments indexOf: childNode) > 0
ifTrue: [arguments at: index put: newNode. ^ self].
+ (index := statements indexOf: childNode) > 0
- (index _ statements indexOf: childNode) > 0
ifTrue: [statements at: index put: newNode. ^ self].
temporaries ifNotNil: [
+ (index := temporaries indexOf: childNode) > 0
- (index _ temporaries indexOf: childNode) > 0
ifTrue: [temporaries at: index put: newNode. ^ self].
].
!
Item was changed:
----- Method: BlockNode>>sizeForValue: (in category '*Etoys-Squeakland-code generation') -----
sizeForValue: encoder
+ nArgsNode := encoder encodeLiteral: arguments size.
+ remoteCopyNode := encoder encodeSelector: #blockCopy:.
+ size := (self sizeForEvaluatedValue: encoder)
- nArgsNode _ encoder encodeLiteral: arguments size.
- remoteCopyNode _ encoder encodeSelector: #blockCopy:.
- size _ (self sizeForEvaluatedValue: encoder)
+ (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
+ arguments := arguments collect: "Chance to prepare debugger remote temps"
- arguments _ arguments collect: "Chance to prepare debugger remote temps"
[:arg | arg asStorableNode: encoder].
+ arguments do: [:arg | size := size + (arg sizeForStorePop: encoder)].
- arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
^1 + (nArgsNode sizeForValue: encoder)
+ (remoteCopyNode size: encoder args: 1 super: false) + 2 + size!
Item was changed:
----- Method: BookMorph>>bookMenu (in category '*Etoys-Squeakland-menu') -----
bookMenu
"Create and answer the standard book menu."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'Book' translated.
aMenu addStayUpItem.
aMenu addTranslatedList: #(
('find...' textSearch 'search the book for word(s)')
('find again' textSearchAgain 'search for the next occurrence of a string')
-
('go to page...' goToPage 'go directly to a page, if you know its page-number')
('duplicate this page' duplicatePage 'add a new page just like this one to the book.')
-
('revert this page' revertPage 'restore this page to its initial condition, if possible.')
('revert entire book' revertAllPages 'restore all pages of this book to their initial condition if possible.')
-) translatedNoop.
self addBookToggleItemsTo: aMenu.
aMenu addTranslatedList: #(
-
('sort pages' sortPages 'open a tool allowing you to arrange the pages of the book.')
('hand me a bookmark for this page' bookmarkForThisPage 'make a bookmark object which, when clicked, will make the book turn to this page.')
('hand me a thumbnail for this page' thumbnailForThisPage 'create an icon representing this page')
-) translatedNoop.
aMenu addLine.
self addTransitionItemsTo: aMenu.
self addSaveAndRevertItemsTo: aMenu.
self addAllPagesItemsTo: aMenu. "At the moment this one does nothing"
self addAdvancedItemsTo: aMenu.
^ aMenu
"
Disused items:
'send all pages to server' savePagesOnURL.
'send this page to server' saveOneOnURL.
'reload all from server' reload.
'keep in one file' keepTogether.
'load PPT images from slide #1' loadImagesIntoBook.
'copy page url to clipboard' copyUrl."
!
Item was changed:
----- Method: BookMorph>>currentPage: (in category '*Etoys-Squeakland-accessing') -----
currentPage: aPage
+ currentPage := aPage.
- currentPage _ aPage.
(currentPage notNil and: [
(aPage hasProperty: #revertMarked) and: [
(self revertablePageForPage: aPage) isNil]]) ifTrue: [
self markForRevert: aPage
].
^ aPage.
!
Item was changed:
----- Method: BookMorph>>deleteAlongWithPlayers (in category '*Etoys-Squeakland-e-toy support') -----
deleteAlongWithPlayers
| set |
+ set := Set new.
- set _ Set new.
pages do: [:page |
page allMorphsDo: [:e |
e player notNil ifTrue: [set add: e player]. e delete]].
self allMorphsDo: [:e | e player notNil ifTrue: [set add: e player]. e delete].
set do: [:p | p class scripts do: [:s | p class removeScriptNamed: s selector]].
(set select: [:p | p class isSystemDefined not]) do: [:p | p class removeFromSystemUnlogged].
!
Item was changed:
----- Method: BookMorph>>deletePageAlongWithPlayers: (in category '*Etoys-Squeakland-new reverting') -----
deletePageAlongWithPlayers: page
| set |
+ set := Set new.
- set _ Set new.
page allMorphsDo: [:e |
e player notNil ifTrue: [set add: e player]. e delete].
(set select: [:p | p class isSystemDefined not]) do: [:p | p class removeFromSystemUnlogged].
!
Item was changed:
----- Method: BookMorph>>invokeShortBookMenu (in category '*Etoys-Squeakland-menu') -----
invokeShortBookMenu
"Invoke the shorter version of the book's control panel menu."
| aMenu |
self class == BookMorph ifFalse: [^ self invokeBookMenu].
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'Book' translated.
aMenu addStayUpItem.
aMenu addTranslatedList: #(
('find...' textSearch)
('go to page...' goToPage)
-
('show more controls' showMoreControls)
-
('revert this page' revertPage)
('revert entire book' revertAllPages)) translatedNoop.
aMenu popUpInWorld
!
Item was changed:
----- Method: BookMorph>>markForRevert: (in category '*Etoys-Squeakland-new reverting') -----
markForRevert: page
"Save the current page for future revert."
| key revertPage revertDict |
page setProperty: #revertMarked toValue: true.
+ revertDict := self pagesForRevert.
- revertDict _ self pagesForRevert.
+ key := page valueOfProperty: #revertKey ifAbsent: [0].
- key _ page valueOfProperty: #revertKey ifAbsent: [0].
revertPage := revertDict at: key ifAbsent: [nil].
(key = 0 or: [revertPage isNil])
ifTrue:
[key := pages inject: 0 into:
[:max :p | max max: (p valueOfProperty: #revertKey ifAbsent: [0]) + 1].
page setProperty: #revertKey toValue: key.
revertDict at: key put: page copy]
ifFalse:
[
self deletePageAlongWithPlayers: revertPage.
revertDict at: key put: page copy]!
Item was changed:
----- Method: BookMorph>>pagesForRevert (in category '*Etoys-Squeakland-new reverting') -----
pagesForRevert
"A normal book has its pages in the pages inst var, and cannot revert a page. If a book has the property pagesForRevert, then any (or all) pages can have a backup copy. The user can ask to revert after messing up a page. Good for tutorials. Only authors are expected to preserve pages using saveForRevert.
This method creates and returns the pagesForRevert collection. It is a journal and is not in the same order as pages."
| revColl |
+ revColl := self valueOfProperty: #pagesForRevert ifAbsent: [nil].
- revColl _ self valueOfProperty: #pagesForRevert ifAbsent: [nil].
(revColl notNil and: [(revColl isKindOf: Dictionary) not]) ifTrue: [
revColl do: [:p |
self deletePageAlongWithPlayers: p value
].
+ revColl := nil.
- revColl _ nil.
].
revColl ifNil: [
+ revColl := Dictionary new.
- revColl _ Dictionary new.
self setProperty: #pagesForRevert toValue: revColl.
].
^ revColl.!
Item was changed:
----- Method: BookMorph>>revertPageInner: (in category '*Etoys-Squeakland-new reverting') -----
revertPageInner: aPage
| replacement index newReplacement |
+ replacement := self revertablePageForPage: aPage.
- replacement _ self revertablePageForPage: aPage.
replacement ifNil: [^ false].
index := pages indexOf: aPage.
+ newReplacement := replacement veryDeepCopy.
- newReplacement _ replacement veryDeepCopy.
newReplacement setNameTo: 'page'.
pages at: index put: newReplacement.
(pages at: index) position: aPage position.
aPage == currentPage ifTrue: [aPage owner ifNotNil: [aPage owner addMorph: newReplacement inFrontOf: aPage]].
self deletePageAlongWithPlayers: aPage.
aPage removeViewersOnSubsIn: self presenter.
aPage == currentPage ifTrue: [self currentPage: newReplacement].
^ true.
!
Item was changed:
----- Method: BookMorph>>saveForRevert (in category '*Etoys-Squeakland-menu commands') -----
saveForRevert
"Save the current page for future revert."
| revertAssocs key assoc |
+ revertAssocs := self pagesForRevert.
+ key := currentPage valueOfProperty: #revertKey ifAbsent: [0].
- revertAssocs _ self pagesForRevert.
- key _ currentPage valueOfProperty: #revertKey ifAbsent: [0].
assoc := revertAssocs detect: [:a | a key = key] ifNone: [nil].
(key = 0 or: [assoc isNil])
ifTrue:
[key := revertAssocs ifEmpty: [1] ifNotEmpty: [(revertAssocs collect: [:a | a key]) max + 1].
currentPage setProperty: #revertKey toValue: key.
revertAssocs add: (key -> currentPage copy)]
ifFalse:
[assoc value: currentPage copy]!
Item was changed:
----- Method: BookMorph>>storeAsDataStreamNamed: (in category '*Etoys-Squeakland-fileIn/out') -----
storeAsDataStreamNamed: zippedFileName
| f d bytes zipped |
+ bytes := WriteStream on: ByteArray new.
+ d := DataStream on: bytes.
- bytes _ WriteStream on: ByteArray new.
- d _ DataStream on: bytes.
d nextPut: self pagesAndColorInSISSFormat.
d close.
+ f := FileStream newFileNamed: zippedFileName.
- f _ FileStream newFileNamed: zippedFileName.
f binary; setFileTypeToObject.
+ zipped := GZipWriteStream on: f.
- zipped _ GZipWriteStream on: f.
zipped nextPutAll: bytes contents.
zipped close.
f close
!
Item was changed:
----- Method: BookMorph>>textSearchAgain (in category '*Etoys-Squeakland-menu') -----
textSearchAgain
"The classic find-again"
| wanted wants list |
+ list := self valueOfProperty: #searchKey ifAbsent: [#()].
+ wanted := String streamContents: [:strm |
- list _ self valueOfProperty: #searchKey ifAbsent: [#()].
- wanted _ String streamContents: [:strm |
list do: [:each | strm nextPutAll: each; space]].
+ wants := wanted findTokens: Character separators.
- wants _ wanted findTokens: Character separators.
wants isEmpty ifTrue: [^ self].
self getAllText. "save in allText, allTextUrls"
^ self findText: wants "goes to the page and highlights the text"!
Item was changed:
----- Method: BookMorph>>unmarkForRevert: (in category '*Etoys-Squeakland-new reverting') -----
unmarkForRevert: page
"Forget the data around reverting for this page."
| key revertPage |
+ revertPage := self revertablePageForPage: page.
- revertPage _ self revertablePageForPage: page.
revertPage ifNotNil: [
+ key := page valueOfProperty: #revertKey.
- key _ page valueOfProperty: #revertKey.
page removeProperty: #revertKey.
page removeProperty: #revertMarked.
self deletePageAlongWithPlayers: revertPage.
self pagesForRevert removeKey: key].
!
Item was changed:
----- Method: BooklikeMorph>>makeDescriptionViewer (in category '*Etoys-Squeakland-page controls') -----
makeDescriptionViewer
| descriptionItem font box |
+ font := Preferences standardMenuFont.
- font _ Preferences standardMenuFont.
descriptionItem := UpdatingStringMorph new.
descriptionItem target: self; getSelector: #descriptionReport.
descriptionItem useStringFormat.
descriptionItem font: font.
+ box := Morph new.
- box _ Morph new.
box color: Color transparent.
box layoutPolicy: TableLayout new.
box vResizing: #rigid.
box hResizing: #rigid.
box color: (Color r: 0.839 g: 1.0 b: 0.806).
box borderWidth: 1.
box borderColor: (Color r: 0.645 g: 0.774 b: 0.613).
box cellInset: 3.
box cellPositioning: #center.
box listCentering: #center.
box wrapCentering: #center.
box width: (font widthOfString: (String new: 14 withAll: $M)).
box height: font height + 4.
box addMorph: descriptionItem.
"box on: #mouseUp send: #showDescriptionMenu: to: self."
^ box!
Item was changed:
----- Method: BooklikeMorph>>showPageControls:allowDragging: (in category '*Etoys-Squeakland-page controls') -----
showPageControls: controlSpecs allowDragging: aBoolean
"Remove any existing page controls, and add fresh controls at the top of the receiver (or in position 2 if the receiver's first submorph is one with property #header). Add a single column of controls."
| pageControls column |
self hidePageControls.
+ column := AlignmentMorph newColumn beTransparent.
+ pageControls := self makePageControlsFrom: controlSpecs.
- column _ AlignmentMorph newColumn beTransparent.
- pageControls _ self makePageControlsFrom: controlSpecs.
pageControls borderWidth: 0; layoutInset: 4.
pageControls beSticky.
pageControls setNameTo: 'Page Controls'.
aBoolean ifTrue: [pageControls on: #mouseDown send: #moveViaTitle:event:from: to: self withValue: column].
column addMorphBack: pageControls.
self addPageControlMorph: column!
Item was changed:
----- Method: BorderedStringMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| nameForm |
+ font := self fontToUse.
+ nameForm := Form extent: bounds extent depth: 8.
- font _ self fontToUse.
- nameForm _ Form extent: bounds extent depth: 8.
nameForm getCanvas drawString: contents at: 0 at 0 font: self fontToUse color: Color black.
(bounds origin + 1) eightNeighbors do: [ :pt |
aCanvas
stencil: nameForm
at: pt
color: self borderColor.
].
aCanvas
stencil: nameForm
at: bounds origin + 1
color: color.
!
Item was changed:
----- Method: BraceNode>>getElderSiblingOf: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
getElderSiblingOf: node
| index |
+ ((index := elements indexOf: node) > 1) ifTrue: [^ elements at: index - 1].
- ((index _ elements indexOf: node) > 1) ifTrue: [^ elements at: index - 1].
^ nil.
!
Item was changed:
----- Method: BraceNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
| index |
+ (index := elements indexOf: childNode) > 0
- (index _ elements indexOf: childNode) > 0
ifTrue: [elements at: index put: newNode.].
!
Item was changed:
----- Method: BroomMorph class>>broomIcon (in category 'icons') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: BroomMorph>>centered: (in category 'accessing') -----
centered: aBoolean
"If aBoolean is true, I align morphs on their H or V centerlines"
+ centered := aBoolean.!
- centered _ aBoolean.!
Item was changed:
----- Method: BroomMorph>>drawBroomIcon: (in category 'accessing') -----
drawBroomIcon: aBoolean
"If aBoolean is true, then I draw a cute broom icon; otherwise I draw a cross"
+ drawBroomIcon := aBoolean.
- drawBroomIcon _ aBoolean.
self changed.!
Item was changed:
----- Method: BroomMorph>>drawPlusOn: (in category 'drawing') -----
drawPlusOn: aCanvas
| halfWidth |
+ halfWidth := width + 1 // 2.
- halfWidth _ width + 1 // 2.
aCanvas line: bounds leftCenter + (halfWidth at 0) to: bounds rightCenter + (halfWidth negated at 0) width: width color: self color.
aCanvas line: bounds topCenter + (0 at halfWidth) to: bounds bottomCenter + (0 at halfWidth negated) width: width color: self color.
!
Item was changed:
----- Method: BroomMorph>>filter: (in category 'accessing') -----
filter: aBlock
"Set my acceptance filter. aBlock should return true for all Morphs to be moved"
+ filter := aBlock fixTemps!
- filter _ aBlock fixTemps!
Item was changed:
----- Method: BroomMorph>>hotspot: (in category 'private') -----
hotspot: aPoint
+ lastHotspot := hotspot.
+ hotspot := aPoint.
- lastHotspot _ hotspot.
- hotspot _ aPoint.
^self center: aPoint!
Item was changed:
----- Method: BroomMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ width := 5.
+ span := 100.
+ hotspot := self center.
- width _ 5.
- span _ 100.
- hotspot _ self center.
self reset.
self color: Color blue muchDarker.
self setBalloonText: 'Drag me to align other Morphs. Drag with the Shift key to move me without affecting other Morphs. Drag me with the second mouse button to align centers.' translated.
+ drawBroomIcon := true.
+ transient := false.
+ centered := false.
- drawBroomIcon _ true.
- transient _ false.
- centered _ false.
!
Item was changed:
----- Method: BroomMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: aMorph event: anEvent
super justDroppedInto: aMorph event: anEvent.
aMorph isPlayfieldLike ifFalse: [ ^self delete ].
self centered: anEvent hand lastEvent yellowButtonPressed.
self transient ifFalse: [ ^self ].
self reset.
+ self hotspot: (start := anEvent position).
- self hotspot: (start _ anEvent position).
anEvent hand mouseFocus: self.
anEvent hand keyboardFocus: self.
"Cursor blank show."!
Item was changed:
----- Method: BroomMorph>>lineWidth: (in category 'accessing') -----
lineWidth: aNumber
+ width := aNumber.
- width _ aNumber.
self changed!
Item was changed:
----- Method: BroomMorph>>morphIfNecessary: (in category 'stepping and presenter') -----
morphIfNecessary: yellowButtonPressed
| pt delta threshold cls center |
+ center := yellowButtonPressed | centered.
+ pt := self center.
+ threshold := self width / 2.
+ delta := pt - start.
+ cls := delta x > threshold
- center _ yellowButtonPressed | centered.
- pt _ self center.
- threshold _ self width / 2.
- delta _ pt - start.
- cls _ delta x > threshold
ifTrue: [center
ifTrue: [CenterBroomMorphRight]
ifFalse: [BroomMorphRight]]
ifFalse: [delta x < threshold negated
ifTrue: [center
ifTrue: [CenterBroomMorphLeft]
ifFalse: [BroomMorphLeft]]
ifFalse: [delta y > threshold
ifTrue: [center
ifTrue: [CenterBroomMorphDown]
ifFalse: [BroomMorphDown]]
ifFalse: [delta y < threshold negated
ifTrue: [center
ifTrue: [CenterBroomMorphUp]
ifFalse: [BroomMorphUp]]]]].
cls
ifNotNil: [self
become: (self as: cls).
self reset.
self resetFilter.
unmoved addAll: self affectedMorphs]!
Item was changed:
----- Method: BroomMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
self reset.
self resetFilter.
+ self hotspot: (start := evt position).
- self hotspot: (start _ evt position).
evt hand mouseFocus: self.
evt hand keyboardFocus: self.
"Cursor blank show."!
Item was changed:
----- Method: BroomMorph>>reset (in category 'initialization') -----
reset
+ moved := IdentityDictionary new. "morph -> original bounds"
+ unmoved := IdentitySet new.
- moved _ IdentityDictionary new. "morph -> original bounds"
- unmoved _ IdentitySet new.
self resetExtent.
+ filter := nil.
- filter _ nil.
!
Item was changed:
----- Method: BroomMorph>>resetExtent (in category 'initialization') -----
resetExtent
super extent: self class broomIcon extent.
+ hotspot := lastHotspot := self center.!
- hotspot _ lastHotspot _ self center.!
Item was changed:
----- Method: BroomMorph>>span: (in category 'accessing') -----
span: aNumber
+ span := aNumber.
- span _ aNumber.
self hotspot: self hotspot.
self changed.!
Item was changed:
----- Method: BroomMorph>>transient: (in category 'accessing') -----
transient: aBoolean
"if aBoolean is true, then I delete myself on mouse-up"
+ transient := aBoolean!
- transient _ aBoolean!
Item was changed:
----- Method: BroomMorph>>undoCommand (in category 'undo') -----
undoCommand
| cmd args |
+ cmd := Command new cmdWording: 'align morphs'.
+ args := OrderedCollection new.
- cmd _ Command new cmdWording: 'align morphs'.
- args _ OrderedCollection new.
moved keysAndValuesDo: [ :m :b |
args add: { m. b. m bounds. m owner. m owner morphPreceding: m }
].
cmd undoTarget: self selector: #undoMove:redo:args: arguments: { cmd. false. args }.
^cmd!
Item was changed:
----- Method: BroomMorph>>undoMove:redo:args: (in category 'undo') -----
undoMove: cmd redo: redo args: args
"morph oldbounds newbounds oldowner oldpredecessor"
cmd redoTarget: self selector: #undoMove:redo:args: arguments: { cmd. true. args }.
args do: [ :a | | morph oldbounds newbounds oldowner oldpredecessor |
+ morph := a at: 1.
+ oldbounds := a at: 2.
+ newbounds := a at: 3.
+ oldowner := a at: 4.
+ oldpredecessor := a at: 5.
- morph _ a at: 1.
- oldbounds _ a at: 2.
- newbounds _ a at: 3.
- oldowner _ a at: 4.
- oldpredecessor _ a at: 5.
oldowner ifNotNil: [ oldpredecessor ifNil: [ oldowner addMorphFront: morph ]
ifNotNil: [ oldowner addMorph: morph after: oldpredecessor ]].
morph bounds: (redo ifTrue: [ newbounds ] ifFalse: [ oldbounds ]).
(morph isKindOf: SystemWindow) ifTrue: [ morph activate ].
].!
Item was changed:
----- Method: BroomMorphDown>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: hotspot x @ lastHotspot y.
- movedRect _ self bounds encompass: hotspot x @ lastHotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds left
right: m bounds right
top: m bounds top
bottom: m bounds top + 1)]!
Item was changed:
----- Method: BroomMorphDown>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| halfWidth |
+ halfWidth := width + 1 // 2.
- halfWidth _ width + 1 // 2.
aCanvas line: bounds topCenter + (0 at halfWidth) to: bounds bottomCenter + (0 at halfWidth negated) width: width color: self color.
aCanvas line: bounds bottomLeft + (halfWidth @ halfWidth negated) to: bounds bottomRight + (halfWidth negated at halfWidth negated) width: width color: self color.
aCanvas line: self hotspot + (span negated @ (width * -2)) to: self hotspot + (span negated @ -1) color: self color.
aCanvas line: self hotspot + (span -1 @ (width * -2)) to: self hotspot + (span-1 @ -1) color: self color.
!
Item was changed:
----- Method: BroomMorphDown>>hotspot: (in category 'accessing') -----
hotspot: aPoint
| left right bottom newBounds |
+ left := aPoint x - span min: bounds left.
+ right := aPoint x + span max: bounds right.
+ bottom := aPoint y max: start y.
+ lastHotspot := hotspot.
+ hotspot := aPoint x @ bottom.
+ newBounds := Rectangle
- left _ aPoint x - span min: bounds left.
- right _ aPoint x + span max: bounds right.
- bottom _ aPoint y max: start y.
- lastHotspot _ hotspot.
- hotspot _ aPoint x @ bottom.
- newBounds _ Rectangle
left: left
right: right
top: bottom - bounds height
bottom: bottom.
self bounds: newBounds.
!
Item was changed:
----- Method: BroomMorphDown>>resetExtent (in category 'drawing') -----
resetExtent
| newBounds |
+ newBounds := 0 at 0 extent: (2*span) @ (12 + width).
- newBounds _ 0 at 0 extent: (2*span) @ (12 + width).
self bounds: (newBounds align: newBounds bottomCenter with: hotspot)!
Item was changed:
----- Method: BroomMorphLeft>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: lastHotspot x @ hotspot y.
- movedRect _ self bounds encompass: lastHotspot x @ hotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds right - 1
right: m bounds right
top: m bounds top
bottom: m bounds bottom)]!
Item was changed:
----- Method: BroomMorphLeft>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| halfWidth |
+ halfWidth := (width + 1 // 2).
- halfWidth _ (width + 1 // 2).
aCanvas line: bounds leftCenter + (halfWidth at 0) to: bounds rightCenter + (halfWidth negated @0) width: width color: self color.
aCanvas line: bounds topLeft + (halfWidth @ halfWidth) to: bounds bottomLeft + (halfWidth @halfWidth negated) width: width color: self color.
aCanvas line: self hotspot + (width * 2 @ (span negated)) to: self hotspot + (1 @ (span negated)) color: self color.
aCanvas line: self hotspot + (width * 2 @ (span-1)) to: self hotspot + (1 @ (span-1)) color: self color.
!
Item was changed:
----- Method: BroomMorphLeft>>hotspot: (in category 'accessing') -----
hotspot: aPoint
| newBounds top bottom left |
+ top := aPoint y - span min: bounds top.
+ bottom := aPoint y + span max: bounds bottom.
+ left := aPoint x min: start x.
+ lastHotspot := hotspot.
+ hotspot := left @ aPoint y.
+ newBounds := Rectangle
- top _ aPoint y - span min: bounds top.
- bottom _ aPoint y + span max: bounds bottom.
- left _ aPoint x min: start x.
- lastHotspot _ hotspot.
- hotspot _ left @ aPoint y.
- newBounds _ Rectangle
left: left
right: left + bounds width
top: top
bottom: bottom.
self bounds: newBounds!
Item was changed:
----- Method: BroomMorphLeft>>resetExtent (in category 'drawing') -----
resetExtent
| newBounds |
+ newBounds := 0 at 0 extent: (12 + width) @ (2*span).
- newBounds _ 0 at 0 extent: (12 + width) @ (2*span).
self bounds: (newBounds align: newBounds leftCenter with: hotspot)!
Item was changed:
----- Method: BroomMorphRight>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: lastHotspot x @ hotspot y.
- movedRect _ self bounds encompass: lastHotspot x @ hotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds left
right: m bounds left + 1
top: m bounds top
bottom: m bounds bottom)]!
Item was changed:
----- Method: BroomMorphRight>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| halfWidth |
+ halfWidth := width + 1 // 2.
- halfWidth _ width + 1 // 2.
aCanvas line: bounds leftCenter + (halfWidth at 0) to: bounds rightCenter + (halfWidth negated @0) width: width color: self color.
aCanvas line: bounds topRight + (halfWidth negated @ halfWidth) to: bounds bottomRight + (halfWidth negated at halfWidth negated) width: width color: self color.
aCanvas line: self hotspot + (width * -2 @ (span negated)) to: self hotspot + (-1 @ (span negated)) color: self color.
aCanvas line: self hotspot + (width * -2 @ (span-1)) to: self hotspot + (-1 @ (span-1)) color: self color.
!
Item was changed:
----- Method: BroomMorphRight>>hotspot: (in category 'accessing') -----
hotspot: aPoint
| newBounds top bottom right |
+ top := aPoint y - span min: bounds top.
+ bottom := aPoint y + span max: bounds bottom.
+ right := aPoint x max: start x.
+ lastHotspot := hotspot.
+ hotspot := right @ aPoint y.
+ newBounds := Rectangle
- top _ aPoint y - span min: bounds top.
- bottom _ aPoint y + span max: bounds bottom.
- right _ aPoint x max: start x.
- lastHotspot _ hotspot.
- hotspot _ right @ aPoint y.
- newBounds _ Rectangle
left: right - bounds width
right: right
top: top
bottom: bottom.
self bounds: newBounds!
Item was changed:
----- Method: BroomMorphRight>>resetExtent (in category 'accessing') -----
resetExtent
| newBounds |
+ newBounds := 0 at 0 extent: (12 + width) @ (2*span).
- newBounds _ 0 at 0 extent: (12 + width) @ (2*span).
self bounds: (newBounds align: newBounds rightCenter with: hotspot)!
Item was changed:
----- Method: BroomMorphUp>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: hotspot x @ lastHotspot y.
- movedRect _ self bounds encompass: hotspot x @ lastHotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds left
right: m bounds right
top: m bounds bottom - 1
bottom: m bounds bottom)]!
Item was changed:
----- Method: BroomMorphUp>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| halfWidth |
+ halfWidth := width + 1 // 2.
- halfWidth _ width + 1 // 2.
aCanvas line: bounds topCenter + (0 at halfWidth) to: bounds bottomCenter + (0 at halfWidth negated) width: width color: self color.
aCanvas line: bounds topLeft + (halfWidth @ halfWidth) to: bounds topRight + ((halfWidth) negated at halfWidth) width: width color: self color.
aCanvas line: self hotspot + (span negated @ (width * 2)) to: self hotspot + (span negated @ 1) color: self color.
aCanvas line: self hotspot + (span -1 @ (width * 2)) to: self hotspot + (span -1 @ 1) color: self color.
!
Item was changed:
----- Method: BroomMorphUp>>hotspot: (in category 'accessing') -----
hotspot: aPoint
| left right newBounds top |
+ left := aPoint x - span min: bounds left.
+ right := aPoint x + span max: bounds right.
+ top := aPoint y min: start y.
+ lastHotspot := hotspot.
+ hotspot := aPoint x @ top.
+ newBounds := Rectangle
- left _ aPoint x - span min: bounds left.
- right _ aPoint x + span max: bounds right.
- top _ aPoint y min: start y.
- lastHotspot _ hotspot.
- hotspot _ aPoint x @ top.
- newBounds _ Rectangle
left: left
right: right
top: top
bottom: top + bounds height.
self bounds: newBounds!
Item was changed:
----- Method: BroomMorphUp>>resetExtent (in category 'drawing') -----
resetExtent
| newBounds |
+ newBounds := 0 at 0 extent: (2*span) @ (12 + width).
- newBounds _ 0 at 0 extent: (2*span) @ (12 + width).
self bounds: (newBounds align: newBounds topCenter with: hotspot)!
Item was changed:
----- Method: Browser>>overwriteDialogHierarchyChange:higher:sourceClassName:destinationClassName:methodSelector: (in category '*Etoys-Squeakland-drag and drop') -----
overwriteDialogHierarchyChange: hierarchyChange higher: higherFlag sourceClassName: srcClassName destinationClassName: dstClassName methodSelector: methodSelector
| lf success |
+ lf := Character cr asString.
+ success := SelectionMenu
- lf _ Character cr asString.
- success _ SelectionMenu
confirm: 'There is a conflict.' , ' Overwrite' , (hierarchyChange
ifTrue: [higherFlag
ifTrue: [' superclass']
ifFalse: [' subclass']]
ifFalse: ['']) , ' method' , lf , dstClassName , '>>' , methodSelector , lf , 'by ' , (hierarchyChange
ifTrue: ['moving']
ifFalse: ['copying']) , ' method' , lf , srcClassName name , '>>' , methodSelector , ' ?'
trueChoice: 'Yes, don''t care.'
falseChoice: 'No, I have changed my opinion.'.
^ success!
Item was changed:
----- Method: ButtonPropertiesMorph>>acceptDroppingMorph:event:in: (in category 'as yet unclassified') -----
acceptDroppingMorph: aMorph event: evt in: aSubmorph
| why |
self clearDropHighlightingEvt: evt morph: aSubmorph.
+ why := aSubmorph valueOfProperty: #intentOfDroppedMorphs.
- why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
why == #changeTargetMorph ifTrue: [
self targetProperties replaceVisibleMorph: aMorph.
+ myTarget := aMorph.
- myTarget _ aMorph.
self rebuild.
^true
].
why == #changeTargetTarget ifTrue: [
(aMorph setAsActionInButtonProperties: self targetProperties) ifFalse: [
^false
].
^true
].
why == #changeTargetMouseDownLook ifTrue: [
self targetProperties mouseDownLook: aMorph.
^false
].
why == #changeTargetMouseEnterLook ifTrue: [
self targetProperties mouseEnterLook: aMorph.
^false
].
^false
!
Item was changed:
----- Method: ButtonPropertiesMorph>>adjustTargetRepeatingInterval: (in category 'as yet unclassified') -----
adjustTargetRepeatingInterval: aFractionalPoint
| n |
+ n := 2 raisedTo: ((aFractionalPoint x * 12) rounded max: 1).
- n _ 2 raisedTo: ((aFractionalPoint x * 12) rounded max: 1).
self targetProperties delayBetweenFirings: n.
!
Item was changed:
----- Method: ButtonPropertiesMorph>>doEnables (in category 'as yet unclassified') -----
doEnables
| itsName |
self allMorphsDo: [ :each |
+ itsName := each knownName.
- itsName _ each knownName.
itsName == #pickerForMouseDownColor ifTrue: [
self enable: each when: self targetWantsRollover
].
itsName == #pickerForMouseOverColor ifTrue: [
self enable: each when: self targetWantsRollover
].
itsName == #paneForRepeatingInterval ifTrue: [
self enable: each when: self targetRepeatingWhileDown
].
].
!
Item was changed:
----- Method: ButtonPropertiesMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
myTarget
+ ifNil: [myTarget := RectangleMorph new openInWorld].
- ifNil: [myTarget _ RectangleMorph new openInWorld].
thingsToRevert at: #buttonProperties: put: myTarget buttonProperties.
self rebuild!
Item was changed:
----- Method: ButtonPropertiesMorph>>mouseDownEvent:for: (in category 'as yet unclassified') -----
mouseDownEvent: evt for: aSubmorph
| why aMenu |
+ why := aSubmorph valueOfProperty: #intentOfDroppedMorphs.
- why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
why == #changeTargetMorph ifTrue: [
+ aMenu := MenuMorph new
- aMenu _ MenuMorph new
defaultTarget: self.
{
{'Rectangle'. RectangleMorph}.
{'Ellipse'. EllipseMorph}
} do: [ :pair |
aMenu
add: pair first translated
target: self
selector: #attachMorphOfClass:to:
argumentList: {pair second. evt hand}.
].
aMenu popUpEvent: evt in: self world.
^self
].
!
Item was changed:
----- Method: ButtonPropertiesMorph>>paneForButtonTargetReport (in category 'as yet unclassified') -----
paneForButtonTargetReport
| r |
+ r := self inARow: {
- r _ self inARow: {
self lockedString: 'Target: ' translated.
UpdatingStringMorph new
useStringFormat;
getSelector: #target;
target: self targetProperties;
growable: true;
minimumWidth: 24;
lock.
}.
r hResizing: #shrinkWrap.
self allowDropsInto: r withIntent: #changeTargetTarget.
r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)' translated.
^self inARow: {r}
!
Item was changed:
----- Method: ButtonPropertiesMorph>>paneForChangeMouseDownLook (in category 'as yet unclassified') -----
paneForChangeMouseDownLook
| r |
+ r := self inARow: {
- r _ self inARow: {
self lockedString: ' Mouse-down look ' translated.
}.
self allowDropsInto: r withIntent: #changeTargetMouseDownLook.
r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.' translated.
^r
!
Item was changed:
----- Method: ButtonPropertiesMorph>>paneForChangeMouseEnterLook (in category 'as yet unclassified') -----
paneForChangeMouseEnterLook
| r |
+ r := self inARow: {
- r _ self inARow: {
self lockedString: ' Mouse-enter look ' translated.
}.
self allowDropsInto: r withIntent: #changeTargetMouseEnterLook.
r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.' translated.
^r
!
Item was changed:
----- Method: ButtonPropertiesMorph>>paneForChangeVisibleMorph (in category 'as yet unclassified') -----
paneForChangeVisibleMorph
| r |
+ r := self inARow: {
- r _ self inARow: {
self lockedString: ' Change morph ' translated.
}.
r on: #mouseDown send: #mouseDownEvent:for: to: self.
self allowDropsInto: r withIntent: #changeTargetMorph.
r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.' translated.
^r
!
Item was changed:
----- Method: ButtonPropertiesMorph>>rebuild (in category 'as yet unclassified') -----
rebuild
| buttonColor |
myTarget ensuredButtonProperties.
"self targetProperties unlockAnyText." "makes styling the text easier"
self removeAllMorphs.
self addAColumn: {
self lockedString: ('Button Properties for {1}' translated format: {myTarget name}).
}.
self addAColumn: {
self paneForButtonTargetReport.
}.
self addAColumn: {
self paneForButtonSelectorReport.
}.
self addAColumn: {
(self inARow: {
self paneForActsOnMouseDownToggle.
self paneForActsOnMouseUpToggle.
}) hResizing: #shrinkWrap.
}.
self addAColumn: {
self inARow: {
(self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap.
self paneForRepeatingInterval.
}.
}.
self addAColumn: {
(self inAColumn: {
self paneForWantsRolloverToggle.
}) hResizing: #shrinkWrap.
}.
self addARow: {
self paneForMouseOverColorPicker.
self paneForMouseDownColorPicker.
}.
self addARow: {
self paneForChangeMouseEnterLook.
self paneForChangeMouseDownLook.
}.
+ buttonColor := color lighter.
- buttonColor _ color lighter.
self addARow: {
self inAColumn: {
self addARow: {
self
buttonNamed: 'Add label' translated action: #addTextToTarget color: buttonColor
help: 'add some text to the button' translated.
self
buttonNamed: 'Remove label' translated action: #removeTextFromTarget color: buttonColor
help: 'remove text from the button' translated.
}.
self addARow: {
self
buttonNamed: 'Accept' translated action: #doAccept color: buttonColor
help: 'keep changes made and close panel' translated.
self
buttonNamed: 'Cancel' translated action: #doCancel color: buttonColor
help: 'cancel changes made and close panel' translated.
self transparentSpacerOfSize: 10 at 3.
self
buttonNamed: 'Main' translated action: #doMainProperties color: color lighter
help: 'open a main properties panel for the morph' translated.
self
buttonNamed: 'Remove' translated action: #doRemoveProperties color: color lighter
help: 'remove the button properties of this morph' translated.
}.
}.
self inAColumn: {
self paneForChangeVisibleMorph
}.
}.
!
Item was changed:
----- Method: ButtonPropertiesMorph>>toggleTargetActsOnMouseDown (in category 'as yet unclassified') -----
toggleTargetActsOnMouseDown
| prop |
+ prop := self targetProperties.
- prop _ self targetProperties.
prop actWhen: (prop actWhen == #mouseDown ifTrue: [nil] ifFalse: [#mouseDown])!
Item was changed:
----- Method: ButtonPropertiesMorph>>toggleTargetActsOnMouseUp (in category 'as yet unclassified') -----
toggleTargetActsOnMouseUp
| prop |
+ prop := self targetProperties.
- prop _ self targetProperties.
prop actWhen: (prop actWhen == #mouseUp ifTrue: [nil] ifFalse: [#mouseUp])!
Item was changed:
----- Method: ButtonPropertiesMorph>>toggleTargetRepeatingWhileDown (in category 'as yet unclassified') -----
toggleTargetRepeatingWhileDown
| prop |
+ prop := self targetProperties.
- prop _ self targetProperties.
prop delayBetweenFirings: (prop delayBetweenFirings ifNil: [1024] ifNotNil: [nil])
!
Item was changed:
----- Method: ButtonPropertiesMorph>>valueForRepeatingInterval (in category 'as yet unclassified') -----
valueForRepeatingInterval
| n s |
+ n := self targetProperties delayBetweenFirings.
- n _ self targetProperties delayBetweenFirings.
+ s := n ifNil: [
- s _ n ifNil: [
'*none*'
] ifNotNil: [
n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs']
].
^'interval: ' translated, s
!
Item was changed:
----- Method: ButtonPropertiesMorph>>wantsDroppedMorph:event:in: (in category 'as yet unclassified') -----
wantsDroppedMorph: aMorph event: evt in: aSubmorph
| why |
+ why := aSubmorph valueOfProperty: #intentOfDroppedMorphs.
- why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs.
^why notNil
" toValue: #changeTargetMorph.
^true"!
Item was changed:
----- Method: ByteString>>primitiveFindSubstring:in:startingAt:matchTable: (in category '*Etoys-Squeakland-comparing') -----
primitiveFindSubstring: key in: body startingAt: start matchTable: matchTable
"Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned.
The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter."
| index |
<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
self var: #key declareC: 'unsigned char *key'.
self var: #body declareC: 'unsigned char *body'.
self var: #matchTable declareC: 'unsigned char *matchTable'.
key size = 0 ifTrue: [^ 0].
start to: body size - key size + 1 do:
[:startIndex |
+ index := 1.
- index _ 1.
[(matchTable at: (body at: startIndex+index-1) asciiValue + 1)
= (matchTable at: (key at: index) asciiValue + 1)]
whileTrue:
[index = key size ifTrue: [^ startIndex].
+ index := index+1]].
- index _ index+1]].
^ 0
"
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7
"!
Item was changed:
----- Method: CP1253ClipboardInterpreter>>toSystemClipboard: (in category 'as yet unclassified') -----
toSystemClipboard: aString
| result converter r |
aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization"
+ result := WriteStream on: (String new: aString size).
+ converter := CP1253TextConverter new.
- result _ WriteStream on: (String new: aString size).
- converter _ CP1253TextConverter new.
aString do: [:each |
+ r := converter fromSqueak: each.
- r _ converter fromSqueak: each.
r charCode < 255 ifTrue: [
result nextPut: r squeakToMac]].
^ result contents.
!
Item was changed:
----- Method: CP1253InputInterpreter>>initialize (in category 'as yet unclassified') -----
initialize
+ converter := CP1253TextConverter new.
- converter _ CP1253TextConverter new.
!
Item was changed:
----- Method: CachingMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ damageRecorder := DamageRecorder new!
- damageRecorder _ DamageRecorder new!
Item was changed:
----- Method: CachingMorph>>releaseCachedState (in category 'caching') -----
releaseCachedState
super releaseCachedState.
+ cacheCanvas := nil.
- cacheCanvas _ nil.
!
Item was changed:
----- Method: CascadeNode>>getElderSiblingOf: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
getElderSiblingOf: node
| index |
+ ((index := messages indexOf: node) > 1) ifTrue: [^ messages at: index - 1].
- ((index _ messages indexOf: node) > 1) ifTrue: [^ messages at: index - 1].
index = 1 ifTrue: [^ receiver].
^ nil.
!
Item was changed:
----- Method: CascadeNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
| index |
+ childNode = receiver ifTrue: [receiver := newNode. ^ self].
+ (index := messages indexOf: childNode) > 0
- childNode = receiver ifTrue: [receiver _ newNode. ^ self].
- (index _ messages indexOf: childNode) > 0
ifTrue: [messages at: index put: newNode. ^ self].
!
Item was changed:
----- Method: CascadeNode>>sizeForValue: (in category '*Etoys-Squeakland-code generation') -----
sizeForValue: encoder
| size |
+ size := (receiver sizeForValue: encoder) + (messages size - 1 * 2).
+ messages do: [:aMessage | size := size + (aMessage sizeForValue: encoder)].
- size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
- messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
^size!
Item was changed:
----- Method: CategoryViewer>>addColorSeesDetailTo: (in category '*Etoys-Squeakland-entries') -----
addColorSeesDetailTo: aRow
"Special-casee code for the boolean-valued phrase variously known as is-over-color or sees-color."
| hotTileForSelf colorMorph |
(aRow submorphs last) delete.
+ aRow addMorphBack: (hotTileForSelf := ColorSeerTile new showPalette: false; yourself).
+ aRow addMorphBack: (colorMorph := ColorTileMorph new showPalette: false;
- aRow addMorphBack: (hotTileForSelf _ ColorSeerTile new showPalette: false; yourself).
- aRow addMorphBack: (colorMorph _ ColorTileMorph new showPalette: false;
typeColor: (ScriptingSystem colorForType: #Color); yourself).
colorMorph colorSwatch color: Color blue.
hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow.
hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow.
hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
hotTileForSelf on: #mouseDown send: #makeGetter:event:from:
to: self
withValue: (Array with: #color:sees: with: #Boolean).
colorMorph on: #mouseEnter send: #addGetterFeedback to: aRow.
colorMorph on: #mouseLeave send: #removeHighlightFeedback to: aRow.
colorMorph on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
colorMorph on: #mouseDown send: #makeGetter:event:from:
to: self
withValue: (Array with: #color:sees: with: #Boolean).
aRow addMorphBack: (Morph new extent: 0@(aRow height)).
!
Item was changed:
----- Method: CategoryViewer>>addHeaderMorph (in category 'header pane') -----
addHeaderMorph
"Add the header at the top of the viewer, with a control for choosing the category, etc."
| header aButton |
+ header := AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
- header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
header beSticky.
header layoutInset: 0.
header cellInset: 0.
+ aButton := self tanOButton.
- aButton _ self tanOButton.
header addMorph: aButton.
aButton setBalloonText: 'remove this pane from the screen
don''t worry -- nothing will be lost!!' translated.
header addMorphBack: self spacerAfterButton.
self addMorph: header.
self addNamePaneTo: header.
+ chosenCategorySymbol := #basic!
- chosenCategorySymbol _ #basic!
Item was changed:
----- Method: CategoryViewer>>addIsOverColorDetailTo: (in category 'entries') -----
addIsOverColorDetailTo: aRow
"Special-casee code for the boolean-valued phrase variously known as is-over-color or sees-color."
| hotTileForSelf |
aRow addMorphBack: (Morph new color: self color; extent: 0 at 10). "spacer"
+ hotTileForSelf := ColorTileMorph new showPalette: false;
- hotTileForSelf _ ColorTileMorph new showPalette: false;
typeColor: (ScriptingSystem colorForType: #Color); yourself.
hotTileForSelf colorSwatch color: Color blue.
hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow.
hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow.
hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
hotTileForSelf on: #mouseDown send: #makeGetter:event:from:
to: self
withValue: (Array with: #seesColor: with: #Color).
aRow addMorphBack: hotTileForSelf.
"The following commented-out code put a readout up; the readout was very nice, but was very consumptive of cpu time, which is why the is-over-color tile got removed from the viewer long ago. Now is-over-color is reinstated to the viewer, minus the expensive readout..."
" aRow addMorphBack: (AlignmentMorph new beTransparent).
+ readout := UpdatingStringMorphWithArgument new
- readout _ UpdatingStringMorphWithArgument new
target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
readout useDefaultFormat.
+ aTile := StringReadoutTile new typeColor: Color lightGray lighter.
- aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
aTile addMorphBack: readout.
aRow addMorphBack: aTile.
aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"!
Item was changed:
----- Method: CategoryViewer>>addNamePaneTo: (in category 'header pane') -----
addNamePaneTo: header
"Add the namePane, which is a pop-up"
| triangle aLabel |
namePane := BorderedMorph new.
namePane layoutPolicy: TableLayout new.
namePane hResizing: #spaceFill.
namePane listDirection: #leftToRight.
namePane wrapCentering: #center.
namePane cellInset: 2.
namePane layoutInset: 6 @ 0.
namePane color: ScriptingSystem baseColor.
namePane borderColor: Preferences menuTitleBorderColor.
namePane borderWidth: 0.
namePane height: TileMorph defaultH.
namePane useRoundedCornersInEtoys.
+ triangle := ImageMorph new image: (ScriptingSystem formAtKey: #MenuTriangle).
- triangle _ ImageMorph new image: (ScriptingSystem formAtKey: #MenuTriangle).
namePane addMorph: triangle.
aLabel := StringMorph contents: '---------' font: ScriptingSystem fontForViewerCategoryPopups.
namePane addMorphBack: aLabel.
namePane on: #mouseDown send: #chooseCategory to: self.
header addMorphBack: namePane!
Item was changed:
----- Method: CategoryViewer>>arrowSetterButton:args: (in category 'get/set slots') -----
arrowSetterButton: sel args: argArray
| m |
+ m := RectangleMorph new
- m _ RectangleMorph new
color: (ScriptingSystem colorForType: #command);
extent: (ScriptingSystem formAtKey: #Gets) extent;
borderWidth: 0.
m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: #Gets)).
m setBalloonText: 'drag from here to obtain an assignment phrase.' translated.
m on: #mouseDown send: sel
to: self
withValue: argArray.
^ m
!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForBounceOnOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForBounceOnOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setBounceOnOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setBounceOnOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetAngleToOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetAngleToOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setAngleToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setAngleToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs second setArgumentDefaultTo: scriptedPlayer.
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetColorComponentOfType:componentName:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetColorComponentOfType: retrieverType componentName: componentName retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setGetColorComponentOperator: retrieverOp componentName: componentName type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setGetColorComponentOperator: retrieverOp componentName: componentName type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetDistanceToOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetDistanceToOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setDistanceToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setDistanceToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs second setArgumentDefaultTo: scriptedPlayer.
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetPatchValueOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetPatchValueOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setGetPixelOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setGetPixelOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs second setArgumentDefaultTo: (scriptedPlayer defaultPatchPlayer).
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetTurtleOfOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetTurtleOfOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setTurtleOfOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setTurtleOfOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseForGetUpHillOfType:retrieverOp:player: (in category 'support') -----
booleanPhraseForGetUpHillOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"
| outerPhrase getterPhrase receiverTile rel finalTile |
+ rel := (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
+ getterPhrase := PhraseTileMorph new setUpHillOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
- rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
- getterPhrase _ PhraseTileMorph new setUpHillOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
getterPhrase submorphs second setSlotRefOperator: retrieverOp.
getterPhrase submorphs second setArgumentDefaultTo: (scriptedPlayer defaultPatchPlayer).
getterPhrase submorphs first changeTableLayout.
+ receiverTile := aPlayer tileToRefer bePossessive.
- receiverTile _ aPlayer tileToRefer bePossessive.
"self halt."
receiverTile position: getterPhrase firstSubmorph position.
getterPhrase firstSubmorph addMorph: receiverTile.
outerPhrase firstSubmorph addMorph: getterPhrase.
+ finalTile := ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseFromNumericGetterWithArgument: (in category '*Etoys-Squeakland-as yet unclassified') -----
booleanPhraseFromNumericGetterWithArgument: phrase
"Answer a morph derived from the incoming phrase, a bearingTo: or distanceToPlayer: phrase, which will be suitable for dropping into a TEST area. "
| outerPhrase rel finalTile |
rel := Vocabulary numberVocabulary comparatorForSampleBoolean.
+ outerPhrase := PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: #Number argType: #Number.
- outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: #Number argType: #Number.
outerPhrase firstSubmorph addMorph: phrase.
outerPhrase firstSubmorph changeTableLayout.
+ finalTile := ScriptingSystem tileForArgType: #Number. "comes with arrows"
- finalTile _ ScriptingSystem tileForArgType: #Number. "comes with arrows"
outerPhrase submorphs last addMorph: finalTile.
outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).
^ outerPhrase!
Item was changed:
----- Method: CategoryViewer>>booleanPhraseFromPhrase: (in category 'support') -----
booleanPhraseFromPhrase: phrase
"Answer, if possible, a boolean-valued phrase derived from the phrase provided"
| retrieverOp retrieverTile |
(phrase isKindOf: ParameterTile orOf: FunctionTile) ifTrue: [^ phrase booleanComparatorPhrase].
phrase isBoolean ifTrue: [^ phrase].
((scriptedPlayer respondsTo: #costume)
and:[scriptedPlayer costume isInWorld not]) ifTrue: [^ Array new].
((phrase isMemberOf: PhraseTileMorph) and: [phrase submorphs size > 1] and: [#(bearingTo: distanceToPlayer:) includes: phrase submorphs second operatorOrExpression])
ifTrue:
[^ self booleanPhraseFromNumericGetterWithArgument: phrase].
+ ((retrieverTile := phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase].
+ retrieverOp := retrieverTile operatorOrExpression.
- ((retrieverTile _ phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase].
- retrieverOp _ retrieverTile operatorOrExpression.
(Vocabulary vocabularyForType: phrase resultType)
affordsCoercionToBoolean ifTrue: [
retrieverOp = #getPatchValueIn: ifTrue: [
^ self booleanPhraseForGetPatchValueOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getRedComponentIn: ifTrue: [
^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #red retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getGreenComponentIn: ifTrue: [
^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #green retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getBlueComponentIn: ifTrue: [
^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #blue retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getUphillIn: ifTrue: [
^ self booleanPhraseForGetUpHillOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getDistanceTo: ifTrue: [
^ self booleanPhraseForGetDistanceToOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #getAngleTo: ifTrue: [
^ self booleanPhraseForGetAngleToOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
retrieverOp = #bounceOn: ifTrue: [
^ self booleanPhraseForBounceOnOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
" (retrieverOp = #bounceOn:color: or: [retrieverOp = #bounceOnColor:]) ifTrue: [
^ self booleanPhraseForBounceOnColorOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
]."
"retrieverOp = #getTurtleAt: ifTrue: [
^ self booleanPhraseForGetTurtleAtOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
]."
retrieverOp = #getTurtleOf: ifTrue: [
^ self booleanPhraseForGetTurtleOfOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
^ self booleanPhraseForRetrieverOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
].
^ phrase!
Item was changed:
----- Method: CategoryViewer>>chooseCategory (in category 'categories') -----
chooseCategory
"The mouse went down on my category-list control; pop up a list of category choices"
| aList aMenu reply aLinePosition lineList special |
Cursor wait showWhile: [
+ aList := (scriptedPlayer categoriesForViewer: self) asOrderedCollection.
- aList _ (scriptedPlayer categoriesForViewer: self) asOrderedCollection.
special := {ScriptingSystem nameForScriptsCategory. ScriptingSystem nameForInstanceVariablesCategory}.
aList removeAllFoundIn: special.
aList := special, aList.
+ aLinePosition := aList indexOf: #miscellaneous ifAbsent: [nil].
+ aList := aList collect:
- aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil].
- aList _ aList collect:
[:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol].
+ lineList := aLinePosition ifNil: [#(2)] ifNotNil: [Array with: 2 with: aLinePosition].
+ aMenu := CustomMenu labels: aList lines: lineList selections: aList.
+ reply := aMenu startUpWithCaption: 'category' translated.
- lineList _ aLinePosition ifNil: [#(2)] ifNotNil: [Array with: 2 with: aLinePosition].
- aMenu _ CustomMenu labels: aList lines: lineList selections: aList.
- reply _ aMenu startUpWithCaption: 'category' translated.
reply ifNil: [^ self].
self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol.
self assureCategoryFullyVisible
]!
Item was changed:
----- Method: CategoryViewer>>chosenCategorySymbol: (in category 'categories') -----
chosenCategorySymbol: aCategorySymbol
"Make the given category be my current one."
| aCategory wording |
+ chosenCategorySymbol := aCategorySymbol.
+ aCategory := self currentVocabulary categoryAt: chosenCategorySymbol.
+ wording := aCategory ifNil: [aCategorySymbol] ifNotNil: [aCategory wording].
- chosenCategorySymbol _ aCategorySymbol.
- aCategory _ self currentVocabulary categoryAt: chosenCategorySymbol.
- wording _ aCategory ifNil: [aCategorySymbol] ifNotNil: [aCategory wording].
self categoryWording: wording.
aCategorySymbol asSymbol = #tests ifTrue: [self addMorph: self phraseForTest after: self submorphs first].
aCategorySymbol asSymbol = #miscellaneous ifTrue: [self addMorph: self phraseForTimesRepeat after: self submorphs first].
!
Item was changed:
----- Method: CategoryViewer>>currentCategory (in category 'categories') -----
currentCategory
"Answer the symbol representing the receiver's currently-selected category"
| current |
+ current := self categoryNameMorph contents.
- current _ self categoryNameMorph contents.
^ current ifNotNil: [current asSymbol] ifNil: [#basic translated]!
Item was changed:
----- Method: CategoryViewer>>getterTilesFor:type: (in category 'get/set slots') -----
getterTilesFor: getterSelector type: aType
"Answer classic getter for the given name/type"
+ "aPhrase := nil, assumed"
- "aPhrase _ nil, assumed"
| selfTile selector aPhrase |
(#(#color:sees: #colorSees) includes: getterSelector)
ifTrue: [aPhrase := self colorSeesPhrase].
(#(#getPatchValueIn:) includes: getterSelector)
+ ifTrue: [aPhrase := self patchValuePhrase].
- ifTrue: [aPhrase _ self patchValuePhrase].
(#(#getRedComponentIn:) includes: getterSelector)
+ ifTrue: [aPhrase := self colorComponentPhraseFor: #red].
- ifTrue: [aPhrase _ self colorComponentPhraseFor: #red].
(#(#getGreenComponentIn:) includes: getterSelector)
+ ifTrue: [aPhrase := self colorComponentPhraseFor: #green].
- ifTrue: [aPhrase _ self colorComponentPhraseFor: #green].
(#(#getBlueComponentIn:) includes: getterSelector)
+ ifTrue: [aPhrase := self colorComponentPhraseFor: #blue].
- ifTrue: [aPhrase _ self colorComponentPhraseFor: #blue].
(#(#getUphillIn:) includes: getterSelector)
+ ifTrue: [aPhrase := self patchUphillPhrase].
- ifTrue: [aPhrase _ self patchUphillPhrase].
(#(#bounceOn:) includes: getterSelector)
+ ifTrue: [aPhrase := self bounceOnPhrase].
- ifTrue: [aPhrase _ self bounceOnPhrase].
" (#(#bounceOn:color: #bounceOnColor:) includes: getterSelector)
+ ifTrue: [aPhrase := self bounceOnColorPhrase]."
- ifTrue: [aPhrase _ self bounceOnColorPhrase]."
(getterSelector = #getDistanceTo:)
+ ifTrue: [aPhrase := self distanceToPhrase].
- ifTrue: [aPhrase _ self distanceToPhrase].
(getterSelector = #getAngleTo:)
+ ifTrue: [aPhrase := self angleToPhrase].
- ifTrue: [aPhrase _ self angleToPhrase].
(getterSelector = #getTurtleOf:)
+ ifTrue: [aPhrase := self turtleOfPhrase].
- ifTrue: [aPhrase _ self turtleOfPhrase].
(getterSelector = #distanceToPlayer:)
+ ifTrue: [aPhrase := self distanceToPlayerPhrase].
- ifTrue: [aPhrase _ self distanceToPlayerPhrase].
(getterSelector = #bearingTo:)
+ ifTrue: [aPhrase := self bearingToPhrase].
- ifTrue: [aPhrase _ self bearingToPhrase].
(getterSelector = #bearingFrom:)
+ ifTrue: [aPhrase := self bearingFromPhrase].
- ifTrue: [aPhrase _ self bearingFromPhrase].
(#(#seesColor: #isOverColor) includes: getterSelector)
ifTrue: [aPhrase := self seesColorPhrase].
(#(#overlaps: #overlaps) includes: getterSelector)
ifTrue: [aPhrase := self overlapsPhrase].
(#(#overlapsAny: #overlapsAny) includes: getterSelector)
ifTrue: [aPhrase := self overlapsAnyPhrase].
(#(#touchesA: #touchesA) includes: getterSelector)
ifTrue: [aPhrase := self touchesAPhrase].
aPhrase ifNil:
[aPhrase := PhraseTileMorph new setSlotRefOperator: getterSelector asSymbol
type: aType].
selfTile := self tileForSelf bePossessive.
selfTile position: aPhrase firstSubmorph position.
aPhrase firstSubmorph addMorph: selfTile.
selector := aPhrase submorphs second.
(#(#getPatchValueIn: getUphillIn: bearingFrom: bearingTo: distanceToPlayer:) includes: getterSelector) ifFalse: [
(Vocabulary vocabularyNamed: aType capitalized)
ifNotNilDo: [:aVocab | aVocab wantsSuffixArrow ifTrue: [selector addSuffixArrow]].
].
selector updateLiteralLabel.
aPhrase enforceTileColorPolicy.
^aPhrase!
Item was changed:
----- Method: CategoryViewer>>infoButtonFor: (in category 'entries') -----
infoButtonFor: aScriptOrSlotSymbol
"Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol. If no such button is appropriate, answer a transparent graphic that fills the same space."
| aButton |
(self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse:
["Fill the space with sweet nothing, since there is no meaningful menu to offer"
+ aButton := RectangleMorph new beTransparent extent: (17 at 20).
- aButton _ RectangleMorph new beTransparent extent: (17 at 20).
aButton borderWidth: 0.
^ aButton].
+ aButton := self menuButton.
- aButton _ self menuButton.
aButton target: scriptedPlayer;
actionSelector: #infoFor:inViewer:;
arguments: (Array with:aScriptOrSlotSymbol with: self).
aButton setBalloonText: 'Press here to get a menu' translated.
^ aButton!
Item was changed:
----- Method: CategoryViewer>>initializeFor:categoryChoice: (in category 'initialization') -----
initializeFor: aPlayer categoryChoice: aChoice
"Initialize the receiver to be associated with the player and category specified"
+ scriptedPlayer := aPlayer.
- scriptedPlayer _ aPlayer.
self addHeaderMorph.
self chooseCategoryWhoseTranslatedWordingIs: aChoice
!
Item was changed:
----- Method: CategoryViewer>>makeSetterForColorComponent:componentName:event:from: (in category 'get/set slots') -----
makeSetterForColorComponent: selectorAndTypePair componentName: componentName event: evt from: aMorph
| argType m argTile selfTile argValue actualGetter |
argType := selectorAndTypePair second.
+ componentName = #red ifTrue: [actualGetter := #setRedComponentIn:].
+ componentName = #green ifTrue: [actualGetter := #setGreenComponentIn:].
+ componentName = #blue ifTrue: [actualGetter := #setBlueComponentIn:].
- componentName = #red ifTrue: [actualGetter _ #setRedComponentIn:].
- componentName = #green ifTrue: [actualGetter _ #setGreenComponentIn:].
- componentName = #blue ifTrue: [actualGetter _ #setBlueComponentIn:].
m := PhraseTileMorph new
setColorComponentRoot: actualGetter
componentName: componentName
type: #command
rcvrType: #Patch
argType: argType
vocabulary: self currentVocabulary.
argValue := self scriptedPlayer
perform: selectorAndTypePair first asSymbol with: nil.
(argValue isKindOf: Player)
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 submorphs second setPatchDefaultTo: scriptedPlayer defaultPatchPlayer.
m openInHand!
Item was changed:
----- Method: CategoryViewer>>phraseForCommandFrom: (in category 'entries') -----
phraseForCommandFrom: aMethodInterface
"Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles"
| aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp |
+ aDocString := aMethodInterface documentation.
+ aDocString = 'no help available' ifTrue: [aDocString := nil].
+ names := scriptedPlayer class namedTileScriptSelectors.
- aDocString _ aMethodInterface documentation.
- aDocString = 'no help available' ifTrue: [aDocString _ nil].
- names _ scriptedPlayer class namedTileScriptSelectors.
+ resultType := aMethodInterface resultType.
+ cmd := aMethodInterface selector.
+ (universal := scriptedPlayer isUniversalTiles)
- resultType _ aMethodInterface resultType.
- cmd _ aMethodInterface selector.
- (universal _ scriptedPlayer isUniversalTiles)
ifTrue:
+ [aPhrase := scriptedPlayer universalTilesForInterface: aMethodInterface]
- [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface]
ifFalse: [cmd numArgs == 0
ifTrue:
+ [aPhrase := PhraseTileMorph new vocabulary: self currentVocabulary.
- [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary.
aPhrase setOperator: cmd
type: resultType
rcvrType: #Player]
ifFalse:
["only one arg supported in classic tiles, so if this is fed
with a selector with > 1 arg, results will be very strange"
+ argType := aMethodInterface typeForArgumentNumber: 1.
+ aPhrase := PhraseTileMorph new vocabulary: self currentVocabulary.
- argType _ aMethodInterface typeForArgumentNumber: 1.
- aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary.
(self isSpecialPatchReceiver: scriptedPlayer and: cmd) ifTrue: [
aPhrase setOperator: cmd
type: resultType
rcvrType: #Patch
argType: argType.
] ifFalse: [
aPhrase setOperator: cmd
type: resultType
rcvrType: #Player
argType: argType.
].
(self isSpecialPatchCase: scriptedPlayer and: cmd) ifTrue: [
+ argTile := (Vocabulary vocabularyForType: argType) defaultArgumentTileFor: scriptedPlayer.
- argTile _ (Vocabulary vocabularyForType: argType) defaultArgumentTileFor: scriptedPlayer.
] ifFalse: [
+ argTile := ScriptingSystem tileForArgType: argType forCommand: cmd.
- argTile _ ScriptingSystem tileForArgType: argType forCommand: cmd.
].
(#(bounce: wrap:) includes: cmd) ifTrue:
["help for the embattled bj"
argTile setLiteral: 'silence'; updateLiteralLabel].
argTile position: aPhrase lastSubmorph position.
aPhrase lastSubmorph addMorph: argTile]].
(scriptedPlayer slotInfo includesKey: cmd)
+ ifTrue: [balloonTextSelector := #userSlot].
- ifTrue: [balloonTextSelector _ #userSlot].
(scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd])
ifTrue:
[aDocString ifNil:
+ [aDocString := (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentation].
- [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentation].
aDocString ifNil:
+ [balloonTextSelector := #userScript]].
- [balloonTextSelector _ #userScript]].
+ tileBearingHelp := universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile].
- tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile].
aDocString
ifNotNil:
[tileBearingHelp setBalloonText: aDocString]
ifNil:
[balloonTextSelector ifNil:
[tileBearingHelp setProperty: #inherentSelector toValue: cmd.
+ balloonTextSelector := nil].
- balloonTextSelector _ nil].
tileBearingHelp balloonTextSelector: balloonTextSelector].
aPhrase markAsPartsDonor.
cmd == #emptyScript ifTrue:
[aPhrase setProperty: #newPermanentScript toValue: true.
aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer.
aPhrase submorphs second setBalloonText:
'drag and drop to
add a new script' translated].
universal ifFalse:
+ [selfTile := self tileForSelf.
- [selfTile _ self tileForSelf.
selfTile position: aPhrase firstSubmorph position.
aPhrase firstSubmorph addMorph: selfTile].
+ aRow := ViewerLine newRow.
- aRow _ ViewerLine newRow.
aRow elementSymbol: cmd asSymbol.
aRow addMorphBack: (
(balloonTextSelector = #userSlot)
ifTrue: [(self infoButtonFor: cmd)]
ifFalse: [cmd = #emptyScript
ifTrue: [ScriptingSystem buttonSpacer]
ifFalse: [ScriptingSystem tryButtonFor: aPhrase]]).
aRow addMorphBack: self spacerAfterButton.
aRow addMorphBack: aPhrase.
"aPhrase on: #mouseEnter send: #addCommandFeedback to: aRow.
aPhrase on: #mouseLeave send: #removeHighlightFeedback to: aRow.
aPhrase on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow."
(names includes: cmd) ifTrue:
[aPhrase userScriptSelector: cmd.
cmd numArgs == 0 ifTrue:
[aPhrase beTransparent.
aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
+ aRow addMorphBack: (stat := (inst := scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph).
- aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph).
inst updateStatusMorph: stat]].
aRow beSticky; disableDragNDrop.
^ aRow!
Item was changed:
----- Method: CategoryViewer>>phraseForTest (in category '*Etoys-Squeakland-entries') -----
phraseForTest
"Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles"
| aPhrase aRow |
+ aPhrase := PhraseTileForTest new.
+ aRow := ViewerLine newRow.
- aPhrase _ PhraseTileForTest new.
- aRow _ ViewerLine newRow.
aRow addMorphBack: ScriptingSystem buttonSpacer.
aRow addMorphBack: self spacerAfterButton.
aRow addMorphBack: aPhrase.
aRow setBalloonText: 'Press here to tear off a TEST/YES/NO unit which you can drop into your script' translated.
^ aRow.
!
Item was changed:
----- Method: CategoryViewer>>phraseForTimesRepeat (in category '*Etoys-Squeakland-entries') -----
phraseForTimesRepeat
"Answer a phrase representing times/repeat"
| aPhrase aRow |
+ aPhrase := PhraseTileForTimesRepeat new.
+ aRow := ViewerLine newRow.
- aPhrase _ PhraseTileForTimesRepeat new.
- aRow _ ViewerLine newRow.
aRow addMorphBack: ScriptingSystem buttonSpacer.
aRow addMorphBack: self spacerAfterButton.
aRow addMorphBack: aPhrase.
aRow setBalloonText: 'Drag here to tear off a Repeat/Times unit which you can drop into your script' translated.
^ aRow.
!
Item was changed:
----- Method: CategoryViewer>>readoutFor:type:readOnly:getSelector:putSelector: (in category 'entries') -----
readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector
"Answer a readout morph for the given part"
| readout delta |
+ readout := (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector.
- readout _ (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector.
(partType == #Number) ifTrue:
+ [(delta := scriptedPlayer arrowDeltaFor: getSelector) = 1
- [(delta _ scriptedPlayer arrowDeltaFor: getSelector) = 1
ifFalse:
[readout setProperty: #arrowDelta toValue: delta].
scriptedPlayer setFloatPrecisionFor: readout updatingStringMorph].
partType == #Point ifTrue:
[scriptedPlayer setFloatPrecisionFor: readout updatingStringMorph].
readout step.
^ readout!
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 meths chosen aMenu aCaption symbolToReport |
+ aVocabulary := self currentVocabulary.
+ allCategories := scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject.
- aVocabulary _ self currentVocabulary.
- allCategories _ scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject.
+ hits := allCategories select:
- hits _ allCategories select:
[:aCategory |
+ meths := aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class.
- meths _ aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class.
meths includes: aSymbol].
hits isEmpty ifTrue: [^ self inform: 'this tile is not actually suitable for use with this kind of object' translated].
symbolToReport := (aSymbol beginsWith: 'get') ifTrue: [Utilities inherentSelectorForGetter: aSymbol] ifFalse: [aSymbol].
aMenu := SelectionMenu selections: hits.
aCaption := hits size = 1
ifTrue:
['is in the following category' translated]
ifFalse:
['can be found in the following categories' translated].
+ chosen := aMenu startUpWithCaption: symbolToReport, ' ', aCaption.
- chosen _ aMenu startUpWithCaption: symbolToReport, ' ', aCaption.
chosen isEmptyOrNil ifFalse:
[self outerViewer addCategoryViewerFor: chosen atEnd: true]
!
Item was changed:
----- Method: CategoryViewer>>universalTilesPhraseForVariableFrom: (in category '*Etoys-Squeakland-entries') -----
universalTilesPhraseForVariableFrom: aMethodInterface
"The universal-tiles variant of phraseForVariableFrom:... Split out to preserve it, somewhat, though we're not using universal tiles any more, presuambly ever again (indeed we never did) but for convenience moved here so that 'universal' code doesn't becloud #phraseForVariableFrom:"
| anArrow slotName getterButton cover inner aRow doc setter tryer |
+ aRow := ViewerLine newRow
+ elementSymbol: (slotName := aMethodInterface selector);
- aRow _ ViewerLine newRow
- elementSymbol: (slotName _ aMethodInterface selector);
wrapCentering: #center;
cellPositioning: #leftCenter.
(self wantsInfoButtonFor: slotName)
ifFalse:
[aRow addMorphBack: ScriptingSystem buttonSpacer]
ifTrue:
[aRow addMorphBack: (self infoButtonFor: slotName)].
aRow addMorphBack: self spacerAfterButton.
+ inner := scriptedPlayer universalTilesForGetterOf: aMethodInterface.
+ cover := Morph new color: Color transparent.
- inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface.
- cover _ Morph new color: Color transparent.
cover extent: inner fullBounds extent.
+ (getterButton := cover copy) addMorph: cover; addMorphBack: inner.
- (getterButton _ cover copy) addMorph: cover; addMorphBack: inner.
cover on: #mouseDown send: #makeUniversalTilesGetter:event:from:
to: self withValue: aMethodInterface.
+ aRow addMorphFront: (tryer := ScriptingSystem tryButtonFor: inner).
- aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner).
tryer color: tryer color lighter lighter.
aRow addMorphBack: getterButton.
getterButton on: #mouseEnter send: #addGetterFeedback to: aRow.
getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow.
getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
+ (doc := aMethodInterface documentation) ifNotNil:
- (doc _ aMethodInterface documentation) ifNotNil:
[getterButton setBalloonText: doc].
aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer"
+ (setter := aMethodInterface companionSetterSelector) ifNotNil:
- (setter _ aMethodInterface companionSetterSelector) ifNotNil:
[aRow addMorphBack: (Morph new color: self color; extent: 2 at 10). " spacer"
+ anArrow := self arrowSetterButton: #newMakeSetterFromInterface:evt:from:
- anArrow _ self arrowSetterButton: #newMakeSetterFromInterface:evt:from:
args: aMethodInterface.
anArrow beTransparent.
aRow addMorphBack: anArrow].
anArrow ifNotNil: [anArrow step].
^ aRow!
Item was changed:
----- Method: CategoryViewer>>wantsRowMenuFor: (in category 'entries') -----
wantsRowMenuFor: aSymbol
"Answer whether a viewer row for the given symbol should have a menu button on it"
| elementType |
true ifTrue: [^ true]. "To allow show categories item. So someday this method can be removed, and its sender can stop sending it..."
+ elementType := scriptedPlayer elementTypeFor: aSymbol vocabulary: self currentVocabulary.
- elementType _ scriptedPlayer elementTypeFor: aSymbol vocabulary: self currentVocabulary.
(elementType == #systemScript) ifTrue: [^ false].
((elementType == #systemSlot) and:
[#(color:sees: touchesA: overlaps: overlapsAny: distanceToPlayer: bearingTo: bearingFrom:) includes: aSymbol]) ifTrue: [^ false].
^ true!
Item was changed:
----- Method: CenterBroomMorphDown>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: hotspot x @ lastHotspot y.
- movedRect _ self bounds encompass: hotspot x @ lastHotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds left
right: m bounds right
top: m bounds center y - 1
bottom: m bounds center y + 1)]!
Item was changed:
----- Method: CenterBroomMorphLeft>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: lastHotspot x @ hotspot y.
- movedRect _ self bounds encompass: lastHotspot x @ hotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds center x - 1
right: m bounds center x + 1
top: m bounds top
bottom: m bounds bottom)]!
Item was changed:
----- Method: CenterBroomMorphRight>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: lastHotspot x @ hotspot y.
- movedRect _ self bounds encompass: lastHotspot x @ hotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds center x - 1
right: m bounds center x + 1
top: m bounds top
bottom: m bounds bottom)]!
Item was changed:
----- Method: CenterBroomMorphUp>>affectedMorphs (in category 'private') -----
affectedMorphs
"Answer all the morphs that I should be moving"
| movedRect |
+ movedRect := self bounds encompass: hotspot x @ lastHotspot y.
- movedRect _ self bounds encompass: hotspot x @ lastHotspot y.
^ owner submorphs
select: [:m | movedRect
intersects: (Rectangle
left: m bounds left
right: m bounds right
top: m bounds center y - 1
bottom: m bounds center y + 1)]!
Item was changed:
----- Method: ChangeSetCategory>>changeSetList (in category 'queries') -----
changeSetList
"Answer the list of change-set names in the category"
| aChangeSet |
self reconstituteList.
keysInOrder size == 0 ifTrue:
["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected"
+ aChangeSet := ChangeSorter assuredChangeSetNamed: 'New Changes'.
- aChangeSet _ ChangeSorter assuredChangeSetNamed: 'New Changes'.
self elementAt: aChangeSet name put: aChangeSet].
^ keysInOrder reversed!
Item was changed:
----- Method: ChangeSetCategory>>fileOutAllChangeSets (in category 'services') -----
fileOutAllChangeSets
"File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task."
| aList |
+ aList := self elementsInOrder select:
- aList _ self elementsInOrder select:
[:aChangeSet | aChangeSet isEmpty not].
aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty'].
(self confirm: 'This will result in filing out ', aList size printString, ' change set(s)
Are you certain you want to do this?') ifFalse: [^ self].
Preferences setFlag: #checkForSlips toValue: false during:
[ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]!
Item was changed:
----- Method: ChangeSetCategory>>fillAggregateChangeSet (in category 'services') -----
fillAggregateChangeSet
"Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category"
| aggChangeSet |
+ aggChangeSet := ChangeSorter assuredChangeSetNamed: #Aggregate.
- aggChangeSet _ ChangeSorter assuredChangeSetNamed: #Aggregate.
aggChangeSet clear.
aggChangeSet setPreambleToSay: '"Change Set: Aggregate
Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'.
(self elementsInOrder copyWithout: aggChangeSet) do:
[:aChangeSet | aggChangeSet assimilateAllChangesFoundIn: aChangeSet].
Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]
!
Item was changed:
----- Method: ChangeSetCategory>>membershipSelector: (in category 'initialization') -----
membershipSelector: aSelector
"Set the membershipSelector"
+ membershipSelector := aSelector!
- membershipSelector _ aSelector!
Item was changed:
----- Method: ChangeSetCategory>>reconstituteList (in category 'miscellaneous') -----
reconstituteList
"Clear out the receiver's elements and rebuild them"
| newMembers |
"First determine newMembers and check if they have not changed..."
+ newMembers := ChangeSorter allChangeSets select:
- newMembers _ ChangeSorter allChangeSets select:
[:aChangeSet | ChangeSorter perform: membershipSelector with: aChangeSet].
(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"].
"Things have changed. Need to recompute the whole category"
self clear.
newMembers do:
[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]
!
Item was changed:
----- Method: ChangeSetCategoryWithParameters>>parameters: (in category 'as yet unclassified') -----
parameters: anArray
+ parameters := anArray!
- parameters _ anArray!
Item was changed:
----- Method: ChangeSetCategoryWithParameters>>reconstituteList (in category 'as yet unclassified') -----
reconstituteList
"Clear out the receiver's elements and rebuild them"
| newMembers |
"First determine newMembers and check if they have not changed..."
+ newMembers := ChangeSorter allChangeSets select:
- newMembers _ ChangeSorter allChangeSets select:
[:aChangeSet | ChangeSorter perform: membershipSelector withArguments: { aChangeSet }, parameters].
(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"].
"Things have changed. Need to recompute the whole category"
self clear.
newMembers do:
[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]!
Item was changed:
----- Method: CharRecog class>>initialize (in category 'initialization') -----
initialize
"Iniitialize the character dictionary if it doesn't exist yet. 2/5/96 sw"
CharacterDictionary == nil ifTrue:
+ [CharacterDictionary := Dictionary new]!
- [CharacterDictionary _ Dictionary new]!
Item was changed:
----- Method: CharRecog class>>readRecognizerDictionaryFrom: (in category 'saving dictionary') -----
readRecognizerDictionaryFrom: aFileName
"Read a fresh version of the Recognizer dictionary in from a file of the given name. 7/26/96 sw"
"CharRecog readRecognizerDictionaryFrom: 'RecogDictionary.2 fixed'"
| aReferenceStream |
+ aReferenceStream := ReferenceStream fileNamed: aFileName.
+ CharacterDictionary := aReferenceStream next.
- aReferenceStream _ ReferenceStream fileNamed: aFileName.
- CharacterDictionary _ aReferenceStream next.
aReferenceStream close.
!
Item was changed:
----- Method: CharRecog class>>reinitializeCharacterDictionary (in category 'initialization') -----
reinitializeCharacterDictionary
"Reset the character dictionary to be empty, ready for a fresh start. 2/5/96 sw"
+ CharacterDictionary := Dictionary new
- CharacterDictionary _ Dictionary new
"CharRecog reinitializeCharacterDictionary" !
Item was changed:
----- Method: CharRecog class>>saveRecognizerDictionaryTo: (in category 'saving dictionary') -----
saveRecognizerDictionaryTo: aFileName
"Save the current state of the Recognizer dictionary to disk. 7/26/96 sw"
| aReferenceStream |
+ aReferenceStream := ReferenceStream fileNamed: aFileName.
- aReferenceStream _ ReferenceStream fileNamed: aFileName.
aReferenceStream nextPut: CharacterDictionary.
aReferenceStream close!
Item was changed:
----- Method: CharRecog>>directionFrom:to: (in category 'historical & disused') -----
directionFrom: p1 to: p2 | ex |
"This does 8 directions and is not used in current recognizer"
+ "get the bounding box" ex := p2 - p1. "unlike bmax-bmin, this can have negatives"
- "get the bounding box" ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"
"Look for degenerate forms first: . - |"
"look for a dot" ex abs < (3 at 3) ifTrue: [^' dot... '].
"look for hori line" ((ex y = 0) or: [(ex x/ex y) abs > 2]) ifTrue:
"look for w-e" [ex x > 0 ifTrue:[^' we-- ']
"it's an e-w" ifFalse:[^' ew-- ']].
"look for vertical line" ((ex x = 0) or: [(ex y/ex x) abs > 2]) ifTrue:
"look for n-s" [(ex y > 0) ifTrue:[ ^' ns||']
"it's a s-n" ifFalse:[^' sn|| ']].
"look for a diagonal" (ex x/ex y) abs <= 2 ifTrue:
"se or ne" [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// '].
"sw or nw" ex y > 0 ifTrue:[^' sw// ']. ^' nw// '].
!
Item was changed:
----- Method: CharRecog>>extractFeatures (in category 'recognizer') -----
extractFeatures | xl xr yl yh reg px py |
+ "get extent bounding box" in := bmax - bmin.
- "get extent bounding box" in _ bmax - bmin.
"Look for degenerate forms first: . - |"
"look for a dot" in < (3 at 3) ifTrue: [^' dot... '].
"Feature 5: turns (these are already in ftrs)"
+ "Feature 4: absolute size" in < (10 at 10) ifTrue: [ftrs := 'SML ', ftrs] ifFalse:
+ [in <= (70 at 70) ifTrue: [ftrs := 'REG ', ftrs] ifFalse:
+ [in > (70 at 70) ifTrue: [ftrs := 'LRG ', ftrs]]].
- "Feature 4: absolute size" in < (10 at 10) ifTrue: [ftrs _ 'SML ', ftrs] ifFalse:
- [in <= (70 at 70) ifTrue: [ftrs _ 'REG ', ftrs] ifFalse:
- [in > (70 at 70) ifTrue: [ftrs _ 'LRG ', ftrs]]].
"Feature 3: aspect ratio"
"horizontal shape" ((in y = 0) or: [(in x/in y) abs > 3]) ifTrue:
+ [ftrs := 'HOR ', ftrs] ifFalse:
- [ftrs _ 'HOR ', ftrs] ifFalse:
"vertical shape" [((in x = 0) or: [(in y/in x) abs >= 3]) ifTrue:
+ [ftrs := 'VER ', ftrs] ifFalse:
- [ftrs _ 'VER ', ftrs] ifFalse:
"boxy shape" [((in x/in y) abs <= 3) ifTrue:
+ [ftrs := 'BOX ', ftrs.
- [ftrs _ 'BOX ', ftrs.
"Now only for boxes"
+ "Feature 2: endstroke reg" ftrs := (self regionOf: (pts last)), ftrs.
- "Feature 2: endstroke reg" ftrs _ (self regionOf: (pts last)), ftrs.
+ "Feature 1: startstroke reg" ftrs := (self regionOf: (pts contents at: 1)), ftrs.]]].
- "Feature 1: startstroke reg" ftrs _ (self regionOf: (pts contents at: 1)), ftrs.]]].
^ftrs
!
Item was changed:
----- Method: CharRecog>>fourDirsFrom:to: (in category 'recognizer') -----
fourDirsFrom: p1 to: p2 | ex |
+ "get the bounding box" ex := p2 - p1. "unlike bmax-bmin, this can have negatives"
- "get the bounding box" ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"
"Look for degenerate forms first: . - |"
"look for a dot" ex abs < (3 at 3) ifTrue: [^' dot... '].
"look for hori line" ((ex y = 0) or: [(ex x/ex y) abs > 1]) ifTrue:
"look for w-e" [ex x > 0 ifTrue:[^'WE ']
"it's an e-w" ifFalse:[^'EW ']].
"look for vertical line" ((ex x = 0) or: [(ex y/ex x) abs >= 1]) ifTrue:
"look for n-s" [(ex y > 0) ifTrue:[ ^'NS ']
"it's a s-n" ifFalse:[^'SN ']].
"look for a diagonal (ex x/ex y) abs <= 2 ifTrue:"
"se or ne [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']."
"sw or nw ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']."
!
Item was changed:
----- Method: CharRecog>>learnPrev (in category 'historical & disused') -----
learnPrev
"The character recognized before this one was wrong. (Got here via the gesture for 'wrong'.) Bring up a dialog box on that char. 8/21/96 tk"
| old result |
+ old := CharacterDictionary at: prevFeatures ifAbsent: [^ ''].
+ "get right char from user" result := FillInTheBlank request:
- old _ CharacterDictionary at: prevFeatures ifAbsent: [^ ''].
- "get right char from user" result _ FillInTheBlank request:
('Redefine the gesture we thought was "', old asString, '".', '
(Letter or: tab cr wrong bs select caret)
', prevFeatures).
"ignore or..." (result = '~' | result = '') ifTrue: ['']
"...enter new char" ifFalse: [
CharacterDictionary at: prevFeatures
put: result].
"caller erases bad char"
"good char" ^ result!
Item was changed:
----- Method: CharRecog>>recogPar (in category 'historical & disused') -----
recogPar | prv cdir result features char r s t dir |
+ "Inits" (p := Pen new) defaultNib: 1; down.
+ "for points" pts := ReadWriteStream on: #().
- "Inits" (p _ Pen new) defaultNib: 1; down.
- "for points" pts _ ReadWriteStream on: #().
"Event Loop"
[Sensor anyButtonPressed] whileFalse: [(Sensor mousePoint x < 50) ifTrue: [^''].].
"First-Time" pts reset.
+ "will hold features" ftrs := ''.
- "will hold features" ftrs _ ''.
(Sensor anyButtonPressed) ifTrue:
+ [pts nextPut: (bmin := bmax := t := s := sts := Sensor mousePoint).
+ p place: sts. cdir := nil.
- [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
- p place: sts. cdir _ nil.
"Each-Time" [Sensor anyButtonPressed] whileTrue:
[
+ "ink raw input" p goto: (r := Sensor mousePoint).
+ "smooth it" s := (0.5*s) + (0.5*r).
- "ink raw input" p goto: (r _ Sensor mousePoint).
- "smooth it" s _ (0.5*s) + (0.5*r).
"thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
[ pts nextPut: t.
+ "bounding box" bmin := bmin min: s. bmax := bmax max: s.
+ "get current dir" dir := (self fourDirsFrom: t to: s). t := s.
- "bounding box" bmin _ bmin min: s. bmax _ bmax max: s.
- "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s.
dir ~= ' dot... ' ifTrue: [
+ "store new dirs" cdir ~= dir ifTrue: [ftrs := ftrs, (cdir := dir)]].
- "store new dirs" cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" p place: t; go: 1; place: r.
].
"End Each-Time Loop" ].
"Last-Time"
"start a new recog for next point" [CharRecog new recognize] fork.
"save last points" pts nextPut: t; nextPut: r.
+ "find rest of features" features := self extractFeatures.
+ "find char..." char := CharacterDictionary at: features ifAbsent:
+ "...or get from user" [ result := FillInTheBlank request:
- "find rest of features" features _ self extractFeatures.
- "find char..." char _ CharacterDictionary at: features ifAbsent:
- "...or get from user" [ result _ FillInTheBlank request:
'Not recognized. type char, or type ~: ', features.
"ignore or..." result = '~' ifTrue: ['']
"...enter new char" ifFalse: [CharacterDictionary at: features put: result. result]].
"control the editor" (char = 'cr' ifTrue: [Transcript cr] ifFalse:
[char = 'bs' ifTrue: [Transcript bs] ifFalse:
[char = 'tab' ifTrue:[Transcript tab] ifFalse:
[Transcript show: char]]]).
"End First-Time Loop" ].
!
Item was changed:
----- Method: CharRecog>>recognize (in category 'historical & disused') -----
recognize | prv cdir result features char r s t dir |
"Alan Kay's recognizer as of 1/31/96. This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar. Within the current image, the recognizer is now called via #recognizeAndDispatch:until:"
+ "Inits" (p := Pen new) defaultNib: 1; down.
+ "for points" pts := ReadWriteStream on: #().
- "Inits" (p _ Pen new) defaultNib: 1; down.
- "for points" pts _ ReadWriteStream on: #().
"Event Loop"
[(Sensor mousePoint x) < 50] whileFalse:
"First-Time" [pts reset.
+ "will hold features" ftrs := ''.
- "will hold features" ftrs _ ''.
(Sensor anyButtonPressed) ifTrue:
+ [pts nextPut: (bmin := bmax := t := s := sts := Sensor mousePoint).
+ p place: sts. cdir := nil.
- [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
- p place: sts. cdir _ nil.
"Each-Time" [Sensor anyButtonPressed] whileTrue:
[
+ "ink raw input" p goto: (r := Sensor mousePoint).
+ "smooth it" s := (0.5*s) + (0.5*r).
- "ink raw input" p goto: (r _ Sensor mousePoint).
- "smooth it" s _ (0.5*s) + (0.5*r).
"thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
[ pts nextPut: t.
+ "bounding box" bmin := bmin min: s. bmax := bmax max: s.
+ "get current dir" dir := (self fourDirsFrom: t to: s). t := s.
- "bounding box" bmin _ bmin min: s. bmax _ bmax max: s.
- "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s.
dir ~= ' dot... ' ifTrue: [
+ "store new dirs" cdir ~= dir ifTrue: [ftrs := ftrs, (cdir := dir)]].
- "store new dirs" cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" p place: t; go: 1; place: r.
].
"End Each-Time Loop" ].
"Last-Time"
"save last points" pts nextPut: t; nextPut: r.
+ "find rest of features" features := self extractFeatures.
+ "find char..." char := CharacterDictionary at: features ifAbsent:
+ "...or get from user" [ result := FillInTheBlank request:
- "find rest of features" features _ self extractFeatures.
- "find char..." char _ CharacterDictionary at: features ifAbsent:
- "...or get from user" [ result _ FillInTheBlank request:
'Not recognized. type char, or type ~: ', features.
"ignore or..." result = '~' ifTrue: ['']
"...enter new char" ifFalse: [CharacterDictionary at: features put: result. result]].
"control the editor" (char = 'cr' ifTrue: [Transcript cr] ifFalse:
[char = 'bs' ifTrue: [Transcript bs] ifFalse:
[char = 'tab' ifTrue:[Transcript tab] ifFalse:
[Transcript show: char]]]).
"End First-Time Loop" ].
"End Event-Loop" ].
!
Item was changed:
----- Method: CharRecog>>recognizeAndDispatch:ifUnrecognized:until: (in category 'recognizer') -----
recognizeAndDispatch: charDispatchBlock ifUnrecognized: unrecognizedFeaturesBlock until: terminationBlock
"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method. 2/2/96 sw. 2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window. 8/17/96 tk: Turn cr, tab, bs into strings so they work.
9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt. unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none."
| prv cdir features char r s t dir |
+ "Inits" (p := Pen new) defaultNib: 1; down.
+ "for points" pts := ReadWriteStream on: #().
- "Inits" (p _ Pen new) defaultNib: 1; down.
- "for points" pts _ ReadWriteStream on: #().
"Event Loop"
[terminationBlock value] whileFalse:
"First-Time" [pts reset.
+ "will hold features" ftrs := ''.
- "will hold features" ftrs _ ''.
(Sensor anyButtonPressed) ifTrue:
+ [pts nextPut: (bmin := bmax := t := s := sts := Sensor mousePoint).
+ p place: sts. cdir := nil.
- [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
- p place: sts. cdir _ nil.
"Each-Time" [Sensor anyButtonPressed] whileTrue:
+ "ink raw input" [p goto: (r := Sensor mousePoint).
+ "smooth it" s := (0.5*s) + (0.5*r).
- "ink raw input" [p goto: (r _ Sensor mousePoint).
- "smooth it" s _ (0.5*s) + (0.5*r).
"thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
[pts nextPut: t.
+ "bounding box" bmin := bmin min: s. bmax := bmax max: s.
+ "get current dir" dir := (self fourDirsFrom: t to: s). t := s.
- "bounding box" bmin _ bmin min: s. bmax _ bmax max: s.
- "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s.
dir ~= ' dot... ' ifTrue:
+ "store new dirs" [cdir ~= dir ifTrue: [ftrs := ftrs, (cdir := dir)]].
- "store new dirs" [cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" p place: t; go: 1; place: r]].
"End Each-Time Loop"
"Last-Time"
"save last points" pts nextPut: t; nextPut: r.
+ "find rest of features" features := self extractFeatures.
+ "find char..." char := CharacterDictionary at: features ifAbsent:
- "find rest of features" features _ self extractFeatures.
- "find char..." char _ CharacterDictionary at: features ifAbsent:
[unrecognizedFeaturesBlock value: features].
"special chars" char size > 0 ifTrue:
+ [char = 'tab' ifTrue: [char := Tab].
+ char = 'cr' ifTrue: [char := CR].
- [char = 'tab' ifTrue: [char _ Tab].
- char = 'cr' ifTrue: [char _ CR].
"must be a string" char class == Character ifTrue:
+ [char := String with: char].
+ char = 'bs' ifTrue: [char := BS].
- [char _ String with: char].
- char = 'bs' ifTrue: [char _ BS].
"control the editor" charDispatchBlock value: char]]]
!
Item was changed:
----- Method: CharRecog>>regionOf: (in category 'recognizer') -----
regionOf: pt
| px py reg xl yl yh xr rg |
+ "it's some other character" rg := in/3. xl := bmin x + rg x. xr := bmax x - rg x.
+ "divide box into 9 regions" yl := bmin y + rg y. yh := bmax y - rg y.
- "it's some other character" rg _ in/3. xl _ bmin x + rg x. xr _ bmax x - rg x.
- "divide box into 9 regions" yl _ bmin y + rg y. yh _ bmax y - rg y.
+ px := pt x. py := pt y.
+ reg := (px < xl ifTrue: [py < yl ifTrue: ['NW ']
- px _ pt x. py _ pt y.
- reg _ (px < xl ifTrue: [py < yl ifTrue: ['NW ']
"py >= yl" ifFalse:[ py < yh ifTrue:['W ']
ifFalse: ['SW ']]]
ifFalse: [px < xr ifTrue: [py < yl ifTrue: ['N ']
ifFalse: [py < yh ifTrue: ['C ']
ifFalse: ['S ']]]
ifFalse: [py < yl ifTrue: ['NE ']
ifFalse: [py < yh ifTrue: ['E ']
ifFalse: ['SE ']]]]).
^reg.
!
Item was changed:
----- Method: CharRecog>>stringForUnrecognizedFeatures: (in category 'recognizer') -----
stringForUnrecognizedFeatures: features
"Prompt the user for what string the current features represent, and return the result. 9/18/96 sw"
| result |
+ result := FillInTheBlank request:
- result _ FillInTheBlank request:
('Not recognized. type char, or "tab", "cr" or "bs",
or hit return to ignore
', features).
textMorph ifNotNil:
[textMorph world displayWorld "take down the FillInTheBlank morph"].
^ (result = '~' | result = '')
ifTrue:
['']
ifFalse:
[CharacterDictionary at: features put: result. result]!
Item was changed:
----- Method: CharRecog>>textMorph: (in category 'morphic dockup') -----
textMorph: aTextMorph
+ textMorph := aTextMorph!
- textMorph _ aTextMorph!
Item was changed:
----- Method: Character>>asUnicodeChar (in category '*Etoys-Squeakland-converting') -----
asUnicodeChar
"@@@ FIXME: Make this use asUnicode and move it to its lonely sender @@@"
| table charset v |
self leadingChar = 0 ifTrue: [^ self asInteger].
+ charset := EncodedCharSet charsetAt: self leadingChar.
- charset _ EncodedCharSet charsetAt: self leadingChar.
charset isCharset ifFalse: [^ self].
+ table := charset ucsTable.
- table _ charset ucsTable.
table isNil ifTrue: [^ Character value: 16rFFFD].
+ v := table at: self charCode + 1.
- v _ table at: self charCode + 1.
v = -1 ifTrue: [^ Character value: 16rFFFD].
^ Character leadingChar: charset unicodeLeadingChar code: v.!
Item was changed:
----- Method: ChessBoard class>>initializeHashKeys (in category 'class initialization') -----
initializeHashKeys
"ChessGame initialize"
| random |
+ HashKeys := Array new: 12.
- HashKeys _ Array new: 12.
1 to: HashKeys size do:[:i| HashKeys at: i put: (WordArray new: 64)].
+ HashLocks := Array new: 12.
- HashLocks _ Array new: 12.
1 to: HashLocks size do:[:i| HashLocks at: i put: (WordArray new: 64)].
+ random := Random seed: 23648646.
- random _ Random seed: 23648646.
1 to: 12 do:[:i|
1 to: 64 do:[:j|
(HashKeys at: i) at: j put: (random nextInt: SmallInteger maxVal) - 1.
(HashLocks at: i) at: j put: (random nextInt: SmallInteger maxVal) - 1.
].
].
!
Item was changed:
----- Method: ChessBoard>>initialize (in category 'initialize') -----
initialize
+ generator ifNil:[generator := ChessMoveGenerator new initialize].
+ searchAgent ifNil:[searchAgent := ChessPlayerAI new initialize].
- generator ifNil:[generator _ ChessMoveGenerator new initialize].
- searchAgent ifNil:[searchAgent _ ChessPlayerAI new initialize].
self resetGame.
!
Item was changed:
----- Method: ChessBoard>>movePieceFrom:to: (in category 'moving') -----
movePieceFrom: sourceSquare to: destSquare
| move |
searchAgent isThinking ifTrue:[^self].
+ move := (activePlayer findPossibleMovesAt: sourceSquare) contents
- move _ (activePlayer findPossibleMovesAt: sourceSquare) contents
detect:[:any| any destinationSquare = destSquare].
self nextMove: move.
searchAgent activePlayer: activePlayer.!
Item was changed:
----- Method: ChessBoard>>postCopy (in category 'copying') -----
postCopy
whitePlayer == activePlayer ifTrue:[
+ whitePlayer := whitePlayer copy.
+ blackPlayer := blackPlayer copy.
+ activePlayer := whitePlayer.
- whitePlayer _ whitePlayer copy.
- blackPlayer _ blackPlayer copy.
- activePlayer _ whitePlayer.
] ifFalse:[
+ whitePlayer := whitePlayer copy.
+ blackPlayer := blackPlayer copy.
+ activePlayer := blackPlayer.
- whitePlayer _ whitePlayer copy.
- blackPlayer _ blackPlayer copy.
- activePlayer _ blackPlayer.
].
whitePlayer opponent: blackPlayer.
blackPlayer opponent: whitePlayer.
whitePlayer board: self.
blackPlayer board: self.
self userAgent: nil.!
Item was changed:
----- Method: ChessBoard>>resetGame (in category 'initialize') -----
resetGame
+ hashKey := hashLock := 0.
+ whitePlayer := ChessPlayer new initialize.
+ blackPlayer := ChessPlayer new initialize.
- hashKey _ hashLock _ 0.
- whitePlayer _ ChessPlayer new initialize.
- blackPlayer _ ChessPlayer new initialize.
whitePlayer opponent: blackPlayer.
whitePlayer board: self.
blackPlayer opponent: whitePlayer.
blackPlayer board: self.
+ activePlayer := whitePlayer.
- activePlayer _ whitePlayer.
searchAgent reset: self.
userAgent ifNotNil:[userAgent gameReset].!
Item was changed:
----- Method: ChessBoard>>searchAgent: (in category 'accessing') -----
searchAgent: anAgent
+ searchAgent := anAgent.!
- searchAgent _ anAgent.!
Item was changed:
----- Method: ChessBoard>>userAgent: (in category 'accessing') -----
userAgent: anObject
+ userAgent := anObject.!
- userAgent _ anObject.!
Item was changed:
----- Method: ChessConstants class>>initializeBishopMovers (in category 'pool initialization') -----
initializeBishopMovers.
+ BishopMovers := Set new.
- BishopMovers _ Set new.
BishopMovers add:Bishop.
BishopMovers add:Queen.!
Item was changed:
----- Method: ChessConstants class>>initializeBishopMoves (in category 'pool initialization') -----
initializeBishopMoves
"ChessPlayer initialize"
| index moveList1 moveList2 moveList3 moveList4 px py |
+ BishopMoves := Array new: 64 withAll: #().
- BishopMoves _ Array new: 64 withAll: #().
0 to: 7 do:[:j|
0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList1 := moveList2 := moveList3 := moveList4 := #().
- index _ (j * 8) + i + 1.
- moveList1 _ moveList2 _ moveList3 _ moveList4 _ #().
1 to: 7 do:[:k|
+ px := i + k. py := j - k.
- px _ i + k. py _ j - k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList1 := moveList1 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j - k.
- moveList1 _ moveList1 copyWith: (py * 8) + px + 1].
- px _ i - k. py _ j - k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList2 := moveList2 copyWith: (py * 8) + px + 1].
+ px := i + k. py := j + k.
- moveList2 _ moveList2 copyWith: (py * 8) + px + 1].
- px _ i + k. py _ j + k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList3 := moveList3 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j + k.
- moveList3 _ moveList3 copyWith: (py * 8) + px + 1].
- px _ i - k. py _ j + k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList4 := moveList4 copyWith: (py * 8) + px + 1].
- moveList4 _ moveList4 copyWith: (py * 8) + px + 1].
].
BishopMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
].
].!
Item was changed:
----- Method: ChessConstants class>>initializeCastlingConstants (in category 'pool initialization') -----
initializeCastlingConstants
+ CastlingDone := 1.
- CastlingDone _ 1.
+ CastlingDisableKingSide := 2.
+ CastlingDisableQueenSide := 4.
+ CastlingDisableAll := CastlingDisableQueenSide bitOr: CastlingDisableKingSide.
- CastlingDisableKingSide _ 2.
- CastlingDisableQueenSide _ 4.
- CastlingDisableAll _ CastlingDisableQueenSide bitOr: CastlingDisableKingSide.
+ CastlingEnableKingSide := CastlingDone bitOr: CastlingDisableKingSide.
+ CastlingEnableQueenSide := CastlingDone bitOr: CastlingDisableQueenSide.
- CastlingEnableKingSide _ CastlingDone bitOr: CastlingDisableKingSide.
- CastlingEnableQueenSide _ CastlingDone bitOr: CastlingDisableQueenSide.
!
Item was changed:
----- Method: ChessConstants class>>initializeCenterScores (in category 'pool initialization') -----
initializeCenterScores
"ChessPlayer initialize"
+ PieceCenterScores := Array new: 6.
- PieceCenterScores _ Array new: 6.
1 to: 6 do:[:i| PieceCenterScores at: i put: (ByteArray new: 64)].
PieceCenterScores at: Knight put:
#(
-4 0 0 0 0 0 0 -4
-4 0 2 2 2 2 0 -4
-4 2 3 2 2 3 2 -4
-4 1 2 5 5 2 2 -4
-4 1 2 5 5 2 2 -4
-4 2 3 2 2 3 2 -4
-4 0 2 2 2 2 0 -4
-4 0 0 0 0 0 0 -4
).
PieceCenterScores at: Bishop put:
#(
-2 -2 -2 -2 -2 -2 -2 -2
-2 0 0 0 0 0 0 -2
-2 0 1 1 1 1 0 -2
-2 0 1 2 2 1 0 -2
-2 0 1 2 2 1 0 -2
-2 0 1 1 1 1 0 -2
-2 0 0 0 0 0 0 -2
-2 -2 -2 -2 -2 -2 -2 -2
).
PieceCenterScores at: Queen put:
#(
-3 0 0 0 0 0 0 -3
-2 0 0 0 0 0 0 -2
-2 0 1 1 1 1 0 -2
-2 0 1 2 2 1 0 -2
-2 0 1 2 2 1 0 -2
-2 0 1 1 1 1 0 -2
-2 0 0 0 0 0 0 -2
-3 0 0 0 0 0 0 -3
).!
Item was changed:
----- Method: ChessConstants class>>initializeKingMoves (in category 'pool initialization') -----
initializeKingMoves
"ChessPlayer initialize"
| index px py moveList |
+ KingMoves := Array new: 64 withAll: #().
- KingMoves _ Array new: 64 withAll: #().
0 to: 7 do:[:j|
0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList := #().
- index _ (j * 8) + i + 1.
- moveList _ #().
#( (-1 -1) (0 -1) (1 -1) (-1 0) (1 0) (-1 1) (0 1) (1 1)) do:[:spec|
+ px := i + spec first.
+ py := j + spec last.
- px _ i + spec first.
- py _ j + spec last.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList := moveList copyWith: (py * 8) + px + 1]].
- moveList _ moveList copyWith: (py * 8) + px + 1]].
KingMoves at: index put: moveList
].
].!
Item was changed:
----- Method: ChessConstants class>>initializeKnightMoves (in category 'pool initialization') -----
initializeKnightMoves
"ChessPlayer initialize"
| index px py moveList |
+ KnightMoves := Array new: 64 withAll: #().
- KnightMoves _ Array new: 64 withAll: #().
0 to: 7 do:[:j|
0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList := #().
- index _ (j * 8) + i + 1.
- moveList _ #().
#( (-2 -1) (-1 -2) (1 -2) (2 -1) (-2 1) (-1 2) (1 2) (2 1)) do:[:spec|
+ px := i + spec first.
+ py := j + spec last.
- px _ i + spec first.
- py _ j + spec last.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList := moveList copyWith: (py * 8) + px + 1]].
- moveList _ moveList copyWith: (py * 8) + px + 1]].
KnightMoves at: index put: moveList
].
].!
Item was changed:
----- Method: ChessConstants class>>initializePieceValues (in category 'pool initialization') -----
initializePieceValues
+ PieceValues := Array new: 6.
- PieceValues _ Array new: 6.
PieceValues at: Pawn put: 100.
PieceValues at: Knight put: 300.
PieceValues at: Bishop put: 350.
PieceValues at: Rook put: 500.
PieceValues at: Queen put: 900.
PieceValues at: King put: 2000.
!
Item was changed:
----- Method: ChessConstants class>>initializeRookMovers (in category 'pool initialization') -----
initializeRookMovers.
+ RookMovers := Set new.
- RookMovers _ Set new.
RookMovers add:Rook.
RookMovers add:Queen.!
Item was changed:
----- Method: ChessConstants class>>initializeRookMoves (in category 'pool initialization') -----
initializeRookMoves
"ChessPlayer initialize"
| index moveList1 moveList2 moveList3 moveList4 px py |
+ RookMoves := Array new: 64 withAll: #().
- RookMoves _ Array new: 64 withAll: #().
0 to: 7 do:[:j|
0 to: 7 do:[:i|
+ index := (j * 8) + i + 1.
+ moveList1 := moveList2 := moveList3 := moveList4 := #().
- index _ (j * 8) + i + 1.
- moveList1 _ moveList2 _ moveList3 _ moveList4 _ #().
1 to: 7 do:[:k|
+ px := i + k. py := j.
- px _ i + k. py _ j.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList1 := moveList1 copyWith: (py * 8) + px + 1].
+ px := i. py := j + k.
- moveList1 _ moveList1 copyWith: (py * 8) + px + 1].
- px _ i. py _ j + k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList2 := moveList2 copyWith: (py * 8) + px + 1].
+ px := i - k. py := j.
- moveList2 _ moveList2 copyWith: (py * 8) + px + 1].
- px _ i - k. py _ j.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList3 := moveList3 copyWith: (py * 8) + px + 1].
+ px := i. py := j - k.
- moveList3 _ moveList3 copyWith: (py * 8) + px + 1].
- px _ i. py _ j - k.
((px between: 0 and: 7) and:[py between: 0 and: 7]) ifTrue:[
+ moveList4 := moveList4 copyWith: (py * 8) + px + 1].
- moveList4 _ moveList4 copyWith: (py * 8) + px + 1].
].
RookMoves at: index put: {moveList1. moveList2. moveList3. moveList4}.
].
].!
Item was changed:
----- Method: ChessHistoryTable>>addMove: (in category 'accessing') -----
addMove: aMove
| index |
+ index := (aMove sourceSquare bitShift: 6) + aMove destinationSquare.
- index _ (aMove sourceSquare bitShift: 6) + aMove destinationSquare.
self at: index put: (self at: index + 1)!
Item was changed:
----- Method: ChessMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aMorph event: anEvent
| destSquare sourceSquare |
+ sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
- sourceSquare _ aMorph valueOfProperty: #chessBoardSourceSquare.
aMorph removeProperty: #chessBoardSourceSquare.
+ destSquare := self asSquare: aMorph center.
- destSquare _ self asSquare: aMorph center.
"!!!!!! ACTUAL MOVE HAPPENS INDIRECTLY !!!!!!"
(self atSquare: sourceSquare) addMorphCentered: aMorph.
destSquare ifNil:[^self].
self movePieceFrom: sourceSquare to: destSquare.
self showMovesAt: destSquare.!
Item was changed:
----- Method: ChessMorph>>addButtonRow (in category 'initialize') -----
addButtonRow
| r m |
+ r := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
- r _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent.
r addMorphBack: (self buttonName: ' New ' translated action: #newGame).
r addMorphBack: (self buttonName: ' Help ' translated action: #findBestMove).
r addMorphBack: (self buttonName: ' Play ' translated action: #thinkAndMove).
r addMorphBack: (self buttonName: ' Auto ' translated action: #autoPlay).
r addMorphBack: (self buttonName: ' Undo ' translated action: #undoMove).
r addMorphBack: (self buttonName: ' Redo ' translated action: #redoMove).
r addMorphBack: (self buttonName: ' Quit ' translated action: #delete).
r disableTableLayout: true.
r align: r bounds topLeft with: self layoutBounds topLeft.
self addMorphFront: r.
+ m := UpdatingStringMorph on: self selector: #statusString.
- m _ UpdatingStringMorph on: self selector: #statusString.
m useStringFormat.
m disableTableLayout: true.
m align: m bounds topLeft with: r fullBounds bottomLeft.
self addMorphFront: m.!
Item was changed:
----- Method: ChessMorph>>addSquares (in category 'initialize') -----
addSquares
| white black square index |
+ white := Color white.
+ black := Color lightGray.
+ index := 0.
- white _ Color white.
- black _ Color lightGray.
- index _ 0.
#(
( ' ' 'a' 'b' 'c' 'd' 'e' 'f' 'g' 'h' ' ')
( '1' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
( '2' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
( '3' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
( '4' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
( '5' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
( '6' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
( '7' 'B' 'W' 'B' 'W' 'B' 'W' 'B' 'W' ' ')
( '8' 'W' 'B' 'W' 'B' 'W' 'B' 'W' 'B' ' ')
( ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ')
) do:[:file|
file do:[:sq|
+ square := self newSquare.
- square _ self newSquare.
square borderWidth: 0.
(sq = 'W' or:[sq = 'B']) ifTrue:[
square color: (sq = 'W' ifTrue:[white] ifFalse:[black]).
square borderColor: Color red.
+ square setProperty: #squarePosition toValue: (index := index + 1).
- square setProperty: #squarePosition toValue: (index _ index + 1).
square setNameTo:
(String with: ($a asInteger + (index - 1 bitAnd: 7)) asCharacter with: ($1 asInteger + (index -1 bitShift: -3)) asCharacter).
square on: #mouseEnter send: #showMoves:from: to: self.
square on: #mouseEnterDragging send: #dragSquareEnter:from: to: self.
square on: #mouseLeaveDragging send: #dragSquareLeave:from: to: self.
] ifFalse:["decoration"
square color: Color transparent.
sq = ' ' ifFalse:[
square addMorphCentered: (StringMorph contents: sq asUppercase font: Preferences windowTitleFont emphasis: 1).
].
].
square extent: 40 at 40.
self addMorphBack: square.
]].
!
Item was changed:
----- Method: ChessMorph>>addedPiece:at:white: (in category 'game callbacks') -----
addedPiece: piece at: square white: isWhite
| m |
+ m := self newPiece: piece white: isWhite.
- m _ self newPiece: piece white: isWhite.
m on: #mouseDown send: #dragPiece:from: to: self.
m setProperty: #chessBoard toValue: self.
(self atSquare: square) removeAllMorphs; addMorphCentered: m.!
Item was changed:
----- Method: ChessMorph>>autoPlay (in category 'playing') -----
autoPlay
+ autoPlay := autoPlay not.
- autoPlay _ autoPlay not.
autoPlay ifTrue:[self thinkAndMove].!
Item was changed:
----- Method: ChessMorph>>buttonFillStyle (in category 'initialize') -----
buttonFillStyle
| fill |
+ fill := GradientFillStyle ramp: {
- fill _ GradientFillStyle ramp: {
0.0 -> (Color r: 0.05 g: 0.5 b: 1.0).
1.0 -> (Color r: 0.85 g: 0.95 b: 1.0)}.
fill origin: (0 at 0).
fill direction: 40 at 10.
fill radial: false.
^ fill
!
Item was changed:
----- Method: ChessMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the receiver's default color"
| result |
+ result := GradientFillStyle ramp: {0.0
- result _ GradientFillStyle ramp: {0.0
-> (Color
r: 0.05
g: 0.5
b: 1.0). 1.0
-> (Color
r: 0.85
g: 0.95
b: 1.0)}.
result origin: self bounds origin;
direction: self extent.
result radial: false.
^ result!
Item was changed:
----- Method: ChessMorph>>findBestMove (in category 'playing') -----
findBestMove
| move |
board searchAgent isThinking ifTrue:[^self].
+ Cursor wait showWhile:[move := board searchAgent think].
- Cursor wait showWhile:[move _ board searchAgent think].
self inform: 'I suggest: ' translated, move printString.
^move!
Item was changed:
----- Method: ChessMorph>>finishedGame: (in category 'game callbacks') -----
finishedGame: result
"
0 - white lost
0.5 - draw
1 - white won
"
+ board := nil.!
- board _ nil.!
Item was changed:
----- Method: ChessMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ animateMove := false.
+ autoPlay := false.
- animateMove _ false.
- autoPlay _ false.
self cornerStyle: #rounded.
self layoutPolicy: TableLayout new.
self listDirection: #leftToRight;
wrapDirection: #bottomToTop.
self addSquares.
self addButtonRow.
self newGame!
Item was changed:
----- Method: ChessMorph>>movedPiece:from:to: (in category 'game callbacks') -----
movedPiece: piece from: sourceSquare to: destSquare
| sourceMorph destMorph sourcePos destPos w startTime nowTime deltaTime |
+ sourceMorph := (self atSquare: sourceSquare) firstSubmorph.
+ destMorph := self atSquare: destSquare.
- sourceMorph _ (self atSquare: sourceSquare) firstSubmorph.
- destMorph _ self atSquare: destSquare.
animateMove ifTrue:[
+ sourcePos := sourceMorph boundsInWorld center.
+ destPos := destMorph boundsInWorld center.
+ (w := self world) ifNotNil:[
- sourcePos _ sourceMorph boundsInWorld center.
- destPos _ destMorph boundsInWorld center.
- (w _ self world) ifNotNil:[
w addMorphFront: sourceMorph.
sourceMorph addDropShadow.
sourceMorph shadowColor: (Color black alpha: 0.5).
+ deltaTime := (sourcePos dist: destPos) * 10 asInteger.
+ startTime := Time millisecondClockValue.
+ [nowTime := Time millisecondClockValue.
- deltaTime _ (sourcePos dist: destPos) * 10 asInteger.
- startTime _ Time millisecondClockValue.
- [nowTime _ Time millisecondClockValue.
nowTime - startTime < deltaTime] whileTrue:[
sourceMorph center: sourcePos + (destPos - sourcePos * (nowTime - startTime) // deltaTime) asIntegerPoint.
w displayWorldSafely].
sourceMorph removeDropShadow.
].
].
destMorph removeAllMorphs.
destMorph addMorphCentered: sourceMorph.
+ animateMove := false.!
- animateMove _ false.!
Item was changed:
----- Method: ChessMorph>>newGame (in category 'playing') -----
newGame
+ board ifNil:[board := ChessBoard new].
- board ifNil:[board _ ChessBoard new].
board initialize.
board userAgent: self.
board initializeNewBoard.
+ history := OrderedCollection new.
+ redoList := OrderedCollection new.
- history _ OrderedCollection new.
- redoList _ OrderedCollection new.
!
Item was changed:
----- Method: ChessMorph>>newPiece:white: (in category 'initialize') -----
newPiece: piece white: isWhite
| index selector m |
+ index := piece.
+ isWhite ifFalse:[index := index + 6].
+ selector := #(
- index _ piece.
- isWhite ifFalse:[index _ index + 6].
- selector _ #(
whitePawnImage
whiteKnightImage
whiteBishopImage
whiteRookImage
whiteQueenImage
whiteKingImage
blackPawnImage
blackKnightImage
blackBishopImage
blackRookImage
blackQueenImage
blackKingImage) at: index.
+ m := ChessPieceMorph new image: (self class perform: selector).
- m _ ChessPieceMorph new image: (self class perform: selector).
m setProperty: #isWhite toValue: isWhite.
m setProperty: #piece toValue: piece.
^m!
Item was changed:
----- Method: ChessMorph>>showMoves:from: (in category 'events') -----
showMoves: evt from: aMorph
| square |
+ square := aMorph valueOfProperty: #squarePosition.
- square _ aMorph valueOfProperty: #squarePosition.
square ifNotNil:[^self showMovesAt: square].!
Item was changed:
----- Method: ChessMorph>>showMovesAt: (in category 'events') -----
showMovesAt: square
| list |
board ifNil:[^self].
board searchAgent isThinking ifTrue:[^self].
self squaresDo:[:m| m borderWidth: 0].
+ list := board activePlayer findValidMovesAt: square.
- list _ board activePlayer findValidMovesAt: square.
list isEmpty ifTrue:[^self].
(self atSquare: square) borderWidth: 1.
list do:[:move|
(self atSquare: move destinationSquare) borderWidth: 1.
].!
Item was changed:
----- Method: ChessMorph>>step (in category 'stepping and presenter') -----
step
| move |
board searchAgent isThinking ifTrue:[
+ move := board searchAgent thinkStep.
- move _ board searchAgent thinkStep.
move ifNotNil:[
+ animateMove := true.
- animateMove _ true.
board movePieceFrom: move sourceSquare
to: move destinationSquare].
] ifFalse:[
autoPlay ifTrue:[board searchAgent startThinking].
].!
Item was changed:
----- Method: ChessMorph>>validateGamePosition (in category 'game callbacks') -----
validateGamePosition
"This method does nothing but validating what you see (on screen) is what you get (from the board)."
| square piece isWhite p |
1 to: 64 do:[:idx|
+ square := self atSquare: idx.
- square _ self atSquare: idx.
square hasSubmorphs
+ ifTrue:[piece := square firstSubmorph valueOfProperty: #piece.
+ isWhite := square firstSubmorph valueOfProperty: #isWhite]
+ ifFalse:[piece := 0. isWhite := nil].
+ p := board whitePlayer pieceAt: idx.
+ idx = board whitePlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
- ifTrue:[piece _ square firstSubmorph valueOfProperty: #piece.
- isWhite _ square firstSubmorph valueOfProperty: #isWhite]
- ifFalse:[piece _ 0. isWhite _ nil].
- p _ board whitePlayer pieceAt: idx.
- idx = board whitePlayer castlingRookSquare ifTrue:[p _ ChessPlayer rook].
isWhite == true ifTrue:[
p = piece ifFalse:[self error:'White broken'].
] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
+ p := board blackPlayer pieceAt: idx.
+ idx = board blackPlayer castlingRookSquare ifTrue:[p := ChessPlayer rook].
- p _ board blackPlayer pieceAt: idx.
- idx = board blackPlayer castlingRookSquare ifTrue:[p _ ChessPlayer rook].
isWhite == false ifTrue:[
p = piece ifFalse:[self error:'White broken'].
] ifFalse:[p = 0 ifFalse:[self error:'White broken']].
].!
Item was changed:
----- Method: ChessMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: anEvent
| sourceSquare destSquare |
(aMorph valueOfProperty: #chessBoard) == self ifFalse:[^false].
board ifNil:[^true].
+ sourceSquare := aMorph valueOfProperty: #chessBoardSourceSquare.
+ destSquare := self asSquare: aMorph bounds center.
- sourceSquare _ aMorph valueOfProperty: #chessBoardSourceSquare.
- destSquare _ self asSquare: aMorph bounds center.
destSquare ifNil:[^false].
^board activePlayer isValidMoveFrom: sourceSquare to: destSquare!
Item was changed:
----- Method: ChessMove class>>initialize (in category 'class initialization') -----
initialize
"ChessMove initialize"
+ MoveNormal := 1.
+ MoveDoublePush := 2.
+ MoveCaptureEnPassant := 3.
+ MoveCastlingKingSide := 4.
+ MoveCastlingQueenSide := 5.
+ MoveResign := 6.
+ MoveStaleMate := 7.
- MoveNormal _ 1.
- MoveDoublePush _ 2.
- MoveCaptureEnPassant _ 3.
- MoveCastlingKingSide _ 4.
- MoveCastlingQueenSide _ 5.
- MoveResign _ 6.
- MoveStaleMate _ 7.
+ BasicMoveMask := 15.
+ PromotionShift := 4.
+ ExtractPromotionShift := 0 - PromotionShift.
- BasicMoveMask _ 15.
- PromotionShift _ 4.
- ExtractPromotionShift _ 0 - PromotionShift.
+ EvalTypeAccurate := 0.
+ EvalTypeUpperBound := 1.
+ EvalTypeLowerBound := 2.
- EvalTypeAccurate _ 0.
- EvalTypeUpperBound _ 1.
- EvalTypeLowerBound _ 2.
+ NullMove := 0.
- NullMove _ 0.
!
Item was changed:
----- Method: ChessMove>>captureEnPassant:from:to: (in category 'initialize') -----
captureEnPassant: aPiece from: startSquare to: endSquare
+ movingPiece := capturedPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCaptureEnPassant.!
- movingPiece _ capturedPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- type _ MoveCaptureEnPassant.!
Item was changed:
----- Method: ChessMove>>capturedPiece: (in category 'accessing') -----
capturedPiece: aValue
+ ^capturedPiece := aValue!
- ^capturedPiece _ aValue!
Item was changed:
----- Method: ChessMove>>checkMate: (in category 'initialize') -----
checkMate: aPiece
+ movingPiece := aPiece.
+ sourceSquare := 0.
+ destinationSquare := 0.
+ type := MoveResign.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ 0.
- destinationSquare _ 0.
- type _ MoveResign.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>destinationSquare: (in category 'accessing') -----
destinationSquare: aValue
+ ^destinationSquare := aValue!
- ^destinationSquare _ aValue!
Item was changed:
----- Method: ChessMove>>doublePush:from:to: (in category 'initialize') -----
doublePush: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveDoublePush.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- type _ MoveDoublePush.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>init (in category 'initialize') -----
init
+ movingPiece := sourceSquare := destinationSquare := 1.
+ type := MoveNormal.
+ capturedPiece := 0.!
- movingPiece _ sourceSquare _ destinationSquare _ 1.
- type _ MoveNormal.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>move:from:to: (in category 'initialize') -----
move: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveNormal.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- type _ MoveNormal.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>move:from:to:capture: (in category 'initialize') -----
move: aPiece from: startSquare to: endSquare capture: capture
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ capturedPiece := capture.
+ type := MoveNormal.
- movingPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- capturedPiece _ capture.
- type _ MoveNormal.
!
Item was changed:
----- Method: ChessMove>>moveCastlingKingSide:from:to: (in category 'initialize') -----
moveCastlingKingSide: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCastlingKingSide.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- type _ MoveCastlingKingSide.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>moveCastlingQueenSide:from:to: (in category 'initialize') -----
moveCastlingQueenSide: aPiece from: startSquare to: endSquare
+ movingPiece := aPiece.
+ sourceSquare := startSquare.
+ destinationSquare := endSquare.
+ type := MoveCastlingQueenSide.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ startSquare.
- destinationSquare _ endSquare.
- type _ MoveCastlingQueenSide.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>moveEncoded: (in category 'initialize') -----
moveEncoded: encodedMove
+ destinationSquare := encodedMove bitAnd: 255.
+ sourceSquare := (encodedMove bitShift: -8) bitAnd: 255.
+ movingPiece := (encodedMove bitShift: -16) bitAnd: 255.
+ capturedPiece := (encodedMove bitShift: -24) bitAnd: 255.
+ type := MoveNormal.
- destinationSquare _ encodedMove bitAnd: 255.
- sourceSquare _ (encodedMove bitShift: -8) bitAnd: 255.
- movingPiece _ (encodedMove bitShift: -16) bitAnd: 255.
- capturedPiece _ (encodedMove bitShift: -24) bitAnd: 255.
- type _ MoveNormal.
!
Item was changed:
----- Method: ChessMove>>moveType: (in category 'accessing') -----
moveType: aType
+ ^type := aType!
- ^type _ aType!
Item was changed:
----- Method: ChessMove>>movingPiece: (in category 'accessing') -----
movingPiece: aValue
+ ^movingPiece := aValue!
- ^movingPiece _ aValue!
Item was changed:
----- Method: ChessMove>>promote:to: (in category 'initialize') -----
promote: move to: promotion
+ movingPiece := move movingPiece.
+ capturedPiece := move capturedPiece.
+ sourceSquare := move sourceSquare.
+ destinationSquare := move destinationSquare.
+ type := move moveType.
+ type := type bitOr: (promotion bitShift: PromotionShift).
- movingPiece _ move movingPiece.
- capturedPiece _ move capturedPiece.
- sourceSquare _ move sourceSquare.
- destinationSquare _ move destinationSquare.
- type _ move moveType.
- type _ type bitOr: (promotion bitShift: PromotionShift).
!
Item was changed:
----- Method: ChessMove>>sourceSquare: (in category 'accessing') -----
sourceSquare: aValue
+ ^sourceSquare := aValue!
- ^sourceSquare _ aValue!
Item was changed:
----- Method: ChessMove>>staleMate: (in category 'initialize') -----
staleMate: aPiece
+ movingPiece := aPiece.
+ sourceSquare := 0.
+ destinationSquare := 0.
+ type := MoveStaleMate.
+ capturedPiece := 0.!
- movingPiece _ aPiece.
- sourceSquare _ 0.
- destinationSquare _ 0.
- type _ MoveStaleMate.
- capturedPiece _ 0.!
Item was changed:
----- Method: ChessMove>>value: (in category 'accessing') -----
value: newValue
+ value := newValue!
- value _ newValue!
Item was changed:
----- Method: ChessMoveGenerator>>blackPawnCaptureAt:direction: (in category 'moves-pawns') -----
blackPawnCaptureAt: square direction: dir
| destSquare move piece |
+ destSquare := square-8-dir.
+ piece := itsPieces at: destSquare.
- destSquare _ square-8-dir.
- piece _ itsPieces at: destSquare.
piece = 0 ifFalse:[
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (move _ moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: Pawn from: square to: destSquare capture: piece.
+ piece = King ifTrue:[kingAttack := move].
- piece = King ifTrue:[kingAttack _ move].
destSquare <= 8 "a promotion"
ifTrue:[self promotePawn: move].
].
"attempt an en-passant capture"
enpassantSquare = destSquare ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
captureEnPassant: Pawn from: square to: destSquare.
].!
Item was changed:
----- Method: ChessMoveGenerator>>blackPawnPushAt: (in category 'moves-pawns') -----
blackPawnPushAt: square
| destSquare move |
"Try to push this pawn"
+ destSquare := square-8.
- destSquare _ square-8.
(myPieces at: destSquare) = 0 ifFalse:[^self].
(itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (move _ moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: Pawn from: square to: destSquare.
destSquare <= 8 "a promotion (can't be double-push so get out)"
ifTrue:[^self promotePawn: move].
"Try to double-push if possible"
square > 48 ifFalse:[^self].
+ destSquare := square-16.
- destSquare _ square-16.
(myPieces at: destSquare) = 0 ifFalse:[^self].
(itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
doublePush: Pawn from: square to: destSquare.!
Item was changed:
----- Method: ChessMoveGenerator>>findPossibleMovesFor: (in category 'public') -----
findPossibleMovesFor: player
"Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
+ forceCaptures := false.
- forceCaptures _ false.
^self findAllPossibleMovesFor: player.!
Item was changed:
----- Method: ChessMoveGenerator>>findPossibleMovesFor:at: (in category 'public') -----
findPossibleMovesFor: player at: square
"Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
| piece action |
+ forceCaptures := false.
+ myPlayer := player.
+ myPieces := player pieces.
+ itsPieces := player opponent pieces.
+ castlingStatus := player castlingStatus.
+ enpassantSquare := player opponent enpassantSquare.
- forceCaptures _ false.
- myPlayer _ player.
- myPieces _ player pieces.
- itsPieces _ player opponent pieces.
- castlingStatus _ player castlingStatus.
- enpassantSquare _ player opponent enpassantSquare.
firstMoveIndex = lastMoveIndex ifFalse:[self error:'I am confused'].
+ kingAttack := nil.
+ piece := myPieces at: square.
- kingAttack _ nil.
- piece _ myPieces at: square.
piece = 0 ifFalse:[
+ action := #(movePawnAt:
- action _ #(movePawnAt:
moveKnightAt:
moveBishopAt:
moveRookAt:
moveQueenAt:
moveKingAt:) at: piece.
self perform: action with: square.
].
^self moveList!
Item was changed:
----- Method: ChessMoveGenerator>>findQuiescenceMovesFor: (in category 'public') -----
findQuiescenceMovesFor: player
"Find all the quiescence moves (that is moves capturing pieces)"
+ forceCaptures := true.
- forceCaptures _ true.
^self findAllPossibleMovesFor: player.!
Item was changed:
----- Method: ChessMoveGenerator>>initialize (in category 'initialize') -----
initialize
EmptyPieceMap ifNil:[
+ EmptyPieceMap := ByteArray new: 256.
- EmptyPieceMap _ ByteArray new: 256.
2 to: 7 do:[:i| EmptyPieceMap at: i put: 1]].
+ streamList := Array new: 100. "e.g., 100 plies"
- streamList _ Array new: 100. "e.g., 100 plies"
1 to: streamList size do:[:i| streamList at: i put: (ChessMoveList on: #())].
+ moveList := Array new: streamList size * 30. "avg. 30 moves per ply"
- moveList _ Array new: streamList size * 30. "avg. 30 moves per ply"
1 to: moveList size do:[:i| moveList at: i put: (ChessMove new init)].
+ firstMoveIndex := lastMoveIndex := streamListIndex := 0.!
- firstMoveIndex _ lastMoveIndex _ streamListIndex _ 0.!
Item was changed:
----- Method: ChessMoveGenerator>>moveBishopAt: (in category 'moves-general') -----
moveBishopAt: square
| moves |
+ moves := BishopMoves at: square.
- moves _ BishopMoves at: square.
1 to: moves size do:[:i|
self movePiece: Bishop along: (moves at: i) at: square.
].
!
Item was changed:
----- Method: ChessMoveGenerator>>moveBlackKingAt: (in category 'moves-general') -----
moveBlackKingAt: square
| capture |
(KingMoves at: square) do:[:destSquare|
(myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
- capture _ itsPieces at: destSquare.
(forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- capture = King ifTrue:[kingAttack _ moveList at: lastMoveIndex].
].
].
].
forceCaptures ifTrue:[^self].
"now consider castling"
self canCastleBlackKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
moveCastlingKingSide: King from: square to: square+2.
].
self canCastleBlackQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
moveCastlingQueenSide: King from: square to: square-2.
].!
Item was changed:
----- Method: ChessMoveGenerator>>moveKnightAt: (in category 'moves-general') -----
moveKnightAt: square
| capture moves destSquare |
+ moves := KnightMoves at: square.
- moves _ KnightMoves at: square.
1 to: moves size do:[:i|
+ destSquare := moves at: i.
- destSquare _ moves at: i.
(myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
- capture _ itsPieces at: destSquare.
(forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: Knight from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := (moveList at: lastMoveIndex)].
- capture = King ifTrue:[kingAttack _ (moveList at: lastMoveIndex)].
].
].
].!
Item was changed:
----- Method: ChessMoveGenerator>>moveList (in category 'public') -----
moveList
| list |
kingAttack ifNotNil:[
+ lastMoveIndex := firstMoveIndex.
- lastMoveIndex _ firstMoveIndex.
^nil].
+ list := streamList at: (streamListIndex := streamListIndex + 1).
- list _ streamList at: (streamListIndex _ streamListIndex + 1).
list on: moveList from: firstMoveIndex+1 to: lastMoveIndex.
+ firstMoveIndex := lastMoveIndex.
- firstMoveIndex _ lastMoveIndex.
^list!
Item was changed:
----- Method: ChessMoveGenerator>>movePiece:along:at: (in category 'moves-general') -----
movePiece: piece along: rayList at: square
| destSquare capture |
1 to: rayList size do:[:i|
+ destSquare := rayList at: i.
- destSquare _ rayList at: i.
(myPieces at: destSquare) = 0 ifFalse:[^self].
+ capture := itsPieces at: destSquare.
- capture _ itsPieces at: destSquare.
(forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: piece from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- capture = King ifTrue:[kingAttack _ moveList at: lastMoveIndex].
].
capture = 0 ifFalse:[^self].
].!
Item was changed:
----- Method: ChessMoveGenerator>>moveQueenAt: (in category 'moves-general') -----
moveQueenAt: square
| moves |
+ moves := RookMoves at: square.
- moves _ RookMoves at: square.
1 to: moves size do:[:i|
self movePiece: Queen along: (moves at: i) at: square.
].
+ moves := BishopMoves at: square.
- moves _ BishopMoves at: square.
1 to: moves size do:[:i|
self movePiece: Queen along: (moves at: i) at: square.
].!
Item was changed:
----- Method: ChessMoveGenerator>>moveRookAt: (in category 'moves-general') -----
moveRookAt: square
| moves |
+ moves := RookMoves at: square.
- moves _ RookMoves at: square.
1 to: moves size do:[:i|
self movePiece: Rook along: (moves at: i) at: square.
].
!
Item was changed:
----- Method: ChessMoveGenerator>>moveWhiteKingAt: (in category 'moves-general') -----
moveWhiteKingAt: square
| capture |
(KingMoves at: square) do:[:destSquare|
(myPieces at: destSquare) = 0 ifTrue:[
+ capture := itsPieces at: destSquare.
- capture _ itsPieces at: destSquare.
(forceCaptures and:[capture = 0]) ifFalse:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: King from: square to: destSquare capture: capture.
+ capture = King ifTrue:[kingAttack := moveList at: lastMoveIndex].
- capture = King ifTrue:[kingAttack _ moveList at: lastMoveIndex].
].
].
].
forceCaptures ifTrue:[^self].
"now consider castling"
self canCastleWhiteKingSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
moveCastlingKingSide: King from: square to: square+2.
].
self canCastleWhiteQueenSide ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
moveCastlingQueenSide: King from: square to: square-2.
].!
Item was changed:
----- Method: ChessMoveGenerator>>profileGenerationFor: (in category 'public') -----
profileGenerationFor: player
| list |
Smalltalk garbageCollect.
MessageTally spyOn:[
1 to: 100000 do:[:i|
+ list := self findPossibleMovesFor: player.
- list _ self findPossibleMovesFor: player.
self recycleMoveList: list].
].
!
Item was changed:
----- Method: ChessMoveGenerator>>promotePawn: (in category 'moves-pawns') -----
promotePawn: move
"Duplicate the given move and embed all promotion types"
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Knight.
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Bishop.
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1)) promote: move to: Rook.
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1)) promote: move to: Knight.
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1)) promote: move to: Bishop.
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1)) promote: move to: Rook.
move promote: move to: Queen.!
Item was changed:
----- Method: ChessMoveGenerator>>recycleMoveList: (in category 'public') -----
recycleMoveList: aChessMoveList
(streamList at: streamListIndex) == aChessMoveList ifFalse:[^self error:'I am confused'].
+ streamListIndex := streamListIndex - 1.
+ firstMoveIndex := lastMoveIndex := aChessMoveList startIndex - 1.
- streamListIndex _ streamListIndex - 1.
- firstMoveIndex _ lastMoveIndex _ aChessMoveList startIndex - 1.
!
Item was changed:
----- Method: ChessMoveGenerator>>whitePawnCaptureAt:direction: (in category 'moves-pawns') -----
whitePawnCaptureAt: square direction: dir
| destSquare move piece |
+ destSquare := square+8+dir.
+ piece := itsPieces at: destSquare.
- destSquare _ square+8+dir.
- piece _ itsPieces at: destSquare.
piece = 0 ifFalse:[
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (move _ moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: Pawn from: square to: destSquare capture: piece.
+ piece = King ifTrue:[kingAttack := move].
- piece = King ifTrue:[kingAttack _ move].
destSquare > 56 "a promotion"
ifTrue:[self promotePawn: move].
].
"attempt an en-passant capture"
enpassantSquare = destSquare ifTrue:[
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
captureEnPassant: Pawn from: square to: destSquare.
].!
Item was changed:
----- Method: ChessMoveGenerator>>whitePawnPushAt: (in category 'moves-pawns') -----
whitePawnPushAt: square
"Pawns only move in one direction so check for which direction to use"
| destSquare move |
"Try to push this pawn"
+ destSquare := square+8.
- destSquare _ square+8.
(myPieces at: destSquare) = 0 ifFalse:[^self].
(itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (move := moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (move _ moveList at: (lastMoveIndex _ lastMoveIndex + 1))
move: Pawn from: square to: destSquare.
destSquare > 56 "a promotion (can't be double-push so get out)"
ifTrue:[^self promotePawn: move].
"Try to double-push if possible"
square <= 16 ifFalse:[^self].
+ destSquare := square+16.
- destSquare _ square+16.
(myPieces at: destSquare) = 0 ifFalse:[^self].
(itsPieces at: destSquare) = 0 ifFalse:[^self].
+ (moveList at: (lastMoveIndex := lastMoveIndex + 1))
- (moveList at: (lastMoveIndex _ lastMoveIndex + 1))
doublePush: Pawn from: square to: destSquare.!
Item was changed:
----- Method: ChessMoveList>>on:from:to: (in category 'private') -----
on: aCollection from: firstIndex to: lastIndex
+ startIndex := firstIndex.
- startIndex _ firstIndex.
^super on: aCollection from: firstIndex to: lastIndex.
!
Item was changed:
----- Method: ChessMoveList>>sort:to:using: (in category 'sorting') -----
sort: i to: j using: sorter
"Sort elements i through j of self to be nondescending according to sorter."
| di dij dj tt ij k l n |
"The prefix d means the data at that index."
+ (n := j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort."
- (n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort."
"Sort di,dj."
+ di := collection at: i.
+ dj := collection at: j.
- di _ collection at: i.
- dj _ collection at: j.
(sorter sorts: di before: dj) ifFalse:["i.e., should di precede dj?"
collection swap: i with: j.
+ tt := di. di := dj. dj := tt].
- tt _ di. di _ dj. dj _ tt].
n > 2 ifTrue:["More than two elements."
+ ij := (i + j) // 2. "ij is the midpoint of i and j."
+ dij := collection at: ij. "Sort di,dij,dj. Make dij be their median."
- ij _ (i + j) // 2. "ij is the midpoint of i and j."
- dij _ collection at: ij. "Sort di,dij,dj. Make dij be their median."
(sorter sorts: di before: dij) ifTrue:["i.e. should di precede dij?"
(sorter sorts: dij before: dj) "i.e., should dij precede dj?"
ifFalse:[collection swap: j with: ij.
+ dij := dj].
- dij _ dj].
] ifFalse:[ "i.e. di should come after dij"
collection swap: i with: ij.
+ dij := di
- dij _ di
].
n > 3 ifTrue:["More than three elements."
"Find k>i and l<j such that dk,dij,dl are in reverse order.
Swap k and l. Repeat this procedure until k and l pass each other."
+ k := i. l := j.
- k _ i. l _ j.
[
+ [l := l - 1. k <= l and: [sorter sorts: dij before: (collection at: l)]]
- [l _ l - 1. k <= l and: [sorter sorts: dij before: (collection at: l)]]
whileTrue. "i.e. while dl succeeds dij"
+ [k := k + 1. k <= l and: [sorter sorts: (collection at: k) before: dij]]
- [k _ k + 1. k <= l and: [sorter sorts: (collection at: k) before: dij]]
whileTrue. "i.e. while dij succeeds dk"
k <= l
] whileTrue:[collection swap: k with: l].
"Now l<k (either 1 or 2 less), and di through dl are all less than
or equal to dk through dj. Sort those two segments."
self sort: i to: l using: sorter.
self sort: k to: j using: sorter]].
!
Item was changed:
----- Method: ChessPlayer>>addPiece:at: (in category 'adding/removing') -----
addPiece: piece at: square
pieces at: square put: piece.
+ materialValue := materialValue + (PieceValues at: piece).
+ positionalValue := positionalValue + ((PieceCenterScores at: piece) at: square).
+ piece = Pawn ifTrue:[numPawns := numPawns + 1].
- materialValue _ materialValue + (PieceValues at: piece).
- positionalValue _ positionalValue + ((PieceCenterScores at: piece) at: square).
- piece = Pawn ifTrue:[numPawns _ numPawns + 1].
board updateHash: piece at: square from: self.
self userAgent ifNotNil:[self userAgent addedPiece: piece at: square white: self isWhitePlayer].!
Item was changed:
----- Method: ChessPlayer>>applyCastleKingSideMove: (in category 'moving') -----
applyCastleKingSideMove: move
self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook from: move sourceSquare+3 to: (castlingRookSquare := move sourceSquare+1).
- self movePiece: Rook from: move sourceSquare+3 to: (castlingRookSquare _ move sourceSquare+1).
pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
- castlingStatus _ castlingStatus bitOr: CastlingDone.!
Item was changed:
----- Method: ChessPlayer>>applyCastleQueenSideMove: (in category 'moving') -----
applyCastleQueenSideMove: move
self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.
+ self movePiece: Rook from: move sourceSquare-4 to: (castlingRookSquare := move sourceSquare-1).
- self movePiece: Rook from: move sourceSquare-4 to: (castlingRookSquare _ move sourceSquare-1).
pieces at: castlingRookSquare put: King.
+ castlingStatus := castlingStatus bitOr: CastlingDone.!
- castlingStatus _ castlingStatus bitOr: CastlingDone.!
Item was changed:
----- Method: ChessPlayer>>applyDoublePushMove: (in category 'moving') -----
applyDoublePushMove: move
+ enpassantSquare := (move sourceSquare + move destinationSquare) bitShift: -1.
- enpassantSquare _ (move sourceSquare + move destinationSquare) bitShift: -1.
"Above means: the field between start and destination"
^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was changed:
----- Method: ChessPlayer>>applyMove: (in category 'moving') -----
applyMove: move
"Apply the given move"
| action |
"Apply basic move"
+ action := #(
- action _ #(
applyNormalMove:
applyDoublePushMove:
applyEnpassantMove:
applyCastleKingSideMove:
applyCastleQueenSideMove:
applyResign:
applyStaleMate:
) at: (move moveType bitAnd: ChessMove basicMoveMask).
self perform: action with: move.
"Promote if necessary"
self applyPromotion: move.
"Maintain castling status"
self updateCastlingStatus: move.
!
Item was changed:
----- Method: ChessPlayer>>applyNormalMove: (in category 'moving') -----
applyNormalMove: move
| piece |
+ (piece := move capturedPiece) = EmptySquare
- (piece _ move capturedPiece) = EmptySquare
ifFalse:[opponent removePiece: piece at: move destinationSquare].
^self movePiece: move movingPiece from: move sourceSquare to: move destinationSquare.!
Item was changed:
----- Method: ChessPlayer>>applyPromotion: (in category 'moving') -----
applyPromotion: move
| piece |
+ piece := move promotion.
- piece _ move promotion.
piece = 0 ifFalse:[self replacePiece: move movingPiece with: piece at: move destinationSquare].!
Item was changed:
----- Method: ChessPlayer>>board: (in category 'accessing') -----
board: aBoard
+ board := aBoard!
- board _ aBoard!
Item was changed:
----- Method: ChessPlayer>>copyPlayer: (in category 'copying') -----
copyPlayer: aPlayer
"Copy all the volatile state from aPlayer"
+ castlingRookSquare := aPlayer castlingRookSquare.
+ enpassantSquare := aPlayer enpassantSquare.
+ castlingStatus := aPlayer castlingStatus.
+ materialValue := aPlayer materialValue.
+ numPawns := aPlayer numPawns.
+ positionalValue := aPlayer positionalValue.
- castlingRookSquare _ aPlayer castlingRookSquare.
- enpassantSquare _ aPlayer enpassantSquare.
- castlingStatus _ aPlayer castlingStatus.
- materialValue _ aPlayer materialValue.
- numPawns _ aPlayer numPawns.
- positionalValue _ aPlayer positionalValue.
pieces replaceFrom: 1 to: pieces size with: aPlayer pieces startingAt: 1.!
Item was changed:
----- Method: ChessPlayer>>evaluateMaterial (in category 'evaluation') -----
evaluateMaterial
"Compute the board's material balance, from the point of view of the side
player. This is an exact clone of the eval function in CHESS 4.5"
| total diff value |
self materialValue = opponent materialValue ifTrue:[^0]. "both sides are equal"
+ total := self materialValue + opponent materialValue.
+ diff := self materialValue - opponent materialValue.
+ value := (2400 min: diff) +
- total _ self materialValue + opponent materialValue.
- diff _ self materialValue - opponent materialValue.
- value _ (2400 min: diff) +
((diff * (12000 - total) * self numPawns) // (6400 * (self numPawns + 1))).
^value!
Item was changed:
----- Method: ChessPlayer>>findPossibleMoves (in category 'moves-general') -----
findPossibleMoves
"Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
| moveList moves |
+ moveList := board generator findPossibleMovesFor: self.
- moveList _ board generator findPossibleMovesFor: self.
moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
- moves _ moveList contents collect:[:move| move copy].
board generator recycleMoveList: moveList.
^moves!
Item was changed:
----- Method: ChessPlayer>>findPossibleMovesAt: (in category 'moves-general') -----
findPossibleMovesAt: square
"Find all possible moves at the given square. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
| moveList moves |
+ moveList := board generator findPossibleMovesFor: self at: square.
- moveList _ board generator findPossibleMovesFor: self at: square.
moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
- moves _ moveList contents collect:[:move| move copy].
board generator recycleMoveList: moveList.
^moves!
Item was changed:
----- Method: ChessPlayer>>findQuiescenceMoves (in category 'moves-general') -----
findQuiescenceMoves
"Find all possible moves. This method does not check if the move is legal, e.g., if the king of the player is under attack after the move. If the opponent is check mate (e.g., the king could be taken in the next move) the method returns nil. If the game is stale mate (e.g., the receiver has no move left) this method returns an empty array."
| moveList moves |
+ moveList := board generator findQuiescenceMovesFor: self.
- moveList _ board generator findQuiescenceMovesFor: self.
moveList ifNil:[^nil].
+ moves := moveList contents collect:[:move| move copy].
- moves _ moveList contents collect:[:move| move copy].
board generator recycleMoveList: moveList.
^moves!
Item was changed:
----- Method: ChessPlayer>>findValidMoves (in category 'moves-general') -----
findValidMoves
"Find all the valid moves"
| moveList |
+ moveList := self findPossibleMoves ifNil:[^nil].
- moveList _ self findPossibleMoves ifNil:[^nil].
^moveList select:[:move| self isValidMove: move].!
Item was changed:
----- Method: ChessPlayer>>findValidMovesAt: (in category 'moves-general') -----
findValidMovesAt: square
"Find all the valid moves"
| moveList |
+ moveList := (self findPossibleMovesAt: square) ifNil:[^nil].
- moveList _ (self findPossibleMovesAt: square) ifNil:[^nil].
^moveList select:[:move| self isValidMove: move].!
Item was changed:
----- Method: ChessPlayer>>initialize (in category 'initialize') -----
initialize
"ChessPlayer initialize"
+ pieces := ByteArray new: 64.
+ materialValue := 0.
+ positionalValue := 0.
+ numPawns := 0.
+ enpassantSquare := 0.
+ castlingRookSquare := 0.
+ castlingStatus := 0.!
- pieces _ ByteArray new: 64.
- materialValue _ 0.
- positionalValue _ 0.
- numPawns _ 0.
- enpassantSquare _ 0.
- castlingRookSquare _ 0.
- castlingStatus _ 0.!
Item was changed:
----- Method: ChessPlayer>>isValidMove: (in category 'testing') -----
isValidMove: move
"Is the given move actually valid for the receiver?
If the receiver's king can't be taken after applying the move, it is."
| copy |
+ copy := board copy.
- copy _ board copy.
copy nextMove: move.
^copy activePlayer findPossibleMoves notNil!
Item was changed:
----- Method: ChessPlayer>>isValidMoveFrom:to: (in category 'testing') -----
isValidMoveFrom: sourceSquare to: destSquare
| move |
+ move := (self findValidMovesAt: sourceSquare)
- move _ (self findValidMovesAt: sourceSquare)
detect:[:any| any destinationSquare = destSquare] ifNone:[nil].
^move notNil!
Item was changed:
----- Method: ChessPlayer>>movePiece:from:to: (in category 'adding/removing') -----
movePiece: piece from: sourceSquare to: destSquare
| score |
+ score := PieceCenterScores at: piece.
+ positionalValue := positionalValue - (score at: sourceSquare).
+ positionalValue := positionalValue + (score at: destSquare).
- score _ PieceCenterScores at: piece.
- positionalValue _ positionalValue - (score at: sourceSquare).
- positionalValue _ positionalValue + (score at: destSquare).
pieces at: sourceSquare put: 0.
pieces at: destSquare put: piece.
board updateHash: piece at: sourceSquare from: self.
board updateHash: piece at: destSquare from: self.
self userAgent ifNotNil:[self userAgent movedPiece: piece from: sourceSquare to: destSquare].!
Item was changed:
----- Method: ChessPlayer>>opponent: (in category 'accessing') -----
opponent: aPlayer
+ opponent := aPlayer!
- opponent _ aPlayer!
Item was changed:
----- Method: ChessPlayer>>postCopy (in category 'copying') -----
postCopy
+ pieces := pieces clone.!
- pieces _ pieces clone.!
Item was changed:
----- Method: ChessPlayer>>prepareNextMove (in category 'initialize') -----
prepareNextMove
"Clear enpassant square and reset any pending extra kings"
+ enpassantSquare := 0.
- enpassantSquare _ 0.
castlingRookSquare = 0 ifFalse:[pieces at: castlingRookSquare put: Rook].
+ castlingRookSquare := 0.
- castlingRookSquare _ 0.
!
Item was changed:
----- Method: ChessPlayer>>removePiece:at: (in category 'adding/removing') -----
removePiece: piece at: square
pieces at: square put: 0.
+ materialValue := materialValue - (PieceValues at: piece).
+ positionalValue := positionalValue - ((PieceCenterScores at: piece) at: square).
+ piece = Pawn ifTrue:[numPawns := numPawns - 1].
- materialValue _ materialValue - (PieceValues at: piece).
- positionalValue _ positionalValue - ((PieceCenterScores at: piece) at: square).
- piece = Pawn ifTrue:[numPawns _ numPawns - 1].
board updateHash: piece at: square from: self.
self userAgent ifNotNil:[self userAgent removedPiece: piece at: square].!
Item was changed:
----- Method: ChessPlayer>>replacePiece:with:at: (in category 'adding/removing') -----
replacePiece: oldPiece with: newPiece at: square
pieces at: square put: newPiece.
+ materialValue := materialValue - (PieceValues at: oldPiece) + (PieceValues at: newPiece).
+ positionalValue := positionalValue - ((PieceCenterScores at: oldPiece) at: square).
+ positionalValue := positionalValue + ((PieceCenterScores at: newPiece) at: square).
- materialValue _ materialValue - (PieceValues at: oldPiece) + (PieceValues at: newPiece).
- positionalValue _ positionalValue - ((PieceCenterScores at: oldPiece) at: square).
- positionalValue _ positionalValue + ((PieceCenterScores at: newPiece) at: square).
+ oldPiece = Pawn ifTrue:[numPawns := numPawns - 1].
+ newPiece = Pawn ifTrue:[numPawns := numPawns + 1].
- oldPiece = Pawn ifTrue:[numPawns _ numPawns - 1].
- newPiece = Pawn ifTrue:[numPawns _ numPawns + 1].
board updateHash: oldPiece at: square from: self.
board updateHash: newPiece at: square from: self.
self userAgent ifNotNil:[self userAgent replacedPiece: oldPiece with: newPiece at: square white: self isWhitePlayer].!
Item was changed:
----- Method: ChessPlayer>>undoDoublePushMove: (in category 'undo') -----
undoDoublePushMove: move
+ enpassantSquare := 0.
- enpassantSquare _ 0.
self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.!
Item was changed:
----- Method: ChessPlayer>>undoMove: (in category 'undo') -----
undoMove: move
"Undo the given move"
| action |
self undoPromotion: move.
"Apply basic move"
+ action := #(
- action _ #(
undoNormalMove:
undoDoublePushMove:
undoEnpassantMove:
undoCastleKingSideMove:
undoCastleQueenSideMove:
undoResign:
undoStaleMate:
) at: (move moveType bitAnd: ChessMove basicMoveMask).
self perform: action with: move.!
Item was changed:
----- Method: ChessPlayer>>undoNormalMove: (in category 'undo') -----
undoNormalMove: move
| piece |
self movePiece: move movingPiece from: move destinationSquare to: move sourceSquare.
+ (piece := move capturedPiece) = EmptySquare
- (piece _ move capturedPiece) = EmptySquare
ifFalse:[opponent addPiece: piece at: move destinationSquare].
!
Item was changed:
----- Method: ChessPlayer>>undoPromotion: (in category 'undo') -----
undoPromotion: move
| piece |
+ piece := move promotion.
- piece _ move promotion.
piece = 0 ifFalse:[self replacePiece: piece with: move movingPiece at: move destinationSquare].!
Item was changed:
----- Method: ChessPlayer>>updateCastlingStatus: (in category 'moving') -----
updateCastlingStatus: move
"Cannot castle when king has moved"
(move movingPiece = King)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableAll].
- ifTrue:[^castlingStatus _ castlingStatus bitOr: CastlingDisableAll].
"See if a rook has moved"
(move movingPiece = Rook) ifFalse:[^self].
self isWhitePlayer ifTrue:[
(move sourceSquare = 1)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
- ifTrue:[^castlingStatus _ castlingStatus bitOr: CastlingDisableQueenSide].
(move sourceSquare = 8)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
- ifTrue:[^castlingStatus _ castlingStatus bitOr: CastlingDisableKingSide].
] ifFalse:[
(move sourceSquare = 57)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableQueenSide].
- ifTrue:[^castlingStatus _ castlingStatus bitOr: CastlingDisableQueenSide].
(move sourceSquare = 64)
+ ifTrue:[^castlingStatus := castlingStatus bitOr: CastlingDisableKingSide].
- ifTrue:[^castlingStatus _ castlingStatus bitOr: CastlingDisableKingSide].
].!
Item was changed:
----- Method: ChessPlayerAI class>>initialize (in category 'class initialization') -----
initialize
"ChessPlayerAI initialize"
+ AlphaBetaGiveUp := -29990.
+ AlphaBetaIllegal := -31000.
+ AlphaBetaMaxVal := 30000.
+ AlphaBetaMinVal := -30000.
+ ValueAccurate := 2.
+ ValueBoundary := 4.
+ ValueLowerBound := 4.
+ ValueUpperBound := 5.
+ ValueThreshold := 200.!
- AlphaBetaGiveUp _ -29990.
- AlphaBetaIllegal _ -31000.
- AlphaBetaMaxVal _ 30000.
- AlphaBetaMinVal _ -30000.
- ValueAccurate _ 2.
- ValueBoundary _ 4.
- ValueLowerBound _ 4.
- ValueUpperBound _ 5.
- ValueThreshold _ 200.!
Item was changed:
----- Method: ChessPlayerAI>>activePlayer: (in category 'initialize') -----
activePlayer: aPlayer
+ player := aPlayer.
+ board := player board.
+ generator := board generator.
- player _ aPlayer.
- board _ player board.
- generator _ board generator.
self reset.!
Item was changed:
----- Method: ChessPlayerAI>>initialize (in category 'initialize') -----
initialize
+ historyTable := ChessHistoryTable new.
- historyTable _ ChessHistoryTable new.
"NOTE: transposition table is initialized only when we make the first move. It costs a little to do all the entries and the garbage collections so we do it only when we *really* need it."
+ transTable := nil.
+ random := Random new.
+ nodesVisited := ttHits := alphaBetaCuts := stamp := 0.
+ variations := Array new: 11.
- transTable _ nil.
- random _ Random new.
- nodesVisited _ ttHits _ alphaBetaCuts _ stamp _ 0.
- variations _ Array new: 11.
1 to: variations size do:[:i|
variations at: i put: (Array new: variations size).
(variations at: i) atAllPut: 0].
+ bestVariation := Array new: variations size.
- bestVariation _ Array new: variations size.
bestVariation atAllPut: 0.
+ activeVariation := Array new: variations size.
- activeVariation _ Array new: variations size.
activeVariation atAllPut: 0.
self reset.!
Item was changed:
----- Method: ChessPlayerAI>>initializeTranspositionTable (in category 'initialize') -----
initializeTranspositionTable
"Initialize the transposition table. Note: For now we only use 64k entries since they're somewhat space intensive. If we should get a serious speedup at some point we may want to increase the transposition table - 256k seems like a good idea; but right now 256k entries cost us roughly 10MB of space. So we use only 64k entries (2.5MB of space).
If you have doubts about the size of the transition table (e.g., if you think it's too small or too big) then modify the value below and have a look at ChessTranspositionTable>>clear which can print out some valuable statistics.
"
+ transTable := ChessTranspositionTable new: 16. "1 << 16 entries"!
- transTable _ ChessTranspositionTable new: 16. "1 << 16 entries"!
Item was changed:
----- Method: ChessPlayerAI>>negaScout:depth:alpha:beta: (in category 'searching') -----
negaScout: theBoard depth: depth alpha: initialAlpha beta: initialBeta
"Modified version to return the move rather than the score"
| move score alpha bestScore moveList newBoard beta goodMove a b notFirst |
self
assert: [initialAlpha < initialBeta].
ply < 10
ifTrue: [(variations at: ply + 1)
at: 1
put: 0].
+ ply := 0.
+ alpha := initialAlpha.
+ beta := initialBeta.
+ bestScore := AlphaBetaMinVal.
- ply _ 0.
- alpha _ initialAlpha.
- beta _ initialBeta.
- bestScore _ AlphaBetaMinVal.
"Generate new moves"
+ moveList := generator findPossibleMovesFor: theBoard activePlayer.
- moveList _ generator findPossibleMovesFor: theBoard activePlayer.
moveList
ifNil: [^ nil].
moveList size = 0
ifTrue: [generator recycleMoveList: moveList.
^ nil].
"Sort move list according to history heuristics"
moveList sortUsing: historyTable.
"And search"
+ a := alpha.
+ b := beta.
+ notFirst := false.
+ [(move := moveList next) isNil]
+ whileFalse: [newBoard := (boardList at: ply + 1)
- a _ alpha.
- b _ beta.
- notFirst _ false.
- [(move _ moveList next) isNil]
- whileFalse: [newBoard _ (boardList at: ply + 1)
copyBoard: theBoard.
newBoard nextMove: move.
"Search recursively"
"Search recursively"
+ ply := ply + 1.
+ score := 0
- ply _ ply + 1.
- score _ 0
- (self
ngSearch: newBoard
depth: depth - 1
alpha: 0 - b
beta: 0 - a).
(notFirst
and: [score > a
and: [score < beta
and: [depth > 1]]])
+ ifTrue: [score := 0
- ifTrue: [score _ 0
- (self
ngSearch: newBoard
depth: depth - 1
alpha: 0 - beta
beta: 0 - score)].
+ notFirst := true.
+ ply := ply - 1.
- notFirst _ true.
- ply _ ply - 1.
stopThinking
ifTrue: [generator recycleMoveList: moveList.
^ move].
score = AlphaBetaIllegal
ifFalse: [score > bestScore
ifTrue: [ply < 10
ifTrue: [self copyVariation: move].
+ goodMove := move copy.
- goodMove _ move copy.
goodMove value: score.
activeVariation
replaceFrom: 1
to: activeVariation size
with: variations first
startingAt: 1.
+ bestScore := score].
- bestScore _ score].
"See if we can cut off the search"
score > a
+ ifTrue: [a := score.
- ifTrue: [a _ score.
a >= beta
ifTrue: [transTable
storeBoard: theBoard
value: score
type: (ValueBoundary
bitOr: (ply bitAnd: 1))
depth: depth
stamp: stamp.
historyTable addMove: move.
+ alphaBetaCuts := alphaBetaCuts + 1.
- alphaBetaCuts _ alphaBetaCuts + 1.
generator recycleMoveList: moveList.
^ goodMove]].
+ b := a + 1]].
- b _ a + 1]].
transTable
storeBoard: theBoard
value: bestScore
type: (ValueAccurate
bitOr: (ply bitAnd: 1))
depth: depth
stamp: stamp.
generator recycleMoveList: moveList.
^ goodMove!
Item was changed:
----- Method: ChessPlayerAI>>reset: (in category 'initialize') -----
reset: aBoard
self reset.
boardList ifNil:[
+ boardList := Array new: 100.
- boardList _ Array new: 100.
1 to: boardList size do:[:i| boardList at: i put: (aBoard copy userAgent: nil)].
+ boardListIndex := 0].
+ board := aBoard.!
- boardListIndex _ 0].
- board _ aBoard.!
Item was changed:
----- Method: ChessPlayerAI>>statusString (in category 'nil') -----
statusString
| av count |
^String streamContents:[:s|
(myMove == #none or:[myMove == nil]) ifFalse:[
s print: myMove value * 0.01; space.
].
+ av := bestVariation.
+ count := av at: 1.
- av _ bestVariation.
- count _ av at: 1.
count > 0 ifFalse:[
+ av := activeVariation.
+ count := av at: 1].
- av _ activeVariation.
- count _ av at: 1].
count > 0 ifFalse:[
s nextPutAll:'***'.
+ av := variations at: 1.
+ count := av at: 1.
+ count > 3 ifTrue:[count := 3]].
- av _ variations at: 1.
- count _ av at: 1.
- count > 3 ifTrue:[count _ 3]].
2 to: count + 1 do:[:index|
s nextPutAll: (ChessMove decodeFrom: (av at: index)) moveString.
s space].
s nextPut:$[.
s print: nodesVisited.
" s nextPut:$|.
s print: ttHits.
s nextPut: $|.
s print: alphaBetaCuts.
" s nextPut:$].
].!
Item was changed:
----- Method: ChessTTEntry>>clear (in category 'accessing') -----
clear
+ value := valueType := timeStamp := depth := -1.!
- value _ valueType _ timeStamp _ depth _ -1.!
Item was changed:
----- Method: ChessTTEntry>>depth: (in category 'accessing') -----
depth: aNumber
+ depth := aNumber!
- depth _ aNumber!
Item was changed:
----- Method: ChessTTEntry>>hashLock: (in category 'accessing') -----
hashLock: aNumber
+ hashLock := aNumber!
- hashLock _ aNumber!
Item was changed:
----- Method: ChessTTEntry>>timeStamp: (in category 'accessing') -----
timeStamp: aNumber
+ timeStamp := aNumber!
- timeStamp _ aNumber!
Item was changed:
----- Method: ChessTTEntry>>value: (in category 'accessing') -----
value: newValue
+ value := newValue!
- value _ newValue!
Item was changed:
----- Method: ChessTTEntry>>valueType: (in category 'accessing') -----
valueType: newType
+ valueType := newType!
- valueType _ newType!
Item was changed:
----- Method: ChessTranspositionTable>>initialize: (in category 'initialize') -----
initialize: nBits
"Initialize the receiver using 1<<nBits entries. See also ChessPlayerAI>>initializeTranspositionTable."
| entry |
+ array := Array new: 1 << nBits.
+ used := ReadWriteStream on: (Array new: 50000). "<- will grow if not sufficient!!"
+ entry := ChessTTEntry new clear.
- array _ Array new: 1 << nBits.
- used _ ReadWriteStream on: (Array new: 50000). "<- will grow if not sufficient!!"
- entry _ ChessTTEntry new clear.
1 to: array size do:[:i| array at: i put: entry clone].
+ collisions := 0.
- collisions _ 0.
Smalltalk garbageCollect. "We *really* want them old here"!
Item was changed:
----- Method: ChessTranspositionTable>>lookupBoard: (in category 'lookup') -----
lookupBoard: aBoard
| key entry |
+ key := aBoard hashKey bitAnd: array size - 1.
+ entry := array at: key + 1.
- key _ aBoard hashKey bitAnd: array size - 1.
- entry _ array at: key + 1.
entry ifNil:[^nil].
entry valueType = -1 ifTrue:[^nil].
entry hashLock = aBoard hashLock ifFalse:[^nil].
^entry!
Item was changed:
----- Method: ChessTranspositionTable>>storeBoard:value:type:depth:stamp: (in category 'initialize') -----
storeBoard: aBoard value: value type: valueType depth: depth stamp: timeStamp
| key entry |
+ key := aBoard hashKey bitAnd: array size - 1.
+ entry := array at: key + 1.
- key _ aBoard hashKey bitAnd: array size - 1.
- entry _ array at: key + 1.
entry valueType = -1
ifTrue:[used nextPut: entry]
+ ifFalse:[entry hashLock = aBoard hashLock ifFalse:[collisions := collisions + 1]].
- ifFalse:[entry hashLock = aBoard hashLock ifFalse:[collisions _ collisions + 1]].
(entry valueType = -1
or:[entry depth <= depth
or:[entry timeStamp < timeStamp]]) ifFalse:[^self].
entry hashLock: aBoard hashLock.
entry value: value.
entry valueType: valueType.
entry depth: depth.
entry timeStamp: timeStamp.
!
Item was changed:
----- Method: ChineseCheckerPiece>>setBoard:loc: (in category 'accessing') -----
setBoard: aBoard loc: aBoardLoc
+ myBoard := aBoard.
+ boardLoc := aBoardLoc!
- myBoard _ aBoard.
- boardLoc _ aBoardLoc!
Item was changed:
----- Method: ChineseCheckers>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aPiece event: evt
| dropLoc |
+ dropLoc := self boardLocAt: evt cursorPoint.
- dropLoc _ self boardLocAt: evt cursorPoint.
dropLoc = aPiece boardLoc ifTrue: "Null move"
[^ aPiece rejectDropMorphEvent: evt].
+ (plannedMove := (self allMovesFrom: aPiece boardLoc)
- (plannedMove _ (self allMovesFrom: aPiece boardLoc)
detect: [:move | move last = dropLoc]
ifNone: [nil])
ifNil: [^ aPiece rejectDropMorphEvent: evt. "Not a valid move"].
super acceptDroppingMorph: aPiece event: evt.
+ movePhase := 1. "Start the animation if any."
- movePhase _ 1. "Start the animation if any."
!
Item was changed:
----- Method: ChineseCheckers>>animateMoves (in category 'menu') -----
animateMoves
+ animateMoves := true!
- animateMoves _ true!
Item was changed:
----- Method: ChineseCheckers>>boardLocAt: (in category 'board geometry') -----
boardLocAt: cellPoint
| dx dy row col |
+ dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
+ row := (cellPoint y - self position y) // dy + 1.
+ col := (cellPoint x - self position x) / (dx/2.0) + 16 - row // 2.
- dx _ self width/15.0. dy _ dx * 0.8660254037844385 "(Float pi / 3) sin".
- row _ (cellPoint y - self position y) // dy + 1.
- col _ (cellPoint x - self position x) / (dx/2.0) + 16 - row // 2.
^ row @ col!
Item was changed:
----- Method: ChineseCheckers>>cellPointAt: (in category 'board geometry') -----
cellPointAt: boardLoc
| dx dy row col |
+ dx := self width/15.0. dy := dx * 0.8660254037844385 "(Float pi / 3) sin".
+ row := boardLoc x.
+ col := boardLoc y.
- dx _ self width/15.0. dy _ dx * 0.8660254037844385 "(Float pi / 3) sin".
- row _ boardLoc x.
- col _ boardLoc y.
^ self position + ((col*2+row-16*dx//2)@(row-1*dy)) asIntegerPoint!
Item was changed:
----- Method: ChineseCheckers>>checkDoneAfter: (in category 'moves') -----
checkDoneAfter: move
| team locsAfterMove |
(team := self at: move first) = 0 ifTrue: [^ false].
+ (locsAfterMove := (teams at: team) copy) replaceAll: move first with: move last.
- (locsAfterMove _ (teams at: team) copy) replaceAll: move first with: move last.
^ self testDone: locsAfterMove for: team!
Item was changed:
----- Method: ChineseCheckers>>distFrom:to: (in category 'board geometry') -----
distFrom: a to: b
"The six possible moves are: 1 at 0, 1@ -1, 0 at 1, 0@ -1, -1 at 0, -1 at 1."
| dx dy |
+ dx := b x - a x.
+ dy := b y - a y.
- dx _ b x - a x.
- dy _ b y - a y.
dx abs >= dy abs
ifTrue: ["Major change is in x-coord..."
dx >= 0
ifTrue: [(dy between: (0-dx) and: 0)
ifTrue: [^ dx "no lateral motion"].
^ dx + ((0-dx) - dy max: dy - 0) "added lateral dist"]
ifFalse: ["Reverse sign and rerun same code"
^ self distFrom: b to: a]]
ifFalse: ["Transpose and re-run same code"
^ self distFrom: a transposed to: b transposed]!
Item was changed:
----- Method: ChineseCheckers>>dontAnimateMoves (in category 'menu') -----
dontAnimateMoves
+ animateMoves := false!
- animateMoves _ false!
Item was changed:
----- Method: ChineseCheckers>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| row1 row2 offset dotExtent |
super drawOn: aCanvas. "Draw square board"
"Only draw rows in the clipping region"
+ dotExtent := (self width//25) asPoint.
+ offset := self pieceSize - dotExtent + 1 // 2. "Offset of smaller dots rel to larger"
+ row1 := (self boardLocAt: aCanvas clipRect topLeft) x max: 1.
+ row2 := (self boardLocAt: aCanvas clipRect bottomRight) x min: board size.
- dotExtent _ (self width//25) asPoint.
- offset _ self pieceSize - dotExtent + 1 // 2. "Offset of smaller dots rel to larger"
- row1 _ (self boardLocAt: aCanvas clipRect topLeft) x max: 1.
- row2 _ (self boardLocAt: aCanvas clipRect bottomRight) x min: board size.
row1 to: row2 do:
[:row | (board at: row) doWithIndex:
[:cell :i | cell ifNotNil:
[aCanvas fillOval: ((self cellPointAt: (row at i)) + offset extent: dotExtent)
color: (colors at: cell+1)]]]!
Item was changed:
----- Method: ChineseCheckers>>endGameFor: (in category 'moves') -----
endGameFor: team
"Return true if we are in the end game (all players within 1 of home triangle)."
| goalLoc |
+ goalLoc := homes atWrap: team+3. "Farthest cell across the board"
- goalLoc _ homes atWrap: team+3. "Farthest cell across the board"
(teams at: team)
do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 4 ifTrue: [^ false]].
^ true!
Item was changed:
----- Method: ChineseCheckers>>extent: (in category 'geometry') -----
extent: newExtent
| extraY |
+ extraY := (newExtent x / 15.0 * 1.25) asInteger.
- extraY _ (newExtent x / 15.0 * 1.25) asInteger.
super extent: (newExtent x) @ (newExtent x + extraY).
self submorphsDo:
[:m | (m isKindOf: ChineseCheckerPiece) ifTrue:
[m position: (self cellPointAt: m boardLoc); extent: self pieceSize]]!
Item was changed:
----- Method: ChineseCheckers>>initialize (in category 'initialization') -----
initialize
"Default creation is for one person against Squeak."
super initialize.
""
self extent: 382 @ 413.
+ animateMoves := true.
- animateMoves _ true.
self teams: #(2 5 ) autoPlay: {false. true}!
Item was changed:
----- Method: ChineseCheckers>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
"Default creation is for one person against Squeak."
super initializeToStandAlone.
self extent: 382 at 413.
self color: (Color r: 0.6 g: 0.4 b: 0.0).
self borderWidth: 2.
+ animateMoves := true.
- animateMoves _ true.
self teams: #(2 5) autoPlay: {false. true}.
!
Item was changed:
----- Method: ChineseCheckers>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| menu |
evt yellowButtonPressed ifFalse: [^ self].
+ menu := MenuMorph new defaultTarget: self.
- menu _ MenuMorph new defaultTarget: self.
self addMenuItemsTo: menu hand: evt hand.
menu popUpEvent: evt in: self world.
!
Item was changed:
----- Method: ChineseCheckers>>newGame (in category 'menu') -----
newGame
"Reset the board, with same teams."
| teamNumbers |
+ teamNumbers := (1 to: 6) reject: [:i | (teams at: i) isEmpty].
- teamNumbers _ (1 to: 6) reject: [:i | (teams at: i) isEmpty].
self teams: teamNumbers
autoPlay: (teamNumbers collect: [:i | autoPlay at: i]).
!
Item was changed:
----- Method: ChineseCheckers>>nextTurn (in category 'game sequence') -----
nextTurn
(self testDone: (teams at: whoseMove) for: whoseMove) ifTrue:
[(self pieceAt: self turnIndicatorLoc) extent: self width asPoint//6; borderWidth: 2.
+ ^ whoseMove := 0. "Game over."].
- ^ whoseMove _ 0. "Game over."].
+ [whoseMove := whoseMove\\6 + 1.
- [whoseMove _ whoseMove\\6 + 1.
(teams at: whoseMove) isEmpty] "Turn passes to the next player"
whileTrue: [].
(self pieceAt: self turnIndicatorLoc) color: (colors at: whoseMove+1)!
Item was changed:
----- Method: ChineseCheckers>>reset (in category 'menu') -----
reset
"Reset the board, choosing anew how many teams."
| nPlayers nHumans |
+ nPlayers := (SelectionMenu
- nPlayers _ (SelectionMenu
selections: (1 to: 6))
startUpWithCaption: 'How many players?' translated.
+ nPlayers ifNil: [nPlayers := 2].
+ nHumans := (SelectionMenu
- nPlayers ifNil: [nPlayers _ 2].
- nHumans _ (SelectionMenu
selections: (0 to: nPlayers))
startUpWithCaption: 'How many humans?' translated.
+ nHumans ifNil: [nHumans := 1].
- nHumans ifNil: [nHumans _ 1].
self teams: (#((1) (2 5) (2 4 6) (1 2 4 5) (1 2 3 4 6) (1 2 3 4 5 6)) at: nPlayers)
autoPlay: ((1 to: nPlayers) collect: [:i | i > nHumans]).
!
Item was changed:
----- Method: ChineseCheckers>>score:for: (in category 'moves') -----
score: move for: team
"Return the decrease in distance toward this team's goal"
| goal closerToGoal wasBack nowBack |
+ goal := homes atWrap: team+3.
+ wasBack := self distFrom: move first to: goal.
+ nowBack := self distFrom: move last to: goal.
+ closerToGoal := wasBack - nowBack.
- goal _ homes atWrap: team+3.
- wasBack _ self distFrom: move first to: goal.
- nowBack _ self distFrom: move last to: goal.
- closerToGoal _ wasBack - nowBack.
closerToGoal < -1 ifTrue: [^ -99]. "Quick rejection if move backward more than 1"
(nowBack <= 3 and: [self checkDoneAfter: move]) ifTrue: [^ 999].
"Reward closerToGoal, but add bias to move those left far behind."
^ (closerToGoal*5) + wasBack!
Item was changed:
----- Method: ChineseCheckers>>showNextMoveSegment (in category 'game sequence') -----
showNextMoveSegment
"Display the current move in progress. Starts with movePhase = 1.
Increments movePhase at each tick. Ends by setting movePhase to 0."
| dot p1 p2 delta secondPhase line |
+ delta := self width//40.
- delta _ self width//40.
movePhase <= plannedMove size
ifTrue:
["First we trace the move with dots and lines..."
+ movePhase = 1 ifTrue: [pathMorphs := OrderedCollection new].
+ p1 := self cellPointAt: (plannedMove at: movePhase).
+ dot := (ImageMorph new image: (Form dotOfSize: 7)) position: p1 + delta - (7//2).
- movePhase = 1 ifTrue: [pathMorphs _ OrderedCollection new].
- p1 _ self cellPointAt: (plannedMove at: movePhase).
- dot _ (ImageMorph new image: (Form dotOfSize: 7)) position: p1 + delta - (7//2).
self addMorph: dot. pathMorphs addLast: dot.
movePhase > 1 ifTrue:
+ [p2 := self cellPointAt: (plannedMove at: movePhase-1).
+ line := PolygonMorph vertices: {p2 + delta. p1 + delta} color: Color black
- [p2 _ self cellPointAt: (plannedMove at: movePhase-1).
- line _ PolygonMorph vertices: {p2 + delta. p1 + delta} color: Color black
borderWidth: 3 borderColor: Color black.
self addMorph: line. pathMorphs addLast: line]]
ifFalse:
["...then we erase the path while moving the piece."
+ secondPhase := movePhase - plannedMove size.
- secondPhase _ movePhase - plannedMove size.
pathMorphs removeFirst delete.
secondPhase > 1 ifTrue:
[pathMorphs removeFirst delete.
self makeMove: {plannedMove at: secondPhase - 1. plannedMove at: secondPhase}.
(self pieceAt: (plannedMove at: secondPhase - 1))
position: (self cellPointAt: (plannedMove at: secondPhase));
setBoard: self loc: (plannedMove at: secondPhase).
self changed]].
+ (movePhase := movePhase + 1) > (plannedMove size * 2)
+ ifTrue: [movePhase := 0 "End of animated move"].
- (movePhase _ movePhase + 1) > (plannedMove size * 2)
- ifTrue: [movePhase _ 0 "End of animated move"].
!
Item was changed:
----- Method: ChineseCheckers>>teams:autoPlay: (in category 'initialization') -----
teams: teamsPlaying autoPlay: ifAuto
"Initialize board, teams, steps, jumps"
| p q teamInPlay |
+ colors := (#(gray) , #(red green blue cyan magenta yellow white) shuffled)
- colors _ (#(gray) , #(red green blue cyan magenta yellow white) shuffled)
collect: [:c | Color perform: c]. "New set of colors each time."
self removeAllMorphs. "eg, from previous game."
board := (1 to: 19) collect: [:i | Array new: 19].
sixDeltas := {0 at 1. -1 at 1. -1 at 0. 0@ -1. 1@ -1. 1 at 0}.
homes := {14 at 2. 18 at 6. 14 at 14. 6 at 18. 2 at 14. 6 at 6}.
teams := (1 to: 6) collect: [:i | OrderedCollection new].
autoPlay := (1 to: 6) collect: [:i | false].
1 to: 6 do:
[:team | p:= homes at: team.
(teamInPlay := teamsPlaying includes: team) ifTrue:
[autoPlay at: team put: (ifAuto at: (teamsPlaying indexOf: team))].
"Place empty cells in rhombus extending out from each
home, and occupied cells in active home triangles."
1 to: 5 do: [:i | q := p.
1 to: 5 do: [:j |
(teamInPlay and: [j <= (5 - i)])
ifTrue: [self at: q put: team.
(teams at: team) add: q.
self addMorph:
((ChineseCheckerPiece
newBounds: ((self cellPointAt: q) extent: self pieceSize)
color: (colors at: team+1))
setBoard: self loc: q)]
ifFalse: [self at: q put: 0].
q := q + (sixDeltas at: team). "right,forward"].
p := p + (sixDeltas atWrap: team+1). "left,forward"].
teams at: team put: (teams at: team) asArray].
+ whoseMove := teamsPlaying first.
- whoseMove _ teamsPlaying first.
self addMorph:
((ChineseCheckerPiece
newBounds: ((self cellPointAt: self turnIndicatorLoc) extent: self pieceSize)
color: (colors at: whoseMove+1))
setBoard: self loc: self turnIndicatorLoc).
+ plannedMove := nil.
- plannedMove _ nil.
self changed!
Item was changed:
----- Method: ChineseCheckers>>testDone:for: (in category 'moves') -----
testDone: teamLocs for: team
"Return true if we are done (all players in home triangle)."
| goalLoc |
+ goalLoc := homes atWrap: team+3.
- goalLoc _ homes atWrap: team+3.
teamLocs
do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 3 ifTrue: [^ false]].
^ true!
Item was changed:
----- Method: CipherPanel class>>encode: (in category 'as yet unclassified') -----
encode: aString
"CipherPanel encode: 'Now is the time for all good men to come to the aid of their country.'"
| dict repeat |
+ dict := Dictionary new.
+ repeat := true.
- dict _ Dictionary new.
- repeat _ true.
[repeat] whileTrue:
+ [repeat := false.
- [repeat _ false.
($A to: $Z) with: ($A to: $Z) shuffled do:
+ [:a :b | a = b ifTrue: [repeat := true].
- [:a :b | a = b ifTrue: [repeat _ true].
dict at: a put: b]].
^ aString asUppercase collect: [:a | dict at: a ifAbsent: [a]]!
Item was changed:
----- Method: CipherPanel>>cipherStats (in category 'menu') -----
cipherStats
| letterCounts digraphs d digraphCounts |
+ letterCounts := (quote copyWithout: Character space) asBag sortedCounts.
+ digraphs := Bag new.
- letterCounts _ (quote copyWithout: Character space) asBag sortedCounts.
- digraphs _ Bag new.
quote withIndexDo:
[:c :i |
i < quote size ifTrue:
+ [d := quote at: i+1.
- [d _ quote at: i+1.
(c ~= Character space and: [d ~= Character space]) ifTrue:
[digraphs add: (String with: c with: d)]]].
+ digraphCounts := digraphs sortedCounts.
- digraphCounts _ digraphs sortedCounts.
^ String streamContents:
[:strm |
1 to: 10 do:
[:i |
strm cr; tab; nextPut: (letterCounts at: i) value.
strm tab; print: (letterCounts at: i) key.
(digraphCounts at: i) key > 1 ifTrue:
[strm tab; tab; tab; nextPutAll: (digraphCounts at: i) value.
strm tab; print: (digraphCounts at: i) key]]]!
Item was changed:
----- Method: CipherPanel>>extent: (in category 'geometry') -----
extent: newExtent
"Lay out with word wrap, alternating bewteen decoded and encoded lines."
"Currently not tolerant of narrow (less than a word) margins"
| w h relLoc topLeft thisWord i m corner row firstWord |
self removeAllMorphs.
+ w := originalMorphs first width - 1. h := originalMorphs first height * 2 + 10.
+ topLeft := self position + self borderWidth + (0 at 10).
+ thisWord := OrderedCollection new.
+ i := 1. firstWord := true. relLoc := 0 at 0. corner := topLeft.
- w _ originalMorphs first width - 1. h _ originalMorphs first height * 2 + 10.
- topLeft _ self position + self borderWidth + (0 at 10).
- thisWord _ OrderedCollection new.
- i _ 1. firstWord _ true. relLoc _ 0 at 0. corner _ topLeft.
[i <= originalMorphs size] whileTrue:
+ [m := originalMorphs at: i.
- [m _ originalMorphs at: i.
thisWord addLast: ((decodingMorphs at: i) position: topLeft + relLoc).
thisWord addLast: (m position: topLeft + relLoc + (0 at m height)).
(m letter = Character space or: [i = originalMorphs size])
ifTrue: [self addAllMorphs: thisWord.
+ corner := corner max: thisWord last bounds bottomRight.
+ thisWord reset. firstWord := false].
+ relLoc := relLoc + (w at 0).
- corner _ corner max: thisWord last bounds bottomRight.
- thisWord reset. firstWord _ false].
- relLoc _ relLoc + (w at 0).
(relLoc x + w) > newExtent x
ifTrue: [firstWord
ifTrue: ["No spaces -- force a line break"
thisWord removeLast; removeLast.
self addAllMorphs: thisWord.
+ corner := corner max: thisWord last bounds bottomRight]
+ ifFalse: [i := i - (thisWord size//2) + 1].
+ thisWord reset. firstWord := true.
+ relLoc := 0@(relLoc y + h)]
+ ifFalse: [i := i + 1]].
+ row := self buttonRow. row fullBounds.
- corner _ corner max: thisWord last bounds bottomRight]
- ifFalse: [i _ i - (thisWord size//2) + 1].
- thisWord reset. firstWord _ true.
- relLoc _ 0@(relLoc y + h)]
- ifFalse: [i _ i + 1]].
- row _ self buttonRow. row fullBounds.
self addMorph: row.
super extent: (corner - topLeft) + (self borderWidth * 2) + (0 at row height+10).
row align: row bounds bottomCenter with: self bounds bottomCenter - (0 at 2).!
Item was changed:
----- Method: CipherPanel>>keyCharacter:atIndex:nextFocus: (in category 'defaults') -----
keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus
| encodedLetter |
+ encodedLetter := quote at: indexInQuote.
- encodedLetter _ quote at: indexInQuote.
originalMorphs with: decodingMorphs do:
[:e :d | e letter = encodedLetter ifTrue: [d setLetter: aLetter color: Color red]].
!
Item was changed:
----- Method: Class>>addInstVarNames: (in category '*Etoys-Squeakland-instance variables') -----
addInstVarNames: aCollection
| newInstVarString |
+ newInstVarString := self instanceVariablesString.
- newInstVarString _ self instanceVariablesString.
aCollection do:
+ [:varName | (self instVarNames includes: varName) ifFalse: [newInstVarString := newInstVarString , ' ' , varName]].
- [:varName | (self instVarNames includes: varName) ifFalse: [newInstVarString _ newInstVarString , ' ' , varName]].
^(ClassBuilder new)
name: self name
inEnvironment: self environment
subclassOf: superclass
type: self typeOfClass
instanceVariableNames: newInstVarString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category
!
Item was changed:
----- Method: Class>>removeInstVarNames: (in category '*Etoys-Squeakland-instance variables') -----
removeInstVarNames: aCollection
| newInstVarString |
aCollection do: [:aString |
(self instVarNames includes: aString)
ifFalse: [self error: aString , ' is not one of my instance variables'].
].
+ newInstVarString := ''.
- newInstVarString _ ''.
(self instVarNames copyWithoutAll: aCollection) do:
+ [:varName | newInstVarString := newInstVarString , ' ' , varName].
- [:varName | newInstVarString _ newInstVarString , ' ' , varName].
^(ClassBuilder new)
name: self name
inEnvironment: self environment
subclassOf: superclass
type: self typeOfClass
instanceVariableNames: newInstVarString
classVariableNames: self classVariablesString
poolDictionaries: self sharedPoolsString
category: self category
!
Item was changed:
----- Method: ClassDescription>>compile:classified:withStamp:notifying:logSource:for: (in category '*Etoys-Squeakland-compiling') -----
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource for: anInstance
| methodAndNode |
+ methodAndNode := self basicCompile: text asString notifying: requestor
- methodAndNode _ self basicCompile: text asString notifying: requestor
trailer: self defaultMethodTrailer ifFail: [^nil] for: anInstance.
methodAndNode method: (methodAndNode method copyWithTempNames: (methodAndNode node tempNames)).
logSource ifTrue: [
self logMethodSource: text forMethodWithNode: methodAndNode
inCategory: category withStamp: changeStamp notifying: requestor.
].
self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode
method inProtocol: category notifying: requestor.
self theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta.
^ methodAndNode selector!
Item was changed:
----- Method: Clipboard>>delete (in category '*Etoys-Squeakland-accessing') -----
delete
"Cleanup only internal buffer, but external"
+ contents := '' asText!
- contents _ '' asText!
Item was changed:
----- Method: CodecDemoMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aMorph event: evt
| codecClass |
'None' = codecClassName
ifTrue: [aMorph sound play]
ifFalse: [
+ codecClass := Smalltalk at: codecClassName ifAbsent: [^ self].
- codecClass _ Smalltalk at: codecClassName ifAbsent: [^ self].
(codecClass new compressAndDecompress: aMorph sound) play].
aMorph position: self topRight + (10 at 0).
!
Item was changed:
----- Method: CodecDemoMorph>>codecClassName: (in category 'as yet unclassified') -----
codecClassName: aStringOrSymbol
| label |
+ codecClassName := aStringOrSymbol asSymbol.
- codecClassName _ aStringOrSymbol asSymbol.
self removeAllMorphs.
+ label := StringMorph contents: aStringOrSymbol.
- label _ StringMorph contents: aStringOrSymbol.
label position: self position + (5 at 5).
self addMorph: label.
label lock: true.
self extent: label extent + (10 at 10).
!
Item was changed:
----- Method: CodecDemoMorph>>selectCodec (in category 'as yet unclassified') -----
selectCodec
| aMenu codecs newCodec |
+ aMenu := CustomMenu new title: 'Codec:'.
+ codecs := (SoundCodec allSubclasses collect: [:c | c name]) asSortedCollection.
- aMenu _ CustomMenu new title: 'Codec:'.
- codecs _ (SoundCodec allSubclasses collect: [:c | c name]) asSortedCollection.
codecs add: 'None'.
codecs do:[:cName | aMenu add: cName action: cName].
+ newCodec := aMenu startUp.
- newCodec _ aMenu startUp.
newCodec ifNil: [^ self].
self codecClassName: newCodec.
!
Item was changed:
----- Method: Collection>>toBraceStack: (in category '*Etoys-Squeakland-private') -----
toBraceStack: itsSize
"Push receiver's elements onto the stack of thisContext sender. Error if receiver does
not have itsSize elements or if receiver is unordered.
+ Do not call directly: this is called by {a. b} := ... constructs."
- Do not call directly: this is called by {a. b} _ ... constructs."
self size ~= itsSize ifTrue:
[self error: 'Trying to store ', self size printString,
' values into ', itsSize printString, ' variables.'].
thisContext sender push: itsSize fromIndexable: self!
Item was changed:
----- Method: Color class>>colorPaletteForDepth:extent: (in category '*Etoys-Squeakland-color from user') -----
colorPaletteForDepth: depth extent: chartExtent
"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
"Note: It is slow to build this palette, so it should be cached for quick access."
"(Color colorPaletteForDepth: 16 extent: 190 at 60) display"
| basicHue x y c startHue palette vSteps transCaption hSteps captionHeight |
+ palette := Form extent: chartExtent depth: depth.
+ transCaption := "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
- palette _ Form extent: chartExtent depth: depth.
- transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
(Form extent: 34 at 9 depth: 1
fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
offset: 0 at 0).
captionHeight := self colorPaletteCaptionHeight.
palette fillWhite: (0 at 0 extent: palette width at captionHeight).
palette fillBlack: (0 at captionHeight extent: palette width at 1).
transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
+ startHue := 338.0.
+ vSteps := palette height - captionHeight // 2.
+ hSteps := palette width - self colorPaletteGrayWidth.
+ x := 0.
- startHue _ 338.0.
- vSteps _ palette height - captionHeight // 2.
- hSteps _ palette width - self colorPaletteGrayWidth.
- x _ 0.
startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
+ basicHue := Color h: h asFloat s: 1.0 v: 1.0.
+ y := captionHeight+1.
- basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
- y _ captionHeight+1.
0 to: vSteps do: [:n |
+ c := basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
- c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
palette fill: (x at y extent: 1 at 1) fillColor: c.
+ y := y + 1].
- y _ y + 1].
1 to: vSteps do: [:n |
+ c := Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
- c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
palette fill: (x at y extent: 1 at 1) fillColor: c.
+ y := y + 1].
+ x := x + 1].
+ y := captionHeight + 1.
- y _ y + 1].
- x _ x + 1].
- y _ captionHeight + 1.
1 to: vSteps * 2 do: [:n |
+ c := Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
- c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
palette fill: (x at y extent: self colorPaletteGrayWidth @1) fillColor: c.
+ y := y + 1].
- y _ y + 1].
^ palette
!
Item was changed:
----- Method: ColorPickerMorph>>initializeForJustCursor (in category '*Etoys-Squeakland-initialization') -----
initializeForJustCursor
+ isModal := true.
- isModal _ true.
self removeAllMorphs.
+ selectedColor ifNil: [selectedColor := Color white].
+ sourceHand := nil.
+ deleteOnMouseUp := false.
+ updateContinuously := true.
+ noChart := true.
- selectedColor ifNil: [selectedColor _ Color white].
- sourceHand _ nil.
- deleteOnMouseUp _ false.
- updateContinuously _ true.
- noChart _ true.
self form: (Form extent: 2 at 2 depth: 16).
!
Item was changed:
----- Method: ColorSeerTile>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| m1 m2 desiredW wording |
super initialize.
""
self removeAllMorphs.
"get rid of the parts of a regular Color tile"
+ type := #operator.
+ operatorOrExpression := #color:sees:.
+ wording := (Vocabulary eToyVocabulary
- type _ #operator.
- operatorOrExpression _ #color:sees:.
- wording _ (Vocabulary eToyVocabulary
methodInterfaceAt: operatorOrExpression
ifAbsent: []) wording.
+ m1 := StringMorph contents: wording font: ScriptingSystem fontForTiles.
+ m2 := Morph new extent: 16 @ 14;
- m1 _ StringMorph contents: wording font: ScriptingSystem fontForTiles.
- m2 _ Morph new extent: 16 @ 14;
color: (Color
r: 0.8
g: 0
b: 0).
+ desiredW := m1 width + 6.
- desiredW _ m1 width + 6.
self extent: (desiredW max: self basicWidth)
@ self class defaultH.
m1 position: bounds center x - (m1 width // 2) @ (bounds top + 5).
m2 position: bounds center x - (m2 width // 2) + 3 @ (bounds top + 8).
self addMorph: m1;
addMorphFront: m2.
+ colorSwatch := m2!
- colorSwatch _ m2!
Item was changed:
----- Method: ColorTileMorph>>addColorSwatch (in category 'other') -----
addColorSwatch
| m1 m2 desiredW |
+ m1 := StringMorph contents: 'color' translated font: ScriptingSystem fontForTiles.
+ m2 := Morph new extent: 16 at 14; color: (Color r: 0.8 g: 0 b: 0).
+ desiredW := m1 width + 6.
- m1 _ StringMorph contents: 'color' translated font: ScriptingSystem fontForTiles.
- m2 _ Morph new extent: 16 at 14; color: (Color r: 0.8 g: 0 b: 0).
- desiredW _ m1 width + 6.
self extent: (desiredW max: self basicWidth) @ self class defaultH.
m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1).
self addMorph: m1; addMorph: m2.
+ colorSwatch := m2!
- colorSwatch _ m2!
Item was changed:
----- Method: ColorTileMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ type := #literal.
- type _ #literal.
self addColorSwatch.
+ showPalette := true.
- showPalette _ true.
!
Item was changed:
----- Method: ColorTileMorph>>showPalette: (in category 'accessing') -----
showPalette: aBoolean
+ showPalette := aBoolean.
- showPalette _ aBoolean.
!
Item was changed:
----- Method: ColorType>>updatingTileForTarget:partName:getter:setter: (in category '*Etoys-tiles') -----
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"
| readout |
+ readout := UpdatingRectangleMorph new.
- readout _ UpdatingRectangleMorph new.
readout
getSelector: getter;
target: aTarget;
borderWidth: 1;
extent: 20 at 20.
((aTarget isKindOf: KedamaExamplerPlayer) and: [getter = #getColor]) ifTrue: [
readout getSelector: #getColorOpaque.
].
(setter isNil or: [#(unused none #nil) includes: setter]) ifFalse:
[readout putSelector: setter].
^ readout
!
Item was changed:
----- Method: CommandTilesMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self wrapCentering: #center; cellPositioning: #leftCenter.
self hResizing: #shrinkWrap.
+ borderWidth := 0.
- borderWidth _ 0.
self layoutInset: 0.
self extent: 5 at 5. "will grow to fit"
!
Item was changed:
----- Method: CommandTilesMorph>>setMorph: (in category 'initialization') -----
setMorph: aMorph
+ playerScripted := aMorph playerScripted
- playerScripted _ aMorph playerScripted
!
Item was changed:
----- Method: CompiledMethod>>methodNodeDecompileClass:selector: (in category '*Etoys-Squeakland-decompiling') -----
methodNodeDecompileClass: aClass selector: selector
"Return the parse tree that represents self"
| source |
+ ^ ((source := self getSourceFromFile) isNil or: [
- ^ ((source _ self getSourceFromFile) isNil or: [
(Smalltalk
at: #MMetaCompiler
ifPresent: [:c | c metaProductionName: source asString]) notNil]) ifTrue: [
self decompileClass: aClass selector: selector
] ifFalse: [self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]
!
Item was changed:
----- Method: CompiledMethod>>qDecompress: (in category '*Etoys-Squeakland-source code management') -----
qDecompress: byteArray
"Decompress strings compressed by qCompress:.
Most common 12 chars get values 0-11 packed in one 4-bit nibble;
others get values 12-15 (2 bits) * 16 plus next nibble"
| charTable extended ext |
+ charTable := "Character encoding table must match qCompress:"
- charTable _ "Character encoding table must match qCompress:"
' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
^ String streamContents:
+ [:strm | extended := false. "Flag for 2-nibble characters"
- [:strm | extended _ false. "Flag for 2-nibble characters"
byteArray do:
[:byte |
(Array with: byte//16 with: byte\\16)
do:
[:nibble | extended
+ ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended := false]
- ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]
ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]
+ ifFalse: [ext := nibble-12. extended := true]]]]]!
- ifFalse: [ext _ nibble-12. extended _ true]]]]]!
Item was changed:
----- Method: CompiledMethod>>scanLongLoad: (in category '*Etoys-Squeakland-scanning') -----
scanLongLoad: extension
"Answer whether the receiver contains a long load whose extension is the
argument."
| scanner |
+ scanner := InstructionStream on: self.
- scanner _ InstructionStream on: self.
^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]!
Item was changed:
----- Method: CompiledMethod>>scanLongStore: (in category '*Etoys-Squeakland-scanning') -----
scanLongStore: extension
"Answer whether the receiver contains a long store whose extension is
the argument."
| scanner |
+ scanner := InstructionStream on: self.
- scanner _ InstructionStream on: self.
^scanner scanFor:
[:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]!
Item was changed:
----- Method: CompiledMethod>>scanVeryLongLoad:offset: (in category '*Etoys-Squeakland-scanning') -----
scanVeryLongLoad: extension offset: offset
"Answer whether the receiver contains a long load whose extension is the
argument."
| scanner |
+ scanner := InstructionStream on: self.
- scanner _ InstructionStream on: self.
^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])
and: [scanner thirdByte = offset]]!
Item was changed:
----- Method: Component>>addVariableNamed: (in category 'variables') -----
addVariableNamed: varName
"Adjust name if necessary and add it"
| otherNames i partName |
otherNames := self class allInstVarNames.
i := nil.
[partName := i isNil
ifTrue: [varName]
ifFalse: [varName , i printString].
otherNames includes: partName]
whileTrue: [i := i isNil ifTrue: [1] ifFalse: [i + 1]].
self class addInstVarName: partName.
"Now compile read method and write-with-change method"
self class
compile: (String streamContents:
[:s |
s
nextPutAll: partName;
cr;
tab;
nextPutAll: '^' , partName])
classified: 'view access'
notifying: nil.
self class
compile: (String streamContents:
[:s |
s
nextPutAll: partName , 'Set: newValue';
cr;
tab;
+ nextPutAll: partName , ' := newValue.';
- nextPutAll: partName , ' _ newValue.';
cr;
tab;
nextPutAll: 'self changed: #' , partName , '.';
cr;
tab;
nextPutAll: '^ true' "for components that expect a boolean for accept"])
classified: 'view access'
notifying: nil.
^Array with: partName asSymbol with: (partName , 'Set:') asSymbol!
Item was changed:
----- Method: Component>>chooseNameLike: (in category 'naming') -----
chooseNameLike: someName
| stem otherNames i partName |
+ stem := someName.
- stem _ someName.
(stem size > 5 and: [stem endsWith: 'Morph'])
+ ifTrue: [stem := stem copyFrom: 1 to: stem size - 5].
+ stem := stem first asLowercase asString , stem allButFirst.
+ otherNames := self class allInstVarNames asSet.
- ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
- stem _ stem first asLowercase asString , stem allButFirst.
- otherNames _ self class allInstVarNames asSet.
"otherNames addAll: self world allKnownNames."
+ i := 1.
+ [otherNames includes: (partName := stem , i printString)]
+ whileTrue: [i := i + 1].
+ partName := FillInTheBlank request: 'Please give this part a name'
- i _ 1.
- [otherNames includes: (partName _ stem , i printString)]
- whileTrue: [i _ i + 1].
- partName _ FillInTheBlank request: 'Please give this part a name'
initialAnswer: partName.
partName isEmpty ifTrue: [^ nil].
(otherNames includes: partName) ifTrue:
[self inform: 'Sorry, that name is already used'.
^ nil].
^ partName!
Item was changed:
----- Method: Component>>initComponentIn: (in category 'initialize') -----
initComponentIn: aLayout
+ model := aLayout model.
- model _ aLayout model.
self nameMeIn: aLayout world.
self color: Color lightCyan.
self showPins.
model addDependent: self!
Item was changed:
----- Method: Component>>justDroppedInto:event: (in category 'drag and drop') -----
justDroppedInto: aMorph event: anEvent
| theModel |
+ theModel := aMorph model.
- theModel _ aMorph model.
((aMorph isKindOf: ComponentLayout)
and: [theModel isKindOf: Component]) ifFalse:
["Disconnect prior to removal by move"
+ (theModel isKindOf: Component) ifTrue: [self unwire. model := nil].
- (theModel isKindOf: Component) ifTrue: [self unwire. model _ nil].
^ super justDroppedInto: aMorph event: anEvent].
theModel == model ifTrue: [^ self "Presumably just a move"].
self initComponentIn: aMorph.
super justDroppedInto: aMorph event: anEvent.!
Item was changed:
----- Method: Component>>nameMeIn: (in category 'naming') -----
nameMeIn: aWorld
| stem otherNames i partName className |
+ className := self class name.
+ stem := className.
- className _ self class name.
- stem _ className.
(stem size > 5 and: [stem endsWith: 'Morph'])
+ ifTrue: [stem := stem copyFrom: 1 to: stem size - 5].
+ stem := stem first asLowercase asString , stem allButFirst.
+ otherNames := Set newFrom: aWorld allKnownNames.
+ i := 1.
+ [otherNames includes: (partName := stem , i printString)]
+ whileTrue: [i := i + 1].
- ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
- stem _ stem first asLowercase asString , stem allButFirst.
- otherNames _ Set newFrom: aWorld allKnownNames.
- i _ 1.
- [otherNames includes: (partName _ stem , i printString)]
- whileTrue: [i _ i + 1].
self setNamePropertyTo: partName!
Item was changed:
----- Method: Component>>renameMe (in category 'naming') -----
renameMe
| newName |
+ newName := self chooseNameLike: self knownName.
- newName _ self chooseNameLike: self knownName.
newName ifNil: [^ nil].
self setNamePropertyTo: newName!
Item was changed:
----- Method: ComponentLayout>>inspectModelInMorphic (in category 'as yet unclassified') -----
inspectModelInMorphic
| insp |
+ insp := InspectorBrowser openAsMorphOn: self model.
- insp _ InspectorBrowser openAsMorphOn: self model.
self world addMorph: insp; startStepping: insp!
Item was changed:
----- Method: ComponentLikeModel>>addPinFromSpec: (in category 'components') -----
addPinFromSpec: pinSpec
| pin |
+ pin := PinMorph new component: self pinSpec: pinSpec.
- pin _ PinMorph new component: self pinSpec: pinSpec.
self addMorph: pin.
pin placeFromSpec.
^ pin!
Item was changed:
----- Method: ComponentLikeModel>>initComponentIn: (in category 'components') -----
initComponentIn: aLayout
+ model := aLayout model.
- model _ aLayout model.
self nameMeIn: aLayout.
self color: Color lightCyan.
self initPinSpecs.
self initFromPinSpecs.
self showPins.
model addDependent: self!
Item was changed:
----- Method: ComponentLikeModel>>initPinSpecs (in category 'components') -----
initPinSpecs
"no-op for default"
+ pinSpecs := Array new.
- pinSpecs _ Array new.
!
Item was changed:
----- Method: ComponentLikeModel>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: aMorph event: anEvent
| theModel |
+ theModel := aMorph modelOrNil.
- theModel _ aMorph modelOrNil.
((aMorph isKindOf: ComponentLayout)
and: [theModel isKindOf: Component]) ifFalse:
["Disconnect prior to removal by move"
+ (theModel isKindOf: Component) ifTrue: [self unwire. model := nil].
- (theModel isKindOf: Component) ifTrue: [self unwire. model _ nil].
^ super justDroppedInto: aMorph event: anEvent].
theModel == model ifTrue: [^ self "Presumably just a move"].
self initComponentIn: aMorph.
super justDroppedInto: aMorph event: anEvent!
Item was changed:
----- Method: ComponentLikeModel>>nameMeIn: (in category 'components') -----
nameMeIn: aWorld
| stem otherNames i partName className |
+ className := self class name.
+ stem := className.
- className _ self class name.
- stem _ className.
(stem size > 5 and: [stem endsWith: 'Morph'])
+ ifTrue: [stem := stem copyFrom: 1 to: stem size - 5].
+ stem := stem first asLowercase asString , stem allButFirst.
+ otherNames := Set newFrom: aWorld allKnownNames.
+ i := 1.
+ [otherNames includes: (partName := stem , i printString)]
+ whileTrue: [i := i + 1].
- ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
- stem _ stem first asLowercase asString , stem allButFirst.
- otherNames _ Set newFrom: aWorld allKnownNames.
- i _ 1.
- [otherNames includes: (partName _ stem , i printString)]
- whileTrue: [i _ i + 1].
self setNamePropertyTo: partName!
Item was changed:
----- Method: ComponentLikeModel>>renameMe (in category 'components') -----
renameMe
| otherNames newName |
+ otherNames := Set newFrom: self pasteUpMorph allKnownNames.
+ newName := FillInTheBlank request: 'Please give this new a name'
- otherNames _ Set newFrom: self pasteUpMorph allKnownNames.
- newName _ FillInTheBlank request: 'Please give this new a name'
initialAnswer: self knownName.
newName isEmpty ifTrue: [^ nil].
(otherNames includes: newName) ifTrue:
[self inform: 'Sorry, that name is already used'. ^ nil].
self setNamePropertyTo: newName!
Item was changed:
----- Method: CompoundTileMorph>>aboutToBeAcceptedInScriptor (in category '*Etoys-Squeakland-miscellaneous') -----
aboutToBeAcceptedInScriptor
"The receiver is about to be accepted in a Scriptor. Adjust state information accordingly."
+ justGrabbedFromViewer := false.
- justGrabbedFromViewer _ false.
self removeProperty: #newPermanentScript.
self removeProperty: #newPermanentPlayer.
!
Item was changed:
----- Method: CompoundTileMorph>>addCommandFeedback: (in category '*Etoys-Squeakland-miscellaneous') -----
addCommandFeedback: evt
"Add screen feedback showing what would be torn off in a drag"
| aMorph |
+ aMorph := RectangleMorph new bounds: (self bounds).
- aMorph _ RectangleMorph new bounds: (self bounds).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem commandFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: self outmostScriptEditor!
Item was changed:
----- Method: CompoundTileMorph>>blockNodeElements:with: (in category '*Etoys-Squeakland-code generation') -----
blockNodeElements: scriptPart with: encoder
| rows r |
+ rows := scriptPart tileRows.
- rows _ scriptPart tileRows.
^ Array streamContents: [:strm |
1 to: rows size do: [:i |
+ r := rows at: i.
- r _ rows at: i.
r do: [:t | strm nextPut: (t parseNodeWith: encoder asStatement: true)].
].
].
!
Item was changed:
----- Method: CompoundTileMorph>>delegatingMouseEnter: (in category '*Etoys-Squeakland-initialization') -----
delegatingMouseEnter: evt
| o oo |
+ (o := self owner) ifNotNil: [(oo := o owner) ifNotNil: [^ oo mouseEnter: evt]].
- (o _ self owner) ifNotNil: [(oo _ o owner) ifNotNil: [^ oo mouseEnter: evt]].
!
Item was changed:
----- Method: CompoundTileMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| r stringMorph d h |
super initialize.
self layoutInset: 2.
self listDirection: #topToBottom.
self hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200 at 14).
h := Preferences standardEToysFont height.
"NB: hResizing gets reset to #spaceFill below, after the standalone structure is created"
+ r := AlignmentMorph newRow color: color;
- r _ AlignmentMorph newRow color: color;
layoutInset: 0.
r setProperty: #demandsBoolean toValue: true.
r addMorphBack: (Morph new color: color;
extent: 2 @ 5).
"spacer"
+ stringMorph := StringMorph new contents: 'Test' translated.
- stringMorph _ StringMorph new contents: 'Test' translated.
stringMorph name: 'Test'.
stringMorph font: Preferences standardEToysFont.
stringMorph on: #mouseEnterDragging send: #delegatingMouseEnter: to: self.
r addMorphBack: stringMorph.
r addMorphBack: (Morph new color: color;
extent: 5 @ 5).
"spacer"
+ r addMorphBack: (testPart := BooleanScriptEditor new borderWidth: 0;
- r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0;
layoutInset: 1).
testPart color: Color transparent.
testPart height: h; minHeight: h.
testPart hResizing: #spaceFill.
self addMorphBack: r.
+ r := AlignmentMorph newRow color: color;
- r _ AlignmentMorph newRow color: color;
layoutInset: 0.
+ r addMorphBack: (d := Morph new color: color;
- r addMorphBack: (d _ Morph new color: color;
extent: 30 @ stringMorph height)."stringMorph is refering to wrong one, but ok."
d on: #mouseEnterDragging send: #delegatingMouseEnter: to: self.
"spacer"
+ stringMorph := StringMorph new contents: 'Yes' translated.
- stringMorph _ StringMorph new contents: 'Yes' translated.
stringMorph name: 'Yes'.
stringMorph font: Preferences standardEToysFont.
r addMorphBack: stringMorph.
r addMorphBack: (Morph new color: color;
extent: 5 @ 5).
"spacer"
+ r addMorphBack: (yesPart := ScriptEditorMorph new borderWidth: 0;
- r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0;
layoutInset: 2).
yesPart height: h; minHeight: h.
yesPart hResizing: #spaceFill.
yesPart color: Color transparent.
self addMorphBack: r.
+ r := AlignmentMorph newRow color: color;
- r _ AlignmentMorph newRow color: color;
layoutInset: 0.
+ r addMorphBack: (d := Morph new color: color;
- r addMorphBack: (d _ Morph new color: color;
extent: 35 @ stringMorph height).
d on: #mouseEnterDragging send: #delegatingMouseEnter: to: self.
"spacer"
+ stringMorph := StringMorph new contents: 'No' translated.
- stringMorph _ StringMorph new contents: 'No' translated.
stringMorph name: 'No'.
stringMorph font: Preferences standardEToysFont.
r addMorphBack: stringMorph.
r addMorphBack: (Morph new color: color;
extent: 5 @ 5).
"spacer"
+ r addMorphBack: (noPart := ScriptEditorMorph new borderWidth: 0;
- r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0;
layoutInset: 2).
noPart height: h; minHeight: h.
noPart hResizing: #spaceFill.
noPart color: Color transparent.
self addMorphBack: r.
self bounds: self fullBounds.
self updateWordingToMatchVocabulary.
self hResizing:#spaceFill
!
Item was changed:
----- Method: CompoundTileMorph>>justGrabbedFromViewer (in category '*Etoys-Squeakland-miscellaneous') -----
justGrabbedFromViewer
"Answer whether the receiver originated in a Viewer. Only tiles that originated in a viewer will ever do that infernal sprouting of a new script around them. The nil branch is only for backward compatibility."
+ ^ justGrabbedFromViewer ifNil: [justGrabbedFromViewer := true]!
- ^ justGrabbedFromViewer ifNil: [justGrabbedFromViewer _ true]!
Item was changed:
----- Method: CompoundTileMorph>>justGrabbedFromViewer: (in category '*Etoys-Squeakland-miscellaneous') -----
justGrabbedFromViewer: aBoolean
"Set the receiver's justGrabbedFromViewer instance variable"
+ justGrabbedFromViewer := aBoolean!
- justGrabbedFromViewer _ aBoolean!
Item was changed:
----- Method: CompoundTileMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: evt
"Resume drop-tracking in enclosing editor"
| ed |
self removeHighlightFeedback.
+ (ed := self enclosingEditor) ifNotNil: [^ed mouseEnterDragging: evt].!
- (ed _ self enclosingEditor) ifNotNil: [^ed mouseEnterDragging: evt].!
Item was changed:
----- Method: CompoundTileMorph>>parseNodeWith: (in category '*Etoys-Squeakland-code generation') -----
parseNodeWith: encoder
| rec yes no |
+ rec := (self blockNodeElements: testPart with: encoder).
+ rec size > 0 ifTrue: [rec := rec last] ifFalse: [rec := encoder encodeLiteral: true].
+ yes := self blockNode: yesPart with: encoder.
+ no := self blockNode: noPart with: encoder.
- rec _ (self blockNodeElements: testPart with: encoder).
- rec size > 0 ifTrue: [rec _ rec last] ifFalse: [rec _ encoder encodeLiteral: true].
- yes _ self blockNode: yesPart with: encoder.
- no _ self blockNode: noPart with: encoder.
^ MessageNode new
receiver: rec
selector: #ifTrue:ifFalse:
arguments: (Array with: yes with: no)
precedence: (#ifTrue:ifFalse: precedence)
from: encoder
sourceRange: nil.
!
Item was changed:
----- Method: ConnectionQueue>>oldListenLoop (in category '*Etoys-Squeakland-private') -----
oldListenLoop
"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."
| newConnection |
+ socket := Socket newTCP.
- socket _ Socket newTCP.
"We'll accept four simultanous connections at the same time"
socket listenOn: self portNumber backlogSize: 4.
"If the listener is not valid then the we cannot use the
BSD style accept() mechanism."
socket isValid ifFalse: [^self oldStyleListenLoop].
[true] whileTrue: [
socket isValid ifFalse: [
"socket has stopped listening for some reason"
socket destroy.
(Delay forMilliseconds: 10) wait.
^self oldListenLoop ].
+ newConnection := socket waitForAcceptFor: 10.
- newConnection _ socket waitForAcceptFor: 10.
(newConnection notNil and:[newConnection isConnected]) ifTrue:
[accessSema critical: [connections addLast: newConnection].
+ newConnection := nil].
- newConnection _ nil].
self pruneStaleConnections]. !
Item was changed:
----- Method: CrosticPanel>>breakColumnAndResizeWithButtons: (in category 'initialization') -----
breakColumnAndResizeWithButtons: buttonRow
| indexToSplit yToSplit |
"The column of clues has been laid out, and the crostic panel has been resized to that width and embedded as a submorph. This method breaks the clues in two, placing the long part to the left of the crostic and the short one below it."
+ yToSplit := cluesPanel height + quotePanel height // 2 + self top.
+ indexToSplit := cluesPanel submorphs findFirst: [:m | m bottom > yToSplit].
+ cluesCol2 := AlignmentMorph newColumn color: self color;
- yToSplit _ cluesPanel height + quotePanel height // 2 + self top.
- indexToSplit _ cluesPanel submorphs findFirst: [:m | m bottom > yToSplit].
- cluesCol2 _ AlignmentMorph newColumn color: self color;
hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0;
cellPositioning: #topLeft.
cluesCol2 addAllMorphs: (cluesPanel submorphs copyFrom: indexToSplit + 1
to: cluesPanel submorphs size).
cluesPanel position: self position + self borderWidth + (0 @ 4).
quotePanel position: self position + (quotePanel width @ 0).
cluesCol2 position: self position + quotePanel extent + (0 @ 4).
self addMorph: cluesCol2.
self addMorph: buttonRow.
buttonRow align: buttonRow topLeft with: cluesCol2 bottomLeft.
self extent: 100 at 100; bounds: ((self fullBounds topLeft - self borderWidth asPoint)
corner: (self fullBounds bottomRight - (2 at 0))).
!
Item was changed:
----- Method: CrosticPanel>>quote:clues:answers:quotePanel: (in category 'initialization') -----
quote: indexableQuote clues: clueStrings answers: answerIndices quotePanel: panel
| row clue answer answerMorph letterMorph prev clueText clueStyle |
+ quote := indexableQuote.
+ quotePanel := panel.
+ clues := clueStrings.
+ answers := answerIndices.
+ cluesPanel := AlignmentMorph newColumn color: self color;
- quote _ indexableQuote.
- quotePanel _ panel.
- clues _ clueStrings.
- answers _ answerIndices.
- cluesPanel _ AlignmentMorph newColumn color: self color;
hResizing: #shrinkWrap; vResizing: #shrinkWrap;
cellPositioning: #topLeft; layoutInset: 1.
+ letterMorphs := Array new: quotePanel letterMorphs size.
+ clueStyle := nil.
- letterMorphs _ Array new: quotePanel letterMorphs size.
- clueStyle _ nil.
1 to: clues size do:
+ [:i | clue := clues at: i. answer := answers at: i.
+ row := AlignmentMorph newRow cellPositioning: #bottomLeft.
+ clueText := (TextMorph newBounds: (0 at 0 extent: 120 at 20) color: Color black)
- [:i | clue _ clues at: i. answer _ answers at: i.
- row _ AlignmentMorph newRow cellPositioning: #bottomLeft.
- clueText _ (TextMorph newBounds: (0 at 0 extent: 120 at 20) color: Color black)
string: (CrosticPanel oldStyle
ifTrue: [(($A to: $Z) at: i) asString , '. ' , clue]
ifFalse: [clue])
fontName: 'ComicPlain' size: 13.
clueStyle ifNil: ["Make up a special style with decreased leading"
+ clueStyle := clueText textStyle copy.
- clueStyle _ clueText textStyle copy.
clueStyle gridForFont: 1 withLead: -2].
clueText text: clueText asText textStyle: clueStyle. "All clues share same style"
clueText composeToBounds.
row addMorphBack: clueText.
+ answerMorph := AlignmentMorph newRow layoutInset: 0.
+ prev := nil.
- answerMorph _ AlignmentMorph newRow layoutInset: 0.
- prev _ nil.
answer do:
+ [:n | letterMorph := WordGameLetterMorph new underlined
- [:n | letterMorph _ WordGameLetterMorph new underlined
indexInQuote: n
id1: (CrosticPanel oldStyle ifTrue: [n printString] ifFalse: [nil]);
setLetter: Character space.
letterMorph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
letterMorph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
letterMorph predecessor: prev.
prev ifNotNil: [prev successor: letterMorph].
+ prev := letterMorph.
- prev _ letterMorph.
letterMorphs at: n put: letterMorph.
answerMorph addMorphBack: letterMorph].
answerMorph color: answerMorph firstSubmorph color.
row addMorphBack: answerMorph.
row fullBounds.
row color: answerMorph firstSubmorph color.
cluesPanel addMorphBack: row].
self addMorph: cluesPanel.
self bounds: cluesPanel fullBounds.
!
Item was changed:
----- Method: CrosticQuotePanel>>extent: (in category 'geometry') -----
extent: newExtent
| w h nAcross relLoc topLeft |
+ w := self firstSubmorph width - 1. h := self firstSubmorph height - 1.
+ nAcross := newExtent x - (self borderWidth-1*2)-1 // w.
+ topLeft := self position + self borderWidth - 1.
- w _ self firstSubmorph width - 1. h _ self firstSubmorph height - 1.
- nAcross _ newExtent x - (self borderWidth-1*2)-1 // w.
- topLeft _ self position + self borderWidth - 1.
submorphs withIndexDo:
[:m :i |
+ relLoc := (i-1 \\ nAcross * w) @ (i-1 // nAcross * h).
- relLoc _ (i-1 \\ nAcross * w) @ (i-1 // nAcross * h).
m position: topLeft + relLoc].
super extent: ((w * nAcross + 1) @ (submorphs size - 1 // nAcross + 1 * h+1))
+ (self borderWidth - 1 * 2).
!
Item was changed:
----- Method: CrosticQuotePanel>>quote:answers:cluesPanel: (in category 'initialization') -----
quote: quoteWithBlanks answers: theAnswers cluesPanel: panel
| n morph prev clueIxs |
+ cluesPanel := panel.
- cluesPanel _ panel.
self color: Color gray.
+ clueIxs := Array new: quoteWithBlanks size.
- clueIxs _ Array new: quoteWithBlanks size.
theAnswers withIndexDo: [:a :i | a do: [:j | clueIxs at: j put: i]].
+ letterMorphs := OrderedCollection new.
+ prev := nil.
- letterMorphs _ OrderedCollection new.
- prev _ nil.
self addAllMorphs: (quoteWithBlanks asArray collect:
[:c |
c isLetter
+ ifTrue: [n := letterMorphs size + 1.
+ morph := WordGameLetterMorph new boxed.
- ifTrue: [n _ letterMorphs size + 1.
- morph _ WordGameLetterMorph new boxed.
CrosticPanel oldStyle
ifTrue: [morph indexInQuote: n id1: n printString.
morph id2: (($A to: $Z) at: (clueIxs at: n)) asString]
ifFalse: [morph indexInQuote: n id1: nil].
morph setLetter: Character space.
morph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
morph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
letterMorphs addLast: morph]
+ ifFalse: [morph := WordGameLetterMorph new boxed indexInQuote: nil id1: nil.
- ifFalse: [morph _ WordGameLetterMorph new boxed indexInQuote: nil id1: nil.
CrosticPanel oldStyle ifTrue: [morph extent: 26 at 24 "Oops"]].
morph predecessor: prev.
prev ifNotNil: [prev successor: morph].
+ prev := morph]).
- prev _ morph]).
!
Item was changed:
----- Method: DHtmlFormatter>>endHeader: (in category 'formatting commands') -----
endHeader: level
+ boldLevel := boldLevel - 1. "self decreaseBold"
- boldLevel _ boldLevel - 1. "self decreaseBold"
self ensureNewlines: 2.
self endFont: nil.!
Item was changed:
----- Method: DHtmlFormatter>>lastFontSize (in category 'formatting commands') -----
lastFontSize
| textAttrib |
fontSpecs isEmptyOrNil ifTrue: [^1].
fontSpecs reverseDo: [:specs |
+ textAttrib := specs detect: [:attrib | attrib isKindOf: TextFontChange] ifNone: [].
- textAttrib _ specs detect: [:attrib | attrib isKindOf: TextFontChange] ifNone: [].
textAttrib ifNotNil: [^textAttrib fontNumber]].
^1 "default font size in Squeak (1) corresponds to HTML's default 4"!
Item was changed:
----- Method: DHtmlFormatter>>setAttributes (in category 'private-formatting') -----
setAttributes
"set attributes on the output stream"
| attribs |
+ attribs := OrderedCollection new.
- attribs _ OrderedCollection new.
indentLevel > 0 ifTrue: [ attribs add: (TextIndent tabs: indentLevel) ].
boldLevel > 0 ifTrue: [ attribs add: TextEmphasis bold ].
italicsLevel > 0 ifTrue: [ attribs add: TextEmphasis italic ].
underlineLevel > 0 ifTrue: [ attribs add: TextEmphasis underlined ].
strikeLevel > 0 ifTrue: [ attribs add: TextEmphasis struckOut ].
urlLink isNil ifFalse: [ attribs add: (TextURL new url: urlLink) ].
fontSpecs isEmptyOrNil
ifFalse: [attribs addAll: fontSpecs last]
ifTrue: [attribs add: (TextFontChange defaultFontChange)].
outputStream currentAttributes: attribs!
Item was changed:
----- Method: DHtmlFormatter>>startFont: (in category 'formatting commands') -----
startFont: aTextAttribList
"aTextAttribList is a collection of TextAttributes"
+ fontSpecs ifNil: [fontSpecs := OrderedCollection new].
- fontSpecs ifNil: [fontSpecs _ OrderedCollection new].
fontSpecs add: aTextAttribList.
self setAttributes!
Item was changed:
----- Method: DHtmlFormatter>>startHeader: (in category 'formatting commands') -----
startHeader: level
self ensureNewlines: 3.
+ boldLevel := boldLevel + 1. "self increaseBold"
- boldLevel _ boldLevel + 1. "self increaseBold"
self startFont: (self headerFont: level).!
Item was changed:
----- Method: DataType>>updatingTileForTarget:partName:getter:setter: (in category '*Etoys-tiles') -----
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"
| aTile displayer actualSetter |
+ actualSetter := setter ifNotNil:
- actualSetter _ setter ifNotNil:
[(#(none #nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]].
+ aTile := self newReadoutTile.
- aTile _ self newReadoutTile.
+ displayer := UpdatingStringMorph new
- displayer _ UpdatingStringMorph new
getSelector: getter;
target: aTarget;
growable: true;
minimumWidth: 48;
putSelector: actualSetter.
"Note that where relevant (Number and Point types), the #target: call above will have dealt with floatPrecision details"
displayer font: Preferences standardEToysFont.
self setFormatForDisplayer: displayer.
aTile addMorphBack: displayer.
displayer setNameTo: 'readout string' translated.
(actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows].
getter numArgs == 0 ifTrue:
[aTile setLiteralInitially: (aTarget perform: getter)].
^ aTile
!
Item was changed:
----- Method: Debugger>>buttonRowForPreDebugWindow: (in category '*Etoys-Squeakland-initialize') -----
buttonRowForPreDebugWindow: aDebugWindow
"Answer a morph that will serve as the button row in a pre-debug window."
| aRow aButton quads aFont |
+ aRow := AlignmentMorph newRow hResizing: #spaceFill.
- aRow _ AlignmentMorph newRow hResizing: #spaceFill.
aRow beSticky.
aRow on: #mouseDown send: #yourself to: self. "Avoid dragging window."
aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
+ quads := OrderedCollection withAll: self preDebugButtonQuads.
- quads _ OrderedCollection withAll: self preDebugButtonQuads.
((self interruptedContext selector == #doesNotUnderstand:) and:
[Preferences eToyFriendly not]) ifTrue:
[quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' }].
aFont := Preferences eToyFriendly
ifFalse:
[Preferences standardButtonFont]
ifTrue:
[Preferences standardEToysButtonFont].
quads do:
[:quad |
+ aButton := SimpleButtonMorph new target: aDebugWindow.
- aButton _ SimpleButtonMorph new target: aDebugWindow.
aButton color: Color transparent; borderWidth: 1.
aButton actionSelector: quad second.
aButton label: quad first font: aFont.
aButton submorphs first color: (Color colorFrom: quad third).
aButton setBalloonText: quad fourth.
Preferences alternativeWindowLook
ifTrue:[aButton borderWidth: 2; borderColor: #raised].
aRow addMorphBack: aButton.
aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
^ aRow!
Item was changed:
----- Method: Debugger>>preDebugNotifierContentsFrom: (in category '*Etoys-Squeakland-initialize') -----
preDebugNotifierContentsFrom: messageString
| first second msg |
^ Preferences eToyFriendly
ifFalse:
[messageString]
ifTrue:
[
+ msg := messageString.
+ msg ifNil: [msg := ''].
+ first := second := 0.
+ first := msg indexOf: $\ ifAbsent: [0].
+ first > 0 ifTrue: [second := msg indexOf: $\ startingAt: first + 1 ifAbsent: [0]].
- msg _ messageString.
- msg ifNil: [msg _ ''].
- first _ second _ 0.
- first _ msg indexOf: $\ ifAbsent: [0].
- first > 0 ifTrue: [second _ msg indexOf: $\ startingAt: first + 1 ifAbsent: [0]].
(first > 0 and: [second > 0]) ifTrue: [
'An error has occurred in\{3} of {2}.\Fix your script(s), hit ''Abandon'' and try again.' translated withCRs format: {msg copyFrom: 1 to: first - 1. msg copyFrom: first + 1 to: second - 1. msg copyFrom: second + 1 to: msg size}
] ifFalse: [
'An error has occurred; you should probably just hit ''abandon''. Sorry!!' translated
]
] !
Item was changed:
----- Method: Decompiler>>checkForBlock: (in category '*Etoys-Squeakland-control') -----
checkForBlock: receiver
"We just saw a blockCopy: message. Check for a following block."
| savePc jump args argPos block |
receiver == constructor codeThisContext ifFalse: [^false].
+ savePc := pc.
+ (jump := self interpretJump) notNil
- savePc _ pc.
- (jump _ self interpretJump) notNil
ifFalse:
+ [pc := savePc. ^nil].
- [pc _ savePc. ^nil].
"Definitely a block"
+ jump := jump + pc.
+ argPos := statements size.
- jump _ jump + pc.
- argPos _ statements size.
[self willStorePop]
whileTrue:
[stack addLast: ArgumentFlag. "Flag for doStore:"
self interpretNextInstructionFor: self].
+ args := Array new: statements size - argPos.
- args _ Array new: statements size - argPos.
1 to: args size do: "Retrieve args"
[:i | args at: i put: statements removeLast.
(args at: i) scope: -1 "flag args as block temps"].
+ block := self blockTo: jump.
- block _ self blockTo: jump.
stack addLast: (constructor codeArguments: args block: block).
^true!
Item was changed:
----- Method: DeepCopier>>checkNewTarget (in category '*Etoys-Squeakland-checking') -----
checkNewTarget
"Any class that holds a morph in an instance variable needs to hold is weakly. The morph should only be copied it is really is in the tree of morphs of this deepCopy. Search for classes that have target and xxxSelector and xxxArguments, and do not implement veryDeepInner: and veryDeepFixupWith:. Show them in the transcript.
DeepCopier new checkNewTarget "
| suspect |
+ suspect := 'selector'.
- suspect _ 'selector'.
(self systemNavigation allClasses) do: [:aClass |
aClass instVarNames do: [:instN |
('*',suspect,'*' match: instN) ifTrue: [
aClass compiledMethodAt: #veryDeepInner: ifAbsent: [
Transcript show: aClass name, ' ', instN; cr]]]].
" Look in selectors... (too many of these)
+ suspect := 'selector'.
- suspect _ 'selector'.
(self systemNavigation allClasses) do: [:aClass |
aClass methodDictionary keysDo: [:key |
('*',suspect,'*' match: key) ifTrue: [
aClass compiledMethodAt: #veryDeepInner: ifAbsent: [
Transcript show: aClass name, ' ', key; cr]]]].
"!
Item was changed:
----- Method: DeepCopier>>mapUniClassMethods: (in category '*Etoys-Squeakland-full copy') -----
mapUniClassMethods: pool
"Players also refer to each other using associations in the References dictionary. Search the literals of the methods of our Players for those. There are already new entries in project-local References and point to them."
| newKey newAssoc oldSelList newSelList newValue |
uniClasses "values" do: [:newClass |
+ oldSelList := OrderedCollection new. newSelList := OrderedCollection new.
- oldSelList _ OrderedCollection new. newSelList _ OrderedCollection new.
newClass selectorsDo: [:sel |
(newClass compiledMethodAt: sel) literals do: [:assoc |
assoc isVariableBinding ifTrue: [
+ newValue := references at: assoc value ifAbsent: [].
- newValue _ references at: assoc value ifAbsent: [].
newValue ifNotNil: [
+ newKey := newValue externalName asSymbol.
- newKey _ newValue externalName asSymbol.
(assoc key ~= newKey) & (pool includesKey: newKey) ifTrue: [
+ newAssoc := pool associationAt: newKey.
- newAssoc _ pool associationAt: newKey.
newClass methodDictionary at: sel put:
(newClass compiledMethodAt: sel) clone. "were sharing it"
(newClass compiledMethodAt: sel)
literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
put: newAssoc.
(oldSelList includes: assoc key) ifFalse: [
oldSelList add: assoc key. newSelList add: newKey]]]]]].
oldSelList with: newSelList do: [:old :new |
newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"!
Item was changed:
----- Method: DeferredActionStandardSystemController>>initialize (in category 'as yet unclassified') -----
initialize
super initialize.
+ queue := SharedQueue new.!
- queue _ SharedQueue new.!
Item was changed:
----- Method: DialectMethodNode>>setDialect: (in category 'as yet unclassified') -----
setDialect: dialectSymbol
+ dialect := dialectSymbol!
- dialect _ dialectSymbol!
Item was changed:
----- Method: DialectParser class>>test (in category 'as yet unclassified') -----
test "DialectParser test"
"PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running):
BalloonEngineSimulation circleCosTable and
BalloonEngineSimulation circleSinTable.
These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors.
Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on.
NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing...
Smalltalk recompileAllFrom: 'AARDVAARK'.
"
| newCodeString methodNode oldMethod newMethod badOnes n heading |
Preferences enable: #printAlternateSyntax.
+ badOnes := OrderedCollection new.
- badOnes _ OrderedCollection new.
Transcript clear.
Smalltalk forgetDoIts.
'Formatting and recompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
+ during: [:bar | n := 0.
- during: [:bar | n _ 0.
Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class"
[:nonMeta | "Transcript cr; show: nonMeta name."
{nonMeta. nonMeta class} do:
[:cls |
cls selectors do:
+ [:selector | (n := n+1) \\ 100 = 0 ifTrue: [bar value: n].
+ newCodeString := (cls compilerClass new)
- [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
- newCodeString _ (cls compilerClass new)
format: (cls sourceCodeAt: selector)
in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
+ heading := cls organization categoryOfElement: selector.
+ methodNode := cls compilerClass new
- heading _ cls organization categoryOfElement: selector.
- methodNode _ cls compilerClass new
compile: newCodeString
in: cls notifying: (SyntaxError new category: heading)
ifFail: [].
+ newMethod := methodNode generate: CompiledMethodTrailer empty.
+ oldMethod := cls compiledMethodAt: selector.
- newMethod _ methodNode generate: CompiledMethodTrailer empty.
- oldMethod _ cls compiledMethodAt: selector.
"Transcript cr; show: cls name , ' ' , selector."
oldMethod = newMethod ifFalse:
[Transcript cr; show: '***' , cls name , ' ' , selector.
oldMethod size = newMethod size ifFalse:
[Transcript show: ' difft size'].
oldMethod header = newMethod header ifFalse:
[Transcript show: ' difft header'].
oldMethod literals = newMethod literals ifFalse:
[Transcript show: ' difft literals'].
Transcript endEntry.
badOnes add: cls name , ' ' , selector]]]].
].
self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'.
Preferences disable: #printAlternateSyntax.
!
Item was changed:
----- Method: DialectParser>>assignment: (in category 'as yet unclassified') -----
assignment: varNode
" 'set' (var) 'to' (expression) => AssignmentNode."
| loc |
+ (loc := varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
- (loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
ifTrue: [^self notify: 'Cannot store into' at: loc].
varNode nowHasDef.
self advance. " to "
self expression ifFalse: [^self expected: 'Expression'].
+ parseNode := AssignmentNode new
- parseNode _ AssignmentNode new
variable: varNode
value: parseNode
from: encoder.
^ true!
Item was changed:
----- Method: DialectParser>>blockExpression (in category 'as yet unclassified') -----
blockExpression
"[ ({:var} |) (| {temps} |) (statements) ] => BlockNode."
| variableNodes temporaryBlockVariables |
+ variableNodes := OrderedCollection new.
- variableNodes _ OrderedCollection new.
"Gather parameters."
(self matchToken: 'With') ifTrue:
[[self match: #period]
whileFalse: [variableNodes addLast: (encoder autoBind: self argumentName)]].
+ temporaryBlockVariables := self temporaryBlockVariables.
- temporaryBlockVariables _ self temporaryBlockVariables.
self statements: variableNodes innerBlock: true.
parseNode temporaries: temporaryBlockVariables.
(self match: #rightBracket) ifFalse: [^ self expected: 'Period or right bracket'].
"The scope of the parameters and temporary block variables is no longer active."
temporaryBlockVariables do: [:variable | variable scope: -1].
variableNodes do: [:variable | variable scope: -1]!
Item was changed:
----- Method: DialectParser>>expressionWithInitialKeyword: (in category 'as yet unclassified') -----
expressionWithInitialKeyword: kwdIfAny
| checkpoint |
(hereType == #word and: [here = 'Set' and: [tokenType == #word]]) ifTrue:
["Parse assignment statement 'Set' var 'to' expression"
+ checkpoint := self checkpoint.
- checkpoint _ self checkpoint.
self advance.
token = 'to'
ifTrue: [^ self assignment: self variable]
ifFalse: [self revertToCheckpoint: checkpoint]].
self matchKeyword
ifTrue: ["It's an initial keyword."
kwdIfAny isEmpty ifFalse: [self error: 'compiler logic error'].
^ self expressionWithInitialKeyword: ':' , self advance , ':'].
hereType == #leftBrace
ifTrue: [self braceExpression]
ifFalse: [self primaryExpression ifFalse: [^ false]].
(self messagePart: 3 repeat: true initialKeyword: kwdIfAny)
ifTrue: [hereType == #semicolon ifTrue: [self cascade]].
^ true!
Item was changed:
----- Method: DialectParser>>messagePart:repeat:initialKeyword: (in category 'as yet unclassified') -----
messagePart: level repeat: repeat initialKeyword: kwdIfAny
| start receiver selector args precedence words keywordStart |
+ [receiver := parseNode.
- [receiver _ parseNode.
(self matchKeyword and: [level >= 3])
ifTrue:
+ [start := self startOfNextToken.
+ selector := WriteStream on: (String new: 32).
- [start _ self startOfNextToken.
- selector _ WriteStream on: (String new: 32).
selector nextPutAll: kwdIfAny.
+ args := OrderedCollection new.
+ words := OrderedCollection new.
- args _ OrderedCollection new.
- words _ OrderedCollection new.
[self matchKeyword]
whileTrue:
+ [keywordStart := self startOfNextToken + requestorOffset.
- [keywordStart _ self startOfNextToken + requestorOffset.
selector nextPutAll: self advance , ':'.
words addLast: (keywordStart to: hereEnd + requestorOffset).
self primaryExpression ifFalse: [^ self expected: 'Argument'].
args addLast: parseNode].
+ (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym])
+ ifFalse: [ selector := self correctSelector: selector contents
- (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
- ifFalse: [ selector _ self correctSelector: selector contents
wordIntervals: words
exprInterval: (start to: self endOfLastToken)
ifAbort: [ ^ self fail ] ].
+ precedence := 3]
- precedence _ 3]
ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
and: [level >= 2])
ifTrue:
+ [start := self startOfNextToken.
+ selector := self advance asSymbol.
- [start _ self startOfNextToken.
- selector _ self advance asSymbol.
self primaryExpression ifFalse: [^self expected: 'Argument'].
self messagePart: 1 repeat: true.
+ args := Array with: parseNode.
+ precedence := 2]
- args _ Array with: parseNode.
- precedence _ 2]
ifFalse: [(hereType == #word
and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not])
ifTrue:
+ [start := self startOfNextToken.
+ selector := self advance.
+ args := #().
+ words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset).
+ (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym])
+ ifFalse: [ selector := self correctSelector: selector
- [start _ self startOfNextToken.
- selector _ self advance.
- args _ #().
- words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset).
- (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
- ifFalse: [ selector _ self correctSelector: selector
wordIntervals: words
exprInterval: (start to: self endOfLastToken)
ifAbort: [ ^ self fail ] ].
+ precedence := 1]
- precedence _ 1]
ifFalse: [^args notNil]]].
+ parseNode := MessageNode new
- parseNode _ MessageNode new
receiver: receiver
selector: selector
arguments: args
precedence: precedence
from: encoder
sourceRange: (start to: self endOfLastToken).
repeat]
whileTrue: [].
^true!
Item was changed:
----- Method: DialectParser>>parseArgsAndTemps:notifying: (in category 'as yet unclassified') -----
parseArgsAndTemps: aString notifying: req
"Parse the argument, aString, notifying req if an error occurs. Otherwise,
answer a two-element Array containing Arrays of strings (the argument
names and temporary variable names)."
aString == nil ifTrue: [^#()].
+ doitFlag := false. "Don't really know if a doit or not!!"
- doitFlag _ false. "Don't really know if a doit or not!!"
^self initPattern: aString
notifying: req
return: [:pattern | (pattern at: 2) , self temporaries]!
Item was changed:
----- Method: DialectParser>>pattern:inContext: (in category 'as yet unclassified') -----
pattern: fromDoit inContext: ctxt
" unarySelector | binarySelector arg | keyword arg {keyword arg} =>
{selector, arguments, precedence}."
| args selector checkpoint |
+ doitFlag := fromDoit.
- doitFlag _ fromDoit.
fromDoit ifTrue:
[ctxt == nil
ifTrue: [^ {#DoIt. {}. 1}]
ifFalse: [^ {#DoItIn:. {encoder encodeVariable: 'homeContext'}. 3}]].
"NOTE: there is now an ambiguity between
keywordSelector (argName) -and- unarySelector (first expression).
Also, there is an amibuity (if there are no temp declarations) between
keywordSelector (argName) -and- PrefixKeyword (some expression).
We use duct tape for now."
(hereType == #word and: [tokenType == #leftParenthesis]) ifTrue:
+ [checkpoint := self checkpoint. "in case we have to back out"
+ selector := WriteStream on: (String new: 32).
+ args := OrderedCollection new.
- [checkpoint _ self checkpoint. "in case we have to back out"
- selector _ WriteStream on: (String new: 32).
- args _ OrderedCollection new.
[hereType == #word
and: [tokenType == #leftParenthesis
and: [here first isLowercase
or: [(#('Test' 'Repeat' 'Answer') includes: here) not]]]]
whileTrue:
[selector nextPutAll: self advance , ':'. "selector part"
self advance. "open paren"
(args size = 0 and: [tokenType ~~ #rightParenthesis]) ifTrue:
["This is really a unary selector on a method that
begins with a parenthesized expression. Back out now"
self revertToCheckpoint: checkpoint.
^ {self advance asSymbol. {}. 1}].
args addLast: (encoder bindArg: self argumentName).
(self match: #rightParenthesis)
ifFalse: [^ self expected: 'right parenthesis']].
^ {selector contents asSymbol. args. 3}].
hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}].
(hereType == #binary or: [hereType == #verticalBar])
ifTrue:
+ [selector := self advance asSymbol.
+ args := Array with: (encoder bindArg: self argumentName).
- [selector _ self advance asSymbol.
- args _ Array with: (encoder bindArg: self argumentName).
^ {selector. args. 2}].
^ self expected: 'Message pattern'!
Item was changed:
----- Method: DialectParser>>temporaries (in category 'as yet unclassified') -----
temporaries
" [ 'Use' (variable)* '.' ]"
| vars theActualText |
(self matchToken: #'Use') ifFalse:
["no temps"
doitFlag ifTrue: [cue requestor
+ ifNil: [tempsMark := 1]
+ ifNotNil: [tempsMark := cue requestor selectionInterval first].
- ifNil: [tempsMark _ 1]
- ifNotNil: [tempsMark _ cue requestor selectionInterval first].
^ #()].
+ tempsMark := prevEnd+1.
- tempsMark _ prevEnd+1.
tempsMark > 0 ifTrue:
+ [theActualText := source contents.
- [theActualText _ source contents.
[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
+ whileTrue: [tempsMark := tempsMark + 1]].
- whileTrue: [tempsMark _ tempsMark + 1]].
^ #()].
+ vars := OrderedCollection new.
- vars _ OrderedCollection new.
[hereType == #word]
whileTrue: [vars addLast: (encoder bindTemp: self advance)].
(self match: #period) ifTrue:
+ [tempsMark := prevMark.
- [tempsMark _ prevMark.
^ vars].
^ self expected: 'Period'!
Item was changed:
----- Method: DialectStream class>>dialect:contents: (in category 'instance creation') -----
dialect: dialectSymbol contents: blockWithArg
"Evaluate blockWithArg on a DialectStream of the given description"
| stream |
+ stream := self on: (Text new: 400).
- stream _ self on: (Text new: 400).
stream setDialect: dialectSymbol.
blockWithArg value: stream.
^ stream contents!
Item was changed:
----- Method: DialectStream class>>initializeST80ColorTable (in category 'class initialization') -----
initializeST80ColorTable
"Initiialize the colors that characterize the ST80 dialect"
+ ST80ColorTable := IdentityDictionary new.
- ST80ColorTable _ IdentityDictionary new.
#( (temporaryVariable blue italic)
(methodArgument blue normal)
(methodSelector black bold)
(blockArgument red normal)
(comment brown normal)
(variable magenta normal)
(literal tan normal)
(keyword darkGray bold)
(prefixKeyword veryDarkGray bold)
(setOrReturn black bold)) do:
[:aTriplet |
ST80ColorTable at: aTriplet first put: aTriplet allButFirst]
"DialectStream initialize"!
Item was changed:
----- Method: DialectStream class>>initializeSq00ColorTable (in category 'class initialization') -----
initializeSq00ColorTable
"Initiialize the colors that characterize the Sq00 dialect"
+ Sq00ColorTable := IdentityDictionary new.
- Sq00ColorTable _ IdentityDictionary new.
#( (temporaryVariable black normal)
(methodArgument black normal)
(methodSelector black bold)
(blockArgument black normal)
(comment brown normal)
(variable black normal)
(literal blue normal)
(keyword darkGray bold)
(prefixKeyword veryDarkGray bold)
(setOrReturn black bold)) do:
[:aTriplet |
Sq00ColorTable at: aTriplet first put: aTriplet allButFirst]!
Item was changed:
----- Method: DialectStream>>colorTable (in category 'color/style') -----
colorTable
"Answer the table to use to determine colors"
^ colorTable ifNil:
+ [colorTable := dialect == #SQ00
- [colorTable _ dialect == #SQ00
ifTrue:
[Sq00ColorTable]
ifFalse:
[ST80ColorTable]]!
Item was changed:
----- Method: DialectStream>>setDialect: (in category 'access') -----
setDialect: dialectSymbol
+ dialect := dialectSymbol!
- dialect _ dialectSymbol!
Item was changed:
----- Method: DialectStream>>withStyleFor:do: (in category 'color/style') -----
withStyleFor: elementType do: aBlock
"Evaluate aBlock with appropriate emphasis and color for the given elementType"
| colorAndStyle |
+ colorAndStyle := self colorTable at: elementType.
- colorAndStyle _ self colorTable at: elementType.
^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock!
Item was changed:
----- Method: Dictionary>>explorerContentsWithIndexCollect: (in category '*Etoys-Squeakland-user interface') -----
explorerContentsWithIndexCollect: twoArgBlock
| sortedKeys |
+ sortedKeys := self keys asSortedCollection: [:x :y |
- sortedKeys _ self keys asSortedCollection: [:x :y |
((x isString and: [y isString])
or: [x isNumber and: [y isNumber]])
ifTrue: [x < y]
ifFalse: [x class == y class
ifTrue: [x printString < y printString]
ifFalse: [x class name < y class name]]].
^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k].
!
Item was changed:
----- Method: Dictionary>>keyAt: (in category '*Etoys-Squeakland-private') -----
keyAt: index
"May be overridden by subclasses so that fixCollisions will work"
| assn |
+ assn := array at: index.
- assn _ array at: index.
assn == nil ifTrue: [^ nil]
ifFalse: [^ assn key]!
Item was changed:
----- Method: Dictionary>>noCheckAdd: (in category '*Etoys-Squeakland-private') -----
noCheckAdd: anObject
"Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association. 9/7/96 tk"
array at: (self findElementOrNil: anObject key) put: anObject.
+ tally := tally + 1!
- tally _ tally + 1!
Item was changed:
----- Method: DocLibrary class>>properStemFor: (in category 'as yet unclassified') -----
properStemFor: classAndMethod
"Put 'class method' into proper form as a file name. Leave upper and lower case. The fileName must be short enough and have proper characters for all platforms and servers."
| sz |
classAndMethod size > 23 ifTrue: ["too long"
+ sz := classAndMethod size.
- sz _ classAndMethod size.
"input contains space and :, not . and ;"
^ (classAndMethod copyFrom: 1 to: 2),
((classAndMethod copyFrom: 3 to: sz//2) crc16 printString),
((classAndMethod copyFrom: sz//2+1 to: sz) crc16 printString)
].
^ (classAndMethod copyReplaceAll: ' ' with: '.')
copyReplaceAll: ':' with: ';'
!
Item was changed:
----- Method: DocLibrary>>absorbAfter:from: (in category 'database of updates') -----
absorbAfter: oldVersion from: fileName
"Read the .ix file and add to the methodVersions database. See class comment."
| server aUrl strm newUpdate newName prevFile classAndMethod updateID key verList new |
+ server := ServerDirectory serverInGroupNamed: group.
- server _ ServerDirectory serverInGroupNamed: group.
"later try multiple servers"
+ aUrl := server altUrl, 'docpane/', fileName.
+ strm := HTTPSocket httpGetNoError: aUrl
- aUrl _ server altUrl, 'docpane/', fileName.
- strm _ HTTPSocket httpGetNoError: aUrl
args: nil accept: 'application/octet-stream'.
strm class == RWBinaryOrTextStream ifFalse: [^ false].
(strm upTo: $ ) = 'External' ifFalse: [strm close. ^ false].
+ newUpdate := Integer readFrom: strm.
- newUpdate _ Integer readFrom: strm.
newUpdate = oldVersion ifTrue: [strm close. ^ false]. "already have it"
strm upTo: $'.
+ newName := strm nextDelimited: $'. strm upTo: Character cr.
+ prevFile := strm upTo: Character cr.
- newName _ strm nextDelimited: $'. strm upTo: Character cr.
- prevFile _ strm upTo: Character cr.
"does this report on updates just after what I know?"
oldVersion = (prevFile splitInteger first) ifFalse: [
strm close. ^ prevFile]. "see earlier sucessor file"
[strm atEnd] whileFalse: [
strm upTo: $'.
+ classAndMethod := strm nextDelimited: $'. strm next.
+ updateID := Integer readFrom: strm.
+ key := DocLibrary properStemFor: classAndMethod.
+ verList := methodVersions at: key ifAbsent: [#()].
- classAndMethod _ strm nextDelimited: $'. strm next.
- updateID _ Integer readFrom: strm.
- key _ DocLibrary properStemFor: classAndMethod.
- verList _ methodVersions at: key ifAbsent: [#()].
(verList includes: updateID) ifFalse: [
+ new := verList, (Array with: updateID with: -1 "file date seen").
- new _ verList, (Array with: updateID with: -1 "file date seen").
methodVersions at: key put: new]].
strm close.
+ lastUpdate := newUpdate.
+ lastUpdateName := newName.
- lastUpdate _ newUpdate.
- lastUpdateName _ newName.
^ true!
Item was changed:
----- Method: DocLibrary>>assureCacheFolder (in category 'doc pane') -----
assureCacheFolder
"Make sure there is a folder docPaneCache and a file: url for it in DocsCachePath. In local folder or one level up. User may wish to install a different path and folder name (as a url). Could be a url to a local server."
| dir local |
DocsCachePath ifNil: [
+ dir := FileDirectory default.
- dir _ FileDirectory default.
(dir includesKey: 'docPaneCache') ifTrue: [
+ DocsCachePath := dir url, 'docPaneCache/']].
- DocsCachePath _ dir url, 'docPaneCache/']].
DocsCachePath ifNil: [
+ dir := FileDirectory default containingDirectory.
+ DocsCachePath := dir url, 'docPaneCache/'.
- dir _ FileDirectory default containingDirectory.
- DocsCachePath _ dir url, 'docPaneCache/'.
(dir includesKey: 'docPaneCache') ifFalse: [
^ dir createDirectory: 'docPaneCache']]. "create the folder"
+ local := ServerDirectory new fullPath: DocsCachePath.
- local _ ServerDirectory new fullPath: DocsCachePath.
local exists ifFalse: [
+ DocsCachePath := nil. "we must be on a new disk"
- DocsCachePath _ nil. "we must be on a new disk"
self assureCacheFolder].!
Item was changed:
----- Method: DocLibrary>>cache:as: (in category 'doc pane') -----
cache: strm as: fileName
"Save the file locally in case the network is not available."
| local |
+ local := ServerDirectory new fullPath: DocsCachePath.
- local _ ServerDirectory new fullPath: DocsCachePath.
(local fileNamed: fileName) nextPutAll: strm contents; close.!
Item was changed:
----- Method: DocLibrary>>docNamesAt: (in category 'doc pane') -----
docNamesAt: classAndMethod
"Return a list of fileNames to try for this method. 'Point x:' is form of classAndMethod."
| key verList fileNames |
+ key := DocLibrary properStemFor: classAndMethod.
+ verList := methodVersions at: key ifAbsent: [#()].
+ fileNames := OrderedCollection new.
- key _ DocLibrary properStemFor: classAndMethod.
- verList _ methodVersions at: key ifAbsent: [#()].
- fileNames _ OrderedCollection new.
1 to: verList size by: 2 do: [:ind |
fileNames addFirst: key,'.',(verList at: ind) printString, '.sp'].
fileNames addLast: key,'.0.sp'.
^ fileNames!
Item was changed:
----- Method: DocLibrary>>docNamesAt:asOf: (in category 'doc pane') -----
docNamesAt: classAndMethod asOf: currentUpdate
"Return a list of fileNames to try for this method. 'Point x:' is form of classAndMethod."
| key verList fileNames |
+ key := DocLibrary properStemFor: classAndMethod.
+ verList := methodVersions at: key ifAbsent: [#()].
+ fileNames := OrderedCollection new.
- key _ DocLibrary properStemFor: classAndMethod.
- verList _ methodVersions at: key ifAbsent: [#()].
- fileNames _ OrderedCollection new.
1 to: verList size by: 2 do: [:ind |
(verList at: ind) <= currentUpdate ifTrue: [
fileNames addFirst: key,'.',(verList at: ind) printString, '.sp']].
fileNames addLast: key,'.0.sp'.
^ fileNames!
Item was changed:
----- Method: DocLibrary>>docObjectAt: (in category 'doc pane') -----
docObjectAt: classAndMethod
"Return a morphic object that is the documentation pane for this method. nil if none can be found. Look on both the network and the disk."
| fileNames server aUrl strm local obj |
methodVersions size = 0 ifTrue: [self updateMethodVersions]. "first time"
+ fileNames := self docNamesAt: classAndMethod.
- fileNames _ self docNamesAt: classAndMethod.
self assureCacheFolder.
+ "server := (ServerDirectory serverInGroupNamed: group) clone." "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up"
+ server := ServerDirectory serverInGroupNamed: group.
- "server _ (ServerDirectory serverInGroupNamed: group) clone." "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up"
- server _ ServerDirectory serverInGroupNamed: group.
"later try multiple servers"
+ aUrl := server altUrl, 'docpane/'.
- aUrl _ server altUrl, 'docpane/'.
fileNames do: [:aVersion |
+ strm := HTTPSocket httpGetNoError: aUrl,aVersion
- strm _ HTTPSocket httpGetNoError: aUrl,aVersion
args: nil accept: 'application/octet-stream'.
strm class == RWBinaryOrTextStream ifTrue: [
self cache: strm as: aVersion.
strm reset.
+ obj := strm fileInObjectAndCode asMorph.
- obj _ strm fileInObjectAndCode asMorph.
(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
self inform: 'suspicious object'.
obj setProperty: #classAndMethod toValue: classAndMethod].
^ obj]. "The pasteUpMorph itself"
"If file not there, error 404, just keep going"].
+ local := ServerDirectory new fullPath: DocsCachePath.
- local _ ServerDirectory new fullPath: DocsCachePath.
"check that it is really there -- let user respecify"
fileNames do: [:aVersion |
(local includesKey: aVersion) ifTrue: [
+ strm := local readOnlyFileNamed: aVersion.
+ obj := strm fileInObjectAndCode asMorph.
- strm _ local readOnlyFileNamed: aVersion.
- obj _ strm fileInObjectAndCode asMorph.
(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
self inform: 'suspicious object'.
obj setProperty: #classAndMethod toValue: classAndMethod].
Transcript cr; show: 'local cache: ', aVersion.
^ obj]. "The pasteUpMorph itself"
"If file not there, just keep looking"].
"Never been documented"
^ nil!
Item was changed:
----- Method: DocLibrary>>fetchDocSel:class: (in category 'doc pane') -----
fetchDocSel: aSelector class: className
"Look on servers to see if there is documentation pane for the selected message. Take into account the current update number. If not, ask the user if she wants to create a blank one."
| key response docPane ext |
+ key := aSelector size = 0
- key _ aSelector size = 0
ifFalse: [className, ' ', aSelector]
ifTrue: [className].
(self openDocAt: key) ifNil: [
+ response := (PopUpMenu labels: 'Create new page\Cancel' withCRs)
- response _ (PopUpMenu labels: 'Create new page\Cancel' withCRs)
startUpWithCaption: 'No documentation exists for this method.\
Would you like to write some?' withCRs.
response = 1 ifTrue: [
+ docPane := PasteUpMorph new.
- docPane _ PasteUpMorph new.
docPane color: Color white; borderWidth: 2; borderColor: Color green.
docPane setProperty: #classAndMethod toValue: key.
+ docPane setProperty: #initialExtent toValue: (ext := 200 at 200).
- docPane setProperty: #initialExtent toValue: (ext _ 200 at 200).
docPane topLeft: (RealEstateAgent initialFrameFor: docPane world: Smalltalk currentWorld) origin.
docPane extent: ext.
docPane addMorph: (TextMorph new topLeft: docPane topLeft + (10 at 10);
extent: docPane width - 15 @ 30).
Smalltalk currentWorld addMorph: docPane]].
"If found, openDocAt: put it on the screen"!
Item was changed:
----- Method: DocLibrary>>initialize (in category 'initialize') -----
initialize
+ lastUpdate := 0.
+ methodVersions := Dictionary new.!
- lastUpdate _ 0.
- methodVersions _ Dictionary new.!
Item was changed:
----- Method: DocLibrary>>openDocAt: (in category 'doc pane') -----
openDocAt: classAndMethod
| docPane |
+ (docPane := self docObjectAt: classAndMethod) ifNotNil: [
- (docPane _ self docObjectAt: classAndMethod) ifNotNil: [
docPane setProperty: #initialExtent toValue: docPane bounds extent.
docPane topLeft: (RealEstateAgent initialFrameFor: docPane world: Smalltalk currentWorld) origin.
Smalltalk currentWorld addMorph: docPane].
^ docPane!
Item was changed:
----- Method: DocLibrary>>saveDoc: (in category 'doc pane') -----
saveDoc: aMorph
"Broadcast this documentation to the Squeak community. Associate it with the method it documents. Send to a drop box, where it can be inspected before being posted on External servers."
| classAndMethod fName remoteFile |
+ classAndMethod := aMorph valueOfProperty: #classAndMethod.
- classAndMethod _ aMorph valueOfProperty: #classAndMethod.
classAndMethod ifNil: [
^ self error: 'need to know the class and method']. "later let user set it"
+ fName := (self docNamesAt: classAndMethod) first.
- fName _ (self docNamesAt: classAndMethod) first.
DropBox user asLowercase = 'anonymous' ifTrue: [
+ fName := fName, 1000 atRandom printString]. "trusted users store directly"
- fName _ fName, 1000 atRandom printString]. "trusted users store directly"
DropBox password. "In case user has to type it. Avoid timeout from server"
Cursor wait showWhile: [
+ remoteFile := DropBox fileNamed: fName.
- remoteFile _ DropBox fileNamed: fName.
remoteFile fileOutClass: nil andObject: aMorph.
"remoteFile close"].
!
Item was changed:
----- Method: DocLibrary>>saveDocCheck: (in category 'doc pane') -----
saveDocCheck: aMorph
"Make sure the document gets attached to the version of the code that the user was looking at. Is there a version of this method in a changeSet beyond the updates we know about? Works even when the user has internal update numbers and the documentation is for external updates (It always is)."
| classAndMethod parts selector class lastUp beyond ours docFor unNum ok key verList ext response |
+ classAndMethod := aMorph valueOfProperty: #classAndMethod.
- classAndMethod _ aMorph valueOfProperty: #classAndMethod.
classAndMethod ifNil: [
^ self error: 'need to know the class and method']. "later let user set it"
+ parts := classAndMethod findTokens: ' .'.
+ selector := parts last asSymbol.
+ class := Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph].
+ parts size = 3 ifTrue: [class := class class].
- parts _ classAndMethod findTokens: ' .'.
- selector _ parts last asSymbol.
- class _ Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph].
- parts size = 3 ifTrue: [class _ class class].
"Four indexes we are looking for:
docFor = highest numbered below lastUpdate that has method.
unNum = a higher unnumbered set that has method.
lastUp = lastUpdate we know about in methodVersions
beyond = any set about lastUp that has the method."
ChangeSorter allChangeSets doWithIndex: [:cs :ind | "youngest first"
+ (cs name includesSubString: lastUpdateName) ifTrue: [lastUp := ind].
- (cs name includesSubString: lastUpdateName) ifTrue: [lastUp _ ind].
(cs atSelector: selector class: class) ~~ #none ifTrue: [
+ lastUp ifNotNil: [beyond := ind. ours := cs name]
+ ifNil: [cs name first isDigit ifTrue: [docFor := ind]
+ ifFalse: [unNum := ind. ours := cs name]]]].
- lastUp ifNotNil: [beyond _ ind. ours _ cs name]
- ifNil: [cs name first isDigit ifTrue: [docFor _ ind]
- ifFalse: [unNum _ ind. ours _ cs name]]]].
"See if version the user sees is the version he is documenting"
+ ok := beyond == nil.
+ unNum ifNotNil: [docFor ifNotNil: [ok := docFor > unNum]
+ ifNil: [ok := false]]. "old changeSets gone"
- ok _ beyond == nil.
- unNum ifNotNil: [docFor ifNotNil: [ok _ docFor > unNum]
- ifNil: [ok _ false]]. "old changeSets gone"
ok ifTrue: [^ self saveDoc: aMorph].
+ key := DocLibrary properStemFor: classAndMethod.
+ verList := (methodVersions at: key ifAbsent: [#()]), #(0 0).
+ ext := verList first. "external update number we will write to"
+ response := (PopUpMenu labels: 'Cancel\Broadcast Page' withCRs)
- key _ DocLibrary properStemFor: classAndMethod.
- verList _ (methodVersions at: key ifAbsent: [#()]), #(0 0).
- ext _ verList first. "external update number we will write to"
- response _ (PopUpMenu labels: 'Cancel\Broadcast Page' withCRs)
startUpWithCaption: 'You are documenting a method in External Update ', ext asString, '.\There is a more recent version of that method in ' withCRs, ours,
'.\If you are explaining the newer version, please Cancel.\Wait until that version appears in an External Update.' withCRs.
response = 2 ifTrue: [self saveDoc: aMorph].
!
Item was changed:
----- Method: DocLibrary>>scan:updateID: (in category 'database of updates') -----
scan: updateStream updateID: updateID
"Scan this update file and remember the update numbers of the methods."
| changeList ee semi key verList new |
updateStream reset; readOnly.
Cursor read showWhile:
+ [changeList := ChangeList new
- [changeList _ ChangeList new
scanFile: updateStream from: 0 to: updateStream size].
changeList list do: [:entry |
+ ee := nil.
- ee _ nil.
(entry beginsWith: 'method: ') ifTrue: [
+ (semi := entry indexOf: $;) = 0
+ ifTrue: [semi := entry size]
+ ifFalse: [semi := semi-1].
+ ee := entry copyFrom: 9 to: semi].
- (semi _ entry indexOf: $;) = 0
- ifTrue: [semi _ entry size]
- ifFalse: [semi _ semi-1].
- ee _ entry copyFrom: 9 to: semi].
(entry beginsWith: 'class comment for ') ifTrue: [
+ (semi := entry indexOf: $;) = 0
+ ifTrue: [semi := entry size]
+ ifFalse: [semi := semi-1].
+ ee := entry copyFrom: 19 to: semi]. "comment for whole class"
- (semi _ entry indexOf: $;) = 0
- ifTrue: [semi _ entry size]
- ifFalse: [semi _ semi-1].
- ee _ entry copyFrom: 19 to: semi]. "comment for whole class"
ee ifNotNil: [
+ key := DocLibrary properStemFor: ee.
- key _ DocLibrary properStemFor: ee.
Transcript show: key; cr.
+ verList := methodVersions at: key ifAbsent: [#()].
- verList _ methodVersions at: key ifAbsent: [#()].
(verList includes: updateID) ifFalse: [
+ new := verList, (Array with: updateID with: -1 "file date seen").
- new _ verList, (Array with: updateID with: -1 "file date seen").
methodVersions at: key put: new]].
].!
Item was changed:
----- Method: DocLibrary>>scan:updateID:writeOn: (in category 'database of updates') -----
scan: updateStream updateID: updateID writeOn: strm
"Scan this update file and remember the update numbers of the methods."
| changeList ee semi |
updateStream reset; readOnly.
Cursor read showWhile:
+ [changeList := ChangeList new
- [changeList _ ChangeList new
scanFile: updateStream from: 0 to: updateStream size].
changeList list do: [:entry |
+ ee := nil.
- ee _ nil.
(entry beginsWith: 'method: ') ifTrue: [
+ (semi := entry indexOf: $;) = 0
+ ifTrue: [semi := entry size]
+ ifFalse: [semi := semi-1].
+ ee := entry copyFrom: 9 to: semi].
- (semi _ entry indexOf: $;) = 0
- ifTrue: [semi _ entry size]
- ifFalse: [semi _ semi-1].
- ee _ entry copyFrom: 9 to: semi].
(entry beginsWith: 'class comment for ') ifTrue: [
+ (semi := entry indexOf: $;) = 0
+ ifTrue: [semi := entry size]
+ ifFalse: [semi := semi-1].
+ ee := entry copyFrom: 19 to: semi]. "comment for whole class"
- (semi _ entry indexOf: $;) = 0
- ifTrue: [semi _ entry size]
- ifFalse: [semi _ semi-1].
- ee _ entry copyFrom: 19 to: semi]. "comment for whole class"
ee ifNotNil: [
Transcript show: ee; cr.
strm cr; nextPutAll: ee surroundedBySingleQuotes; space;
nextPutAll: updateID asString].
].!
Item was changed:
----- Method: DocLibrary>>scanFolder:from: (in category 'database of updates') -----
scanFolder: directoryUrl from: updateID
"Scan all update files in the directory starting at updateID+1. updates.list must be present to tell us the file names."
| updateList line num |
+ updateList := (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
+ [line := updateList upTo: Character cr.
- updateList _ (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
- [line _ updateList upTo: Character cr.
updateList atEnd] whileFalse: [
line first isDigit ifTrue: [
+ num := line splitInteger first.
- num _ line splitInteger first.
num > updateID ifTrue: [
self scan: (ServerFile new fullPath: directoryUrl,line) asStream
updateID: num]
]].
lastUpdate <= num ifTrue: [
+ lastUpdate := num.
+ lastUpdateName := line splitInteger last].
- lastUpdate _ num.
- lastUpdateName _ line splitInteger last].
!
Item was changed:
----- Method: DocLibrary>>scanUpdatesIn: (in category 'database of updates') -----
scanUpdatesIn: directoryUrl
"Scan all update files in the directory starting at lastUpdate+1. Create a .ix file on my local hard disk. updates.list must be present to tell us the file names."
| updateList line num temp out |
+ updateList := (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
+ temp := WriteStream on: (String new: 2000).
+ [line := updateList upTo: Character cr.
- updateList _ (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
- temp _ WriteStream on: (String new: 2000).
- [line _ updateList upTo: Character cr.
updateList atEnd] whileFalse: [
line first isDigit ifTrue: [
+ num := line splitInteger first.
- num _ line splitInteger first.
num > lastUpdate ifTrue: [
self scan: (ServerFile new fullPath: directoryUrl,line) asStream
updateID: num writeOn: temp]
]].
num >= lastUpdate ifTrue: [
+ out := FileStream newFileNamed: 'to', num asString, '.ix'.
- out _ FileStream newFileNamed: 'to', num asString, '.ix'.
out nextPutAll: 'External ', num asString; space.
line splitInteger last storeOn: out. "quoted"
out cr; nextPutAll: lastUpdate asString, '.ix' "; cr". "temp begins with cr"
out nextPutAll: temp contents; close.
self inform: 'Rename latest.ix to ', lastUpdate asString,
'.ix on both external servers.
Put to', num asString, '.ix on both and call it latest.ix'].
!
Item was changed:
----- Method: DocLibrary>>setUp (in category 'initialize') -----
setUp
"set up the External version"
| email |
self initialize.
+ External := self.
+ group := 'Squeak Public Updates'. "right for http, but not for ftp"
+ lastUpdate := 599.
+ lastUpdateName := 'MTMcontainsPoint-ar.cs'.
+ DropBox := ServerDirectory new.
- External _ self.
- group _ 'Squeak Public Updates'. "right for http, but not for ftp"
- lastUpdate _ 599.
- lastUpdateName _ 'MTMcontainsPoint-ar.cs'.
- DropBox _ ServerDirectory new.
DropBox server: 'squeak.cs.uiuc.edu'; directory: 'incoming'.
DropBox type: #ftp.
+ email := nil. "Celeste popUserName." "If nil, we ask at drop time"
- email _ nil. "Celeste popUserName." "If nil, we ask at drop time"
DropBox user: 'anonymous'; password: email.
DropBox moniker: 'Doc Pane DropBox'.
"later allow a second server"
!
Item was changed:
----- Method: DocLibrary>>updateMethodVersions (in category 'database of updates') -----
updateMethodVersions
"See if any new updates have occurred, and put their methods into the database."
| indexFile list result |
+ indexFile := 'latest.ix'.
+ list := OrderedCollection new.
+ [result := self absorbAfter: lastUpdate from: indexFile.
- indexFile _ 'latest.ix'.
- list _ OrderedCollection new.
- [result _ self absorbAfter: lastUpdate from: indexFile.
"boolean if succeeded, or we are up to date, or server not available"
result isString] whileTrue: [
"result is the prev file name"
list addFirst: indexFile.
+ indexFile := result].
- indexFile _ result].
list do: [:aFile | self absorbAfter: lastUpdate from: aFile].
"should always work this time"
!
Item was changed:
----- Method: DoubleClickExample>>startDrag: (in category 'event handling') -----
startDrag: evt
"We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
| oldCenter |
evt isMouseDown ifTrue:
[self showBalloon: 'drag (mouse down)' hand: evt hand.
self world displayWorld.
(Delay forMilliseconds: 750) wait].
evt isMouseUp ifTrue:
[self showBalloon: 'drag (mouse up)' hand: evt hand].
(evt isMouseUp or: [evt isMouseDown]) ifFalse:
[self showBalloon: 'drag (mouse still down)' hand: evt hand].
(self containsPoint: evt cursorPoint)
ifFalse: [^ self].
+ oldCenter := self center.
- oldCenter _ self center.
color = Color red
ifTrue:
[self extent: self extent + (1 at 1)]
ifFalse:
[self extent: ((self extent - (1 at 1)) max: (16 at 16))].
self center: oldCenter!
Item was changed:
----- Method: DownloadingImageMorph>>altText: (in category 'as yet unclassified') -----
altText: aString
"set the text to be displayed while downloading"
+ altText := aString.
- altText _ aString.
aString ifNotNil: [self setBalloonText: aString].
self setContents!
Item was changed:
----- Method: DownloadingImageMorph>>defaultExtent: (in category 'as yet unclassified') -----
defaultExtent: aPoint
"set the size to use when the image hasn't yet downloaded"
+ defaultExtent := aPoint!
- defaultExtent _ aPoint!
Item was changed:
----- Method: DownloadingImageMorph>>downloadStateIn: (in category 'as yet unclassified') -----
downloadStateIn: aScamper
"download the image"
| doc |
+ doc := url retrieveContents.
- doc _ url retrieveContents.
downloadQueue nextPut: doc.
!
Item was changed:
----- Method: DownloadingImageMorph>>formatter: (in category 'accessing') -----
formatter: aFormatter
+ formatter := aFormatter!
- formatter _ aFormatter!
Item was changed:
----- Method: DownloadingImageMorph>>imageMapName: (in category 'accessing') -----
imageMapName: aString
+ imageMapName := aString!
- imageMapName _ aString!
Item was changed:
----- Method: DownloadingImageMorph>>initialize (in category 'as yet unclassified') -----
initialize
super initialize.
+ altText := '[image]'.
- altText _ '[image]'.
self color: Color transparent.
+ downloadQueue := SharedQueue new.!
- downloadQueue _ SharedQueue new.!
Item was changed:
----- Method: DownloadingImageMorph>>setContents (in category 'as yet unclassified') -----
setContents
"set up our morphic contents"
| imageMorph imageMap |
self removeAllMorphs.
image ifNil: [^self setNoImageContents].
defaultExtent isNil
+ ifTrue: [(imageMorph := ImageMorph new) image: image]
- ifTrue: [(imageMorph _ ImageMorph new) image: image]
ifFalse: [imageMorph := SketchMorph withForm: image].
(imageMapName notNil
and: [formatter notNil
+ and: [(imageMap := formatter imageMapNamed: imageMapName) notNil]])
- and: [(imageMap _ formatter imageMapNamed: imageMapName) notNil]])
ifTrue: [imageMap buildImageMapForImage: imageMorph andBrowser: formatter browser].
imageMorph position: self position.
self addMorph: imageMorph.
defaultExtent isNil
ifFalse: [imageMorph extent: defaultExtent].
self extent ~= imageMorph extent
ifTrue: [ self extent: imageMorph extent ]!
Item was changed:
----- Method: DownloadingImageMorph>>setNoImageContents (in category 'as yet unclassified') -----
setNoImageContents
"set up our morphic contents in case image download/decoding failed"
| stringMorph outlineMorph extent |
altText isEmptyOrNil
ifTrue: [ self extent: 0 at 0. "don't display anything..." ^self ].
+ stringMorph := StringMorph new.
- stringMorph _ StringMorph new.
stringMorph contents: altText.
stringMorph position: self position+(2 at 2).
self addMorph: stringMorph.
+ outlineMorph := RectangleMorph new.
- outlineMorph _ RectangleMorph new.
outlineMorph borderWidth: 1.
outlineMorph color: Color transparent.
outlineMorph position: self position.
"figure out how big to make the box"
+ extent := defaultExtent ifNil: [ 0 @ 0 ].
- extent _ defaultExtent ifNil: [ 0 @ 0 ].
stringMorph width + 4 > extent x ifTrue: [
+ extent := (stringMorph width + 4) @ extent y ].
- extent _ (stringMorph width + 4) @ extent y ].
stringMorph height + 4 > extent y ifTrue: [
+ extent := extent x @ (stringMorph height + 4) ].
- extent _ extent x @ (stringMorph height + 4) ].
outlineMorph extent: extent.
self addMorph: outlineMorph.
self extent: outlineMorph extent
!
Item was changed:
----- Method: DownloadingImageMorph>>step (in category 'as yet unclassified') -----
step
| doc |
downloadQueue size > 0 ifTrue: [
+ doc := downloadQueue next.
- doc _ downloadQueue next.
(doc notNil and: [doc mainType = 'image'])
ifTrue: [
+ [image := ImageReadWriter formFromStream: doc contentStream binary]
+ ifError: [:err :rcvr | "ignore" image := nil].
- [image _ ImageReadWriter formFromStream: doc contentStream binary]
- ifError: [:err :rcvr | "ignore" image _ nil].
self setContents ] ].!
Item was changed:
----- Method: DownloadingImageMorph>>url: (in category 'as yet unclassified') -----
url: aUrl
"set the url to download"
+ url := aUrl asUrl.!
- url _ aUrl asUrl.!
Item was changed:
----- Method: EFontBDFFontReaderForRanges>>additionalRangesForSimplifiedChinese (in category '*Etoys-Squeakland-as yet unclassified') -----
additionalRangesForSimplifiedChinese
| basics |
+ basics := {
- basics _ {
{16rFF00. 16rFF60}
}.
^ basics
!
Item was changed:
----- Method: EFontBDFFontReaderForRanges>>override2:with:ranges:transcodingTable:additionalRange: (in category '*Etoys-Squeakland-as yet unclassified') -----
override2: chars with: otherFileName ranges: pairArray transcodingTable: table additionalRange: additionalRanges
| other newChars form u j in newArray |
+ other := BDFFontReader readOnlyFileNamed: otherFileName.
- other _ BDFFontReader readOnlyFileNamed: otherFileName.
+ newChars := PluggableSet new.
- newChars _ PluggableSet new.
newChars hashBlock: [:elem | (elem at: 2) hash].
newChars equalBlock: [:a :b | (a at: 2) = (b at: 2)].
other readChars do: [:array |
+ j := array at: 2.
+ u := table at: (((j // 256) - 33 * 94 + ((j \\ 256) - 33)) + 1).
- j _ array at: 2.
- u _ table at: (((j // 256) - 33 * 94 + ((j \\ 256) - 33)) + 1).
u ~= -1 ifTrue: [
u hex printString displayAt: 0 at 0.
+ in := false.
- in _ false.
pairArray do: [:pair |
(u between: pair first and: pair second) ifTrue: [
+ in := true
- in _ true
]
].
in ifTrue: [
+ form := array at: 1.
- form _ array at: 1.
form ifNotNil: [
+ newArray := array clone.
- newArray _ array clone.
newArray at: 2 put: u.
newChars add: newArray.
].
].
].
].
newChars addAll: chars.
^ newChars.
!
Item was changed:
----- Method: EFontBDFFontReaderForRanges>>rangesForSimplifiedChinese (in category '*Etoys-Squeakland-as yet unclassified') -----
rangesForSimplifiedChinese
| basics etc |
+ basics := {
- basics _ {
Array with: 16rA1 with: 16rFF
}.
+ etc := {
- etc _ {
Array with: 16r100 with: 16r17F. "extended latin"
Array with: 16r370 with: 16r3FF. "greek"
Array with: 16r400 with: 16r52F. "cyrillic"
Array with: 16r2000 with: 16r206F. "general punctuation"
Array with: 16r2100 with: 16r214F. "letterlike"
Array with: 16r2150 with: 16r218F. "number form"
Array with: 16r2190 with: 16r21FF. "arrows"
Array with: 16r2200 with: 16r22FF. "math operators"
Array with: 16r2300 with: 16r23FF. "misc tech"
Array with: 16r2460 with: 16r24FF. "enclosed alnum"
Array with: 16r2500 with: 16r257F. "box drawing"
Array with: 16r2580 with: 16r259F. "box elem"
Array with: 16r25A0 with: 16r25FF. "geometric shapes"
Array with: 16r2600 with: 16r26FF. "misc symbols"
Array with: 16r3000 with: 16r303F. "cjk symbols"
Array with: 16r3040 with: 16r309F. "hiragana"
Array with: 16r30A0 with: 16r30FF. "katakana"
Array with: 16r3190 with: 16r319F. "kanbun"
Array with: 16r31F0 with: 16r31FF. "katakana extension"
Array with: 16r3200 with: 16r32FF. "enclosed CJK"
Array with: 16r3300 with: 16r33FF. "CJK compatibility"
Array with: 16r4E00 with: 16r9FAF. "CJK ideograph"
Array with: 16rAC00 with: 16rD7AF. "Hangul Syllables"
Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph"
Array with: 16rFF00 with: 16rFFEF. "half and full"
}.
^ basics, etc.
!
Item was changed:
----- Method: EFontBDFFontReaderForRanges>>readCharactersInRanges2:storeInto: (in category '*Etoys-Squeakland-as yet unclassified') -----
readCharactersInRanges2: ranges storeInto: chars
| array form code rangeStream in |
+ rangeStream := ReadStream on: ranges.
- rangeStream _ ReadStream on: ranges.
[true] whileTrue: [
+ array := self readOneCharacter.
- array _ self readOneCharacter.
array second ifNil: [^ self].
+ code := array at: 2.
+ in := false.
- code _ array at: 2.
- in _ false.
ranges do: [:range |
(code between: range first and: range last) ifTrue: [
+ in := true.
- in _ true.
].
].
in ifTrue: [
+ form := array at: 1.
- form _ array at: 1.
form ifNotNil: [
chars add: array.
].
].
].
!
Item was changed:
----- Method: EFontBDFFontReaderForRanges>>readRangesForSimplifiedChinese:overrideWith:otherRanges:additionalOverrideRange: (in category '*Etoys-Squeakland-as yet unclassified') -----
readRangesForSimplifiedChinese: ranges overrideWith: otherFileName otherRanges: otherRanges additionalOverrideRange: additionalRange
| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end |
+ form := encoding := bbx := nil.
- form _ encoding _ bbx _ nil.
self initialize.
self readAttributes.
+ height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2).
+ ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first.
+ descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first.
- height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2).
- ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first.
- descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first.
(properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [
+ pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
- pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
] ifFalse: [
+ pointSize := (ascent + descent) * 72 // 96.
- pointSize _ (ascent + descent) * 72 // 96.
].
+ maxWidth := 0.
+ minAscii := 16r200000.
+ strikeWidth := 0.
+ maxAscii := 0.
- maxWidth _ 0.
- minAscii _ 16r200000.
- strikeWidth _ 0.
- maxAscii _ 0.
+ charsNum := Integer readFromString: (properties at: #CHARS) first.
+ chars := Set new: charsNum.
- charsNum _ Integer readFromString: (properties at: #CHARS) first.
- chars _ Set new: charsNum.
self readCharactersInRanges2: ranges storeInto: chars.
+ chars := self override2: chars with: otherFileName ranges: otherRanges transcodingTable: (UCSTable jisx0208Table) additionalRange: additionalRange.
- chars _ self override2: chars with: otherFileName ranges: otherRanges transcodingTable: (UCSTable jisx0208Table) additionalRange: additionalRange.
+ chars := chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].
+ charsNum := chars size. "undefined encodings make this different"
- chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].
- charsNum _ chars size. "undefined encodings make this different"
chars do: [:array |
+ encoding := array at: 2.
+ bbx := array at: 3..
+ width := bbx at: 1.
+ maxWidth := maxWidth max: width.
+ minAscii := minAscii min: encoding.
+ maxAscii := maxAscii max: encoding.
+ strikeWidth := strikeWidth + width.
- encoding _ array at: 2.
- bbx _ array at: 3..
- width _ bbx at: 1.
- maxWidth _ maxWidth max: width.
- minAscii _ minAscii min: encoding.
- maxAscii _ maxAscii max: encoding.
- strikeWidth _ strikeWidth + width.
].
+ glyphs := Form extent: strikeWidth at height.
+ blt := BitBlt toForm: glyphs.
+ start := ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min.
+ end := ((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 3.
+ "xRange := Array with: (Array with: ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min
- glyphs _ Form extent: strikeWidth at height.
- blt _ BitBlt toForm: glyphs.
- start _ ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min.
- end _ ((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 3.
- "xRange _ Array with: (Array with: ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min
with: (((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 2))."
+ "xTable := XTableForUnicodeFont new
- "xTable _ XTableForUnicodeFont new
ranges: xRange."
+ xTable := SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start defaultValue: -1.
+ lastAscii := start.
- xTable _ SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start defaultValue: -1.
- lastAscii _ start.
xTable at: lastAscii + 2 put: 0.
1 to: charsNum do: [:i |
+ form := (chars at: i) first.
+ encoding := (chars at: i) second.
+ bbx := (chars at: i) third.
- form _ (chars at: i) first.
- encoding _ (chars at: i) second.
- bbx _ (chars at: i) third.
"lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]."
+ lastValue := xTable at: lastAscii + 1 + 1.
- lastValue _ xTable at: lastAscii + 1 + 1.
xTable at: encoding + 1 put: lastValue.
blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4)))
extent: (bbx at: 1)@(bbx at: 2))
from: 0 at 0 in: form.
xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1).
+ lastAscii := encoding.
- lastAscii _ encoding.
].
xTable at: xTable size put: (xTable at: xTable size - 1).
xTable zapDefaultOnlyEntries.
+ ret := Array new: 8.
- ret _ Array new: 8.
ret at: 1 put: xTable.
ret at: 2 put: glyphs.
ret at: 3 put: minAscii.
ret at: 4 put: maxAscii.
ret at: 5 put: maxWidth.
ret at: 6 put: ascent.
ret at: 7 put: descent.
ret at: 8 put: pointSize.
^ret.
" ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"
!
Item was changed:
----- Method: EToyExpressionTransformer>>inputQueueNext (in category 'all') -----
inputQueueNext
| e f |
+ e := inputQueue removeFirst.
- e _ inputQueue removeFirst.
inputQueue size > 0 ifTrue: [
+ f := inputQueue removeFirst.
- f _ inputQueue removeFirst.
(f isMemberOf: MessageNode) ifTrue: [
self pushAMessageNode: f
] ifFalse: [
inputQueue addFirst: f
].
].
^ e.
!
Item was changed:
----- Method: EToyExpressionTransformer>>newMessageFor:encoder: (in category 'all') -----
newMessageFor: aMessageNode encoder: e
+ encoder := e.
+ inputQueue := OrderedCollection new: 3.
- encoder _ e.
- inputQueue _ OrderedCollection new: 3.
self pushAMessageNode: aMessageNode.
+ stack := OrderedCollection new: 3.
- stack _ OrderedCollection new: 3.
!
Item was changed:
----- Method: EToyExpressionTransformer>>pushAMessageNode: (in category 'all') -----
pushAMessageNode: node
| s |
node isEToyBinaryExp ifTrue: [
inputQueue addLast: node receiver.
+ inputQueue addLast: ((s := node selector) isSymbol ifTrue: [s] ifFalse: [s key]).
- inputQueue addLast: ((s _ node selector) isSymbol ifTrue: [s] ifFalse: [s key]).
inputQueue addLast: node arguments first.
] ifFalse: [
inputQueue addLast: node
].
!
Item was changed:
----- Method: EToyExpressionTransformer>>reduceOnStack (in category 'all') -----
reduceOnStack
| list left sel right m |
+ list := stack removeLast: 3.
+ left := list at: 1.
+ sel := list at: 2.
+ right := list at: 3.
- list _ stack removeLast: 3.
- left _ list at: 1.
- sel _ list at: 2.
- right _ list at: 3.
m _ MessageNode new
receiver: left
selector: sel
arguments: (Array with: right)
precedence: (sel precedence)
from: encoder
sourceRange: nil.
stack addLast: m.
!
Item was changed:
----- Method: EToyExpressionTransformer>>transform (in category 'all') -----
transform
| leftPrec rightPrec n |
[(self inputQueueEmpty and: [stack size = 1]) not] whileTrue: [
+ leftPrec := self precl.
+ rightPrec := self precr: (n := self inputQueuePeek).
- leftPrec _ self precl.
- rightPrec _ self precr: (n _ self inputQueuePeek).
leftPrec >= rightPrec ifTrue: [
self reduceOnStack.
] ifFalse: [
self inputQueueNext.
stack addLast: n.
].
].
^ stack last.
!
Item was changed:
----- Method: EToyProjectDetailsMorph>>rebuild (in category 'initialization') -----
rebuild
"Rebuild the receiver from scratch."
| bottomButtons header toAdd |
self removeAllMorphs.
header := self addARow: {
self lockedString: 'Please describe this project' translated.
}.
header color: ScriptingSystem baseColor.
self addARow: {
self lockedString: 'Project Name' translated.
self inAColumnForText: {self fieldForProjectName}
}.
self expandedFormat ifTrue: [
self fieldToDetailsMappings do: [ :each |
toAdd := (each size < 5 or: [each fifth = #text])
ifTrue:
[self genericTextFieldNamed: each first]
ifFalse:
[self popUpEntryNamed: each first menuTitle: each third].
self addARow: {
self lockedString: each third translated.
self inAColumnForText: {toAdd height: each fourth}
}.
].
].
+ bottomButtons := self expandedFormat ifTrue: [
- bottomButtons _ self expandedFormat ifTrue: [
{
self okButton.
self cancelButton.
}
] ifFalse: [
{
self okButton.
self expandButton.
self cancelButton.
}
].
self addARow: bottomButtons.
self fillInDetails.!
Item was changed:
----- Method: EToyProjectQueryMorph class>>onServer: (in category 'instance creation') -----
onServer: aProjectServer
"EToyProjectQueryMorph onServer: SuperSwikiServer testOnlySuperSwiki"
| detailsMorph messageToSendIfValid |
detailsMorph := self basicNew.
messageToSendIfValid := MessageSend receiver: detailsMorph selector: #carryOutQuery:onProjectServer: arguments: {nil. aProjectServer}.
detailsMorph
project: nil
actionBlock: messageToSendIfValid;
"*** actionBlock: [ :x |
+ criteria := OrderedCollection new.
- criteria _ OrderedCollection new.
x keysAndValuesDo: [ :k :v |
+ (clean := v withBlanksTrimmed convertToEncoding: SuperSwikiServer defaultEncodingName) isEmpty
- (clean _ v withBlanksTrimmed convertToEncoding: SuperSwikiServer defaultEncodingName) isEmpty
ifFalse: [criteria add: k,': *',clean,'*']].
aProjectServer queryProjectsAndShow: criteria]; ****"
initialize;
becomeModal;
openCenteredInWorld!
Item was changed:
----- Method: EToyProjectQueryMorph>>carryOutQuery:onProjectServer: (in category '*Etoys-Squeakland-query') -----
carryOutQuery: details onProjectServer: aProjectServer
"The user submitted a query; the parameter holds the details dictionary. Carry out the query."
| criteria clean |
criteria := OrderedCollection new.
details keysAndValuesDo:
[ :k :v |
+ (clean := v withBlanksTrimmed convertToEncoding: SuperSwikiServer defaultEncodingName) isEmpty
- (clean _ v withBlanksTrimmed convertToEncoding: SuperSwikiServer defaultEncodingName) isEmpty
ifFalse: [criteria add: k,': *',clean,'*']].
aProjectServer queryProjectsAndShow: criteria!
Item was changed:
----- Method: Encoder>>requestor: (in category '*Etoys-Squeakland-error handling') -----
requestor: req
"Often the requestor is a BrowserCodeController"
+ requestor := req!
- requestor _ req!
Item was changed:
----- Method: EtoyDAVLoginMorph>>buttonNamed:action:color:help: (in category 'building') -----
buttonNamed: aString action: aSymbol color: aColor help: helpString
| f col |
+ f := SimpleButtonMorph new
- f _ SimpleButtonMorph new
target: self;
label: aString font: self myFont;
color: aColor;
actionSelector: aSymbol;
setBalloonText: helpString.
+ col := (self inAColumn: {f}) hResizing: #spaceFill.
- col _ (self inAColumn: {f}) hResizing: #spaceFill.
^col!
Item was changed:
----- Method: EtoyDAVLoginMorph>>doOK (in category 'actions') -----
doOK
| proposed proposedPass |
+ proposed := theNameMorph contents string.
- proposed _ theNameMorph contents string.
proposed isEmpty ifTrue: [^self inform: 'Please enter your login name' translated].
proposed size > 24 ifTrue: [^self inform: 'Please make the name 24 characters or less' translated].
(Project isBadNameForStoring: proposed) ifTrue: [
^self inform: 'Please remove any funny characters' translated
].
proposedPass := thePasswordMorph contents string.
(actionBlock value: proposed value: proposedPass) ifTrue:[self delete].!
Item was changed:
----- Method: EtoyDAVLoginMorph>>name:actionBlock:cancelBlock: (in category 'initialize') -----
name: aString actionBlock: aBlock cancelBlock: altBlock
+ theName := aString.
+ actionBlock := aBlock.
+ cancelBlock := altBlock.
- theName _ aString.
- actionBlock _ aBlock.
- cancelBlock _ altBlock.
theNameMorph contentsWrapped: theName.
theNameMorph editor selectAll.!
Item was changed:
----- Method: EtoyDAVLoginMorph>>rebuild (in category 'initialize') -----
rebuild
| title link |
self removeAllMorphs.
title := StringMorph contents: 'Login to Squeakland' translated font: self myFont.
title lock.
link := StringMorph contents: '(create account)' translated font: Preferences standardListFont emphasis: 4.
link color: Color blue.
link beSticky.
link on: #click send: #launchBrowser to: self.
self addARow: { title. self newSpacer: Color transparent. link}.
self addARow: { (StringMorph contents:'') lock }.
(self addARow: {
(StringMorph contents: 'Username:' translated font: self myFont) lock.
Morph new extent: 15 at 0; color: Color transparent.
self newSpacer: Color transparent.
+ (theNameMorph := TextMorph new
- (theNameMorph _ TextMorph new
beAllFont: self myFont;
crAction: (MessageSend receiver: self selector: #doOK);
extent: 250 at 20;
borderStyle: (InsetBorder new color: Color black; width: 2);
contentsWrapped: 'the old name'
).
}) color: self defaultColor; borderWidth: 0.
self addARow: { (StringMorph contents:'') lock }.
(self addARow: {
(StringMorph contents: 'Password:' translated font: self myFont) lock.
Morph new extent: 15 at 0; color: Color transparent.
self newSpacer: Color transparent.
+ (thePasswordMorph := TextMorph new
- (thePasswordMorph _ TextMorph new
beAllFont: (FixedFaceFont new passwordFont baseFont: self myFont copy);
crAction: (MessageSend receiver: self selector: #doOK);
extent: 250 at 20;
borderStyle: (InsetBorder new color: Color black; width: 2);
contentsWrapped: ''
).
}) color: self defaultColor.
self addARow: { (StringMorph contents:'') lock }.
self addARow: {
self newSpacer: Color transparent.
self okButton hResizing: #rigid.
Morph new extent: 30 at 0; color: Color transparent.
self cancelButton hResizing: #rigid.
}.
!
Item was changed:
----- Method: EtoyUpdatingThreePhaseButtonMorph class>>setForms: (in category '*Etoys-Squeakland-as yet unclassified') -----
setForms: size
| c |
+ UncheckedForm := Form extent: size at size depth: 16.
+ c := UncheckedForm getCanvas asBalloonCanvas.
- UncheckedForm _ Form extent: size at size depth: 16.
- c _ UncheckedForm getCanvas asBalloonCanvas.
c frameRectangle: UncheckedForm boundingBox width: (size // 12) color: Color black.
+ MouseDownForm := UncheckedForm deepCopy.
- MouseDownForm _ UncheckedForm deepCopy.
+ CheckedForm := UncheckedForm deepCopy.
+ c := CheckedForm getCanvas asBalloonCanvas.
- CheckedForm _ UncheckedForm deepCopy.
- c _ CheckedForm getCanvas asBalloonCanvas.
c
line: ((size*0.2)@(size*0.5)) asIntegerPoint
to: ((size*0.4)@(size*0.7)) asIntegerPoint
width: 2
color: Color gray darker.
c line: ((size*0.4)@(size*0.7)) asIntegerPoint
to: ((size*0.9)@(size*0.2)) asIntegerPoint
width: 2
color: Color gray darker.
!
Item was changed:
----- Method: EtoysPresenter>>reallyAllExtantPlayersNoSort (in category 'intialize') -----
reallyAllExtantPlayersNoSort
"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"
| fullList objectsReferredToByTiles aSet fullClassList |
self flushPlayerListCache.
+ aSet := IdentitySet new: 400.
- aSet _ IdentitySet new: 400.
associatedMorph allMorphsAndBookPagesInto: aSet.
+ fullList := aSet select:
- fullList _ aSet select:
[:m | m player ~~ nil] thenCollect: [:m | m player].
fullClassList := fullList collect: [:aPlayer | aPlayer class] thenSelect: [:aClass | aClass isUniClass].
fullClassList do:
[:aPlayerClass |
aPlayerClass scripts do:
[:aScript | aScript isTextuallyCoded ifFalse:
[aScript currentScriptEditor ifNotNilDo: [:ed |
+ objectsReferredToByTiles := ed allMorphs
- objectsReferredToByTiles _ ed allMorphs
select:
[:aMorph | (aMorph isKindOf: TileMorph) and: [aMorph type == #objRef]]
thenCollect:
[:aMorph | aMorph actualObject].
fullList addAll: objectsReferredToByTiles]]]].
^ fullList!
Item was changed:
----- Method: EventMorph>>event: (in category 'accessing') -----
event: anObject
"Set the value of event."
+ event := anObject!
- event _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>autoDismiss: (in category 'accessing') -----
autoDismiss: anObject
"Set the value of autoDismiss"
+ autoDismiss := anObject!
- autoDismiss _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>autoStart: (in category 'accessing') -----
autoStart: anObject
"Set the value of autoStart"
+ autoStart := anObject!
- autoStart _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>caption: (in category 'accessing') -----
caption: anObject
"Set the value of caption"
+ caption := anObject!
- caption _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>finalPicture: (in category 'accessing') -----
finalPicture: anObject
"Set the value of finalPicture"
+ finalPicture := anObject!
- finalPicture _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>initialPicture: (in category 'accessing') -----
initialPicture: anObject
"Set the value of initialPicture"
+ initialPicture := anObject!
- initialPicture _ anObject!
Item was changed:
----- Method: EventPlaybackButton>>tape: (in category 'accessing') -----
tape: anObject
"Set the value of tape"
+ tape := anObject!
- tape _ anObject!
Item was changed:
----- Method: EventPlaybackSpace>>autoDismiss: (in category 'accessing') -----
autoDismiss: anObject
"Set the value of autoDismiss"
+ autoDismiss := anObject!
- autoDismiss _ anObject!
Item was changed:
----- Method: EventPlaybackSpace>>autoStart: (in category 'accessing') -----
autoStart: anObject
"Set the value of autoStart"
+ autoStart := anObject!
- autoStart _ anObject!
Item was changed:
----- Method: EventRecorderMorph>>createPlayButton (in category '*Etoys-Squeakland-commands') -----
createPlayButton
"Make a simple button interface for replay only"
| butnCaption erm |
+ butnCaption := FillInTheBlank request: 'Caption for this button?' translated initialAnswer: 'play' translated.
- butnCaption _ FillInTheBlank request: 'Caption for this button?' translated initialAnswer: 'play' translated.
butnCaption isEmpty ifTrue: [^ self].
+ erm := (EventRecorderMorph basicNew
- erm _ (EventRecorderMorph basicNew
caption: butnCaption
voiceRecorder: voiceRecorder copy
tape: tape) initialize.
self world primaryHand attachMorph: erm!
Item was changed:
----- Method: EventRecorderMorph>>makeStatusLightIn: (in category '*Etoys-Squeakland-initialization') -----
makeStatusLightIn: aPoint
+ ^statusLight := EllipseMorph new
- ^statusLight _ EllipseMorph new
extent: aPoint;
color: Color green;
borderWidth: 0!
Item was changed:
----- Method: EventRecorderMorph>>mergeTapes: (in category '*Etoys-Squeakland-fileIn/Out') -----
mergeTapes: anArray
"Read multiple tapes and merge two timestamps"
"(self new mergeTapes: #('ClickStart.tape' 'Drawing.tape')) openInHand"
| lastTape offset writer aStream aTape |
lastTape := nil.
offset := 0.
writer := #() writeStream.
anArray do: [:fileName |
aStream := FileStream readOnlyFileNamed: fileName.
[aTape := self readFrom: aStream] ensure: [aStream close].
lastTape ifNotNil: [
offset := lastTape last timeStamp - aTape first timeStamp.
aTape do: [:each | each setTimeStamp: each timeStamp + offset]].
writer nextPutAll: aTape.
lastTape := aTape].
tape := writer contents.
+ saved := true "Still exists on file"!
- saved _ true "Still exists on file"!
Item was changed:
----- Method: EventRecorderMorph>>spawnStartingState (in category '*Etoys-Squeakland-commands') -----
spawnStartingState
"When recording stops, and we are inside a scripting area, and we have a primalConfig saved, install tape in recorder in primalConfig, Install a button on the desktop containg the primalConfig, and remove it from this scripting area. (This area, the end configuration, can be used to start the next tutorial.)"
| tutorial primalCopy recorderInPrimal |
"are we a tutorial?"
+ tutorial := self firstOwnerSuchThat: [:mm | mm hasProperty: #tutorial].
- tutorial _ self firstOwnerSuchThat: [:mm | mm hasProperty: #tutorial].
tutorial ifNil: [^ false]. "do nothing if not embedded in a tutorial scripting area"
"Do we have a complete copy of the starting configuration of this scripting area?"
+ primalCopy := self valueOfProperty: #primalConfig ifAbsent: [^ false].
- primalCopy _ self valueOfProperty: #primalConfig ifAbsent: [^ false].
primalCopy ifNil: [^ false].
+ recorderInPrimal := primalCopy
- recorderInPrimal _ primalCopy
findDeepSubmorphThat: [:mm | mm isKindOf: EventRecorderMorph]
ifAbsent: [^ false].
"transfer the recorded tape"
recorderInPrimal tape: tape.
"make a button with thumbnail"
+ "newButton := Morph new."
- "newButton _ Morph new."
"install the saved scripting area"
"place button in owner"
tutorial owner ifNotNil: [tutorial owner addMorph: primalCopy].
"tutorial owner ifNotNil: [tutorial owner addMorph: newButton].
newButton position: tutorial topRight + (10@(5 random * 40))."
self setProperty: #primalConfig toValue: nil. "remove from me"
^ true
!
Item was changed:
----- Method: EventRecorderMorph>>tape: (in category '*Etoys-Squeakland-accessing') -----
tape: anArray
+ tape := anArray!
- tape _ anArray!
Item was changed:
----- Method: EventRecordingSpace>>addNavigatorFlap (in category 'flaps') -----
addNavigatorFlap
"Add a navigator flap if there is none."
| existing aFlap navBar aFlapTab |
existing := contentArea submorphs detect: [:aMorph | (aMorph isKindOf: FlapTab) and: [aMorph flapID = 'Navigator']] ifNone: [nil].
existing ifNotNil: [^ self]. "already present"
+ navBar := EventRecordingSpaceNavigator new.
+ aFlap := PasteUpMorph newSticky borderWidth: 0;
- navBar _ EventRecordingSpaceNavigator new.
- aFlap _ PasteUpMorph newSticky borderWidth: 0;
extent: navBar extent + (0 at 20);
color: (Color orange alpha: 0.8);
beFlap: true;
addMorph: navBar beSticky.
aFlap hResizing: #shrinkWrap; vResizing: #shrinkWrap.
aFlap useRoundedCorners.
aFlap setNameTo: 'Navigator' translated.
navBar fullBounds. "to establish width"
+ aFlapTab := InteriorFlapTab new referent: aFlap.
- aFlapTab _ InteriorFlapTab new referent: aFlap.
aFlapTab setName: 'Navigator' translated edge: #bottom color: Color orange.
aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.
aFlap borderWidth: 0.
contentArea addMorphFront: aFlapTab.
aFlapTab position: (contentArea bottomLeft + (0 @ -24)).
aFlapTab referent left: (aFlapTab center x - (aFlapTab referent width//2) max: 0).
contentArea installFlaps
!
Item was changed:
----- Method: EventRecordingSpace>>balloonHelpString: (in category 'accessing') -----
balloonHelpString: anObject
"Set the value of balloonHelpString"
+ balloonHelpString := anObject!
- balloonHelpString _ anObject!
Item was changed:
----- Method: EventRecordingSpace>>editMenuButtonDefinition (in category 'menu') -----
editMenuButtonDefinition
"For debugging and development only!! Open up a single-method browser on the method that defines the main menu of the receiver."
| mr |
+ mr := MethodReference new setStandardClass: self class methodSymbol: #addMenuButtonItemsTo:.
- mr _ MethodReference new setStandardClass: self class methodSymbol: #addMenuButtonItemsTo:.
self systemNavigation browseMessageList: {mr} name: 'Event Theatre menu Definition' translated autoSelect: nil!
Item was changed:
----- Method: EventRecordingSpace>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver to be a complete mentoring space"
super initialize.
eventRecorder := MentoringEventRecorder new.
eventRecorder recordingSpace: self.
self beSticky.
self listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap.
self extent: 1 at 1.
self borderWidth: 2; borderColor: Color gray.
self useRoundedCorners.
showingSoundPanel := false.
+ (contentArea := Worldlet new)
- (contentArea _ Worldlet new)
setNameTo: 'tutorial';
color: Color white;
setProperty: #automaticPhraseExpansion toValue: true;
beSticky.
self addMorphBack: contentArea.
controlsPanel := AlignmentMorph newRow.
controlsPanel hResizing: #spaceFill.
controlsPanel listCentering: #center.
controlsPanel listSpacing: #equal.
controlsPanel cellInset: 4.
controlsPanel minHeight: 32.
self addMorphBack: controlsPanel.
soundPanel := AlignmentMorph newRow.
soundPanel hResizing: #spaceFill.
soundPanel listCentering: #center.
soundPanel listSpacing: #equal.
soundPanel cellInset: 4.
soundPanel minHeight: 32.
soundPanel color: (Color r: 1.0 g: 0.839 b: 0.645).
self makeStatusButtons.
state := #readyToRecord.
self populateControlsPanel.
SugarNavigatorBar showSugarNavigator
ifTrue:
[self addSugarNavigatorFlap]
ifFalse:
[self addSuppliesFlap.
self addNavigatorFlap]!
Item was changed:
----- Method: EventRecordingSpace>>offerMenu (in category 'menu') -----
offerMenu
"A menu button was hit. Offer a menu of options for the receiver."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
self addMenuButtonItemsTo: aMenu.
aMenu popUpInWorld!
Item was changed:
----- Method: EventRecordingSpace>>populateSoundPanel (in category 'processing') -----
populateSoundPanel
"Like de selector say."
| rec levelSlider meterBox voiceControls sliderWrapper |
(#( playbackAddingVoiceover) includes: self state) ifTrue:
[self addToSoundPanelWithSpacer: stopRecordingVoiceoverButton].
(#(playback) includes: self state) ifTrue:
[self addToSoundPanelWithSpacer: recordVoiceoverButton].
rec := eventRecorder assuredVoiceRecorder.
voiceControls := AlignmentMorph newColumn.
voiceControls hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0.
voiceControls setNameTo: 'voice controls'.
+ levelSlider := SimpleSliderMorph new
- levelSlider _ SimpleSliderMorph new
color: color;
extent: 60 at 2;
target: rec;
setNameTo: 'level control';
actionSelector: #recordLevel:;
adjustToValue: rec recordLevel.
+ sliderWrapper := AlignmentMorph newRow
- sliderWrapper _ AlignmentMorph newRow
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #rigid;
height: 8.
sliderWrapper addMorphBack: (StringMorph contents: '0 ' font: (StrikeFont familyName: 'Accujen' size: 10)).
sliderWrapper addMorphBack: levelSlider.
sliderWrapper addMorphBack: (StringMorph contents: ' 10' font: (StrikeFont familyName: 'Accujen' size: 10)).
voiceControls addMorphBack: sliderWrapper.
+ meterBox := Morph new extent: 82 at 8; color: Color gray.
- meterBox _ Morph new extent: 82 at 8; color: Color gray.
eventRecorder recordMeter height: 8.
meterBox addMorph: eventRecorder recordMeter.
eventRecorder recordMeter position: meterBox position.
voiceControls addMorphBack: meterBox.
meterBox setNameTo: 'meter box'.
self addToSoundPanelWithSpacer: voiceControls
!
Item was changed:
----- Method: EventRecordingSpace>>possiblyAddVoiceControlsToControlPanel (in category 'processing') -----
possiblyAddVoiceControlsToControlPanel
"Like de selector say."
| rec levelSlider meterBox voiceControls sliderWrapper |
(rec := eventRecorder voiceRecorder) ifNil: [^ self].
voiceControls := AlignmentMorph newColumn.
voiceControls hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0.
voiceControls setNameTo: 'voice controls'.
+ levelSlider := SimpleSliderMorph new
- levelSlider _ SimpleSliderMorph new
color: color;
extent: 60 at 2;
target: rec;
setNameTo: 'level control';
actionSelector: #recordLevel:;
adjustToValue: rec recordLevel.
+ sliderWrapper := AlignmentMorph newRow
- sliderWrapper _ AlignmentMorph newRow
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #rigid;
height: 8.
sliderWrapper addMorphBack: (StringMorph contents: '0 ' font: (StrikeFont familyName: 'Accujen' size: 10)).
sliderWrapper addMorphBack: levelSlider.
sliderWrapper addMorphBack: (StringMorph contents: ' 10' font: (StrikeFont familyName: 'Accujen' size: 10)).
voiceControls addMorphBack: sliderWrapper.
+ meterBox := Morph new extent: 82 at 8; color: Color gray.
- meterBox _ Morph new extent: 82 at 8; color: Color gray.
eventRecorder recordMeter height: 8.
meterBox addMorph: eventRecorder recordMeter.
eventRecorder recordMeter position: meterBox position.
voiceControls addMorphBack: meterBox.
meterBox setNameTo: 'meter box'.
self addToSoundPanelWithSpacer: voiceControls
!
Item was changed:
----- Method: EventRecordingSpace>>setBalloonHelp (in category 'commands') -----
setBalloonHelp
"Allow the user to edit the balloon-help string to be used for playback buttons."
| reply aString |
aString :=
+ reply := FillInTheBlank
- reply _ FillInTheBlank
multiLineRequest: 'Edit the balloon help to be supplied for playback buttons made for this event movie' translated
centerAt: Sensor cursorPoint
initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString])
answerHeight: 200.
reply ifNil: [^ self]. "User cancelled out of the dialog"
(reply isEmpty or: [reply asString = self noHelpString])
ifTrue: [self balloonHelpString: nil]
ifFalse: [self balloonHelpString: reply]!
Item was changed:
----- Method: EventRecordingSpace>>sugarSuppliesFlapTab (in category 'sugar flaps') -----
sugarSuppliesFlapTab
"Build and answer an interior sugar-supplies flap"
| aFlapTab aStrip quads |
quads := self sugarPartsBinQuads.
+ aStrip := PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color gray muchLighter from: quads withPreviousEntries: #().
- aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color gray muchLighter from: quads withPreviousEntries: #().
Flaps twiddleSuppliesButtonsIn: aStrip.
+ aFlapTab := InteriorSolidSugarSuppliesTab new referent: aStrip beSticky.
- aFlapTab _ InteriorSolidSugarSuppliesTab new referent: aStrip beSticky.
aFlapTab sugarNavBar: self sugarNavBarOrNil.
aFlapTab setName: 'Supplies' translated edge: #top color: Color red lighter.
aFlapTab position: (contentArea topLeft + (0 @ SugarNavTab new height)).
aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.
aFlapTab applyThickness: 20.
aStrip extent: contentArea width @ (76 * (1 + (1350 // contentArea width))).
aStrip beFlap: true.
aStrip autoLineLayout: true.
aFlapTab useSolidTab.
aFlapTab height: 20; color: (Color r: 0.804 g: 0.804 b: 0.804).
^ aFlapTab!
Item was changed:
----- Method: EventRecordingSpaceNavigator>>doNewPainting (in category 'the actions') -----
doNewPainting
"Make a new painting"
| worldlet |
ActiveWorld assureNotPaintingElse: [^ self].
+ worldlet := self ownerThatIsA: Worldlet.
- worldlet _ self ownerThatIsA: Worldlet.
worldlet closeNavigatorFlap.
worldlet makeNewDrawing: (ActiveHand lastEvent copy setPosition: worldlet center)!
Item was changed:
----- Method: EventRollMorph>>scaleSlider (in category 'processing') -----
scaleSlider
"Answer a device that can serve to govern the scale of the piano roll."
| aSlider |
+ aSlider := SimpleSliderMorph new
- aSlider _ SimpleSliderMorph new
color: Color blue muchLighter;
extent: 12 @ 120;
target: self;
minVal: 1;
maxVal: 50;
setNameTo: 'scale';
actionSelector: #establishScale:;
adjustToValue: millisecondsPerPixel.
^ aSlider
!
Item was changed:
----- Method: EventSequence>>startTime: (in category 'accessing') -----
startTime: anObject
"Set the value of startTime."
+ startTime := anObject!
- startTime _ anObject!
Item was changed:
----- Method: EventSequence>>stopTime: (in category 'accessing') -----
stopTime: anObject
"Set the value of stopTime."
+ stopTime := anObject!
- stopTime _ anObject!
Item was changed:
----- Method: EventTapeParser>>eventTape: (in category 'accessing') -----
eventTape: anObject
"Set the value of eventTape"
+ eventTape := anObject!
- eventTape _ anObject!
Item was changed:
----- Method: ExtendedClipboardInterface>>useImageReadWriter:onForm:addClipboardMethod: (in category 'general-api-add') -----
useImageReadWriter: aImageReadWriterClass onForm: aForm addClipboardMethod: aAddClipBoardBlock
| estimate buffer stream pngConverter |
(aForm isKindOf: Form) ifTrue:
+ [estimate := (aForm extent x)*(aForm extent y).
+ estimate := 1024 max: (estimate * 4 * 3 // 4).
+ buffer := ByteArray new: estimate.
+ stream := (RWBinaryOrTextStream on: buffer) binary .
+ pngConverter := aImageReadWriterClass on: stream.
- [estimate _ (aForm extent x)*(aForm extent y).
- estimate _ 1024 max: (estimate * 4 * 3 // 4).
- buffer _ ByteArray new: estimate.
- stream _ (RWBinaryOrTextStream on: buffer) binary .
- pngConverter _ aImageReadWriterClass on: stream.
pngConverter nextPutImage: aForm.
pngConverter close.
aAddClipBoardBlock value: stream contents].
!
Item was changed:
----- Method: ExtendedClipboardMacInterface>>addTextClipboardData: (in category 'general-api-add') -----
addTextClipboardData: data
| buffer stream |
self clearClipboard.
self addClipboardData: data asString dataFormat: 'public.text'.
self halt.
+ buffer := ByteArray new: 2048.
+ stream := (RWBinaryOrTextStream on: buffer) binary .
- buffer _ ByteArray new: 2048.
- stream _ (RWBinaryOrTextStream on: buffer) binary .
data serializeOn: stream.
self addClipboardData: (buffer copyFrom: 1 to: stream size) dataFormat: 'org.squeak.text'.
!
Item was changed:
----- Method: ExternalForm>>colormapFromARGB (in category 'accessing') -----
colormapFromARGB
"Return a ColorMap mapping from canonical ARGB pixel values into the receiver"
+ ^argbMap ifNil:[argbMap := ColorMap mappingFromARGB: self rgbaBitMasks].!
- ^argbMap ifNil:[argbMap _ ColorMap mappingFromARGB: self rgbaBitMasks].!
Item was changed:
----- Method: ExternalForm>>colormapFromARGB: (in category 'accessing') -----
colormapFromARGB: aMap
"Set the ColorMap mapping from canonical ARGB pixel values into the receiver"
+ argbMap := aMap!
- argbMap _ aMap!
Item was changed:
----- Method: ExternalForm>>setExternalHandle:on: (in category 'private') -----
setExternalHandle: aHandle on: aDisplay
"Initialize the receiver from the given external handle"
+ display := aDisplay.
+ bits := aHandle.!
- display _ aDisplay.
- bits _ aHandle.!
Item was changed:
----- Method: ExternalForm>>shutDown (in category 'initialize-release') -----
shutDown
"System is going down. Internalize my bits and be finished."
| copy |
+ copy := Form extent: self extent depth: self depth.
- copy _ Form extent: self extent depth: self depth.
self displayOn: copy.
copy hibernate. "compact bits of copy"
self destroy. "Release my external handle"
+ bits := copy bits. "Now compressed"
+ display := nil. "No longer allocated"
+ argbMap := nil. "No longer external"!
- bits _ copy bits. "Now compressed"
- display _ nil. "No longer allocated"
- argbMap _ nil. "No longer external"!
Item was changed:
----- Method: ExternalFormRegistry>>lock (in category 'accessing') -----
lock
+ lockFlag := true!
- lockFlag _ true!
Item was changed:
----- Method: ExternalFormRegistry>>unlock (in category 'accessing') -----
unlock
+ lockFlag := false.!
- lockFlag _ false.!
Item was changed:
----- Method: ExternalScreen>>allocateForm: (in category 'form support') -----
allocateForm: extentPoint
"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
| formHandle displayForm |
+ formHandle := self primAllocateForm: self depth width: extentPoint x height: extentPoint y.
- formHandle _ self primAllocateForm: self depth width: extentPoint x height: extentPoint y.
formHandle = nil ifTrue:[^super allocateForm: extentPoint].
+ displayForm := (ExternalForm extent: extentPoint depth: self depth bits: nil)
- displayForm _ (ExternalForm extent: extentPoint depth: self depth bits: nil)
setExternalHandle: formHandle on: self.
allocatedForms at: displayForm put: displayForm executor.
^displayForm!
Item was changed:
----- Method: ExternalScreen>>colormapFromARGB (in category 'accessing') -----
colormapFromARGB
"Return a ColorMap mapping from canonical ARGB pixel values into the receiver"
+ ^argbMap ifNil:[argbMap := ColorMap mappingFromARGB: self rgbaBitMasks].!
- ^argbMap ifNil:[argbMap _ ColorMap mappingFromARGB: self rgbaBitMasks].!
Item was changed:
----- Method: ExternalScreen>>copyBits:from:at:clippingBox:rule:fillColor:map: (in category 'blitting support') -----
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map
"Attempt to accelerate blts to the receiver"
| r |
((self isBltAccelerated: rule for: sourceForm) and:[map == nil and:[hf == nil]]) ifTrue:[
"Try an accelerated blt"
+ r := (destOrigin extent: sourceRect extent) intersect: (clipRect intersect: clippingBox).
- r _ (destOrigin extent: sourceRect extent) intersect: (clipRect intersect: clippingBox).
r area <= 0 ifTrue:[^self].
(self primBltFast: bits from: sourceForm getExternalHandle
at: r origin from: sourceRect origin
extent: r extent) ifNotNil:[^self].
].
^super copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map!
Item was changed:
----- Method: ExternalScreen>>destroy (in category 'initialize-release') -----
destroy
"Destroy the receiver"
allocatedForms ifNotNil:[
allocatedForms lock. "Make sure we don't get interrupted"
allocatedForms forceFinalization. "Clean up all lost references"
allocatedForms keys do:[:stillValid| stillValid shutDown].
"All remaining references are simply destroyed"
allocatedForms associationsDo:[:assoc| assoc key: nil].
allocatedForms forceFinalization. "destroy all others"
+ allocatedForms := nil.
- allocatedForms _ nil.
].
bits ifNotNil:[self primDestroyDisplaySurface: bits].
+ bits := nil.!
- bits _ nil.!
Item was changed:
----- Method: ExternalScreen>>displayOn:at:clippingBox:rule:fillColor: (in category 'blitting support') -----
displayOn: destForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf
"Attempt to accelerate blts to aDisplayMedium"
| sourceRect |
((self isBltAccelerated: rule for: destForm) and:[hf = nil]) ifTrue:[
"Try an accelerated blt"
+ sourceRect := (clipRect translateBy: destOrigin negated) intersect: clippingBox.
- sourceRect _ (clipRect translateBy: destOrigin negated) intersect: clippingBox.
(self primBltFast: bits to: destForm getExternalHandle
at: 0 at 0 from: sourceRect origin
extent: sourceRect extent) ifNotNil:[^self]].
destForm copyBits: self boundingBox
from: self
at: destOrigin + self offset
clippingBox: clipRect
rule: rule
fillColor: hf
map: (self colormapIfNeededFor: destForm).
!
Item was changed:
----- Method: ExternalScreen>>fill:rule:fillColor: (in category 'blitting support') -----
fill: aRectangle rule: anInteger fillColor: aColor
"Replace a rectangular area of the receiver with the pattern described by aForm
according to the rule anInteger."
| rect |
(self isFillAccelerated: anInteger for: aColor) ifTrue:[
+ rect := aRectangle intersect: clippingBox.
- rect _ aRectangle intersect: clippingBox.
(self primFill: bits
color: (self pixelWordFor: aColor)
x: rect left
y: rect top
w: rect width
h: rect height) ifNotNil:[^self]].
^super fill: aRectangle rule: anInteger fillColor: aColor!
Item was changed:
----- Method: ExternalScreen>>rgbaBitMasks (in category 'accessing') -----
rgbaBitMasks
"Return the masks for specifying the R,G,B, and A components in the receiver"
| rgbaBitMasks |
+ rgbaBitMasks := Array new: 4.
- rgbaBitMasks _ Array new: 4.
self primDisplay: bits colorMasksInto: rgbaBitMasks.
^rgbaBitMasks!
Item was changed:
----- Method: ExternalScreen>>rgbaBitMasksOfForm: (in category 'form support') -----
rgbaBitMasksOfForm: anExternalForm
| rgbaBitMasks |
+ rgbaBitMasks := Array new: 4.
- rgbaBitMasks _ Array new: 4.
self primForm: anExternalForm getExternalHandle colorMasksInto: rgbaBitMasks.
^rgbaBitMasks!
Item was changed:
----- Method: ExternalScreen>>setExtent:depth: (in category 'private') -----
setExtent: aPoint depth: bitsPerPixel
"Create a 3D accelerated display screen"
| screen |
(bits isInteger and:[depth == bitsPerPixel and: [aPoint = self extent and:
[self supportsDisplayDepth: bitsPerPixel]]]) ifFalse: [
bits ifNotNil:[self primDestroyDisplaySurface: bits].
+ bits := nil. "Free up old bitmap in case space is low"
+ DisplayChangeSignature := (DisplayChangeSignature ifNil: [0]) + 1.
- bits _ nil. "Free up old bitmap in case space is low"
- DisplayChangeSignature _ (DisplayChangeSignature ifNil: [0]) + 1.
(self supportsDisplayDepth: bitsPerPixel)
+ ifTrue:[depth := bitsPerPixel]
- ifTrue:[depth _ bitsPerPixel]
ifFalse:["Search for a suitable depth"
+ depth := self findAnyDisplayDepthIfNone:[nil]].
- depth _ self findAnyDisplayDepthIfNone:[nil]].
depth == nil ifFalse:[
+ bits := self primCreateDisplaySurface: depth
- bits _ self primCreateDisplaySurface: depth
width: aPoint x height: aPoint y].
"Bail out if surface could not be created"
(bits == nil) ifTrue:[
+ screen := DisplayScreen extent: aPoint depth: bitsPerPixel.
- screen _ DisplayScreen extent: aPoint depth: bitsPerPixel.
self == Display ifTrue:[
+ Display := screen.
- Display _ screen.
Display beDisplay].
^screen].
+ width := aPoint x.
+ height := aPoint y.
- width _ aPoint x.
- height _ aPoint y.
].
+ clippingBox := super boundingBox.
- clippingBox _ super boundingBox.
allocatedForms ifNil:[
+ allocatedForms := ExternalFormRegistry new.
- allocatedForms _ ExternalFormRegistry new.
WeakArray addWeakDependent: allocatedForms].
!
Item was changed:
----- Method: ExternalScreen>>shutDown (in category 'initialize-release') -----
shutDown
"Minimize Display memory saved in image"
self destroy.
+ width := 240.
+ height := 120.
+ bits := Bitmap new: self bitsSize.!
- width _ 240.
- height _ 120.
- bits _ Bitmap new: self bitsSize.!
Item was changed:
----- Method: ExternalSemaphoreTable class>>initialize (in category 'initialize') -----
initialize
+ ProtectTable := Semaphore forMutualExclusion!
- ProtectTable _ Semaphore forMutualExclusion!
Item was changed:
----- Method: ExternalSemaphoreTable class>>safelyRegisterExternalObject: (in category 'accessing') -----
safelyRegisterExternalObject: anObject
"Register the given object in the external objects array and return its index. If it is already there, just return its index."
| objects firstEmptyIndex obj sz newObjects |
+ objects := Smalltalk specialObjectsArray at: 39.
- objects _ Smalltalk specialObjectsArray at: 39.
"find the first empty slot"
+ firstEmptyIndex := 0.
- firstEmptyIndex _ 0.
1 to: objects size do: [:i |
+ obj := objects at: i.
- obj _ objects at: i.
obj == anObject ifTrue: [^ i]. "object already there, just return its index"
+ (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex := i]].
- (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex _ i]].
"if no empty slots, expand the array"
firstEmptyIndex = 0 ifTrue: [
+ sz := objects size.
+ newObjects := objects species new: sz + 20. "grow linearly"
- sz _ objects size.
- newObjects _ objects species new: sz + 20. "grow linearly"
newObjects replaceFrom: 1 to: sz with: objects startingAt: 1.
+ firstEmptyIndex := sz + 1.
- firstEmptyIndex _ sz + 1.
Smalltalk specialObjectsArray at: 39 put: newObjects.
+ objects := newObjects].
- objects _ newObjects].
objects at: firstEmptyIndex put: anObject.
^ firstEmptyIndex
!
Item was changed:
----- Method: ExternalSemaphoreTable class>>safelyUnregisterExternalObject: (in category 'accessing') -----
safelyUnregisterExternalObject: anObject
"Unregister the given object in the external objects array. Do nothing if it isn't registered.
JMM change to return if we clear the element, since it should only appear once in the array"
| objects |
anObject ifNil: [^ self].
+ objects := Smalltalk specialObjectsArray at: 39.
- objects _ Smalltalk specialObjectsArray at: 39.
1 to: objects size do: [:i |
(objects at: i) == anObject ifTrue:
[objects at: i put: nil.
^self]].
!
Item was changed:
----- Method: FileInput>>browse (in category 'accessing') -----
browse
| file |
+ file := (StandardFileMenu oldFileFrom: self directory) ifNil: [^nil].
- file _ (StandardFileMenu oldFileFrom: self directory) ifNil: [^nil].
file directory isNil ifTrue: [^ nil].
textMorph setText: (file directory pathName, FileDirectory slash, file name);
hasUnacceptedEdits: true;
accept!
Item was changed:
----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:title:reallyLoad:dirFilterType:isGeneral: (in category '*Etoys-Squeakland-blue ui') -----
morphicViewProjectLoader2InWorld: aWorld title: title reallyLoad: aBoolean dirFilterType: aSymbol isGeneral: isGeneral
"Put up a blue file-list for loading etoy projects."
"
FileList2 morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: true dirFilterType: #limitedSuperSwikiDirectoryList
"
| window aFileList actionRow treePane p |
+ aFileList := self buildFileListDirFilterType: aSymbol.
- aFileList _ self buildFileListDirFilterType: aSymbol.
window := self buildMorphicWindow: aFileList title: title.
+ actionRow := self buildLoadButtons: window fileList: aFileList reallyLoad: aBoolean.
- actionRow _ self buildLoadButtons: window fileList: aFileList reallyLoad: aBoolean.
isGeneral
ifTrue: [self buildFileTypeButtons: window actionRow: actionRow fileList: aFileList].
treePane := self buildPane: aWorld fileList: aFileList window: window dirFilterType: aSymbol.
window addMorphBack: actionRow.
window fullBounds.
window position: aWorld topLeft + (aWorld extent - window extent // 2).
window beSticky.
aFileList sortByName.
"This crazy stuff I really cannot figure out how to get the directory selected by default other than this."
(treePane scroller submorphs detect: [:e |
p := e complexContents withoutListWrapper pathName.
(p beginsWith: 'sugar://') or: [p = SecurityManager default untrustedUserDirectory]] ifNone: [nil])
ifNotNilDo: [:item | WorldState addDeferredUIMessage: [aFileList setSelectedDirectoryTo: item complexContents]].
aFileList postOpen.
^ window!
Item was changed:
----- Method: FileList2>>initialDirectoryListForProjects (in category '*Etoys-Squeakland-initialization') -----
initialDirectoryListForProjects
| dir nameToShow dirList |
+ dirList := (FileDirectory on: '') directoryNames collect: [ :each |
- dirList _ (FileDirectory on: '') directoryNames collect: [ :each |
FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self].
dirList isEmpty ifTrue:[
+ dirList := Array with: (FileDirectoryWrapper
- dirList _ Array with: (FileDirectoryWrapper
with: FileDirectory default
name: FileDirectory default localName
model: self)].
dirList do: [:e | e balloonText: e withoutListWrapper pathName].
+ dirList := dirList,((
- dirList _ dirList,((
ServerDirectory serverNames select: [ :n |
(ServerDirectory serverNamed: n) isProjectSwiki.
]) collect: [:n |
+ dir := ServerDirectory serverNamed: n.
+ nameToShow := n.
- dir _ ServerDirectory serverNamed: n.
- nameToShow _ n.
(dir directoryWrapperClass with: dir name: nameToShow model: self)
balloonText: dir realUrl
]
).
^dirList!
Item was changed:
----- Method: FileList2>>update:fileTypeRow:morphUp: (in category '*Etoys-Squeakland-user interface') -----
update: actionRow fileTypeRow: fileTypeRow morphUp: morph
"Update a row of action buttons."
| fileTypeInfo info2 buttons fileSuffixes fileActions fileTypeString |
(morph valueOfProperty: #enabled) ifFalse: [^self].
fileTypeRow submorphsDo: [ :sub |
(sub findA: StringMorph) color: Color black.
sub == morph
ifTrue: [sub color: (ScriptingSystem baseColor mixed: 1/2 with: Color white)]
ifFalse:
[(sub valueOfProperty: #enabled)
ifTrue:
[sub color: ScriptingSystem baseColor]
ifFalse:
[sub color: Color transparent.
(sub findA: StringMorph) color: (Color gray: 0.8).
]]].
+ fileTypeString := morph valueOfProperty: #buttonText.
- fileTypeString _ morph valueOfProperty: #buttonText.
actionRow removeAllMorphs.
+ fileTypeInfo := self class endingSpecs.
+ info2 := fileTypeInfo
- fileTypeInfo _ self class endingSpecs.
- info2 _ fileTypeInfo
detect: [ :each | each first = fileTypeString]
ifNone: [self error: 'bad fileTypeString' ].
+ fileSuffixes := info2 second.
+ fileActions := info2 third.
+ buttons := fileActions collect: [ :each | self buildButtonForService: each ].
- fileSuffixes _ info2 second.
- fileActions _ info2 third.
- buttons _ fileActions collect: [ :each | self buildButtonForService: each ].
buttons addLast: (self class buildButtonText: 'Cancel' translated balloonText: 'Cancel this search' translated receiver: self selector: #cancelHit).
buttons do: [ :each | actionRow addMorphBack: each].
self fileSelectionBlock: (
self class selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each])
).
self updateFileList!
Item was changed:
----- Method: FilePath>>coverter: (in category '*Etoys-Squeakland-conversion') -----
coverter: aTextConverter
converter class ~= aTextConverter class ifTrue: [
+ converter := aTextConverter.
+ vmPathName := squeakPathName convertToWithConverter: converter
- converter _ aTextConverter.
- vmPathName _ squeakPathName convertToWithConverter: converter
].
!
Item was changed:
----- Method: FishEyeMorph>>calculateTransform (in category 'initialization') -----
calculateTransform
| stepX stepY rect tx ty arrayX arrayY |
(gridNum x = 0 or: [gridNum y = 0]) ifTrue: [^self].
+ stepX := srcExtent x // gridNum x.
+ stepY := srcExtent y // gridNum y.
- stepX _ srcExtent x // gridNum x.
- stepY _ srcExtent y // gridNum y.
+ arrayX := (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
+ arrayY := (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
- arrayX _ (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
- arrayY _ (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
0 to: gridNum y do: [:j |
0 to: gridNum x do: [:i |
(arrayX at: (j + 1)) at: (i + 1) put: i*stepX.
(arrayY at: (j + 1)) at: (i + 1) put: j*stepY.
].
].
0 to: gridNum y do: [:j |
self transformX: (arrayX at: (j+1)).
self transformY: (arrayY at: (j+1)).
].
0 to: gridNum y do: [:j |
arrayX at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayX at: (j+1)) at: i) asInteger]).
arrayY at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayY at: (j+1)) at: i) asInteger]).
].
+ clipRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
+ toRects := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
+ quads := (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- clipRects _ (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- toRects _ (1 to: gridNum y) collect: [:j | Array new: gridNum x].
- quads _ (1 to: gridNum y) collect: [:j | Array new: gridNum x].
0 to: gridNum y - 1 do: [:j |
0 to: gridNum x- 1 do: [:i |
+ rect := (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
- rect _ (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
corner: ((arrayX at: (j+2)) at: (i+2))@((arrayY at: (j+2)) at: (i+2)).
(clipRects at: j+1) at: i+1 put: rect.
+ rect width >= stepX ifTrue: [rect := rect expandBy: (1 at 0)].
+ rect height >= stepY ifTrue: [rect := rect expandBy: (0 at 1)].
- rect width >= stepX ifTrue: [rect _ rect expandBy: (1 at 0)].
- rect height >= stepY ifTrue: [rect _ rect expandBy: (0 at 1)].
(toRects at: j+1) at: i+1 put: rect.
+ tx := (i)*stepX.
+ ty := (j)*stepY.
- tx _ (i)*stepX.
- ty _ (j)*stepY.
(quads at: j+1) at: i+1
put: {(tx)@(ty). (tx)@(ty+stepY). (tx+stepX)@(ty+stepY). (tx+stepX)@(ty)}.
].
].
!
Item was changed:
----- Method: FishEyeMorph>>extent: (in category 'geometry') -----
extent: aPoint
"Round to a number divisible by grid. Note that the superclass has its own implementation."
| g gridSize |
+ gridSize := self gridSizeFor: aPoint.
- gridSize _ self gridSizeFor: aPoint.
"self halt."
+ g := (aPoint - (2 * borderWidth)) // gridSize.
+ srcExtent := g * gridSize.
+ gridNum := g.
- g _ (aPoint - (2 * borderWidth)) // gridSize.
- srcExtent _ g * gridSize.
- gridNum _ g.
^super extent: self defaultExtent!
Item was changed:
----- Method: FishEyeMorph>>g:max:focus: (in category 'initialization') -----
g: aFloatArray max: max focus: focus
| dNormX array |
+ dNormX := aFloatArray - focus.
- dNormX _ aFloatArray - focus.
+ array := dNormX / max.
- array _ dNormX / max.
array *= d.
array += 1.0.
+ array := 1.0 / array.
- array _ 1.0 / array.
dNormX *= (d+1.0).
array *= dNormX.
^array += focus.
!
Item was changed:
----- Method: FishEyeMorph>>gridSizeFor: (in category 'private') -----
gridSizeFor: aPoint
"returns appropriate size for specified argument"
| g |
+ g := aPoint x min: aPoint y.
- g _ aPoint x min: aPoint y.
g <= 256 ifTrue: [^8].
^16.!
Item was changed:
----- Method: FishEyeMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
"magnification should be always 1"
+ magnification := 1.
+ d := 1.3.
- magnification _ 1.
- d _ 1.3.
self extent: 130 @ 130!
Item was changed:
----- Method: FishEyeMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
super initializeToStandAlone.
"magnification should be always 1"
+ magnification := 1.
+ d := 1.3.
- magnification _ 1.
- d _ 1.3.
self extent: 130 at 130.
!
Item was changed:
----- Method: FishEyeMorph>>magnifiedForm (in category 'magnifying') -----
magnifiedForm
| warp warpForm fromForm |
savedExtent ~= srcExtent ifTrue: [
+ savedExtent := srcExtent.
- savedExtent _ srcExtent.
self calculateTransform].
+ warpForm := Form extent: srcExtent depth: Display depth.
+ fromForm := super magnifiedForm.
- warpForm _ Form extent: srcExtent depth: Display depth.
- fromForm _ super magnifiedForm.
+ warp := (WarpBlt current toForm: warpForm)
- warp _ (WarpBlt current toForm: warpForm)
sourceForm: fromForm;
colorMap: nil;
cellSize: 2;
combinationRule: Form over.
1 to: gridNum y do: [:j |
1 to: gridNum x do: [:i |
warp
clipRect: ((clipRects at: j) at: i);
copyQuad: ((quads at: j) at: i)
toRect: ((toRects at: j) at: i).
].
].
^warpForm
!
Item was changed:
----- Method: FishEyeMorph>>transformX: (in category 'initialization') -----
transformX: aFloatArray
| focus gridNum2 subArray dMaxX |
+ focus := srcExtent x asFloat / 2.
- focus _ srcExtent x asFloat / 2.
+ gridNum2 := (aFloatArray findFirst: [:x | x > focus]) - 1.
- gridNum2 _ (aFloatArray findFirst: [:x | x > focus]) - 1.
+ dMaxX := 0.0 - focus.
+ subArray := self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.
- dMaxX _ 0.0 - focus.
- subArray _ self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.
aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1.
+ dMaxX := focus. " = (size - focus)"
+ subArray := self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
- dMaxX _ focus. " = (size - focus)"
- subArray _ self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
max: dMaxX focus: focus.
aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1.
!
Item was changed:
----- Method: FlapTab>>changeTabText2: (in category '*Etoys-Squeakland-textual tabs') -----
changeTabText2: aString
| label |
aString isEmptyOrNil ifTrue: [^ self].
+ label := Locale current languageEnvironment class flapTabTextFor: aString in: self.
- label _ Locale current languageEnvironment class flapTabTextFor: aString in: self.
label isEmptyOrNil ifTrue: [^ self].
self assumeString: label
font: Preferences standardFlapFont
orientation: (Flaps orientationForEdge: self edgeToAdhereTo)
color: nil.
!
Item was changed:
----- Method: Flaps class>>addAndEnableEToyFlapsWithPreviousEntries: (in category '*Etoys-Squeakland-predefined flaps') -----
addAndEnableEToyFlapsWithPreviousEntries: aCollection
"Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed."
| aSuppliesFlap |
SharedFlapTabs
ifNotNil: [^ self].
+ SharedFlapTabs := OrderedCollection new.
+ aSuppliesFlap := self newSuppliesFlapFromQuads: self quadsDefiningPlugInSuppliesFlap positioning: #right withPreviousEntries: aCollection.
- SharedFlapTabs _ OrderedCollection new.
- aSuppliesFlap _ self newSuppliesFlapFromQuads: self quadsDefiningPlugInSuppliesFlap positioning: #right withPreviousEntries: aCollection.
aSuppliesFlap referent setNameTo: 'Supplies Flap' translated. "Per request from Kim Rose, 7/19/02"
SharedFlapTabs add: aSuppliesFlap. "The #center designation doesn't quite work at the moment"
SugarNavigatorBar showSugarNavigator
ifTrue: [SharedFlapTabs add: self newSugarNavigatorFlap]
ifFalse: [SharedFlapTabs add: self newNavigatorFlap].
self enableGlobalFlapWithID: 'Supplies' translated.
SugarNavigatorBar showSugarNavigator
ifTrue:
[self enableGlobalFlapWithID: 'Sugar Navigator Flap' translated.
(self globalFlapTabWithID: 'Sugar Navigator Flap' translated) ifNotNilDo:
[:navTab | aSuppliesFlap sugarNavTab: navTab]]
ifFalse: [self enableGlobalFlapWithID: 'Navigator' translated].
+ SharedFlapsAllowed := true.
- SharedFlapsAllowed _ true.
Project current flapsSuppressed: false.
^ SharedFlapTabs
"Flaps addAndEnableEToyFlaps"!
Item was changed:
----- Method: Flaps class>>destroyFlapDotDotDot (in category '*Etoys-Squeakland-menu commands') -----
destroyFlapDotDotDot
"Prompt the user for a flap, and destroy the one chosen"
| aMenu |
+ aMenu := MenuMorph new.
- aMenu _ MenuMorph new.
aMenu title: 'Destroy flap named...' translated.
self globalFlapTabsIfAny do:
[:aFlapTab | aMenu add: aFlapTab flapID target: aFlapTab selector: #destroyFlap].
aMenu popUpInWorld.
!
Item was changed:
----- Method: Flaps class>>newSugarNavigatorFlap (in category '*Etoys-Squeakland-predefined flaps') -----
newSugarNavigatorFlap
| nav aFlapTab |
+ nav := (SugarNavigatorBar newWith: SugarLibrary default) addButtons.
- nav _ (SugarNavigatorBar newWith: SugarLibrary default) addButtons.
+ aFlapTab := SugarNavTab new.
- aFlapTab _ SugarNavTab new.
aFlapTab setNameTo: 'Sugar Navigator Flap' translated.
aFlapTab referent: nav.
aFlapTab addMorph: nav.
aFlapTab inboard: false.
aFlapTab edgeToAdhereTo: #top.
Preferences useArtificialSweetenerBar ifTrue: [nav configureForSqueakland].
aFlapTab resistsRemoval: true.
^ aFlapTab
"Flaps replaceGlobalFlapwithID: 'SugarNavigator' translated "
!
Item was changed:
----- Method: Flaps class>>newSuppliesFlapFromQuads:positioning:withPreviousEntries: (in category '*Etoys-Squeakland-predefined flaps') -----
newSuppliesFlapFromQuads: quads positioning: positionSymbol withPreviousEntries: aCollection
"Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen. Use #center as the positionSymbol to have it centered at the bottom of the screen, or #right to have it placed off near the right edge."
| aFlapTab aStrip aWidth sugarNavigator |
+ sugarNavigator := SugarNavigatorBar showSugarNavigator.
+ aStrip := PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color gray muchLighter from: quads withPreviousEntries: aCollection.
- sugarNavigator _ SugarNavigatorBar showSugarNavigator.
- aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color gray muchLighter from: quads withPreviousEntries: aCollection.
self twiddleSuppliesButtonsIn: aStrip.
+ aFlapTab := (sugarNavigator ifTrue: [SolidSugarSuppliesTab] ifFalse: [FlapTab]) new referent: aStrip beSticky.
- aFlapTab _ (sugarNavigator ifTrue: [SolidSugarSuppliesTab] ifFalse: [FlapTab]) new referent: aStrip beSticky.
aFlapTab setName: 'Supplies' translated edge: (sugarNavigator ifTrue: [#top] ifFalse: [#bottom]) color: Color red lighter.
aFlapTab position: (0 @ ActiveWorld sugarAllowance).
aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.
aFlapTab applyThickness: 20.
aWidth := ActiveWorld width.
aStrip extent: ActiveWorld width @ (76 * (1 + (1350 // aWidth))).
aStrip beFlap: true.
aStrip autoLineLayout: true.
aStrip vResizeToFit: true.
sugarNavigator ifTrue: [
aFlapTab useSolidTab.
aFlapTab height: 20; color: (Color r: 0.804 g: 0.804 b: 0.804).
] ifFalse: [
aFlapTab color: Color red lighter
].
^ aFlapTab
"Flaps replaceGlobalFlapwithID: 'Supplies' translated"!
Item was changed:
----- Method: Float>>exponent (in category '*Etoys-Squeakland-truncation and round off') -----
exponent
"Primitive. Consider the receiver to be represented as a power of two
multiplied by a mantissa (between one and two). Answer with the
SmallInteger to whose power two is raised. Optional. See Object
documentation whatIsAPrimitive."
| positive |
<primitive: 53>
self >= 1.0 ifTrue: [^self floorLog: 2].
self > 0.0
ifTrue:
+ [positive := (1.0 / self) exponent.
- [positive _ (1.0 / self) exponent.
self = (1.0 / (1.0 timesTwoPower: positive))
ifTrue: [^positive negated]
ifFalse: [^positive negated - 1]].
self = 0.0 ifTrue: [^-1].
^self negated exponent!
Item was changed:
----- Method: FontSubstitutionDuringLoading>>familyName: (in category 'accessing') -----
familyName: anObject
"Set the value of familyName"
+ familyName := anObject!
- familyName _ anObject!
Item was changed:
----- Method: FontSubstitutionDuringLoading>>pixelSize: (in category 'accessing') -----
pixelSize: anObject
"Set the value of pixelSize"
+ pixelSize := anObject!
- pixelSize _ anObject!
Item was changed:
----- Method: FormInputSet>>form:browser: (in category 'private-initialization') -----
form: f browser: b
+ inputs := OrderedCollection new.
+ form := f.
+ browser := b.!
- inputs _ OrderedCollection new.
- form _ f.
- browser _ b.!
Item was changed:
----- Method: FormInputSet>>submit (in category 'action') -----
submit
"collect inputs and instruct the browser to do a submission"
| inputValues |
+ inputValues := Dictionary new.
- inputValues _ Dictionary new.
inputs do: [ :input |
input active ifTrue: [
(inputValues includesKey: input name) ifFalse: [
inputValues at: input name put: (OrderedCollection new: 1) ].
(inputValues at: input name) add: input value ] ].
browser submitFormWithInputs: inputValues url: form url
method: form method encoding: form encoding.
^true!
Item was changed:
----- Method: FreeCell class>>initialize (in category 'class initialization') -----
initialize
+ Statistics := FreeCellStatistics new.!
- Statistics _ FreeCellStatistics new.!
Item was changed:
----- Method: FreeCell>>autoMovingHome (in category 'actions') -----
autoMovingHome
elapsedTimeDisplay pause.
+ autoMoveRecursionCount := autoMoveRecursionCount + 1.!
- autoMoveRecursionCount _ autoMoveRecursionCount + 1.!
Item was changed:
----- Method: FreeCell>>board (in category 'accessing') -----
board
board ifNil:
+ [board := FreeCellBoard new
- [board _ FreeCellBoard new
target: self;
actionSelector: #boardAction:].
^board!
Item was changed:
----- Method: FreeCell>>buildButton:target:label:selector: (in category 'private') -----
buildButton: aButton target: aTarget label: aLabel selector: aSelector
"wrap a button or switch in an alignmentMorph to provide some space around the button"
| a |
aButton
target: aTarget;
label: aLabel;
actionSelector: aSelector;
borderColor: #raised;
borderWidth: 2;
color: Color gray.
+ a := AlignmentMorph newColumn
- a _ AlignmentMorph newColumn
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
color: Color transparent;
layoutInset: 1.
a addMorph: aButton.
^ a
!
Item was changed:
----- Method: FreeCell>>cardMovedHome (in category 'actions') -----
cardMovedHome
cardsRemainingDisplay value: (cardsRemainingDisplay value - 1).
+ autoMoveRecursionCount := autoMoveRecursionCount - 1 max: 0.
- autoMoveRecursionCount _ autoMoveRecursionCount - 1 max: 0.
cardsRemainingDisplay value = 0
ifTrue: [self gameWon]
ifFalse: [autoMoveRecursionCount = 0 ifTrue: [elapsedTimeDisplay continue]].!
Item was changed:
----- Method: FreeCell>>fillStyle (in category 'visual properties') -----
fillStyle
myFillStyle ifNil: [
+ myFillStyle := GradientFillStyle ramp: {
- myFillStyle _ GradientFillStyle ramp: {
0.0 -> self colorNearTop.
1.0 -> self colorNearBottom
}.
].
^myFillStyle
origin: self position;
direction: (self width // 2)@self height
!
Item was changed:
----- Method: FreeCell>>gameLost (in category 'actions') -----
gameLost
+ state := #lost.
- state _ #lost.
elapsedTimeDisplay stop.
cardsRemainingDisplay highlighted: true; flash: true.
Statistics gameLost: self currentGame!
Item was changed:
----- Method: FreeCell>>gameWon (in category 'actions') -----
gameWon
+ state := #won.
- state _ #won.
elapsedTimeDisplay stop; highlighted: true; flash: true.
Statistics gameWon: self currentGame!
Item was changed:
----- Method: FreeCell>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
Statistics newSession.
+ autoMoveRecursionCount := 0.
- autoMoveRecursionCount _ 0.
self listDirection: #topToBottom.
self wrapCentering: #center;
cellPositioning: #topCenter.
self vResizing: #shrinkWrap.
self hResizing: #shrinkWrap.
self
addMorph: self makeControls;
addMorph: self board;
newGame!
Item was changed:
----- Method: FreeCell>>newGame (in category 'actions') -----
newGame
Collection initialize.
self newGameNumber: nil.
+ state := #newGame!
- state _ #newGame!
Item was changed:
----- Method: FreeCell>>pickGame (in category 'actions') -----
pickGame
| seed |
+ seed := self promptForSeed.
- seed _ self promptForSeed.
seed isNil ifTrue: [^ self].
self newGameNumber: seed.
+ state := #pickGame!
- state _ #pickGame!
Item was changed:
----- Method: FreeCell>>sameGame (in category 'actions') -----
sameGame
self newGameNumber: self currentGame.
+ state := #sameGame.
- state _ #sameGame.
!
Item was changed:
----- Method: FreeCell>>wrapPanel:label: (in category 'private') -----
wrapPanel: anLedPanel label: aLabel
"wrap an LED panel in an alignmentMorph with a label to its left"
| a |
+ a := AlignmentMorph newRow
- a _ AlignmentMorph newRow
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 0;
layoutInset: 5;
color: Color transparent.
a addMorph: anLedPanel.
a addMorph: (StringMorph contents: aLabel).
^ a
!
Item was changed:
----- Method: FreeCellBoard>>actionSelector: (in category 'accessing') -----
actionSelector: aSymbolOrString
(nil = aSymbolOrString or:
['nil' = aSymbolOrString or:
[aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
- ifTrue: [^ actionSelector _ nil].
+ actionSelector := aSymbolOrString asSymbol.
- actionSelector _ aSymbolOrString asSymbol.
!
Item was changed:
----- Method: FreeCellBoard>>addHardness (in category 'hardness') -----
addHardness
| cnt rand pileInd pile |
"post process the layout of cards to make it harder. See class comment."
hardness ifNil: [^ self].
+ cnt := hardness.
+ rand := Random new seed: cardDeck seed. "Same numbers but different purpose"
+ pileInd := 1.
+ [(cnt := cnt - 1) > 0] whileTrue: [
+ pile := stacks atWrap: (pileInd := pileInd + 1).
+ cnt := cnt - (self makeHarder: pile rand: rand toDo: cnt)]. "mostly 0, but moves cards"!
- cnt _ hardness.
- rand _ Random new seed: cardDeck seed. "Same numbers but different purpose"
- pileInd _ 1.
- [(cnt _ cnt - 1) > 0] whileTrue: [
- pile _ stacks atWrap: (pileInd _ pileInd + 1).
- cnt _ cnt - (self makeHarder: pile rand: rand toDo: cnt)]. "mostly 0, but moves cards"!
Item was changed:
----- Method: FreeCellBoard>>autoMoveCardsHome (in category 'private') -----
autoMoveCardsHome
| first |
+ first := false.
- first _ false.
(self stacks, self freeCells) do: [:deck |
self homeCells do: [ :homeCell |
deck hasCards ifTrue: [
(homeCell repelCard: deck topCard) ifFalse: [
(self isPlayableCardInHomeCells: deck topCard) ifTrue: [
first ifFalse: [ " trigger autoMoving event on first move."
+ first := true.
- first _ true.
self performActionSelector: #autoMovingHome
].
self visiblyMove: deck topCard to: homeCell.
]
]
]
]
].
!
Item was changed:
----- Method: FreeCellBoard>>dragCard:fromStack: (in category 'actions') -----
dragCard: aCard fromStack: aCardDeck
| i cards |
+ cards := aCardDeck cards.
+ i := cards indexOf: aCard ifAbsent: [^ nil].
- cards _ aCardDeck cards.
- i _ cards indexOf: aCard ifAbsent: [^ nil].
i > (self maxDraggableStackSize: false) ifTrue: [^ nil].
[i > 1] whileTrue:
[(aCardDeck inStackingOrder: (cards at: i-1)
onTopOf: (cards at: i)) ifFalse: [^ nil].
+ i := i-1].
- i _ i-1].
^ aCard!
Item was changed:
----- Method: FreeCellBoard>>freeCell (in category 'layout') -----
freeCell
| freeCell |
+ freeCell := self cardCell.
- freeCell _ self cardCell.
freeCell stackingPolicy: #single;
emptyDropPolicy: #any;
target: self;
cardDroppedSelector: #cardMoved;
acceptCardSelector: #acceptSingleCard:on:.
^ freeCell!
Item was changed:
----- Method: FreeCellBoard>>hardness: (in category 'accessing') -----
hardness: integer
+ hardness := integer "or nil"!
- hardness _ integer "or nil"!
Item was changed:
----- Method: FreeCellBoard>>homeCell (in category 'layout') -----
homeCell
| homeCell |
+ homeCell := self cardCell.
- homeCell _ self cardCell.
homeCell stackingPolicy: #straight;
stackingOrder: #ascending;
emptyDropPolicy: #inOrder;
target: self;
cardDroppedSelector: #cardMovedHome;
cardDraggedSelector: #dragCard:fromHome:;
acceptCardSelector: #acceptSingleCard:on:.
^ homeCell!
Item was changed:
----- Method: FreeCellBoard>>isPlayableCardInHomeCells: (in category 'private') -----
isPlayableCardInHomeCells: aPlayingCard
| unplayedOther topsThisColor topsOtherColor unplayedSame |
" are all cards that could be played on this card if it stayed on the stack present in the
home cells?"
aPlayingCard cardNumber <= 2 ifTrue: [^true]. "special case for Aces and 2's"
+ topsThisColor := OrderedCollection new.
+ topsOtherColor := OrderedCollection new.
- topsThisColor _ OrderedCollection new.
- topsOtherColor _ OrderedCollection new.
self homeCells do: [ :deck |
deck hasCards ifTrue: [
(aPlayingCard suitColor == deck topCard suitColor
ifTrue: [topsThisColor] ifFalse: [topsOtherColor]) add: deck topCard cardNumber.
]
].
+ unplayedOther := topsOtherColor size < 2 ifTrue: [1] ifFalse: [topsOtherColor min + 1].
+ unplayedSame := topsThisColor size < 2 ifTrue: [1] ifFalse: [topsThisColor min + 1].
- unplayedOther _ topsOtherColor size < 2 ifTrue: [1] ifFalse: [topsOtherColor min + 1].
- unplayedSame _ topsThisColor size < 2 ifTrue: [1] ifFalse: [topsThisColor min + 1].
unplayedOther > (aPlayingCard cardNumber - 1) ifTrue: [^true].
unplayedOther < (aPlayingCard cardNumber - 1) ifTrue: [^false].
^unplayedSame >= (unplayedOther - 1)
!
Item was changed:
----- Method: FreeCellBoard>>makeHarder:rand:toDo: (in category 'hardness') -----
makeHarder: pile rand: rand toDo: cnt
| deepColor ind thisPile thisCard otherCard |
"Move cards in a stack to make it harder. Pick a card from the pile. Only consider moving it deeper (toward last of pile)."
+ deepColor := stacks first cards last suitColor.
+ ind := ((pile cards size - 1) atRandom: rand). "front card"
+ thisPile := pile cards. "submorphs array. We will stomp it."
+ thisCard := thisPile at: ind.
+ otherCard := thisPile at: ind+1.
- deepColor _ stacks first cards last suitColor.
- ind _ ((pile cards size - 1) atRandom: rand). "front card"
- thisPile _ pile cards. "submorphs array. We will stomp it."
- thisCard _ thisPile at: ind.
- otherCard _ thisPile at: ind+1.
"Move deepColor cards deeper, past cards of the other color"
(thisCard suitColor == deepColor) & (otherCard suitColor ~~ deepColor) ifTrue: [
thisPile at: ind put: otherCard.
thisPile at: ind+1 put: thisCard.
^ 0]. "single moves for now. Make multiple when it's too slow this way"
"When colors the same, move low numbered cards deeper, past high cards"
(thisCard suitColor == otherCard suitColor) ifTrue: [
(thisCard cardNumber < otherCard cardNumber) ifTrue: [
thisPile at: ind put: otherCard.
thisPile at: ind+1 put: thisCard.
^ 0]]. "single moves for now. Make multiple when it's too slow this way"
^ 0!
Item was changed:
----- Method: FreeCellBoard>>maxDraggableStackSize: (in category 'private') -----
maxDraggableStackSize: dropIntoEmptyStack
"Note: dropIntoEmptyStack, means one less empty stack to work with.
This needs to be reevaluated at time of drop."
"Not super smart - doesn't use stacks that are buildable though not empty"
| nFree nEmptyStacks |
+ nFree := (freeCells select: [:d | d hasCards not]) size.
+ nEmptyStacks := (stacks select: [:d | d hasCards not]) size.
+ dropIntoEmptyStack ifTrue: [nEmptyStacks := nEmptyStacks - 1].
- nFree _ (freeCells select: [:d | d hasCards not]) size.
- nEmptyStacks _ (stacks select: [:d | d hasCards not]) size.
- dropIntoEmptyStack ifTrue: [nEmptyStacks _ nEmptyStacks - 1].
^ (1 + nFree) * (2 raisedTo: nEmptyStacks)!
Item was changed:
----- Method: FreeCellBoard>>resetStacks (in category 'initialization') -----
resetStacks
| card stackStream stack |
stacks do: [:deck | deck removeAllCards].
+ stackStream := ReadStream on: stacks.
+ [card := cardDeck deal.
- stackStream _ ReadStream on: stacks.
- [card _ cardDeck deal.
card notNil] whileTrue: [
+ stack := stackStream next ifNil: [stackStream reset; next].
- stack _ stackStream next ifNil: [stackStream reset; next].
stack addCard: card].
!
Item was changed:
----- Method: FreeCellBoard>>target: (in category 'accessing') -----
target: anObject
+ target := anObject!
- target _ anObject!
Item was changed:
----- Method: FreeCellBoard>>visiblyMove:to: (in category 'private') -----
visiblyMove: aCard to: aCell
| p1 p2 nSteps |
self inAutoMove ifFalse: [self captureStateBeforeGrab].
owner owner addMorphFront: aCard.
+ p1 := aCard position.
+ p2 := aCell position.
+ nSteps := 10.
- p1 _ aCard position.
- p2 _ aCell position.
- nSteps _ 10.
1 to: nSteps-1 do: "Note final step happens with actual drop"
[:i | aCard position: ((p2*i) + (p1*(nSteps-i))) // nSteps.
self world displayWorld].
aCell acceptDroppingMorph: aCard event: nil!
Item was changed:
----- Method: FreeCellStatistics>>buildButton:target:label:selector: (in category 'user interface') -----
buildButton: aButton target: aTarget label: aLabel selector: aSelector
"wrap a button or switch in an alignmentMorph to provide some space around the button"
| a |
aButton
target: aTarget;
label: aLabel;
actionSelector: aSelector;
borderColor: #raised;
borderWidth: 2;
color: Color gray.
+ a := AlignmentMorph newColumn
- a _ AlignmentMorph newColumn
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #spaceFill;
vResizing: #shrinkWrap;
color: Color transparent;
layoutInset: 1.
a addMorph: aButton.
^ a
!
Item was changed:
----- Method: FreeCellStatistics>>close (in category 'user interface') -----
close
window ifNotNil: [
window delete.
+ window := nil].!
- window _ nil].!
Item was changed:
----- Method: FreeCellStatistics>>display (in category 'user interface') -----
display
| panel |
(window notNil and: [window owner notNil]) ifTrue: [window activate. ^nil].
+ panel := AlignmentMorph newColumn.
- panel _ AlignmentMorph newColumn.
panel
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #rigid;
vResizing: #rigid;
extent: 250 at 150;
color: self color;
addMorphBack: self makeStatistics;
addMorphBack: self makeControls.
+ window := panel openInWindowLabeled: 'FreeCell Statistics' translated.!
- window _ panel openInWindowLabeled: 'FreeCell Statistics' translated.!
Item was changed:
----- Method: FreeCellStatistics>>gameLost: (in category 'actions') -----
gameLost: gameNumber
"Don't count multiple losses of the same game"
gameNumber = lastGameLost ifTrue: [^ self].
+ lastGameLost := gameNumber.
- lastGameLost _ gameNumber.
+ sessionLosses := sessionLosses + 1.
+ totalLosses := totalLosses + 1.
+ lossesWithReplay := lossesWithReplay + 1.
- sessionLosses _ sessionLosses + 1.
- totalLosses _ totalLosses + 1.
- lossesWithReplay _ lossesWithReplay + 1.
currentType = #losses
+ ifTrue: [currentCount := currentCount + 1]
- ifTrue: [currentCount _ currentCount + 1]
ifFalse:
+ [currentCount := 1.
+ currentType := #losses].
- [currentCount _ 1.
- currentType _ #losses].
self updateStreak.
self changed!
Item was changed:
----- Method: FreeCellStatistics>>gameWon: (in category 'actions') -----
gameWon: gameNumber
+ sessionWins := sessionWins + 1.
+ totalWins := totalWins + 1.
- sessionWins _ sessionWins + 1.
- totalWins _ totalWins + 1.
gameNumber = lastGameWon ifFalse:
[gameNumber = lastGameLost ifTrue:
["Finally won a game by replaying"
+ lossesWithReplay := lossesWithReplay - 1].
+ winsWithReplay := winsWithReplay + 1].
+ lastGameWon := gameNumber.
- lossesWithReplay _ lossesWithReplay - 1].
- winsWithReplay _ winsWithReplay + 1].
- lastGameWon _ gameNumber.
currentType = #wins
+ ifTrue: [currentCount := currentCount + 1]
+ ifFalse: [currentCount := 1.
+ currentType := #wins].
- ifTrue: [currentCount _ currentCount + 1]
- ifFalse: [currentCount _ 1.
- currentType _ #wins].
self updateStreak.
self changed!
Item was changed:
----- Method: FreeCellStatistics>>makeControls (in category 'user interface') -----
makeControls
| row |
+ row := AlignmentMorph newRow.
- row _ AlignmentMorph newRow.
row
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #spaceFill;
vResizing: #shrinkWrap;
color: self color;
borderWidth: 2;
borderColor: #inset;
addMorphBack: self makeOkButton;
addMorphBack: self makeResetButton.
^row.!
Item was changed:
----- Method: FreeCellStatistics>>makeStatistics (in category 'user interface') -----
makeStatistics
| row |
+ row := AlignmentMorph newRow.
- row _ AlignmentMorph newRow.
row
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #spaceFill;
vResizing: #spaceFill;
color: self color;
borderWidth: 2;
borderColor: #inset;
addMorphBack: (AlignmentMorph newColumn
wrapCentering: #center; cellPositioning: #topCenter;
color: self color;
+ addMorph: (statsMorph := TextMorph new contents: self statsText)).
- addMorph: (statsMorph _ TextMorph new contents: self statsText)).
^row.!
Item was changed:
----- Method: FreeCellStatistics>>newSession (in category 'actions') -----
newSession
+ sessionWins := 0.
+ sessionLosses := 0.
+ currentCount := 0.
+ currentType := nil.
- sessionWins _ 0.
- sessionLosses _ 0.
- currentCount _ 0.
- currentType _ nil.
self changed.!
Item was changed:
----- Method: FreeCellStatistics>>ok (in category 'actions') -----
ok
window delete.
+ window := nil.!
- window _ nil.!
Item was changed:
----- Method: FreeCellStatistics>>reset (in category 'actions') -----
reset
sessionWins _ 0.
sessionLosses _ 0.
totalWins _ 0.
totalLosses _ 0.
streakWins _ 0.
streakLosses _ 0.
+ winsWithReplay := 0.
+ lossesWithReplay := 0.
- winsWithReplay _ 0.
- lossesWithReplay _ 0.
lastGameWon _ 0.
lastGameLost _ 0.
currentCount _ 0.
currentType _ nil.
self changed.
!
Item was changed:
----- Method: FreeCellStatistics>>updateStreak (in category 'actions') -----
updateStreak
"I moved the code from #printWins:on: and #printLosses:on: here because
it is basically the same. I hope this increases the maintainability.
th 12/20/1999 20:41"
+ currentType = #losses ifTrue: [streakLosses := streakLosses max: currentCount].
+ currentType = #wins ifTrue: [streakWins := streakWins max: currentCount]!
- currentType = #losses ifTrue: [streakLosses _ streakLosses max: currentCount].
- currentType = #wins ifTrue: [streakWins _ streakWins max: currentCount]!
Item was changed:
----- Method: FreeTranslation class>>extract: (in category 'translation') -----
extract: aMimeDoc
| pageSource str |
"Extract the translated text from the web page"
(aMimeDoc content beginsWith: 'error') ifTrue: [^ aMimeDoc content].
+ pageSource := aMimeDoc content.
- pageSource _ aMimeDoc content.
"brute force way to pull out the result"
+ str := ReadStream on: pageSource.
- str _ ReadStream on: pageSource.
str match: 'Translation Results by Transparent Language'.
str match: '<p>'.
^ str upToAll: '</p>'!
Item was changed:
----- Method: FreeTranslation class>>openScamperOn: (in category 'scamper') -----
openScamperOn: currentSelection
"Submit the string to the translation server at www.freetranslation.com. Ask it to translate from (Preferences parameterAt: #languageTranslateFrom) to (Preferences parameterAt: #languageTranslateTo). Display the results in a Scamper window, reusing the previous one if possible."
| inputs scamperWindow from to |
currentSelection size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
+ from := Preferences parameterAt: #languageTranslateFrom ifAbsentPut: ['English'].
+ to := Preferences parameterAt: #languageTranslateTo ifAbsentPut: ['German'].
- from _ Preferences parameterAt: #languageTranslateFrom ifAbsentPut: ['English'].
- to _ Preferences parameterAt: #languageTranslateTo ifAbsentPut: ['German'].
from = to ifTrue:
[^ self inform: 'You asked to translate from ', from, ' to ', to, '.\' withCRs,
'Use "choose language" to set these.'].
+ inputs := Dictionary new.
- inputs _ Dictionary new.
inputs at: 'SrcText' put: (Array with: currentSelection).
inputs at: 'Sequence' put: #('core').
inputs at: 'Mode' put: #('html').
inputs at: 'template' put: #('TextResult2.htm').
inputs at: 'Language' put: (Array with: from, '/', to).
+ scamperWindow := (WebBrowser default ifNil: [^self]) newOrExistingOn: 'http://ets.freetranslation.com'.
- scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: 'http://ets.freetranslation.com'.
scamperWindow model submitFormWithInputs: inputs
url: 'http://ets.freetranslation.com:5081' asUrl
method: 'post'.
scamperWindow activate.
!
Item was changed:
----- Method: FreeTranslation class>>translate:from:to: (in category 'translation') -----
translate: aString from: fromLang to: toLang
| inputs |
"Submit the string to the translation server at www.freetranslation.com. Return the entire web page that freetranslation sends back."
aString size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
+ inputs := Dictionary new.
- inputs _ Dictionary new.
inputs at: 'SrcText' put: (Array with: aString).
inputs at: 'Sequence' put: #('core').
inputs at: 'Mode' put: #('html').
inputs at: 'template' put: #('TextResult2.htm').
inputs at: 'Language' put: (Array with: fromLang, '/', toLang).
^ 'http://ets.freetranslation.com:5081' asUrl postFormArgs: inputs.
!
Item was changed:
----- Method: FreeTranslation class>>translatePanel:fromTo: (in category 'translation') -----
translatePanel: buttonPlayer fromTo: normalDirection
| ow fromTM toTM fromLang toLang tt doc answer width |
"Gather up all the info I need from the morphs in the button's owner and do the translation. Insert the results in a TextMorph. Use www.freeTranslation.com Refresh the banner ad.
TextMorph with 'from' in the title is starting text.
PopUpChoiceMorph with 'from' in the title is the starting language.
TextMorph with 'from' in the title is place to put the answer.
PopUpChoiceMorph with 'from' in the title is the target language.
If normalDirection is false, translate the other direction."
+ ow := buttonPlayer costume ownerThatIsA: PasteUpMorph.
- ow _ buttonPlayer costume ownerThatIsA: PasteUpMorph.
ow allMorphs do: [:mm |
(mm isTextMorph) ifTrue: [
(mm knownName asString includesSubString: 'from') ifTrue: [
+ fromTM := mm].
- fromTM _ mm].
(mm knownName asString includesSubString: 'to') ifTrue: [
+ toTM := mm]].
- toTM _ mm]].
(mm isKindOf: PopUpChoiceMorph) ifTrue: [
(mm knownName asString includesSubString: 'from') ifTrue: [
+ fromLang := mm contents asString].
- fromLang _ mm contents asString].
(mm owner knownName asString includesSubString: 'from') ifTrue: [
+ fromLang := mm contents asString].
- fromLang _ mm contents asString].
(mm knownName asString includesSubString: 'to') ifTrue: [
+ toLang := mm contents asString].
- toLang _ mm contents asString].
(mm owner knownName asString includesSubString: 'to') ifTrue: [
+ toLang := mm contents asString]]].
- toLang _ mm contents asString]]].
normalDirection ifFalse: ["switch"
+ tt := fromTM. fromTM := toTM. toTM := tt.
+ tt := fromLang. fromLang := toLang. toLang := tt].
- tt _ fromTM. fromTM _ toTM. toTM _ tt.
- tt _ fromLang. fromLang _ toLang. toLang _ tt].
Cursor wait showWhile: [
+ doc := self translate: fromTM contents asString from: fromLang to: toLang.
+ answer := self extract: doc]. "pull out the translated text"
- doc _ self translate: fromTM contents asString from: fromLang to: toLang.
- answer _ self extract: doc]. "pull out the translated text"
+ width := toTM width.
- width _ toTM width.
toTM contents: answer wrappedTo: width.
toTM changed.!
Item was changed:
----- Method: FunctionComponent>>accept (in category 'menu commands') -----
accept
"Inform the model of text to be accepted, and return true if OK."
| textToAccept oldSelector |
+ oldSelector := functionSelector.
+ textToAccept := textMorph asText.
- oldSelector _ functionSelector.
- textToAccept _ textMorph asText.
textToAccept = self getText ifTrue: [^ self]. "No body to compile yet"
+ functionSelector := model class
- functionSelector _ model class
compile: self headerString , textToAccept asString
classified: 'functions' notifying: nil.
self setText: textToAccept.
self hasUnacceptedEdits: false.
oldSelector ifNotNil:
[functionSelector = oldSelector ifFalse: [model class removeSelector: oldSelector]].
self fire!
Item was changed:
----- Method: FunctionComponent>>addPin (in category 'as yet unclassified') -----
addPin
| i prev sideLength wasNew |
+ wasNew := self getText = textMorph asText.
+ i := pinSpecs size.
+ prev := pinSpecs last.
+ sideLength := prev pinLoc asInteger odd ifTrue: [self height] ifFalse: [self width].
+ pinSpecs := pinSpecs copyWith:
- wasNew _ self getText = textMorph asText.
- i _ pinSpecs size.
- prev _ pinSpecs last.
- sideLength _ prev pinLoc asInteger odd ifTrue: [self height] ifFalse: [self width].
- pinSpecs _ pinSpecs copyWith:
(PinSpec new pinName: ('abcdefghi' copyFrom: i to: i) direction: #input
localReadSelector: nil localWriteSelector: nil
modelReadSelector: nil modelWriteSelector: nil
defaultValue: nil pinLoc: prev pinLoc + (8/sideLength) asFloat \\ 4).
self initFromPinSpecs.
self addPinFromSpec: pinSpecs last.
wasNew ifTrue: [self setText: self getText].
self accept
!
Item was changed:
----- Method: FunctionComponent>>getText (in category 'model access') -----
getText
| ps |
^ ('"type a function of' ,
(String streamContents:
[:s | 2 to: pinSpecs size do:
+ [:i | ps := pinSpecs at: i.
- [:i | ps _ pinSpecs at: i.
(i>2 and: [i = pinSpecs size]) ifTrue: [s nextPutAll: ' and'].
s nextPutAll: ' ', ps pinName]]) ,
'"') asText!
Item was changed:
----- Method: FunctionComponent>>headerString (in category 'as yet unclassified') -----
headerString
| ps |
^ String streamContents:
[:s | s nextPutAll: self knownName.
2 to: pinSpecs size do:
+ [:i | ps := pinSpecs at: i.
- [:i | ps _ pinSpecs at: i.
s nextPutAll: ps pinName , ': ';
nextPutAll: ps pinName , ' '].
s cr; tab; nextPutAll: '^ ']!
Item was changed:
----- Method: FunctionComponent>>initFromPinSpecs (in category 'components') -----
initFromPinSpecs
+ outputSelector := pinSpecs first modelWriteSelector.
+ inputSelectors := (pinSpecs copyFrom: 2 to: pinSpecs size)
- outputSelector _ pinSpecs first modelWriteSelector.
- inputSelectors _ (pinSpecs copyFrom: 2 to: pinSpecs size)
collect: [:ps | ps modelReadSelector]!
Item was changed:
----- Method: FunctionComponent>>initPinSpecs (in category 'components') -----
initPinSpecs
+ pinSpecs := Array
- pinSpecs _ Array
with: (PinSpec new pinName: 'output' direction: #output
localReadSelector: nil localWriteSelector: nil
modelReadSelector: nil modelWriteSelector: nil
defaultValue: nil pinLoc: 3.5)
with: (PinSpec new pinName: 'a' direction: #input
localReadSelector: nil localWriteSelector: nil
modelReadSelector: nil modelWriteSelector: nil
defaultValue: nil pinLoc: 1.5)
!
Item was changed:
----- Method: GenericPropertiesMorph>>buttonNamed:action:color:help: (in category 'initialization') -----
buttonNamed: aString action: aSymbol color: aColor help: helpString
"Answer a button with the string provided as label, with the receiver as target, and with the given action; give it the color specified, and associate the given help-sting with it."
| f col |
+ f := SimpleButtonMorph new
- f _ SimpleButtonMorph new
target: self;
labelString: aString font: Preferences standardEToysButtonFont;
color: aColor;
actionSelector: aSymbol;
setBalloonText: helpString.
+ col := (self inAColumn: {f}) hResizing: #shrinkWrap.
- col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
^ col!
Item was changed:
----- Method: GoldBoxMenu>>initializeFor: (in category 'initialization') -----
initializeFor: aScriptor
"Answer a graphical menu to be put up in conjunction with the Gold Box"
| aButton goldBox aReceiver boxBounds example toScale |
+ scriptor := aScriptor.
+ lastItemMousedOver := nil.
- scriptor _ aScriptor.
- lastItemMousedOver _ nil.
self removeAllMorphs.
self setProperty: #goldBox toValue: true.
self listDirection: #topToBottom;
hResizing: #spaceFill; extent: 1 at 1; vResizing: #spaceFill. "standard #newColumn stuff"
self setNameTo: 'Gold Box' translated.
self useRoundedCorners.
self color: Color white.
self borderColor: (Color r: 1.0 g: 0.839 b: 0.065).
self hResizing: #shrinkWrap; vResizing: #shrinkWrap; borderWidth: 4.
{
{ScriptingSystem. #yesNoComplexOfTiles. 'test' translated. 'Test/Yes/No panes for testing a condition.' translated}.
{ScriptingSystem. #timesRepeatComplexOfTiles. 'repeat' translated. 'TimesRepeat panes for running a section of code repeatedly.' translated}.
{ ScriptingSystem. #randomNumberTile. 'random' translated. 'A tile that will produce a random number in a given range.' translated}.
{ ScriptingSystem. #seminalFunctionTile. 'function' translated. 'A tile representing a function call. Click on the function name or the arrows to change functions.' translated}.
{ScriptingSystem. #buttonUpTile. 'button up?' translated. 'Reports whether the mouse button is up' translated}.
{ScriptingSystem. #buttonDownTile. 'button down?' translated. 'Reports whether the mouse button is down' translated}.
{ScriptingSystem. #randomColorTile. 'random color' translated. 'A tile returning a random color' translated}.
{scriptor playerScripted. #tileToRefer. 'tile for me' translated. 'A tile representing the object being scripted' translated}.
{self. #numericConstantTile. 'number' translated. 'A tile holding a plain number' translated}.
} do:
[:tuple |
+ aReceiver := tuple first.
- aReceiver _ tuple first.
example := aReceiver perform: tuple second.
aButton := IconicButton new target: aReceiver.
aButton borderWidth: 0;
color: Color transparent.
toScale := tuple size >= 5
ifTrue:
[tuple first perform: tuple fifth] "bail-out for intractable images."
ifFalse:
[example imageForm].
aButton labelGraphic: (toScale copy scaledToHeight: 40).
aButton actionSelector: #launchPartOffsetVia:label:.
aButton arguments: {tuple second. tuple third}.
(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
[aButton setBalloonText: tuple fourth].
aButton actWhen: #buttonDown.
aButton on: #mouseEnter send: #mousedOverEvent:button: to: self.
aButton on: #click send: #delete to: self.
self addMorphBack: aButton].
+ goldBox := aScriptor submorphs first submorphThat: [:m | (m isKindOf: SimpleButtonMorph) and: [m actionSelector == #offerGoldBoxMenu]] ifNone: [nil].
- goldBox _ aScriptor submorphs first submorphThat: [:m | (m isKindOf: SimpleButtonMorph) and: [m actionSelector == #offerGoldBoxMenu]] ifNone: [nil].
goldBox
ifNil:
[self position: ActiveHand position]
ifNotNil:
+ [boxBounds := goldBox boundsInWorld.
- [boxBounds _ goldBox boundsInWorld.
self center: boxBounds center.
self left: (boxBounds center x - (self width // 2)).
self top: boxBounds bottom].
+ lastItemMousedOver := nil.
- lastItemMousedOver _ nil.
self on: #mouseLeave send: #mouseLeftMenuWithEvent: to: self.
self on: #mouseLeaveDragging send: #delete to: self.!
Item was changed:
----- Method: GoldBoxMenu>>mousedOverEvent:button: (in category 'initialization') -----
mousedOverEvent: evt button: aButton
"The mouse came over a button in my panel; make a note of it, and instigate its mouseover highlighting"
+ lastItemMousedOver := aButton.
- lastItemMousedOver _ aButton.
aButton borderThick!
Item was changed:
----- Method: HTTPSocket class>>argStringUnencoded: (in category '*Etoys-Squeakland-utilities') -----
argStringUnencoded: args
"Return the args in a long string, as encoded in a url"
| argsString first |
args isString ifTrue: ["sent in as a string, not a dictionary"
^ (args first = $? ifTrue: [''] ifFalse: ['?']), args].
+ argsString := WriteStream on: String new.
- argsString _ WriteStream on: String new.
argsString nextPut: $?.
+ first := true.
- first _ true.
args associationsDo: [ :assoc |
assoc value do: [ :value |
+ first ifTrue: [ first := false ] ifFalse: [ argsString nextPut: $& ].
- first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ].
argsString nextPutAll: assoc key.
argsString nextPut: $=.
argsString nextPutAll: value. ] ].
^ argsString contents
!
Item was changed:
----- Method: HTTPSocket class>>retry:asking:ifGiveUp: (in category '*Etoys-Squeakland-utilities') -----
retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock
"Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false."
| response |
[tryBlock value] whileFalse: [
| sema |
+ sema := Semaphore new.
- sema _ Semaphore new.
WorldState addDeferredUIMessage: [
+ response := (PopUpMenu labels: 'Retry\Give Up' translated withCRs)
- response _ (PopUpMenu labels: 'Retry\Give Up' translated withCRs)
startUpWithCaption: troubleString.
sema signal.
].
sema wait.
response = 2 ifTrue: [abortActionBlock value. ^ false]].
^ true
!
Item was changed:
----- Method: HaloMorph>>addSmallHandle:on:send:to: (in category '*Etoys-Squeakland-private') -----
addSmallHandle: handleSpec on: eventName send: selector to: recipient
"Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle. This is the 5/17/04 version of HaloMorph>>addHandle:on:send:to:"
| handle aPoint iconName colorToUse |
+ aPoint := self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement.
+ handle := EllipseMorph
- aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement.
- handle _ EllipseMorph
newBounds: (Rectangle center: aPoint extent: self handleSize asPoint)
+ color: (colorToUse := Color colorFrom: handleSpec color).
- color: (colorToUse _ Color colorFrom: handleSpec color).
handle borderColor: colorToUse muchDarker.
self addMorph: handle.
+ (iconName := handleSpec iconSymbol) ifNotNil:
- (iconName _ handleSpec iconSymbol) ifNotNil:
[ | form |
+ form := ScriptingSystem formAtKey: iconName.
- form _ ScriptingSystem formAtKey: iconName.
form ifNotNil:
[handle addMorphCentered: (ImageMorph new
image: form;
color: colorToUse makeForegroundColor;
lock)]].
handle on: #mouseUp send: #endInteraction to: self.
handle on: eventName send: selector to: recipient.
self isMagicHalo ifTrue:[
handle on: #mouseEnter send: #handleEntered to: self.
handle on: #mouseLeave send: #handleLeft to: self].
handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
^ handle
!
Item was changed:
----- Method: HaloMorph>>dragTarget: (in category '*Etoys-Squeakland-events') -----
dragTarget: event
"Begin dragging the target"
| thePoint |
event controlKeyPressed ifTrue: [^self growTarget: event].
growingOrRotating := false.
innerTarget aboutToBeBrownDragged.
self setProperty: #conclusionSelector toValue: #brownDragConcluded.
+ thePoint := target point: event position - positionOffset from: owner.
- thePoint _ target point: event position - positionOffset from: owner.
target setConstrainedPosition: thePoint hangOut: true.
event hand newMouseFocus: self!
Item was changed:
----- Method: HandMorph class>>initializeCursorForm (in category '*Etoys-Squeakland-initialization') -----
initializeCursorForm
+ NormalCursor := CursorWithMask normal asCursorForm.
- NormalCursor _ CursorWithMask normal asCursorForm.
!
Item was changed:
----- Method: HandMorph>>simulateMorphDropAt: (in category '*Etoys-Squeakland-grabbing/dropping') -----
simulateMorphDropAt: aPosition
"Simulate a drop of the morph I'm carrying."
| event dropped aMorph |
aMorph := submorphs at: 1 ifAbsent: [^ self].
self privateRemove: aMorph.
aMorph privateOwner: self.
+ dropped := aMorph.
- dropped _ aMorph.
(dropped hasProperty: #addedFlexAtGrab)
+ ifTrue:[dropped := aMorph removeFlexShell].
+ event := DropEvent new setPosition: aPosition contents: dropped hand: self.
- ifTrue:[dropped _ aMorph removeFlexShell].
- event _ DropEvent new setPosition: aPosition contents: dropped hand: self.
self sendEvent: event focus: nil.
event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event].
aMorph owner == self ifTrue: [aMorph delete]!
Item was changed:
----- Method: HandMorphForReplay>>suspended: (in category '*Etoys-Squeakland-accessing') -----
suspended: anObject
"Set the value of suspended"
+ suspended := anObject!
- suspended _ anObject!
Item was changed:
----- Method: HeadingMorph>>degrees: (in category 'accessing') -----
degrees: aNumber
+ degrees := (aNumber asFloat + 270.0) \\ 360.0.!
- degrees _ (aNumber asFloat + 270.0) \\ 360.0.!
Item was changed:
----- Method: HeadingMorph>>drawArrowFrom:to:width:color:on: (in category 'drawing') -----
drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas
| d p |
+ d := (p1 - p2) theta radiansToDegrees.
- d _ (p1 - p2) theta radiansToDegrees.
aCanvas line: p1 to: p2 width: w color: aColor.
+ p := p2 + (Point r: 5 degrees: d - 50).
- p _ p2 + (Point r: 5 degrees: d - 50).
aCanvas line: p to: p2 width: w color: aColor.
+ p := p2 + (Point r: 5 degrees: d + 50).
- p _ p2 + (Point r: 5 degrees: d + 50).
aCanvas line: p to: p2 width: w color: aColor.
!
Item was changed:
----- Method: HeadingMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| x y r center box |
super drawOn: aCanvas.
+ box := self innerBounds.
- box _ self innerBounds.
1 to: 9 do: [:i |
+ x := box left + ((box width * i) // 10).
- x _ box left + ((box width * i) // 10).
aCanvas line: (x at box top) to: (x@(box bottom - 1)) color:
Color black.
+ y := box top + ((box height * i) // 10).
- y _ box top + ((box height * i) // 10).
aCanvas line: (box left at y) to: ((box right - 1)@y) color:
Color black].
+ r := ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
+ center := box center.
- r _ ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
- center _ box center.
self drawArrowFrom: center - (1 at 1)
to: center + ((r * degrees degreesToRadians cos)@0) - (1 at 1)
width: 3
color: (Color red)
on: aCanvas.
self drawArrowFrom: center - (1 at 1)
to: center + (0@(r * degrees degreesToRadians sin)) - (1 at 1)
width: 3
color: (Color red)
on: aCanvas.
self drawArrowFrom: center - (1 at 1)
to: center + (Point r: r degrees: degrees) - (1 at 1)
width: 3
color: Color black
on: aCanvas.
!
Item was changed:
----- Method: HeadingMorph>>extent: (in category 'geometry') -----
extent: aPoint
"Contrain extent to be square."
| d |
+ d := aPoint x min: aPoint y.
- d _ aPoint x min: aPoint y.
super extent: d at d.
!
Item was changed:
----- Method: HeadingMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ degrees := 90.0.
+ magnitude := 1.0.
- degrees _ 90.0.
- magnitude _ 1.0.
self extent: 160 @ 160!
Item was changed:
----- Method: HeadingMorph>>magnitude: (in category 'accessing') -----
magnitude: aNumber
+ magnitude := (aNumber asFloat max: 0.0) min: 1.0.!
- magnitude _ (aNumber asFloat max: 0.0) min: 1.0.!
Item was changed:
----- Method: HeadingMorph>>mouseDown: (in category 'events') -----
mouseDown: evt
| v |
self changed.
+ v := evt cursorPoint - bounds center.
+ degrees := v theta radiansToDegrees.
+ magnitude := (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
- v _ evt cursorPoint - bounds center.
- degrees _ v theta radiansToDegrees.
- magnitude _ (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
!
Item was changed:
----- Method: HiddenInput>>name:value: (in category 'private-initialization') -----
name: name0 value: value0
+ name := name0.
+ value := value0.!
- name _ name0.
- value _ value0.!
Item was changed:
----- Method: HtmlAnchor>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| href name |
+ name := self getAttribute: 'name'.
- name _ self getAttribute: 'name'.
name ifNotNil: [
formatter noteAnchorStart: name ].
+ href := self getAttribute: 'href'.
- href _ self getAttribute: 'href'.
href isNil
ifTrue: [ super addToFormatter: formatter ]
ifFalse: [
formatter startLink: href.
super addToFormatter: formatter.
formatter endLink: href. ].
!
Item was changed:
----- Method: HtmlArea>>buildMorph (in category 'formatting') -----
buildMorph
"construct a hot-spot morph"
| coords vertices radiusX radiusY |
+ coords := (self coords findTokens: ', ') collect: [:elem | elem asNumber asInteger].
- coords _ (self coords findTokens: ', ') collect: [:elem | elem asNumber asInteger].
self shape isEmptyOrNil
ifTrue: [^nil].
(self shape asLowercase beginsWith: 'poly')
ifTrue: [coords size even ifFalse: [^nil].
+ vertices := OrderedCollection new.
- vertices _ OrderedCollection new.
coords pairsDo: [:x :y |
vertices add: x @ y].
^(PolygonMorph vertices: vertices color: Color transparent
borderWidth: 1 borderColor: Color transparent) quickFill: false; makeClosed].
(coords size > 4 or: [coords size < 3])
ifTrue: [^nil].
self shape asLowercase = 'circle'
+ ifTrue: [radiusX := coords third.
+ radiusY := coords last.
- ifTrue: [radiusX _ coords third.
- radiusY _ coords last.
^(EllipseMorph newBounds:
(((coords first - radiusX) @ (coords second - radiusY))
extent:
((2 * radiusX) @ (2 * radiusY)))
color: Color transparent) borderColor: Color transparent].
coords size = 4
ifFalse: [^nil].
(self shape asLowercase beginsWith: 'rect')
ifTrue: [^(RectangleMorph newBounds:
(Rectangle origin: (coords first @ coords second)
corner: (coords third @ coords last))
color: Color transparent) borderColor: Color transparent].
^nil!
Item was changed:
----- Method: HtmlArea>>linkMorphForMap:andBrowser: (in category 'formatting') -----
linkMorphForMap: map andBrowser: browser
| m |
+ (m := self buildMorph) ifNil: [^nil].
- (m _ self buildMorph) ifNil: [^nil].
m color: (Color random alpha: 0.1). "hack to ensure the morph is clickable"
m
on: #mouseUp
send: #mouseUpBrowserAndUrl:event:linkMorph:
to: map
withValue: {browser. self href}.
^m!
Item was changed:
----- Method: HtmlCommentEntity>>initializeWithText: (in category 'private-iniitialization') -----
initializeWithText: aString
super initialize.
+ commentText := aString.!
- commentText _ aString.!
Item was changed:
----- Method: HtmlDocument>>formattedText (in category 'formatting') -----
formattedText
"return a version of this document as a formatted Text"
| formatter |
+ formatter := HtmlFormatter preferredFormatterClass new.
- formatter _ HtmlFormatter preferredFormatterClass new.
self addToFormatter: formatter.
^formatter text !
Item was changed:
----- Method: HtmlDocument>>formattedTextForBrowser:defaultBaseUrl: (in category 'formatting') -----
formattedTextForBrowser: browser defaultBaseUrl: defaultBaseUrl
"return a version of this document as a formatted Text (which includes links and such)"
| formatter text |
"set up the formatter"
+ formatter := HtmlFormatter preferredFormatterClass new.
- formatter _ HtmlFormatter preferredFormatterClass new.
formatter browser: browser.
formatter baseUrl: defaultBaseUrl. "should check if the document specifies something else"
"do the formatting"
self addToFormatter: formatter.
"get and return the result"
+ text := formatter text.
- text _ formatter text.
^text!
Item was changed:
----- Method: HtmlDocument>>formattedTextMorph (in category 'formatting') -----
formattedTextMorph
"return a version of this document as a formatted TextMorph (which includes links and such)"
| formatter text textMorph |
+ formatter := HtmlFormatter preferredFormatterClass new.
- formatter _ HtmlFormatter preferredFormatterClass new.
self addToFormatter: formatter.
+ text := formatter text .
- text _ formatter text .
+ textMorph := TextMorph new initialize.
- textMorph _ TextMorph new initialize.
textMorph contentsWrapped: text.
^textMorph!
Item was changed:
----- Method: HtmlDocument>>formattedTextMorphForBrowser:defaultBaseUrl: (in category 'formatting') -----
formattedTextMorphForBrowser: browser defaultBaseUrl: defaultBaseUrl
"return a version of this document as a formatted TextMorph (which includes links and such)"
| formatter textMorph |
"set up the formatter"
+ formatter := HtmlFormatter preferredFormatterClass new.
- formatter _ HtmlFormatter preferredFormatterClass new.
formatter browser: browser.
formatter baseUrl: defaultBaseUrl. "should check if the document specifies something else"
"do the formatting"
self addToFormatter: formatter.
"get and return the result"
+ textMorph := formatter textMorph .
- textMorph _ formatter textMorph .
^textMorph!
Item was changed:
----- Method: HtmlEmbedded class>>initialize (in category 'initialize') -----
initialize
"HtmlEmbedded initialize"
+ ExtensionList := Dictionary new.
- ExtensionList _ Dictionary new.
#(
('swf' FlashPlayerMorph)
) do:[:spec| ExtensionList at: spec first put: spec last].!
Item was changed:
----- Method: HtmlEmbedded>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| url embeddedMorph |
self src isNil ifTrue:[^self].
+ url := self src.
+ embeddedMorph := self embeddedMorphFor: url.
- url _ self src.
- embeddedMorph _ self embeddedMorphFor: url.
embeddedMorph isNil ifTrue:[^self].
+ formatter baseUrl ifNotNil:[url := url asUrlRelativeTo: formatter baseUrl].
- formatter baseUrl ifNotNil:[url _ url asUrlRelativeTo: formatter baseUrl].
embeddedMorph extent: self extent.
embeddedMorph sourceUrl: url.
embeddedMorph setProperty: #embedded toValue: true.
formatter addIncompleteMorph: embeddedMorph.!
Item was changed:
----- Method: HtmlEmbedded>>embeddedMorphClassFor: (in category 'formatting') -----
embeddedMorphClassFor: url
| lastIndex extension className |
+ lastIndex := url findLast:[:c| c = $.].
- lastIndex _ url findLast:[:c| c = $.].
lastIndex = 0 ifTrue:[^nil].
+ extension := url copyFrom: lastIndex+1 to: url size.
+ className := ExtensionList at: extension asLowercase ifAbsent:[^nil].
- extension _ url copyFrom: lastIndex+1 to: url size.
- className _ ExtensionList at: extension asLowercase ifAbsent:[^nil].
^Smalltalk at: className ifAbsent:[nil]
!
Item was changed:
----- Method: HtmlEmbedded>>embeddedMorphFor: (in category 'formatting') -----
embeddedMorphFor: url
| morphClass |
+ morphClass := self embeddedMorphClassFor: url.
- morphClass _ self embeddedMorphClassFor: url.
^morphClass ifNotNil:[morphClass new]!
Item was changed:
----- Method: HtmlEmbedded>>extent (in category 'attributes') -----
extent
"the image extent, according to the WIDTH and HEIGHT attributes. returns nil if either WIDTH or HEIGHT is not specified"
| widthText heightText |
+ widthText := self getAttribute: 'width' ifAbsent: [ ^nil ].
+ heightText := self getAttribute: 'height' ifAbsent: [ ^nil ].
- widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
- heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
^ widthText asNumber @ heightText asNumber!
Item was changed:
----- Method: HtmlEntity class>>initialize (in category 'class initialization') -----
initialize
"HtmlEntity initialize"
+ ReverseCharacterEntities := Dictionary new: 128.
- ReverseCharacterEntities _ Dictionary new: 128.
#('quot' $" 'lt' $< 'amp' $& 'gt' $> 'rsquo' $' 'lsquo' $` 'rdquo' $" 'ldquo' $" ) pairsDo:
[:s :c | ReverseCharacterEntities at: s put: c asciiValue].
#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo:
[:s :i | ReverseCharacterEntities at: s put: i - 1 + 160].!
Item was changed:
----- Method: HtmlEntity class>>valueOfHtmlEntity: (in category 'character entities') -----
valueOfHtmlEntity: specialEntity
"Return the character equivalent to the HTML entity."
| value |
(specialEntity beginsWith: '#') "Handle numeric entities"
ifTrue: [
"NB: We can display only simple numeric special entities in the"
"range [9..255] (HTML 3.2). HTML 4.01 allows the specification of 16 bit"
"characters, so we do a little fiddling to handle a few special cases"
+ value := self convertToNumber: (specialEntity copyFrom: 2 to: specialEntity size).
- value _ self convertToNumber: (specialEntity copyFrom: 2 to: specialEntity size).
"Replace rounded left & right double quotes (HTML 4.01) with simple double quote"
+ (value = 8220 or: [value = 8221]) ifTrue: [ value := $" asInteger ].
- (value = 8220 or: [value = 8221]) ifTrue: [ value _ $" asInteger ].
"Replace rounded left & right single quotes (HTML 4.01) with simple single quote"
+ (value = 8216 or: [value = 8217]) ifTrue: [ value := $' asInteger ].
- (value = 8216 or: [value = 8217]) ifTrue: [ value _ $' asInteger ].
"Replace with a space if outside the normal range (arbitrary choice)"
+ (value < 9 or: [value > 255]) ifTrue: [ value := 32 ].
- (value < 9 or: [value > 255]) ifTrue: [ value _ 32 ].
]
ifFalse: [
"Otherwise this is most likely a named character entity"
+ value := ReverseCharacterEntities at: specialEntity ifAbsent: [^nil].
- value _ ReverseCharacterEntities at: specialEntity ifAbsent: [^nil].
].
^Character value: value.!
Item was changed:
----- Method: HtmlEntity>>attributes: (in category 'attributes') -----
attributes: newAttributes
"set all of the attributes at once. newAttributes should not be modified after passing it in"
+ ^attribs := newAttributes!
- ^attribs _ newAttributes!
Item was changed:
----- Method: HtmlEntity>>doesNotUnderstand: (in category 'attributes') -----
doesNotUnderstand: aMessage
"treat the message as an attribute name"
| selector |
+ selector := aMessage selector.
- selector _ aMessage selector.
selector asLowercase = selector ifFalse: [
"attribute accesses must be in all lowercase. This should cut down on some false doesNotUnderstand: traps"
^super doesNotUnderstand: aMessage ].
selector numArgs == 0 ifTrue: [
"return the named attribute"
^self getAttribute: selector asString default: nil ].
selector numArgs == 1 ifTrue: [
"set the named attribute"
self setAttribute: (selector asString copyFrom: 1 to: (selector size-1)) to: aMessage argument.
^self ].
^super doesNotUnderstand: aMessage!
Item was changed:
----- Method: HtmlEntity>>initialize (in category 'private-initialization') -----
initialize
+ contents := OrderedCollection new.
+ attribs := HtmlAttributes new.!
- contents _ OrderedCollection new.
- attribs _ HtmlAttributes new.!
Item was changed:
----- Method: HtmlEntity>>initialize: (in category 'private-initialization') -----
initialize: aTag
self initialize.
+ attribs := HtmlAttributes newFrom: aTag attribs.!
- attribs _ HtmlAttributes newFrom: aTag attribs.!
Item was changed:
----- Method: HtmlFontChangeEntity>>initialize: (in category 'private-initialization') -----
initialize: aTag
super initialize: aTag.
+ tagName := aTag name!
- tagName _ aTag name!
Item was changed:
----- Method: HtmlFontEntity>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| size color textAttribList |
(formatter respondsTo: #startFont:)
ifFalse: [^super addToFormatter: formatter].
+ size := self getAttribute: 'size'.
+ color := self getAttribute: 'color'.
+ textAttribList := OrderedCollection new.
- size _ self getAttribute: 'size'.
- color _ self getAttribute: 'color'.
- textAttribList _ OrderedCollection new.
color ifNotNil: [textAttribList add: (TextColor color: (Color fromString: color))].
(size isEmptyOrNil not and: [size isAllDigits])
+ ifTrue: [size := (size asNumber - 3) max: 1.
- ifTrue: [size _ (size asNumber - 3) max: 1.
textAttribList add: (TextFontChange fontNumber: (size min: 4))].
formatter startFont: textAttribList.
super addToFormatter: formatter.
formatter endFont: textAttribList!
Item was changed:
----- Method: HtmlForm>>parsingFinished (in category 'parsing') -----
parsingFinished
"figure out who our constituents are"
self allSubentitiesDo: [ :e |
e isFormEntity ifTrue: [ e form: self ] ].
super parsingFinished.
+ formEntities := OrderedCollection new.
- formEntities _ OrderedCollection new.
self allSubentitiesDo: [ :e |
(e isFormEntity and: [ e form == self ])
ifTrue: [ formEntities add: e ] ].!
Item was changed:
----- Method: HtmlFormEntity>>form: (in category 'access') -----
form: aForm
"set which form we are part of"
+ form := aForm!
- form _ aForm!
Item was changed:
----- Method: HtmlFormatter class>>example1 (in category 'examples') -----
example1
"(HtmlFormatter example1 asParagraph compositionRectangle: (0 at 0 extent: 300 at 500) ) displayAt: 0 at 0"
| input |
+ input := ReadStream on:
- input _ ReadStream on:
'<html>
<head>
<title>The Gate of Chaos</title>
</head>
<body>
<h1>Chaos</h1>
<h2>Into the Maelstrom</h2>
Direction is useless in the ever-changing Maelstrom. However,
if you wander with purpose, you might be able to find....
<ul>
<li><a href="/cgi-bin/w">see who''s logged in</a>
<li><a href="/Telnet/connect.html">log in, if you (oooh) have an account</a>
<li><a href="http://chaos.resnet.gatech.edu:9000/sw">The Chaos Swiki</a>--scribble on chaos
<li>the original <a href="/cgi-bin/guestlog-print">Visitor Sands</a>
<li>my old <a href="rant.html">Rant Page</a>
<li>neverending <a href="/cgi-bin/bread">poll</a>: do you have an opinion on bread?
<li>a <a href="http://www.cc.gatech.edu/~lex/linux.html">Linux page</a>-- free UNIX for PC''s!!
<li><a href="english.au">Hear Linus Himself speak!!!!</a>
<li><a href="/doc/">some docs on all kinds of computer stuff</a>
</ul>
<hr>
<h2>Paths of Retreat</h2>
Several commonly travelled ways have left paths leading
<em>away</em> from the maelstrom, too:
<p>
<ul>
<li><a href="friends.html">Friends of Chaos</a>
<li><a href="http://www.apache.org/">The <em>Apache</em> home page</a> --
<em>Chaos</em>''s WWW server!!
<li><a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
Notscape</a>
the <a href="http://www.eskimo.com/%7Eirving/anti-ns/">Anti-Netscape
Page</a> -- fight the tyranny!!
</ul>
<hr>
<a href="/analog/usage.html">usage stats</a> for this server
<hr>
<a href="http://www.eff.org/blueribbon.html"><img src="blueribbon.gif" alt="[blue ribbon campaign]"></a>
<a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
<img src="notscape.gif" alt="[NOTscape]">
</a>
<a href="http://www.anybrowser.org/campaign/">
<img src="anybrowser3.gif" alt="[Best Viewed With Any Browser"]></a>
</body>
</html>'.
^(HtmlParser parse: input) formattedText!
Item was changed:
----- Method: HtmlFormatter class>>initialize (in category 'initialization') -----
initialize
"HtmlFormatter initialize"
+ CSSeparators := CharacterSet separators.
+ CSNonSeparators := CSSeparators complement.!
- CSSeparators _ CharacterSet separators.
- CSNonSeparators _ CSSeparators complement.!
Item was changed:
----- Method: HtmlFormatter>>addChar: (in category 'formatting commands') -----
addChar: c
"add a single character, updating all the tallies"
"add the character to the output"
outputStream nextPut: c.
"update counters for preceeding spaces and preceding newlines"
(c = Character space or: [ c = Character tab ])
+ ifTrue: [ precedingSpaces := precedingSpaces+1. precedingNewlines := 0 ]
- ifTrue: [ precedingSpaces _ precedingSpaces+1. precedingNewlines _ 0 ]
ifFalse: [
(c = Character cr) ifTrue: [
+ precedingSpaces := 0.
+ precedingNewlines := precedingNewlines + 1 ]
- precedingSpaces _ 0.
- precedingNewlines _ precedingNewlines + 1 ]
ifFalse: [
+ precedingSpaces := precedingNewlines := 0 ] ].!
- precedingSpaces _ precedingNewlines _ 0 ] ].!
Item was changed:
----- Method: HtmlFormatter>>addLink:url: (in category 'formatting commands') -----
addLink: text url: url
"add a link with the given url and text"
| savedAttributes linkAttribute |
"set up the link attribute"
+ linkAttribute := TextURL new.
- linkAttribute _ TextURL new.
linkAttribute url: url.
"add the link to the stream"
+ savedAttributes := outputStream currentAttributes.
- savedAttributes _ outputStream currentAttributes.
outputStream currentAttributes: (savedAttributes, linkAttribute).
outputStream nextPutAll: text.
outputStream currentAttributes: savedAttributes.
"reset counters"
+ precedingSpaces := precedingNewlines := 0.!
- precedingSpaces _ precedingNewlines _ 0.!
Item was changed:
----- Method: HtmlFormatter>>addMorph: (in category 'formatting commands') -----
addMorph: aMorph
"add a morph to the output"
| savedAttributes |
self addChar: Character space.
+ savedAttributes := outputStream currentAttributes.
- savedAttributes _ outputStream currentAttributes.
outputStream currentAttributes: (savedAttributes copyWith: (TextAnchor new anchoredMorph: aMorph)).
self addChar: (Character value: 1).
outputStream currentAttributes: savedAttributes.
self addChar: Character space.
morphsToEmbed add: aMorph.!
Item was changed:
----- Method: HtmlFormatter>>addString: (in category 'formatting commands') -----
addString: aString
"adds the text in the given string. It collapses spaces unless we are in a preformatted region"
| space compacted lastC i |
aString isEmpty ifTrue: [ ^self ].
+ space := Character space.
- space _ Character space.
preformattedLevel > 0 ifTrue: [
"add all the characters as literals"
outputStream nextPutAll: aString.
"update the counters"
+ lastC := aString last.
- lastC _ aString last.
(lastC = space or: [ lastC = Character cr ]) ifTrue: [
"how many of these are there?"
+ i := aString size - 1.
+ [ i >= 1 and: [ (aString at: i) = lastC ] ] whileTrue: [ i := i - 1 ].
- i _ aString size - 1.
- [ i >= 1 and: [ (aString at: i) = lastC ] ] whileTrue: [ i _ i - 1 ].
i = 0 ifTrue: [
"the whole string is the same character!!"
lastC = space ifTrue: [
+ precedingSpaces := precedingSpaces + aString size.
+ precedingNewlines := 0.
- precedingSpaces _ precedingSpaces + aString size.
- precedingNewlines _ 0.
^self ]
ifFalse: [
+ precedingSpaces := 0.
+ precedingNewlines := precedingNewlines + aString size.
- precedingSpaces _ 0.
- precedingNewlines _ precedingNewlines + aString size.
^self ]. ].
lastC = space ifTrue: [
+ precedingSpaces := aString size - i.
+ precedingNewlines := 0 ]
- precedingSpaces _ aString size - i.
- precedingNewlines _ 0 ]
ifFalse: [
+ precedingSpaces := 0.
+ precedingNewlines := aString size - i ] ] ]
- precedingSpaces _ 0.
- precedingNewlines _ aString size - i ] ] ]
ifFalse: [
+ compacted := aString withSeparatorsCompacted.
- compacted _ aString withSeparatorsCompacted.
compacted = ' ' ifTrue: [
"no letters in the string--just white space!!"
(precedingNewlines = 0 and: [precedingSpaces = 0]) ifTrue: [
+ precedingSpaces := 1.
- precedingSpaces _ 1.
outputStream nextPut: space. ].
^self ].
(compacted first = Character space and: [
(precedingSpaces > 0) or: [ precedingNewlines > 0] ])
+ ifTrue: [ compacted := compacted copyFrom: 2 to: compacted size ].
- ifTrue: [ compacted _ compacted copyFrom: 2 to: compacted size ].
outputStream nextPutAll: compacted.
"update counters"
+ precedingNewlines := 0.
- precedingNewlines _ 0.
compacted last = space
+ ifTrue: [ precedingSpaces := 1 ]
+ ifFalse: [ precedingSpaces := 0 ]. ]!
- ifTrue: [ precedingSpaces _ 1 ]
- ifFalse: [ precedingSpaces _ 0 ]. ]!
Item was changed:
----- Method: HtmlFormatter>>baseUrl: (in category 'access') -----
baseUrl: url
"set the base url. All relative URLs will be determined relative to it"
+ baseUrl := url.!
- baseUrl _ url.!
Item was changed:
----- Method: HtmlFormatter>>browser: (in category 'access') -----
browser: b
"set what browser we are formatting for"
+ browser := b.!
- browser _ b.!
Item was changed:
----- Method: HtmlFormatter>>decreaseBold (in category 'formatting commands') -----
decreaseBold
+ boldLevel := boldLevel - 1.
- boldLevel _ boldLevel - 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>decreaseIndent (in category 'formatting commands') -----
decreaseIndent
+ indentLevel := indentLevel - 1.
- indentLevel _ indentLevel - 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>decreaseItalics (in category 'formatting commands') -----
decreaseItalics
+ italicsLevel := italicsLevel - 1.
- italicsLevel _ italicsLevel - 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>decreasePreformatted (in category 'formatting commands') -----
decreasePreformatted
+ preformattedLevel := preformattedLevel - 1!
- preformattedLevel _ preformattedLevel - 1!
Item was changed:
----- Method: HtmlFormatter>>decreaseStrike (in category 'formatting commands') -----
decreaseStrike
+ strikeLevel := strikeLevel - 1.
- strikeLevel _ strikeLevel - 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>decreaseUnderline (in category 'formatting commands') -----
decreaseUnderline
+ underlineLevel := underlineLevel - 1.
- underlineLevel _ underlineLevel - 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>endLink: (in category 'formatting commands') -----
endLink: url
+ urlLink := nil.
- urlLink _ nil.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>endOrderedList (in category 'formatting commands') -----
endOrderedList
"end an ordered list"
listLengths removeLast.
listTypes removeLast.
+ indentLevel := indentLevel - 1.
- indentLevel _ indentLevel - 1.
self setAttributes.
self ensureNewlines: 1.
!
Item was changed:
----- Method: HtmlFormatter>>endUnorderedList (in category 'formatting commands') -----
endUnorderedList
"end an unordered list"
listLengths removeLast.
listTypes removeLast.
+ indentLevel := indentLevel - 1.
- indentLevel _ indentLevel - 1.
self setAttributes.
self ensureNewlines: 1.!
Item was changed:
----- Method: HtmlFormatter>>hr (in category 'formatting commands') -----
hr
"add an (attempt at a) horizontal rule"
self ensureNewlines: 1.
25 timesRepeat: [ self addChar: $- ].
self ensureNewlines: 1.
+ precedingSpaces := 0.
+ precedingNewlines := 1000. "pretend it's the top of a new page"!
- precedingSpaces _ 0.
- precedingNewlines _ 1000. "pretend it's the top of a new page"!
Item was changed:
----- Method: HtmlFormatter>>increaseBold (in category 'formatting commands') -----
increaseBold
+ boldLevel := boldLevel + 1.
- boldLevel _ boldLevel + 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>increaseIndent (in category 'formatting commands') -----
increaseIndent
+ indentLevel := indentLevel + 1.
- indentLevel _ indentLevel + 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>increaseItalics (in category 'formatting commands') -----
increaseItalics
+ italicsLevel := italicsLevel + 1.
- italicsLevel _ italicsLevel + 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>increasePreformatted (in category 'formatting commands') -----
increasePreformatted
+ preformattedLevel := preformattedLevel + 1!
- preformattedLevel _ preformattedLevel + 1!
Item was changed:
----- Method: HtmlFormatter>>increaseStrike (in category 'formatting commands') -----
increaseStrike
+ strikeLevel := strikeLevel + 1.
- strikeLevel _ strikeLevel + 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>increaseUnderline (in category 'formatting commands') -----
increaseUnderline
+ underlineLevel := underlineLevel + 1.
- underlineLevel _ underlineLevel + 1.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>initialize (in category 'private-initialization') -----
initialize
+ outputStream := AttributedTextStream new.
+ preformattedLevel := 0.
+ indentLevel := boldLevel := italicsLevel := underlineLevel := strikeLevel := centerLevel := 0.
+ listLengths := OrderedCollection new.
+ listTypes := OrderedCollection new.
+ formDatas := OrderedCollection new.
+ precedingSpaces := 0.
+ precedingNewlines := 1000. "more than will ever be asked for"
+ morphsToEmbed := OrderedCollection new.
+ incompleteMorphs := OrderedCollection new.
+ anchorLocations := Dictionary new.
+ imageMaps := OrderedCollection new.!
- outputStream _ AttributedTextStream new.
- preformattedLevel _ 0.
- indentLevel _ boldLevel _ italicsLevel _ underlineLevel _ strikeLevel _ centerLevel _ 0.
- listLengths _ OrderedCollection new.
- listTypes _ OrderedCollection new.
- formDatas _ OrderedCollection new.
- precedingSpaces _ 0.
- precedingNewlines _ 1000. "more than will ever be asked for"
- morphsToEmbed _ OrderedCollection new.
- incompleteMorphs _ OrderedCollection new.
- anchorLocations _ Dictionary new.
- imageMaps _ OrderedCollection new.!
Item was changed:
----- Method: HtmlFormatter>>setAttributes (in category 'private-formatting') -----
setAttributes
"set attributes on the output stream"
| attribs |
+ attribs := OrderedCollection new.
- attribs _ OrderedCollection new.
indentLevel > 0 ifTrue: [ attribs add: (TextIndent tabs: indentLevel) ].
boldLevel > 0 ifTrue: [ attribs add: TextEmphasis bold ].
italicsLevel > 0 ifTrue: [ attribs add: TextEmphasis italic ].
underlineLevel > 0 ifTrue: [ attribs add: TextEmphasis underlined ].
strikeLevel > 0 ifTrue: [ attribs add: TextEmphasis struckOut ].
urlLink isNil ifFalse: [ attribs add: (TextURL new url: urlLink) ].
outputStream currentAttributes: attribs!
Item was changed:
----- Method: HtmlFormatter>>startLink: (in category 'formatting commands') -----
startLink: url
+ urlLink := url.
- urlLink _ url.
self setAttributes.!
Item was changed:
----- Method: HtmlFormatter>>startOrderedList (in category 'formatting commands') -----
startOrderedList
"begin an ordered list"
listLengths add: 0.
listTypes add: #ordered.
+ indentLevel := indentLevel + 1.
- indentLevel _ indentLevel + 1.
self setAttributes.
!
Item was changed:
----- Method: HtmlFormatter>>startUnorderedList (in category 'formatting commands') -----
startUnorderedList
"begin an unordered list"
listLengths add: 0.
listTypes add: #unordered.
+ indentLevel := indentLevel + 1.
- indentLevel _ indentLevel + 1.
self setAttributes.
!
Item was changed:
----- Method: HtmlFormatter>>text (in category 'formatting') -----
text
| text |
+ text := outputStream contents.
- text _ outputStream contents.
^text!
Item was changed:
----- Method: HtmlFormatter>>textMorph (in category 'formatting') -----
textMorph
| text textMorph |
+ text := outputStream contents.
+ textMorph := TextMorph new contents: text.
- text _ outputStream contents.
- textMorph _ TextMorph new contents: text.
morphsToEmbed do:[ :m | textMorph addMorph: m ].
^textMorph!
Item was changed:
----- Method: HtmlFrame>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| src |
+ src := self getAttribute: 'src' default: nil.
- src _ self getAttribute: 'src' default: nil.
formatter ensureNewlines: 1.
src ifNotNil: [ formatter startLink: src ].
formatter addString: 'frame '.
formatter addString: (self name ifNil: ['(unnamed)']).
src ifNotNil: [ formatter endLink: src ].
formatter ensureNewlines: 1.!
Item was changed:
----- Method: HtmlHead>>title (in category 'metainformation') -----
title
"return the title, or nil if there isn't one"
| te |
+ te := self titleEntity.
- te _ self titleEntity.
te ifNil: [ ^nil ].
^te textualContents!
Item was changed:
----- Method: HtmlHeader>>initialize: (in category 'private-initialization') -----
initialize: aTag
super initialize: aTag.
+ level := aTag name last digitValue.!
- level _ aTag name last digitValue.!
Item was changed:
----- Method: HtmlImage>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| morph url |
self src isNil ifTrue: [ ^self ].
+ url := self src.
- url _ self src.
formatter baseUrl ifNotNil: [
+ url := url asUrlRelativeTo: formatter baseUrl ].
- url _ url asUrlRelativeTo: formatter baseUrl ].
+ morph := DownloadingImageMorph new.
- morph _ DownloadingImageMorph new.
morph defaultExtent: self imageExtent.
morph altText: self alt.
morph url: url.
self imageMapName
ifNotNil:
[morph imageMapName: self imageMapName.
morph formatter: formatter].
formatter addIncompleteMorph: morph.!
Item was changed:
----- Method: HtmlImage>>downloadState: (in category 'downloading') -----
downloadState: baseUrl
| sourceUrl imageSource |
image ifNil: [
+ sourceUrl := self src.
- sourceUrl _ self src.
sourceUrl ifNotNil: [
+ imageSource := HTTPSocket httpGetDocument: (sourceUrl asUrlRelativeTo: baseUrl asUrl) toText.
- imageSource _ HTTPSocket httpGetDocument: (sourceUrl asUrlRelativeTo: baseUrl asUrl) toText.
imageSource contentType = 'image/gif' ifTrue: [
+ [image := (GIFReadWriter on: (RWBinaryOrTextStream with: imageSource content) reset binary) nextImage ]
+ ifError: [ :a :b | "could not decode--ignore it" image := nil ] ].
- [image _ (GIFReadWriter on: (RWBinaryOrTextStream with: imageSource content) reset binary) nextImage ]
- ifError: [ :a :b | "could not decode--ignore it" image _ nil ] ].
] ].
!
Item was changed:
----- Method: HtmlImage>>imageExtent (in category 'attributes') -----
imageExtent
"the image extent, according to the WIDTH and HEIGHT attributes. returns nil if either WIDTH or HEIGHT is not specified"
| widthText heightText |
+ widthText := self getAttribute: 'width' ifAbsent: [ ^nil ].
+ heightText := self getAttribute: 'height' ifAbsent: [ ^nil ].
- widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
- heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
^ [ widthText asNumber @ heightText asNumber ] ifError: [ :a :b | nil ]!
Item was changed:
----- Method: HtmlImage>>imageMapName (in category 'attributes') -----
imageMapName
| imageMapName |
+ (imageMapName := self getAttribute: 'usemap')
- (imageMapName _ self getAttribute: 'usemap')
ifNil: [^nil].
imageMapName first = $#
+ ifTrue: [imageMapName := imageMapName copyFrom: 2 to: imageMapName size].
- ifTrue: [imageMapName _ imageMapName copyFrom: 2 to: imageMapName size].
^imageMapName!
Item was changed:
----- Method: HtmlInput>>addCheckBoxButtonToFormatter: (in category 'formatting') -----
addCheckBoxButtonToFormatter: formatter
| name formData checked button buttonInput |
"dig up relevant attributes"
+ name := self getAttribute: 'name'.
- name _ self getAttribute: 'name'.
name ifNil: [ ^self ].
+ value := self getAttribute: 'value'.
- value _ self getAttribute: 'value'.
value ifNil: [ ^value ].
+ formData := formatter currentFormData.
- formData _ formatter currentFormData.
formData ifNil: [ ^self ].
+ checked := (self getAttribute: 'checked') isNil not.
- checked _ (self getAttribute: 'checked') isNil not.
"set up the form input"
+ buttonInput := ToggleButtonInput name: name value: value checkedByDefault: checked.
- buttonInput _ ToggleButtonInput name: name value: value checkedByDefault: checked.
formData addInput: buttonInput.
"create the actual button"
+ button := UpdatingThreePhaseButtonMorph checkBox.
- button _ UpdatingThreePhaseButtonMorph checkBox.
button target: buttonInput;
getSelector: #pressed;
actionSelector: #toggle.
buttonInput button: button.
formatter addMorph: button.
!
Item was changed:
----- Method: HtmlInput>>addFileInputToFormatter: (in category 'formatting') -----
addFileInputToFormatter: formatter
"is it a submit button?"
| inputMorph size fileInput |
+ inputMorph := PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
+ size := (self getAttribute: 'size' default: '12') asNumber.
- inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
- size _ (self getAttribute: 'size' default: '12') asNumber.
inputMorph extent: (size*10 at 20).
+ fileInput := FileInput name: self name textMorph: inputMorph.
- fileInput _ FileInput name: self name textMorph: inputMorph.
formatter addMorph: inputMorph;
addMorph: ((PluggableButtonMorph on: fileInput getState: nil action: #browse)
label: 'Browse').
formatter currentFormData addInput: fileInput!
Item was changed:
----- Method: HtmlInput>>addImageButtonToFormatter: (in category 'formatting') -----
addImageButtonToFormatter: formatter
"is it a submit button?"
| formData imageUrl morph |
+ (imageUrl := self getAttribute: 'src') ifNil: [^self].
- (imageUrl _ self getAttribute: 'src') ifNil: [^self].
formatter baseUrl
+ ifNotNil: [imageUrl := imageUrl asUrlRelativeTo: formatter baseUrl].
- ifNotNil: [imageUrl _ imageUrl asUrlRelativeTo: formatter baseUrl].
+ morph := DownloadingImageMorph new.
- morph _ DownloadingImageMorph new.
morph defaultExtent: self imageExtent.
morph altText: self alt.
morph url: imageUrl.
+ value := self getAttribute: 'name' default: 'Submit'.
+ formData := formatter currentFormData.
- value _ self getAttribute: 'name' default: 'Submit'.
- formData _ formatter currentFormData.
morph
on: #mouseUp
send: #mouseUpFormData:event:linkMorph:
to: self
withValue: formData.
formatter addIncompleteMorph: morph
!
Item was changed:
----- Method: HtmlInput>>addRadioButtonToFormatter: (in category 'formatting') -----
addRadioButtonToFormatter: formatter
| name formData checked buttonSet button buttonInput |
"dig up relevant attributes"
+ name := self getAttribute: 'name'.
- name _ self getAttribute: 'name'.
name ifNil: [ ^self ].
+ value := self getAttribute: 'value'.
- value _ self getAttribute: 'value'.
value ifNil: [ ^value ].
+ formData := formatter currentFormData.
- formData _ formatter currentFormData.
formData ifNil: [ ^self ].
+ checked := self getAttribute: 'checked'.
- checked _ self getAttribute: 'checked'.
"find or create the set of buttons with our same name"
+ buttonSet := formData inputs detect: [ :i | i isRadioButtonSetInput and: [ i name = name ] ] ifNone: [ nil ].
- buttonSet _ formData inputs detect: [ :i | i isRadioButtonSetInput and: [ i name = name ] ] ifNone: [ nil ].
buttonSet ifNil: [
"create a new button set"
+ buttonSet := RadioButtonSetInput name: name.
- buttonSet _ RadioButtonSetInput name: name.
formData addInput: buttonSet. ].
"set up the form input"
+ buttonInput := RadioButtonInput inputSet: buttonSet value: value.
- buttonInput _ RadioButtonInput inputSet: buttonSet value: value.
buttonSet addInput: buttonInput.
checked ifNotNil: [
buttonSet defaultButton: buttonInput ].
"create the actual button"
+ button := UpdatingThreePhaseButtonMorph radioButton.
- button _ UpdatingThreePhaseButtonMorph radioButton.
button target: buttonInput;
getSelector: #pressed;
actionSelector: #toggle.
buttonInput button: button.
formatter addMorph: button.
!
Item was changed:
----- Method: HtmlInput>>addTextInputToFormatter: (in category 'formatting') -----
addTextInputToFormatter: formatter
"is it a submit button?"
| inputMorph size |
+ inputMorph := PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
- inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
self type = 'password'
ifTrue: [inputMorph font: (StrikeFont passwordFontSize: 12)].
+ size := (self getAttribute: 'size' default: '12') asNumber.
- size _ (self getAttribute: 'size' default: '12') asNumber.
inputMorph extent: (size*10 at 20).
formatter addMorph: inputMorph.
formatter currentFormData addInput:
(TextInput name: self name defaultValue: self defaultValue textMorph: inputMorph).!
Item was changed:
----- Method: HtmlInput>>imageExtent (in category 'attributes') -----
imageExtent
"the image extent, according to the WIDTH and HEIGHT attributes. returns nil if either WIDTH or HEIGHT is not specified"
| widthText heightText |
+ widthText := self getAttribute: 'width' ifAbsent: [ ^nil ].
+ heightText := self getAttribute: 'height' ifAbsent: [ ^nil ].
- widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
- heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
^ widthText asNumber @ heightText asNumber!
Item was changed:
----- Method: HtmlInput>>mouseUpFormData:event:linkMorph: (in category 'morphic') -----
mouseUpFormData: formData event: event linkMorph: linkMorph
| aPoint |
+ aPoint := event cursorPoint - linkMorph topLeft.
- aPoint _ event cursorPoint - linkMorph topLeft.
formData addInput: (HiddenInput name: (value, '.x') value: aPoint x asInteger asString).
formData addInput: (HiddenInput name: (value, '.y') value: aPoint y asInteger asString).
formData submit!
Item was changed:
----- Method: HtmlMap>>buildImageMapForImage:andBrowser: (in category 'morphic') -----
buildImageMapForImage: imageMorph andBrowser: browser
| areaMorph |
contents do: [:area |
(area isArea
+ and: [(areaMorph := area linkMorphForMap: self andBrowser: browser) isNil not])
- and: [(areaMorph _ area linkMorphForMap: self andBrowser: browser) isNil not])
ifTrue: [imageMorph addMorph: areaMorph]].
^imageMorph!
Item was changed:
----- Method: HtmlMap>>mouseUpBrowserAndUrl:event:linkMorph: (in category 'morphic') -----
mouseUpBrowserAndUrl: browserAndUrl event: event linkMorph: linkMorph
"this is an image map area, just follow the link"
| browser url |
+ browser := browserAndUrl first.
+ url := browserAndUrl second.
- browser _ browserAndUrl first.
- url _ browserAndUrl second.
browser jumpToUrl: url!
Item was changed:
----- Method: HtmlMeta>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| httpEquiv |
+ httpEquiv := self getAttribute: 'http-equiv'.
- httpEquiv _ self getAttribute: 'http-equiv'.
httpEquiv ifNil: [ ^self ].
httpEquiv asLowercase = 'refresh' ifTrue: [
formatter addString: '{refresh: ', (self getAttribute: 'content' default: ''), '}' ].!
Item was changed:
----- Method: HtmlMeta>>initialize: (in category 'initialization') -----
initialize: aTag
super initialize: aTag.
+ theTag := aTag.!
- theTag _ aTag.!
Item was changed:
----- Method: HtmlNoEmbed>>addToFormatter: (in category 'formatting') -----
addToFormatter: aFormatter
"Check if the last incomplete morph has the property #embedded set.
If so, assume that the last <EMBED> tag has been handled."
| morphs |
+ morphs := aFormatter incompleteMorphs.
- morphs _ aFormatter incompleteMorphs.
(morphs isEmpty not and:[(morphs last valueOfProperty: #embedded) == true])
ifTrue:[^self].
"If not handled do the usual stuff"
^super addToFormatter: aFormatter!
Item was changed:
----- Method: HtmlParser class>>example1 (in category 'example') -----
example1
"HtmlParser example1"
| input |
+ input := ReadStream on:
- input _ ReadStream on:
'<html>
<head>
<title>The Gate of Chaos</title>
</head>
<body>
<h1>Chaos</h1>
<h2>Into the Maelstrom</h2>
Direction is useless in the ever-changing Maelstrom. However,
if you wander with purpose, you might be able to find....
<ul>
<li><a href="/cgi-bin/w">see who''s logged in</a>
<li><a href="/Telnet/connect.html">log in, if you (oooh) have an account</a>
<li><a href="http://chaos.resnet.gatech.edu:9000/sw">The Chaos Swiki</a>--scribble on chaos
<li>the original <a href="/cgi-bin/guestlog-print">Visitor Sands</a>
<li>my old <a href="rant.html">Rant Page</a>
<li>neverending <a href="/cgi-bin/bread">poll</a>: do you have an opinion on bread?
<li>a <a href="http://www.cc.gatech.edu/~lex/linux.html">Linux page</a>-- free UNIX for PC''s!!
<li><a href="english.au">Hear Linus Himself speak!!!!</a>
<li><a href="/doc/">some docs on all kinds of computer stuff</a>
</ul>
<hr>
<h2>Paths of Retreat</h2>
Several commonly travelled ways have left paths leading
<em>away</em> from the maelstrom, too:
<p>
<ul>
<li><a href="friends.html">Friends of Chaos</a>
<li><a href="http://www.apache.org/">The <em>Apache</em> home page</a> --
<em>Chaos</em>''s WWW server!!
<li><a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
Notscape</a>
the <a href="http://www.eskimo.com/%7Eirving/anti-ns/">Anti-Netscape
Page</a> -- fight the tyranny!!
</ul>
<hr>
<a href="/analog/usage.html">usage stats</a> for this server
<hr>
<a href="http://www.eff.org/blueribbon.html"><img src="blueribbon.gif" alt="[blue ribbon campaign]"></a>
<a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
<img src="notscape.gif" alt="[NOTscape]">
</a>
<a href="http://www.anybrowser.org/campaign/">
<img src="anybrowser3.gif" alt="[Best Viewed With Any Browser]"></a>
</body>
</html>'.
^HtmlParser parse: input!
Item was changed:
----- Method: HtmlParser class>>parseTokens: (in category 'parsing') -----
parseTokens: tokenStream
| entityStack document head token matchesAnything entity body |
+ entityStack := OrderedCollection new.
- entityStack _ OrderedCollection new.
"set up initial stack"
+ document := HtmlDocument new.
- document _ HtmlDocument new.
entityStack add: document.
+ head := HtmlHead new.
- head _ HtmlHead new.
document addEntity: head.
entityStack add: head.
"go through the tokens, one by one"
+ [ token := tokenStream next. token = nil ] whileFalse: [
- [ token _ tokenStream next. token = nil ] whileFalse: [
(token isTag and: [ token isNegated ]) ifTrue: [
"a negated token"
(token name ~= 'html' and: [ token name ~= 'body' ]) ifTrue: [
"see if it matches anything in the stack"
+ matchesAnything := (entityStack detect: [ :e | e tagName = token name ] ifNone: [ nil ]) isNil not.
- matchesAnything _ (entityStack detect: [ :e | e tagName = token name ] ifNone: [ nil ]) isNil not.
matchesAnything ifTrue: [
"pop the stack until we find the right one"
[ entityStack last tagName ~= token name ] whileTrue: [ entityStack removeLast ].
entityStack removeLast.
]. ] ]
ifFalse: [
"not a negated token. it makes its own entity"
token isComment ifTrue: [
+ entity := HtmlCommentEntity new initializeWithText: token source.
- entity _ HtmlCommentEntity new initializeWithText: token source.
].
token isText ifTrue: [
+ entity := HtmlTextEntity new text: token text.
- entity _ HtmlTextEntity new text: token text.
(((entityStack last shouldContain: entity) not) and:
[ token source isAllSeparators ]) ifTrue: [
"blank text may never cause the stack to back up"
+ entity := HtmlCommentEntity new initializeWithText: token source ].
- entity _ HtmlCommentEntity new initializeWithText: token source ].
].
token isTag ifTrue: [
+ entity := token entityFor.
+ entity = nil ifTrue: [ entity := HtmlCommentEntity new initializeWithText: token source ] ].
- entity _ token entityFor.
- entity = nil ifTrue: [ entity _ HtmlCommentEntity new initializeWithText: token source ] ].
(token name = 'body')
ifTrue: [body ifNotNil: [document removeEntity: body].
+ body := HtmlBody new initialize: token.
- body _ HtmlBody new initialize: token.
document addEntity: body.
entityStack add: body].
entity = nil ifTrue: [ self error: 'could not deal with this token' ].
entity isComment ifTrue: [
"just stick it anywhere"
entityStack last addEntity: entity ]
ifFalse: [
"only put it in something that is valid"
[ entityStack last mayContain: entity ]
whileFalse: [ entityStack removeLast ].
"if we have left the head, create a body"
(entityStack size < 2 and: [body isNil]) ifTrue: [
+ body := HtmlBody new.
- body _ HtmlBody new.
document addEntity: body.
entityStack add: body ].
"add the entity"
entityStack last addEntity: entity.
entityStack addLast: entity.
].
]].
body == nil ifTrue: [
"add an empty body"
+ body := HtmlBody new.
- body _ HtmlBody new.
document addEntity: body ].
document parsingFinished.
^document!
Item was changed:
----- Method: HtmlSelect>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| options defaultOption listMorph names size valueHolder |
formatter currentFormData ifNil: [
"not in a form. It's bogus HTML but try to survive"
^self ].
+ names := OrderedCollection new.
+ options := OrderedCollection new.
+ defaultOption := nil.
- names _ OrderedCollection new.
- options _ OrderedCollection new.
- defaultOption _ nil.
(self getAttribute: 'multiple') ifNotNil: [
self flag: #incomplete.
formatter addString: '[M option list]'.
^self ].
contents do: [ :c | c isOption ifTrue: [
names add: c value.
options add: c label withBlanksCondensed.
+ (c getAttribute: 'selected') ifNotNil: [ defaultOption := c label ] ] ].
- (c getAttribute: 'selected') ifNotNil: [ defaultOption _ c label ] ] ].
contents isEmpty ifTrue: [ ^self ].
+ defaultOption ifNil: [ defaultOption := options first ].
- defaultOption ifNil: [ defaultOption _ options first ].
+ size := (self getAttribute: 'size' default: '1') asNumber.
- size _ (self getAttribute: 'size' default: '1') asNumber.
size = 1
+ ifTrue: [listMorph := DropDownChoiceMorph new initialize; contents: defaultOption.
- ifTrue: [listMorph _ DropDownChoiceMorph new initialize; contents: defaultOption.
listMorph items: options; target: nil; getItemsSelector: nil;
maxExtent: options; border: #useBorder]
+ ifFalse: [valueHolder := ValueHolder new contents: (contents indexOf: defaultOption).
+ listMorph := PluggableListMorph on: valueHolder list: nil
- ifFalse: [valueHolder _ ValueHolder new contents: (contents indexOf: defaultOption).
- listMorph _ PluggableListMorph on: valueHolder list: nil
selected: #contents changeSelected: #contents:.
listMorph list: options.
listMorph extent: ((listMorph extent x) @ (listMorph scrollDeltaHeight * size))].
formatter addMorph: listMorph.
formatter currentFormData addInput:
(SelectionInput name: self name defaultValue: defaultOption
list: listMorph values: names asArray)!
Item was changed:
----- Method: HtmlTableRow>>asArrayOfData (in category 'accessing') -----
asArrayOfData
"Return an Array of the table row, removing all html. This is only the text and numbers that the user would see on a web page. Remove all comments and formatting."
| cc |
+ cc := contents select: [:ent | ent isTableDataItem].
- cc _ contents select: [:ent | ent isTableDataItem].
^ cc collect: [:ent | ent asHtml asUnHtml withBlanksTrimmed]
"for now, leave the numbers as strings. User will know which to convert"!
Item was changed:
----- Method: HtmlTag class>>entityClasses (in category 'parser support') -----
entityClasses
"a Dictionary mapping tag names into the correct entity class"
+ "EntityClasses := nil"
- "EntityClasses _ nil"
EntityClasses isNil ifFalse: [ ^EntityClasses ].
+ EntityClasses := Dictionary new.
- EntityClasses _ Dictionary new.
#(
frameset HtmlFrame
frame HtmlFrame
title HtmlTitle
style HtmlStyle
meta HtmlMeta
p HtmlParagraph
form HtmlForm
blockquote HtmlBlockQuote
input HtmlInput
textarea HtmlTextArea
select HtmlSelect
optgroup HtmlOptionGroup
option HtmlOption
img HtmlImage
embed HtmlEmbedded
noembed HtmlNoEmbed
a HtmlAnchor
br HtmlBreak
map HtmlMap
area HtmlArea
li HtmlListItem
dd HtmlDefinitionDefinition
dt HtmlDefinitionTerm
ol HtmlOrderedList
ul HtmlUnorderedList
dl HtmlDefinitionList
h1 HtmlHeader
h2 HtmlHeader
h3 HtmlHeader
h4 HtmlHeader
h5 HtmlHeader
h6 HtmlHeader
hr HtmlHorizontalRule
strong HtmlBoldEntity
b HtmlBoldEntity
em HtmlItalicsEntity
i HtmlItalicsEntity
dfn HtmlItalicsEntity
u HtmlUnderlineEntity
tt HtmlFixedWidthEntity
kbd HtmlFixedWidthEntity
strike HtmlStrikeEntity
big HtmlBiggerFontEntity
small HtmlSmallerFontEntity
sub HtmlSubscript
sup HtmlSuperscript
font HtmlFontEntity
pre HtmlPreformattedRegion
table HtmlTable
tr HtmlTableRow
td HtmlTableDataItem
th HtmlTableHeader
) pairsDo: [
:tagName :className |
EntityClasses at: tagName asString put: (Smalltalk at: className) ].
^EntityClasses !
Item was changed:
----- Method: HtmlTag class>>initialize (in category 'parser support') -----
initialize
"HtmlTag initialize"
+ EntityClasses := nil.!
- EntityClasses _ nil.!
Item was changed:
----- Method: HtmlTag>>entityFor (in category 'parser support') -----
entityFor
"return an empty entity corresponding to this tag"
| eClass |
+ eClass := self class entityClasses at: name ifAbsent: [ ^nil ].
- eClass _ self class entityClasses at: name ifAbsent: [ ^nil ].
^eClass forTag: self !
Item was changed:
----- Method: HtmlTag>>name:negated:attribs: (in category 'private-initialization') -----
name: name0 negated: isNegated0 attribs: attribs0
"initialize from the given attributes"
+ name := name0.
+ isNegated := isNegated0.
+ attribs := attribs0 ifNil: [Dictionary new]!
- name _ name0.
- isNegated _ isNegated0.
- attribs _ attribs0 ifNil: [Dictionary new]!
Item was changed:
----- Method: HtmlText>>text: (in category 'private-initialization') -----
text: text0
+ text := text0.!
- text _ text0.!
Item was changed:
----- Method: HtmlTextArea>>addToFormatter: (in category 'formatting') -----
addToFormatter: formatter
| inputMorph |
formatter currentFormData ifNil: [
"not in a form. It's bogus HTML but try to survive"
^self ].
formatter ensureNewlines: 1.
+ inputMorph := PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
- inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
inputMorph extent: (self columns * 5) @ (self rows * inputMorph scrollDeltaHeight).
inputMorph retractable: false.
formatter addMorph: inputMorph.
formatter currentFormData addInput: (TextInput name: self name defaultValue: self textualContents textMorph: inputMorph).
formatter ensureNewlines: 1.!
Item was changed:
----- Method: HtmlTextArea>>columns (in category 'attributes') -----
columns
| a |
+ a := self getAttribute: 'cols' default: '20'.
- a _ self getAttribute: 'cols' default: '20'.
^(Integer readFrom: (ReadStream on: a)) max: 5.!
Item was changed:
----- Method: HtmlTextArea>>rows (in category 'attributes') -----
rows
| a |
+ a := self getAttribute: 'rows' default: '2'.
- a _ self getAttribute: 'rows' default: '2'.
^(Integer readFrom: (ReadStream on: a)) max: 1.!
Item was changed:
----- Method: HtmlTextEntity>>text: (in category 'access') -----
text: text0
+ text := text0!
- text _ text0!
Item was changed:
----- Method: HtmlToken>>initialize: (in category 'private-initialization') -----
initialize: s
"default initialization doesn't do much. subclasses are free to override"
+ source := s
- source _ s
!
Item was changed:
----- Method: HtmlTokenizer class>>initialize (in category 'initialization') -----
initialize
"HtmlTokenizer initialize"
+ CSAttributeEnders := CharacterSet empty.
- CSAttributeEnders _ CharacterSet empty.
CSAttributeEnders addAll: Character separators.
CSAttributeEnders add: $>.
+ CSNameEnders := CharacterSet empty.
- CSNameEnders _ CharacterSet empty.
CSNameEnders addAll: '=>'.
CSNameEnders addAll: Character separators.
+ CSNonSeparators := CharacterSet separators complement.!
- CSNonSeparators _ CharacterSet separators complement.!
Item was changed:
----- Method: HtmlTokenizer>>initialize: (in category 'private-initialization') -----
initialize: s
+ text := s withSqueakLineEndings.
+ pos := 1.
+ textAreaLevel := 0.!
- text _ s withSqueakLineEndings.
- pos _ 1.
- textAreaLevel _ 0.!
Item was changed:
----- Method: HtmlTokenizer>>next (in category 'tokenizing') -----
next
"return the next HtmlToken, or nil if there are no more"
|token|
"branch, depending on what the first character is"
self atEnd ifTrue: [ ^nil ].
self peekChar = $<
+ ifTrue: [ token := self nextTagOrComment ]
+ ifFalse: [ token := self nextText ].
- ifTrue: [ token _ self nextTagOrComment ]
- ifFalse: [ token _ self nextText ].
"return the token, modulo modifications inside of textarea's"
textAreaLevel > 0 ifTrue: [
(token isTag and: [ token name = 'textarea' ]) ifTrue: [
"textarea tag--change textAreaLevel accordingly"
token isNegated
+ ifTrue: [ textAreaLevel := textAreaLevel - 1 ]
+ ifFalse: [ textAreaLevel := textAreaLevel -2 ].
- ifTrue: [ textAreaLevel _ textAreaLevel - 1 ]
- ifFalse: [ textAreaLevel _ textAreaLevel -2 ].
textAreaLevel > 0
ifTrue: [
"still inside a <textarea>, so convert this tag to text"
^HtmlText forSource: token source ]
ifFalse: [ "end of the textarea; return the tag" ^token ] ].
"end of the textarea"
"inside the text area--return the token as text"
^HtmlText forSource: token source ].
(token isTag and: [ token isNegated not and: [ token name = 'textarea' ]]) ifTrue: [
"beginning of a textarea"
+ inTextArea := true.
- inTextArea _ true.
^token ].
^token!
Item was changed:
----- Method: HtmlTokenizer>>nextAttributeValue (in category 'private-tokenizing') -----
nextAttributeValue
"return the next sequence of alphanumeric characters; used to read in the value part of a tag's attribute, ie <tagname attribname=attribvalue>"
"because of the plethora of sloppy web pages, this is EXTREMELY tolerant"
| c start end |
"make sure there are at least two characters left"
pos >= text size ifTrue: [ ^self nextChar asString ].
"okay, peek at the first character"
+ start := pos.
+ c := text at: start.
- start _ pos.
- c _ text at: start.
"check whether it's either kind of quote mark"
(c = $" or: [ c = $' ]) ifTrue: [
"yes--so find the matching quote mark"
+ end := text indexOf: c startingAt: start+1 ifAbsent: [ text size + 1 ].
+ pos := end+1.
- end _ text indexOf: c startingAt: start+1 ifAbsent: [ text size + 1 ].
- pos _ end+1.
^text copyFrom: start to: end ].
"no--go until a space or a $> is seen"
+ end := text indexOfAnyOf: CSAttributeEnders startingAt: start ifAbsent: [ text size + 1 ].
+ end := end - 1.
+ pos := end + 1.
- end _ text indexOfAnyOf: CSAttributeEnders startingAt: start ifAbsent: [ text size + 1 ].
- end _ end - 1.
- pos _ end + 1.
^text copyFrom: start to: end.!
Item was changed:
----- Method: HtmlTokenizer>>nextChar (in category 'private') -----
nextChar
| c |
self atEnd ifTrue: [ ^nil ].
+ c := text at: pos.
+ pos := pos + 1.
- c _ text at: pos.
- pos _ pos + 1.
^c!
Item was changed:
----- Method: HtmlTokenizer>>nextComment (in category 'private-tokenizing') -----
nextComment
"we've seen < and the next is a !!. read until the whole comment is done"
"this isn't perfectly correct--for instance <!!--> is considered a proper comment--but it should do for now. It also picks up <!!DOCTYPE...> tags"
| source c hyphens |
self nextChar. "swallow the $!!"
+ source := WriteStream on: String new.
- source _ WriteStream on: String new.
source nextPutAll: '<!!'.
self peekChar = $- ifFalse: [
"this case is wierd. go until we find a > at all and pray it's the correct end-of-'comment'"
[ self atEnd or: [ self peekChar = $> ]
] whileFalse: [
+ c := self nextChar.
- c _ self nextChar.
source nextPut: c
].
self atEnd ifFalse: [ source nextPut: self nextChar ].
^HtmlComment forSource: source contents ].
+ hyphens := 0.
- hyphens _ 0.
+ [ c := self nextChar.
- [ c _ self nextChar.
c = nil or: [
source nextPut: c.
(hyphens >=2 and: [ c = $> ])]
] whileFalse: [
+ c = $- ifTrue: [ hyphens := hyphens + 1 ] ifFalse: [ hyphens := 0 ]
- c = $- ifTrue: [ hyphens _ hyphens + 1 ] ifFalse: [ hyphens _ 0 ]
].
^HtmlComment forSource: source contents.
!
Item was changed:
----- Method: HtmlTokenizer>>nextName (in category 'private-tokenizing') -----
nextName
"return the next sequence of alphanumeric characters"
"because of the plethora of sloppy web pages, this also accepts most non-space characters"
| start end |
+ start := pos.
+ end := text indexOfAnyOf: CSNameEnders startingAt: start ifAbsent: [ text size + 1].
+ end := end - 1.
- start _ pos.
- end _ text indexOfAnyOf: CSNameEnders startingAt: start ifAbsent: [ text size + 1].
- end _ end - 1.
+ pos := end+1.
- pos _ end+1.
^text copyFrom: start to: end!
Item was changed:
----- Method: HtmlTokenizer>>nextSpaces (in category 'private-tokenizing') -----
nextSpaces
"read in as many consecutive space characters as possible"
| start end |
"short cut for a common case"
self peekChar isSeparator not ifTrue: [ ^'' ].
"find the start and end of the sequence of spaces"
+ start := pos.
+ end := text indexOfAnyOf: CSNonSeparators startingAt: start ifAbsent: [ text size + 1 ].
+ end := end - 1.
- start _ pos.
- end _ text indexOfAnyOf: CSNonSeparators startingAt: start ifAbsent: [ text size + 1 ].
- end _ end - 1.
"update pos and return the sequence"
+ pos := end + 1.
- pos _ end + 1.
^text copyFrom: start to: end!
Item was changed:
----- Method: HtmlTokenizer>>nextTag (in category 'private-tokenizing') -----
nextTag
"we've seen a < and peek-ed something other than a !!. Parse and return a tag"
| source negated name attribs attribName attribValue sourceStart sourceEnd c |
+ sourceStart := pos-1.
+ attribs := Dictionary new.
- sourceStart _ pos-1.
- attribs _ Dictionary new.
"determine if its negated"
self peekChar = $/
+ ifTrue: [ negated := true. self nextChar. ]
+ ifFalse: [ negated := false ].
- ifTrue: [ negated _ true. self nextChar. ]
- ifFalse: [ negated _ false ].
"read in the name"
self skipSpaces.
+ name := self nextName.
+ name := name asLowercase.
- name _ self nextName.
- name _ name asLowercase.
"read in any attributes"
[ self skipSpaces.
+ c := self peekChar.
- c _ self peekChar.
c = nil or: [c isLetter not ]
] whileFalse: [
+ attribName := self nextName.
+ attribName := attribName asLowercase.
- attribName _ self nextName.
- attribName _ attribName asLowercase.
self skipSpaces.
self peekChar = $=
ifTrue: [
self nextChar.
self skipSpaces.
+ attribValue := self nextAttributeValue withoutQuoting ]
+ ifFalse: [ attribValue := '' ].
- attribValue _ self nextAttributeValue withoutQuoting ]
- ifFalse: [ attribValue _ '' ].
attribs at: attribName put: attribValue ].
self skipSpaces.
"determine if the tag is of the form <foo/>"
self peekChar = $/ ifTrue: [ self nextChar. ].
self skipSpaces.
self peekChar = $> ifTrue: [ self nextChar ].
+ sourceEnd := pos-1.
+ source := text copyFrom: sourceStart to: sourceEnd.
- sourceEnd _ pos-1.
- source _ text copyFrom: sourceStart to: sourceEnd.
^HtmlTag source: source name: name asLowercase negated: negated attribs: attribs!
Item was changed:
----- Method: HtmlTokenizer>>nextText (in category 'private-tokenizing') -----
nextText
"returns the next textual segment"
|start end|
+ start := pos.
+ end := (text indexOf: $< startingAt: start ifAbsent: [ text size + 1 ]) - 1.
- start _ pos.
- end _ (text indexOf: $< startingAt: start ifAbsent: [ text size + 1 ]) - 1.
+ pos := end+1.
- pos _ end+1.
^HtmlText forSource: (text copyFrom: start to: end)!
Item was changed:
----- Method: HtmlTokenizer>>skipSpaces (in category 'private-tokenizing') -----
skipSpaces
"skip as many consecutive space characters as possible"
+ pos := text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].!
- pos _ text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].!
Item was changed:
----- Method: ISO88597ClipboardInterpreter>>toSystemClipboard: (in category 'as yet unclassified') -----
toSystemClipboard: aString
| result converter |
aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization"
+ result := WriteStream on: (String new: aString size).
+ converter := ISO88597TextConverter new.
- result _ WriteStream on: (String new: aString size).
- converter _ ISO88597TextConverter new.
aString do: [:each |
result nextPut: (converter fromSqueak: each).].
^ result contents.
!
Item was changed:
----- Method: ISO88597InputInterpreter>>initialize (in category 'as yet unclassified') -----
initialize
+ converter := ISO88597TextConverter new.
- converter _ ISO88597TextConverter new.
!
Item was changed:
----- Method: IconicButton>>launchPartFromClick (in category '*Etoys-Squeakland-menu') -----
launchPartFromClick
"The user clicked on the receiver."
arguments size = 0 ifTrue:[^self].
target launchPartVia: arguments first label: arguments second.
oldColor ifNotNil:
["if oldColor nil, it signals that mouse had not gone DOWN
inside me, e.g. because of a cmd-drag; in this case we want
to avoid triggering the action!!"
self color: oldColor.
+ oldColor := nil]!
- oldColor _ nil]!
Item was changed:
----- Method: IconicButtonWithLabel>>initializeWithThumbnail:withLabel:andColor:andSend:to: (in category 'as yet unclassified') -----
initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: aColor andSend: aSelector to: aReceiver
"Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver If the label parameter is nil or an empty string, no label is used."
| nonTranslucent |
nonTranslucent := aColor asNontranslucentColor.
aLabel isEmptyOrNil ifFalse: [
+ labelMorph := StringMorph contents: aLabel font: Preferences standardEToysFont.
- labelMorph _ StringMorph contents: aLabel font: Preferences standardEToysFont.
].
self
beTransparent;
labelGraphic: (aThumbnail originalForm) color: nonTranslucent andLabel: labelMorph;
borderWidth: 0;
target: aReceiver;
actionSelector: #launchPartVia:label:;
arguments: {aSelector. aLabel};
actWhen: #buttonDown.
self stationarySetup.!
Item was changed:
----- Method: IconicButtonWithLabel>>labelGraphic:color:andLabel: (in category 'as yet unclassified') -----
labelGraphic: aForm color: nonTranslucent andLabel: aStringMorph
| graphicalMorph labeledItem actualForm |
+ labeledItem := AlignmentMorph newColumn.
- labeledItem _ AlignmentMorph newColumn.
labeledItem hResizing: #shrinkWrap.
labeledItem vResizing: #shrinkWrap.
labeledItem color: nonTranslucent.
labeledItem borderWidth: 0.
labeledItem
layoutInset: 4 at 0;
cellPositioning: #center.
self removeAllMorphs.
+ actualForm := (Form extent: aForm extent depth: 32) fillColor: nonTranslucent.
- actualForm _ (Form extent: aForm extent depth: 32) fillColor: nonTranslucent.
aForm displayOn: actualForm at: 0 at 0 rule: 34.
+ graphicalMorph := SketchMorph withForm: actualForm.
- graphicalMorph _ SketchMorph withForm: actualForm.
labeledItem addMorph: graphicalMorph.
labeledItem addMorphBack: (Morph new extent: (4 at 4)) beTransparent.
aStringMorph ifNotNil: [
labeledItem addMorphBack: aStringMorph
].
self addMorph: labeledItem.
self extent: submorphs first fullBounds extent + (borderWidth + 6).
labeledItem lock.
!
Item was changed:
----- Method: ImageMorphWithSpotlight>>backgroundImage:spotImage:spotShape: (in category 'all') -----
backgroundImage: bkgndImage spotImage: anImage spotShape: formOfDepth1
"See class comment."
+ spotImage := anImage.
+ spotShape := formOfDepth1.
+ spotBuffer := Form extent: spotShape extent depth: spotImage depth.
- spotImage _ anImage.
- spotShape _ formOfDepth1.
- spotBuffer _ Form extent: spotShape extent depth: spotImage depth.
super image: bkgndImage.
+ spotOn := false.!
- spotOn _ false.!
Item was changed:
----- Method: ImageMorphWithSpotlight>>step (in category 'stepping and presenter') -----
step
| cp |
+ ((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp := self cursorPoint))
- ((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp _ self cursorPoint))
ifTrue:
[(cp - (spotBuffer extent // 2)) = spotBuffer offset ifTrue: [^ self]. "No change"
"Cursor has moved where its spotShape is visible"
+ spotOn := true.
- spotOn _ true.
self spotChanged.
spotBuffer offset: cp - (spotBuffer extent // 2).
self spotChanged.
(BitBlt current toForm: spotBuffer)
"clear the buffer"
fill: spotBuffer boundingBox fillColor: (Bitmap with: 0) rule: Form over;
"Clip anything outside the base form"
clipRect: (spotBuffer boundingBox
intersect: (self bounds translateBy: spotBuffer offset negated));
"Fill the spotBuffer with the spot image"
copyForm: spotImage to: self position - spotBuffer offset rule: Form over;
"Mask everything outside the spot shape to 0 (transparent)."
copyForm: spotShape to: spotShape offset negated rule: Form and
colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)]
ifFalse:
+ [spotOn ifTrue: [self spotChanged. spotOn := false]]!
- [spotOn ifTrue: [self spotChanged. spotOn _ false]]!
Item was changed:
----- Method: InfoStringMorph>>block: (in category 'accessing') -----
block: aBlock
+ block := aBlock!
- block _ aBlock!
Item was changed:
----- Method: InfoStringMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ stepTime := 1000.
+ block := [Time now]!
- stepTime _ 1000.
- block _ [Time now]!
Item was changed:
----- Method: InfoStringMorph>>stepTime: (in category 'accessing') -----
stepTime: anInteger
+ stepTime := anInteger!
- stepTime _ anInteger!
Item was changed:
----- Method: InputSpec>>attributeName: (in category 'all') -----
attributeName: aSymbol
+ attributeName := aSymbol.
+ rawGetter := ('raw', attributeName) asSymbol.
+ "rawGetter := attributeName asSymbol."
- attributeName _ aSymbol.
- rawGetter _ ('raw', attributeName) asSymbol.
- "rawGetter _ attributeName asSymbol."
!
Item was changed:
----- Method: InputSpec>>type: (in category 'all') -----
type: aSymbol
"#parentInh, #parentSynth, #parentInhFirstChild, #elderSiblingSynth, #lastChildSynth, #mySynth #myInh, #allChildrenSynth, #intrinsic"
+ type := aSymbol.
- type _ aSymbol.
!
Item was changed:
----- Method: InputSpec>>uniqueName: (in category 'all') -----
uniqueName: aString
+ uniqueName := aString.
- uniqueName _ aString.
!
Item was changed:
----- Method: InstructionStream>>interpretExtension:in:for: (in category '*Etoys-Squeakland-private') -----
interpretExtension: offset in: method for: client
| type offset2 byte2 byte3 |
offset <=6 ifTrue:
["Extended op codes 128-134"
+ byte2 := method at: pc.
+ pc := pc + 1.
- byte2 _ method at: pc.
- pc _ pc + 1.
offset <= 2 ifTrue:
["128-130: extended pushes and pops"
+ type := byte2 // 64.
+ offset2 := byte2 \\ 64.
- type _ byte2 // 64.
- offset2 _ byte2 \\ 64.
offset = 0 ifTrue:
[type = 0 ifTrue: [^ client pushReceiverVariable: offset2].
type = 1 ifTrue: [^ client pushTemporaryVariable: offset2].
type = 2 ifTrue: [^ client pushConstant: (method literalAt: offset2 + 1)].
type = 3 ifTrue: [^ client pushLiteralVariable: (method literalAt: offset2 + 1)]].
offset = 1 ifTrue:
[type = 0 ifTrue: [^ client storeIntoReceiverVariable: offset2].
type = 1 ifTrue: [^ client storeIntoTemporaryVariable: offset2].
type = 2 ifTrue: [self error: 'illegalStore'].
type = 3 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
offset = 2 ifTrue:
[type = 0 ifTrue: [^ client popIntoReceiverVariable: offset2].
type = 1 ifTrue: [^ client popIntoTemporaryVariable: offset2].
type = 2 ifTrue: [self error: 'illegalStore'].
type = 3 ifTrue: [^ client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
"131-134: extended sends"
offset = 3 ifTrue: "Single extended send"
[^ client send: (method literalAt: byte2 \\ 32 + 1)
super: false numArgs: byte2 // 32].
offset = 4 ifTrue: "Double extended do-anything"
+ [byte3 := method at: pc. pc := pc + 1.
+ type := byte2 // 32.
- [byte3 _ method at: pc. pc _ pc + 1.
- type _ byte2 // 32.
type = 0 ifTrue: [^ client send: (method literalAt: byte3 + 1)
super: false numArgs: byte2 \\ 32].
type = 1 ifTrue: [^ client send: (method literalAt: byte3 + 1)
super: true numArgs: byte2 \\ 32].
type = 2 ifTrue: [^ client pushReceiverVariable: byte3].
type = 3 ifTrue: [^ client pushConstant: (method literalAt: byte3 + 1)].
type = 4 ifTrue: [^ client pushLiteralVariable: (method literalAt: byte3 + 1)].
type = 5 ifTrue: [^ client storeIntoReceiverVariable: byte3].
type = 6 ifTrue: [^ client popIntoReceiverVariable: byte3].
type = 7 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
offset = 5 ifTrue: "Single extended send to super"
[^ client send: (method literalAt: byte2 \\ 32 + 1)
super: true numArgs: byte2 // 32].
offset = 6 ifTrue: "Second extended send"
[^ client send: (method literalAt: byte2 \\ 64 + 1)
super: false numArgs: byte2 // 64]].
offset = 7 ifTrue: [^ client doPop].
offset = 8 ifTrue: [^ client doDup].
offset = 9 ifTrue: [^ client pushActiveContext].
self error: 'unusedBytecode'!
Item was changed:
----- Method: InteriorFlapTab>>mouseMove: (in category 'event handling') -----
mouseMove: evt
"Handle a mouseMove event in the flap tab."
| aPosition newReferentThickness adjustedPosition thick relativePosition |
+ dragged ifFalse: [(thick := self referentThickness) > 0
+ ifTrue: [lastReferentThickness := thick]].
+ ((self containsPoint: (aPosition := evt cursorPoint)) and: [dragged not])
- dragged ifFalse: [(thick _ self referentThickness) > 0
- ifTrue: [lastReferentThickness _ thick]].
- ((self containsPoint: (aPosition _ evt cursorPoint)) and: [dragged not])
ifFalse:
[flapShowing ifFalse: [self showFlap].
relativePosition := aPosition - evt hand targetOffset.
adjustedPosition := aPosition - (owner position + evt hand targetOffset).
(edgeToAdhereTo == #bottom)
ifTrue:
+ [newReferentThickness := inboard
- [newReferentThickness _ inboard
ifTrue:
[owner height - adjustedPosition y]
ifFalse:
[owner height - adjustedPosition y - self height]].
(edgeToAdhereTo == #left)
ifTrue:
[newReferentThickness _
inboard
ifTrue:
[adjustedPosition x + self width]
ifFalse:
[adjustedPosition x]].
(edgeToAdhereTo == #right)
ifTrue:
[newReferentThickness _
inboard
ifTrue:
[owner width - adjustedPosition x]
ifFalse:
[owner width - adjustedPosition x - self width]].
(edgeToAdhereTo == #top)
ifTrue:
[newReferentThickness _
inboard
ifTrue:
[adjustedPosition y + self height]
ifFalse:
[adjustedPosition y]].
self isCurrentlySolid ifFalse:
[(#(left right) includes: edgeToAdhereTo)
ifFalse:
[self left: relativePosition x]
ifTrue:
[self top: relativePosition y]].
self applyThickness: newReferentThickness.
+ dragged := true.
- dragged _ true.
self fitOnScreen.
self computeEdgeFraction]!
Item was changed:
----- Method: InteriorSolidSugarSuppliesTab>>fitOnScreen (in category 'positioning') -----
fitOnScreen
"19 sept 2000 - allow flaps in any paste up"
| constrainer t l |
+ constrainer := owner ifNil: [self].
- constrainer _ owner ifNil: [self].
self flapShowing "otherwise no point in doing this"
ifTrue:[self spanWorld].
self orientation == #vertical ifTrue: [
+ t := ((self top min: (constrainer bottom- self height)) max: constrainer top).
- t _ ((self top min: (constrainer bottom- self height)) max: constrainer top).
t = self top ifFalse: [self top: t].
] ifFalse: [
+ l := ((self left min: (constrainer right - self width)) max: constrainer left).
- l _ ((self left min: (constrainer right - self width)) max: constrainer left).
l = self left ifFalse: [self left: l].
].
self flapShowing ifFalse: [self positionObject: self atEdgeOf: constrainer].
!
Item was changed:
----- Method: InteriorSolidSugarSuppliesTab>>mouseMove: (in category 'event handling') -----
mouseMove: evt
"Handle a mouse-move within the solid tab."
| aPosition newReferentThickness adjustedPosition thick aWorldlet |
+ dragged ifFalse: [(thick := self referentThickness) > 0
+ ifTrue: [lastReferentThickness := thick]].
- dragged ifFalse: [(thick _ self referentThickness) > 0
- ifTrue: [lastReferentThickness _ thick]].
aWorldlet := self ownerThatIsA: Worldlet.
aPosition := evt cursorPoint - aWorldlet position.
edgeToAdhereTo == #top
ifTrue:
+ [adjustedPosition := aPosition - evt hand targetOffset.
+ newReferentThickness := adjustedPosition y - self navBarHeight]
- [adjustedPosition _ aPosition - evt hand targetOffset.
- newReferentThickness _ adjustedPosition y - self navBarHeight]
ifFalse:
[adjustedPosition := aPosition - evt hand targetOffset.
newReferentThickness := aWorldlet height - (adjustedPosition y + self navBarHeight + self height)].
self applyThickness: newReferentThickness.
+ dragged := true.
- dragged _ true.
self fitOnScreen!
Item was changed:
----- Method: InteriorSugarNavBar>>changeNaviHeight (in category 'events') -----
changeNaviHeight
"Allow the user to choose a new height for the navigator."
| f n |
+ f := FillInTheBlank request: 'new height of the bar' translated initialAnswer: self height asString.
+ n := f asNumber min: (self pasteUpMorph height // 2) max: 0.
- f _ FillInTheBlank request: 'new height of the bar' translated initialAnswer: self height asString.
- n _ f asNumber min: (self pasteUpMorph height // 2) max: 0.
self naviHeight: n.!
Item was changed:
----- Method: InteriorSugarNavBar>>doNewPainting (in category 'buttons') -----
doNewPainting
"Make a new painting"
| worldlet aRect |
ActiveWorld assureNotPaintingElse: [^ self].
+ worldlet := self ownerThatIsA: Worldlet.
- worldlet _ self ownerThatIsA: Worldlet.
aRect := (worldlet topLeft + (0 @ self height)) corner: worldlet bottomRight.
worldlet makeNewDrawing: (ActiveHand lastEvent copy setPosition: aRect center)!
Item was changed:
----- Method: InteriorSugarNavBar>>resizeButtonsAndTabTo: (in category 'morphic interaction') -----
resizeButtonsAndTabTo: newDim
"The user has chosen a new height for the nav bar; make the buttons follow suit."
| frame wantsSupplies |
wantsSupplies := supplies notNil and: [supplies flapShowing].
wantsSupplies ifTrue: [supplies hideFlap].
+ frame := paintButton owner.
- frame _ paintButton owner.
frame submorphs do: [:e |
e naviHeight: newDim].
frame height: newDim.
self height: newDim.
wantsSupplies ifTrue: [supplies showFlap]!
Item was changed:
----- Method: InteriorSugarNavBar>>setEdgeToAdhereTo (in category 'edge') -----
setEdgeToAdhereTo
"Put up a menu allowing user to specify the edge."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
#(top bottom) do:
[:sym | aMenu add: sym asString translated target: self selector: #adhereToEdge: argument: sym].
aMenu popUpEvent: self currentEvent in: self world!
Item was changed:
----- Method: InteriorSugarNavBar>>toggleSupplies (in category 'button actions') -----
toggleSupplies
"Toggle the whether the interior supplies flap is open."
| ref aFlapTab |
+ aFlapTab := self pasteUpMorph flapTabs
- aFlapTab _ self pasteUpMorph flapTabs
detect: [:s | (s isKindOf: FlapTab)
and: [s flapID = 'Supplies' translated]]
ifNone: [self setupSuppliesFlap].
+ ref := aFlapTab referent.
- ref _ aFlapTab referent.
ref isInWorld
ifTrue:
[aFlapTab hideFlap]
ifFalse:
[aFlapTab showFlap.
(owner notNil and: [owner isFlapTab])
ifTrue: [owner edgeToAdhereTo == #top
ifTrue: [ref position: self bottomLeft].
owner edgeToAdhereTo == #bottom
ifTrue: [ref bottomLeft: self topLeft]]]!
Item was changed:
----- Method: InteriorSugarSuppliesTab>>positionObject:atEdgeOf: (in category 'positioning') -----
positionObject: anObject atEdgeOf: container
"Position the object supplied at the edge of the container supplied."
| extra |
+ extra := (sugarNavBar notNil and: [referent isInWorld]) ifTrue: [sugarNavBar height] ifFalse: [0].
- extra _ (sugarNavBar notNil and: [referent isInWorld]) ifTrue: [sugarNavBar height] ifFalse: [0].
edgeToAdhereTo == #top ifTrue:
[^ anObject top: container innerBounds top + extra].
edgeToAdhereTo == #bottom ifTrue:
[^ anObject bottom: container innerBounds bottom - extra]
!
Item was changed:
----- Method: InteriorSugarSuppliesTab>>sugarNavBar:icon: (in category 'initialization') -----
sugarNavBar: aBar icon: aForm
"Associate the receiver with the given sugar-nav-bar."
+ sugarNavBar := aBar.
- sugarNavBar _ aBar.
aForm ifNotNil:
[self useTextualTab.
self setProperty: #priorGraphic toValue: aForm.
self useGraphicalTab].
!
Item was changed:
----- Method: KOI8RTextConverter class>>initialize (in category 'as yet unclassified') -----
initialize
"
KOI8RTextConverter initialize
"
+ FromTable := Dictionary new.
- FromTable _ Dictionary new.
FromTable at: 16r2500 put: 16r80.
FromTable at: 16r2502 put: 16r81.
FromTable at: 16r250C put: 16r82.
FromTable at: 16r2510 put: 16r83.
FromTable at: 16r2514 put: 16r84.
FromTable at: 16r2518 put: 16r85.
FromTable at: 16r251C put: 16r86.
FromTable at: 16r2524 put: 16r87.
FromTable at: 16r252C put: 16r88.
FromTable at: 16r2534 put: 16r89.
FromTable at: 16r253C put: 16r8A.
FromTable at: 16r2580 put: 16r8B.
FromTable at: 16r2584 put: 16r8C.
FromTable at: 16r2588 put: 16r8D.
FromTable at: 16r258C put: 16r8E.
FromTable at: 16r2590 put: 16r8F.
FromTable at: 16r2591 put: 16r90.
FromTable at: 16r2592 put: 16r91.
FromTable at: 16r2593 put: 16r92.
FromTable at: 16r2320 put: 16r93.
FromTable at: 16r25A0 put: 16r94.
FromTable at: 16r2219 put: 16r95.
FromTable at: 16r221A put: 16r96.
FromTable at: 16r2248 put: 16r97.
FromTable at: 16r2264 put: 16r98.
FromTable at: 16r2265 put: 16r99.
FromTable at: 16r00A0 put: 16r9A.
FromTable at: 16r2321 put: 16r9B.
FromTable at: 16r00B0 put: 16r9C.
FromTable at: 16r00B2 put: 16r9D.
FromTable at: 16r00B7 put: 16r9E.
FromTable at: 16r00F7 put: 16r9F.
FromTable at: 16r2550 put: 16rA0.
FromTable at: 16r2551 put: 16rA1.
FromTable at: 16r2552 put: 16rA2.
FromTable at: 16r0451 put: 16rA3.
FromTable at: 16r2553 put: 16rA4.
FromTable at: 16r2554 put: 16rA5.
FromTable at: 16r2555 put: 16rA6.
FromTable at: 16r2556 put: 16rA7.
FromTable at: 16r2557 put: 16rA8.
FromTable at: 16r2558 put: 16rA9.
FromTable at: 16r2559 put: 16rAA.
FromTable at: 16r255A put: 16rAB.
FromTable at: 16r255B put: 16rAC.
FromTable at: 16r255C put: 16rAD.
FromTable at: 16r255D put: 16rAE.
FromTable at: 16r255E put: 16rAF.
FromTable at: 16r255F put: 16rB0.
FromTable at: 16r2560 put: 16rB1.
FromTable at: 16r2561 put: 16rB2.
FromTable at: 16r0401 put: 16rB3.
FromTable at: 16r2562 put: 16rB4.
FromTable at: 16r2563 put: 16rB5.
FromTable at: 16r2564 put: 16rB6.
FromTable at: 16r2565 put: 16rB7.
FromTable at: 16r2566 put: 16rB8.
FromTable at: 16r2567 put: 16rB9.
FromTable at: 16r2568 put: 16rBA.
FromTable at: 16r2569 put: 16rBB.
FromTable at: 16r256A put: 16rBC.
FromTable at: 16r256B put: 16rBD.
FromTable at: 16r256C put: 16rBE.
FromTable at: 16r00A9 put: 16rBF.
FromTable at: 16r044E put: 16rC0.
FromTable at: 16r0430 put: 16rC1.
FromTable at: 16r0431 put: 16rC2.
FromTable at: 16r0446 put: 16rC3.
FromTable at: 16r0434 put: 16rC4.
FromTable at: 16r0435 put: 16rC5.
FromTable at: 16r0444 put: 16rC6.
FromTable at: 16r0433 put: 16rC7.
FromTable at: 16r0445 put: 16rC8.
FromTable at: 16r0438 put: 16rC9.
FromTable at: 16r0439 put: 16rCA.
FromTable at: 16r043A put: 16rCB.
FromTable at: 16r043B put: 16rCC.
FromTable at: 16r043C put: 16rCD.
FromTable at: 16r043D put: 16rCE.
FromTable at: 16r043E put: 16rCF.
FromTable at: 16r043F put: 16rD0.
FromTable at: 16r044F put: 16rD1.
FromTable at: 16r0440 put: 16rD2.
FromTable at: 16r0441 put: 16rD3.
FromTable at: 16r0442 put: 16rD4.
FromTable at: 16r0443 put: 16rD5.
FromTable at: 16r0436 put: 16rD6.
FromTable at: 16r0432 put: 16rD7.
FromTable at: 16r044C put: 16rD8.
FromTable at: 16r044B put: 16rD9.
FromTable at: 16r0437 put: 16rDA.
FromTable at: 16r0448 put: 16rDB.
FromTable at: 16r044D put: 16rDC.
FromTable at: 16r0449 put: 16rDD.
FromTable at: 16r0447 put: 16rDE.
FromTable at: 16r044A put: 16rDF.
FromTable at: 16r042E put: 16rE0.
FromTable at: 16r0410 put: 16rE1.
FromTable at: 16r0411 put: 16rE2.
FromTable at: 16r0426 put: 16rE3.
FromTable at: 16r0414 put: 16rE4.
FromTable at: 16r0415 put: 16rE5.
FromTable at: 16r0424 put: 16rE6.
FromTable at: 16r0413 put: 16rE7.
FromTable at: 16r0425 put: 16rE8.
FromTable at: 16r0418 put: 16rE9.
FromTable at: 16r0419 put: 16rEA.
FromTable at: 16r041A put: 16rEB.
FromTable at: 16r041B put: 16rEC.
FromTable at: 16r041C put: 16rED.
FromTable at: 16r041D put: 16rEE.
FromTable at: 16r041E put: 16rEF.
FromTable at: 16r041F put: 16rF0.
FromTable at: 16r042F put: 16rF1.
FromTable at: 16r0420 put: 16rF2.
FromTable at: 16r0421 put: 16rF3.
FromTable at: 16r0422 put: 16rF4.
FromTable at: 16r0423 put: 16rF5.
FromTable at: 16r0416 put: 16rF6.
FromTable at: 16r0412 put: 16rF7.
FromTable at: 16r042C put: 16rF8.
FromTable at: 16r042B put: 16rF9.
FromTable at: 16r0417 put: 16rFA.
FromTable at: 16r0428 put: 16rFB.
FromTable at: 16r042D put: 16rFC.
FromTable at: 16r0429 put: 16rFD.
FromTable at: 16r0427 put: 16rFE.
FromTable at: 16r042A put: 16rFF.
!
Item was changed:
----- Method: KOI8RTextConverter>>nextFromStream: (in category 'as yet unclassified') -----
nextFromStream: aStream
| character1 |
aStream isBinary ifTrue: [^ aStream basicNext].
+ character1 := aStream basicNext.
- character1 _ aStream basicNext.
character1 isNil ifTrue: [^ nil].
^ self toSqueak: character1.
!
Item was changed:
----- Method: KOI8RTextConverter>>toSqueak: (in category 'as yet unclassified') -----
toSqueak: char
| value |
+ value := char charCode.
- value _ char charCode.
value < 128 ifTrue: [^ char].
value > 255 ifTrue: [^ char].
^ Character leadingChar: RussianEnvironment leadingChar code: (#(
16r2500 16r2502 16r250C 16r2510 16r2514 16r2518 16r251C 16r2524
16r252C 16r2534 16r253C 16r2580 16r2584 16r2588 16r258C 16r2590
16r2591 16r2592 16r2593 16r2320 16r25A0 16r2219 16r221A 16r2248
16r2264 16r2265 16r00A0 16r2321 16r00B0 16r00B2 16r00B7 16r00F7
16r2550 16r2551 16r2552 16r0451 16r2553 16r2554 16r2555 16r2556
16r2557 16r2558 16r2559 16r255A 16r255B 16r255C 16r255D 16r255E
16r255F 16r2560 16r2561 16r0401 16r2562 16r2563 16r2564 16r2565
16r2566 16r2567 16r2568 16r2569 16r256A 16r256B 16r256C 16r00A9
16r044E 16r0430 16r0431 16r0446 16r0434 16r0435 16r0444 16r0433
16r0445 16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E
16r043F 16r044F 16r0440 16r0441 16r0442 16r0443 16r0436 16r0432
16r044C 16r044B 16r0437 16r0448 16r044D 16r0449 16r0447 16r044A
16r042E 16r0410 16r0411 16r0426 16r0414 16r0415 16r0424 16r0413
16r0425 16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E
16r041F 16r042F 16r0420 16r0421 16r0422 16r0423 16r0416 16r0412
16r042C 16r042B 16r0417 16r0428 16r042D 16r0429 16r0427 16r042A
) at: (value - 128 + 1)).
!
Item was changed:
----- Method: KedamaAttributeDefnition class>>generateAttributeDefinitionInput (in category 'as yet unclassified') -----
generateAttributeDefinitionInput
| attrs |
+ attrs := self attributeDefinition, #((MethodNode #start #intrinsic)).
- attrs _ self attributeDefinition, #((MethodNode #start #intrinsic)).
^ String streamContents: [:strm |
attrs do: [:line |
strm nextPutAll: ('self defineAttributeNamed: #{1} at: {2} type: #{3}.' format: {line second. (Smalltalk at: line first). line third}).
].
strm nextPutAll: 'self generateInstVarAndAccessors.'
].
!
Item was changed:
----- Method: KedamaAttributeDefnition class>>generateSemanticRuleSignatureInput (in category 'as yet unclassified') -----
generateSemanticRuleSignatureInput
| sigs inputs inputString encodeStream |
+ sigs := self semanticRuleSignatures, #((start MethodNode initialNil #())).
- sigs _ self semanticRuleSignatures, #((start MethodNode initialNil #())).
^ String streamContents: [:strm |
sigs do: [:line |
+ encodeStream := WriteStream on: String new.
+ inputs := line fourth.
+ inputString := String streamContents: [:in |
- encodeStream _ WriteStream on: String new.
- inputs _ line fourth.
- inputString _ String streamContents: [:in |
in nextPutAll: '{'.
inputs do: [:input |
in nextPutAll: ('(InputSpec new attributeName: #{1}; type: #{2}; yourself). ' format: input).
].
in nextPutAll: '}'.
].
(self class sourceCodeAt: line third) asString do: [:c | encodeStream nextPut: c. c = $' ifTrue: [encodeStream nextPut: c.]].
strm nextPutAll: ('self
defineSemanticRuleFor: (ParseNodeAttribute new attributeName: #{1}; grammarClass: {2}; yourself)
rule: ''{3}''
selector: #{4}
uses: {5}.' format: {line first. line second. encodeStream contents. line third. inputString}).
strm cr.
].
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator class>>clearInstVarFrom:except: (in category 'as yet unclassified') -----
clearInstVarFrom: rootClass except: aCollection
"
self clearInstVarFrom: ParseNode except: #('comment' 'pc').
"
| instVars |
+ instVars := rootClass instVarNames select: [:var |
- instVars _ rootClass instVarNames select: [:var |
(aCollection includes: var) not.
].
rootClass removeInstVarNames: instVars.
(rootClass organization listAtCategoryNamed: 'accessing') do: [:sel |
rootClass removeSelectorSilently: sel
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator class>>setDefault: (in category 'as yet unclassified') -----
setDefault: anObject
+ Default := anObject.
- Default _ anObject.
!
Item was changed:
----- Method: KedamaAttributeEvaluator class>>setDefaultEvaluator (in category 'as yet unclassified') -----
setDefaultEvaluator
"
self setDefaultEvaluator
"
" | evaluator |
+ evaluator := KedamaAttributeEvaluator new.
- evaluator _ KedamaAttributeEvaluator new.
evaluator defineSyntaxFrom: KedamaAttributeEvaluator tweakTileParseNodes.
evaluator readDefinitionsFrom: KedamaTurtleDefinition.
KedamaAttributeEvaluator setDefault: evaluator.
evaluator compileEvaluator.
"!
Item was changed:
----- Method: KedamaAttributeEvaluator>>addGraphEdgesAt:andParent: (in category 'private') -----
addGraphEdgesAt: parseNode andParent: parentNode
| deps occurrences rule |
+ occurrences := parseNode xxxOccurences.
- occurrences _ parseNode xxxOccurences.
occurrences do: [:oc |
+ rule := self selectRuleFor: oc at: parseNode andParent: parentNode.
- rule _ self selectRuleFor: oc at: parseNode andParent: parentNode.
rule ifNil: [self error: 'no applicable rule found'].
oc selectedRule: rule.
rule inputSpecs size = 0 ifTrue: [oc outTime: 0].
"oc attributeName = #isTopStatement ifTrue: [self halt]."
rule inputSpecs do: [:inputSpec |
+ deps := self addGraphEdgesAt: parseNode andParent: parentNode fromRule: rule forInputSpec: inputSpec.
- deps _ self addGraphEdgesAt: parseNode andParent: parentNode fromRule: rule forInputSpec: inputSpec.
deps size > 0 ifTrue: [
self addToDependencies: deps.
oc inputSizeAt: (rule inputSpecs indexOf: inputSpec) put: ((inputSpec type == #allChildrenSynth) ifTrue: [Array with: deps size] ifFalse: [1]).
].
].
].
parseNode isLeaf ifFalse: [
parseNode getAllChildren do: [:child |
self addGraphEdgesAt: child andParent: parseNode.
].
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>addGraphEdgesAt:andParent:fromRule:forInputSpec: (in category 'private') -----
addGraphEdgesAt: parseNode andParent: parentNode fromRule: rule forInputSpec: inputSpec
| type |
+ type := inputSpec type.
- type _ inputSpec type.
type == #intrinsic ifTrue: [
^ #().
].
type == #myInh ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forMyInhRule: rule inputSpec: inputSpec.
].
type == #mySynth ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forMySynthRule: rule inputSpec: inputSpec.
].
type == #parentInh ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forParentInhRule: rule inputSpec: inputSpec.
].
type == #allChildrenSynth ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forAllChildSynthRule: rule inputSpec: inputSpec.
].
type == #parentInhFirstChild ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forFirstChildInhRule: rule inputSpec: inputSpec.
].
type == #elderSiblingSynth ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forElderSiblingInhRule: rule inputSpec: inputSpec.
].
type == #lastChildSynth ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forLastChildSynthRule: rule inputSpec: inputSpec.
].
type == #parentSynth ifTrue: [
^ self makeGraphEdgesAt: parseNode andParent: parentNode forParentSynthRule: rule inputSpec: inputSpec.
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>addGraphEdgesRoot (in category 'actions') -----
addGraphEdgesRoot
+ dependencies := IdentityDictionary new.
- dependencies _ IdentityDictionary new.
self addGraphEdgesAt: parseTree andParent: nil.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>addToDependencies: (in category 'private') -----
addToDependencies: deps
| src dst list |
deps do: [:pair |
+ src := ((pair at: 1) at: 2) perform: ((pair at: 1) at: 1).
+ dst := ((pair at: 2) at: 2) perform: ((pair at: 2) at: 1).
+ list := dependencies at: src ifAbsentPut: [WriteStream on: (Array new: 8)].
- src _ ((pair at: 1) at: 2) perform: ((pair at: 1) at: 1).
- dst _ ((pair at: 2) at: 2) perform: ((pair at: 2) at: 1).
- list _ dependencies at: src ifAbsentPut: [WriteStream on: (Array new: 8)].
list nextPut: dst.
dst addSource: src.
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>clearReferences (in category 'actions') -----
clearReferences
+ parseTree := nil.
+ attributedTree := nil.
+ receiver := nil..
+ dependencies := nil.
- parseTree _ nil.
- attributedTree _ nil.
- receiver _ nil..
- dependencies _ nil.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>compileEvaluator (in category 'actions') -----
compileEvaluator
| meth |
semanticRules associationsDo: [:assoc |
assoc value do: [:rule |
+ meth := rule ruleText.
- meth _ rule ruleText.
Debug == true ifTrue: [
Transcript show: assoc key name; cr; show: meth; cr.
].
assoc key compileSilently: meth classified: '*Etoys-Tweak-Kedama-Generated'.
].
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>debug: (in category 'accessing') -----
debug: aBoolean
+ Debug := aBoolean
- Debug _ aBoolean
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>defineSemanticRuleFor:rule:selector:uses: (in category 'input definitions') -----
defineSemanticRuleFor: anAttribute rule: aString selector: selector uses: inputSpecs
| rule |
inputSpecs do: [:spec |
(#(parentInh parentSynth parentInhFirstChild elderSiblingSynth lastChildSynth mySynth myInh allChildrenSynth intrinsic) includes: spec type) ifFalse: [^ self error: 'wrong input specification'].
].
+ rule := AttributeSemanticRule new.
- rule _ AttributeSemanticRule new.
rule output: anAttribute.
rule inputSpecs: inputSpecs.
rule ruleText: aString.
"
+ selector := String streamContents: [:strm |
- selector _ String streamContents: [:strm |
strm nextPutAll: anAttribute attributeName.
inputSpecs do: [:in |
strm nextPutAll: in uniqueName.
strm nextPutAll: ':'.
].
].
"
rule selector: selector asSymbol.
(anAttribute grammarClass allSubclasses copyWith: anAttribute grammarClass) do: [:c |
(symbolClasses includes: c) ifTrue: [
((attributes at: c) at: anAttribute attributeName) addRule: rule.
].
].
self addRule: rule forAttribute: anAttribute.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>defineSyntaxFrom:withAliases: (in category 'input definitions') -----
defineSyntaxFrom: list withAliases: anotherList
+ symbolClasses := OrderedCollection new.
- symbolClasses _ OrderedCollection new.
list do: [:triple |
symbolClasses add: triple first.
].
+ symbolClasses := symbolClasses asArray.
+ attributes := IdentityDictionary new.
+ semanticRules := IdentityDictionary new.
+ intrinsicSemanticRules := IdentityDictionary new.
- symbolClasses _ symbolClasses asArray.
- attributes _ IdentityDictionary new.
- semanticRules _ IdentityDictionary new.
- intrinsicSemanticRules _ IdentityDictionary new.
symbolClasses do: [:t |
attributes at: t put: IdentityDictionary new.
semanticRules at: t put: OrderedCollection new.
intrinsicSemanticRules at: t put: OrderedCollection new.
].
anotherList do: [:assoc |
attributes at: assoc key put: (attributes at: assoc value).
].!
Item was changed:
----- Method: KedamaAttributeEvaluator>>evaluateOccurence: (in category 'private') -----
evaluateOccurence: occurence
"pick the attribute from the occurence at parseNode."
"check the dependency for that occurence."
"if they are not evaluated, recursively call itself with new arguments."
"if all the values are evaluated, #perform: the registered method with these values."
| ret n args realArgs |
+ n := occurence node.
+ args := ReadStream on: (occurence dependencies collect: [:oc | oc value]).
+ realArgs := Array new: 0.
- n _ occurence node.
- args _ ReadStream on: (occurence dependencies collect: [:oc | oc value]).
- realArgs _ Array new: 0.
occurence inputSizes do: [:s |
s isCollection ifTrue: [
+ realArgs := realArgs copyWith: (args next: (s at: 1)).
- realArgs _ realArgs copyWith: (args next: (s at: 1)).
] ifFalse: [
+ realArgs := realArgs copyWith: args next.
- realArgs _ realArgs copyWith: args next.
].
].
(n = parseTree and: [occurence selectedRule selector = #rcvr]) ifTrue: [
+ ret := receiver
- ret _ receiver
] ifFalse: [
+ ret := n perform: occurence selectedRule selector withArguments: realArgs.
- ret _ n perform: occurence selectedRule selector withArguments: realArgs.
].
Debug == true ifTrue: [
Transcript show: n printString, ' ', occurence selectedRule selector, ' ', args printString, ' ', realArgs printString, ' ', ret printString; cr.
].
ret ifNil: [Transcript show: occurence printString; cr].
occurence value: ret.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>generateInstVarAndAccessor:forGrammarClass: (in category 'private') -----
generateInstVarAndAccessor: attrName forGrammarClass: grammarClass
| newMessage |
+ newMessage := attrName, '
- newMessage _ attrName, '
"Answer the value of ', attrName, '"
^ (KedamaEvaluatorNodeState stateFor: self at: #', attrName, ') value'.
grammarClass compileSilently: newMessage classified: '*Etoys-Tweak-Kedama-accessing' notifying: nil.
+ newMessage := 'raw', attrName, '
- newMessage _ 'raw', attrName, '
"Answer the value of ', attrName, '"
^ KedamaEvaluatorNodeState stateFor: self at: #', attrName.
grammarClass compileSilently: newMessage classified: '*Etoys-Tweak-Kedama-accessing' notifying: nil.
+ newMessage := attrName, ':', ' anObject
- newMessage _ attrName, ':', ' anObject
"Set the value of ', attrName, '"
KedamaEvaluatorNodeState stateFor: self at: #', attrName, ' put: anObject'.
grammarClass compileSilently: newMessage classified: '*Etoys-Tweak-Kedama-accessing' notifying: nil
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>generateInstVarAndAccessorsForGrammarClass: (in category 'private') -----
generateInstVarAndAccessorsForGrammarClass: grammarClass
| attrs |
+ attrs := declaredAttributes at: grammarClass ifAbsent: [#()].
+ grammarClass = ParseNode ifTrue: [attrs := attrs copyWith: #xxxOccurences].
- attrs _ declaredAttributes at: grammarClass ifAbsent: [#()].
- grammarClass = ParseNode ifTrue: [attrs _ attrs copyWith: #xxxOccurences].
"tfel: We no longer add inst vars to the class, to allow clean loading and unloading of Etoys. We instead keep the instance specific
state in a weak dictionary on a special class singleton"
attrs do: [:attrName |
KedamaEvaluatorNodeState dictionary at: attrName put: WeakIdentityKeyDictionary new.
self generateInstVarAndAccessor: attrName forGrammarClass: grammarClass
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>initialize (in category 'initialize-release') -----
initialize
+ declaredAttributes := Dictionary new.
+ references := IdentityDictionary new.
- declaredAttributes _ Dictionary new.
- references _ IdentityDictionary new.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeAttributedTreeWith:forReceiver: (in category 'actions') -----
makeAttributedTreeWith: aParseTree forReceiver: anObject
+ parseTree := aParseTree normalize.
+ attributedTree := AttributeVisitor new.
- parseTree _ aParseTree normalize.
- attributedTree _ AttributeVisitor new.
attributedTree newWith: parseTree for: self.
+ receiver := anObject.
- receiver _ anObject.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forAllChildSynthRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forAllChildSynthRule: semanticRule inputSpec: inputSpec
| outName inName ret |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parseNode isLeaf ifTrue: [
^ #().
].
+ ret := WriteStream on: (Array new: 4).
- ret _ WriteStream on: (Array new: 4).
parseNode getAllChildren do: [:childNode |
ret nextPut: (Array with: (Array with: inName with: childNode)
with: (Array with: outName with: parseNode)).
].
^ ret contents.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forElderSiblingInhRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forElderSiblingInhRule: semanticRule inputSpec: inputSpec
| inName outName elder |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parentNode ifNil: [
^ #().
].
(parentNode isFirstChild: parseNode) ifTrue: [
^ #().
] ifFalse: [
+ elder := parentNode getElderSiblingOf: parseNode.
- elder _ parentNode getElderSiblingOf: parseNode.
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: elder toAttribute: outName at: parseNode).
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forFirstChildInhRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forFirstChildInhRule: semanticRule inputSpec: inputSpec
| inName outName |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parentNode ifNil: [
^ #().
].
(parentNode isFirstChild: parseNode) ifTrue: [
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: parentNode toAttribute: outName at: parseNode).
] ifFalse: [
^ #().
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forLastChildSynthRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forLastChildSynthRule: semanticRule inputSpec: inputSpec
| inName outName child |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parseNode isLeaf ifTrue: [
^ #().
].
+ (child := parseNode getLastChild) ifNotNil: [
- (child _ parseNode getLastChild) ifNotNil: [
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: child toAttribute: outName at: parseNode).
] ifNil: [
^ #().
].
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forMyInhRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forMyInhRule: semanticRule inputSpec: inputSpec
| inName outName |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: parseNode toAttribute: outName at: parseNode).
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forMySynthRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forMySynthRule: semanticRule inputSpec: inputSpec
| inName outName |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: parseNode toAttribute: outName at: parseNode).
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forParentInhRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forParentInhRule: semanticRule inputSpec: inputSpec
| inName outName |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parentNode ifNil: ["root"
^ #().
].
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: parentNode toAttribute: outName at: parseNode).
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>makeGraphEdgesAt:andParent:forParentSynthRule:inputSpec: (in category 'private') -----
makeGraphEdgesAt: parseNode andParent: parentNode forParentSynthRule: semanticRule inputSpec: inputSpec
| inName outName |
+ inName := inputSpec rawGetter.
+ outName := semanticRule output rawGetter.
- inName _ inputSpec rawGetter.
- outName _ semanticRule output rawGetter.
parentNode ifNil: ["root"
^ #().
].
^ Array with: (self makeDependencyEdgeFromAttribute: inName at: parentNode toAttribute: outName at: parseNode).
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>matchSpec:at:andParent: (in category 'private') -----
matchSpec: spec at: parseNode andParent: parentNode
| inName type |
+ inName := spec attributeName.
+ type := spec type.
- inName _ spec attributeName.
- type _ spec type.
type = #parentInh ifTrue: [
^ parentNode notNil "(and: [self node: parentNode hasAttribute: inName])"
].
type = #parentSynth ifTrue: [
^ parentNode notNil "(and: [self node: parentNode hasAttribute: inName])"
].
type = #allChildrenSynth ifTrue: [
^ parseNode isLeaf not.
].
type = #parentInhFirstChild ifTrue: [
^ parentNode notNil and: [parentNode isFirstChild: parseNode].
].
type = #elderSiblingSynth ifTrue: [
^ parentNode notNil and: [(parentNode isFirstChild: parseNode) not].
].
type = #lastChildSynth ifTrue: [
^ parseNode isLeaf not and: [parseNode getLastChild notNil].
].
type = #myInh ifTrue: [
^ true.
].
type = #mySynth ifTrue: [
^ true.
].
type = #intrinsic ifTrue: [
^ true.
].
^ false.
!
Item was changed:
----- Method: KedamaAttributeEvaluator>>sortDependencies (in category 'actions') -----
sortDependencies
| t keys array |
+ t := TopologicalSorter new.
+ keys := attributedTree allOccurences contents.
- t _ TopologicalSorter new.
- keys _ attributedTree allOccurences contents.
dependencies fasterKeys do: [:key |
+ array := (dependencies at: key) contents.
- array _ (dependencies at: key) contents.
dependencies at: key put: array.
].
t collection: keys.
t edges: dependencies.
^ t sort.
!
Item was changed:
----- Method: KedamaExamplerPlayer>>acceptScript:for: (in category 'method management') -----
acceptScript: aScriptEditorMorph for: aSelector
"Accept the tile code in the script editor as the code for the given selector. This branch is only for the classic-tile system, 1997-2001"
| aUniclassScript str node |
+ (aScriptEditorMorph generateParseNodeDirectly and: [(node := aScriptEditorMorph methodNode) notNil]) ifTrue: [
+ str := node printString.
- (aScriptEditorMorph generateParseNodeDirectly and: [(node _ aScriptEditorMorph methodNode) notNil]) ifTrue: [
- str _ node printString.
self class compileSilently: str classified: 'scripts' for: self.
turtles class compileSilently: str classified: 'scripts' for: self.
sequentialStub class compileSilently: str classified: 'scripts' for: self.
] ifFalse: [
+ str := aScriptEditorMorph methodString.
- str _ aScriptEditorMorph methodString.
self class compileSilently: str classified: 'scripts' for: self.
turtles class compileSilently: str classified: 'scripts' for: self.
sequentialStub class compileSilently: str classified: 'scripts' for: self.
].
+ aUniclassScript := self class assuredMethodInterfaceFor: aSelector asSymbol.
- aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol.
aUniclassScript currentScriptEditor: aScriptEditorMorph.
aScriptEditorMorph world ifNotNil: [aScriptEditorMorph world removeHighlightFeedback].
!
Item was changed:
----- Method: KedamaExamplerPlayer>>addInstanceVarNamed:withValue: (in category 'player protocol') -----
addInstanceVarNamed: aName withValue: aValue
self basicAddInstanceVarNamed: aName withValue: aValue.
+ "turtles := kedamaWorld turtlesOf: self."
- "turtles _ kedamaWorld turtlesOf: self."
turtles addInstanceVarNamed: aName withValue: aValue.
!
Item was changed:
----- Method: KedamaExamplerPlayer>>copyAllMethodsAgain2 (in category '*Etoys-Squeakland-debug support') -----
copyAllMethodsAgain2
| c result |
+ c := turtles class.
+ result := (ClassBuilder new)
- c _ turtles class.
- result _ (ClassBuilder new)
name: c name
inEnvironment: c environment
subclassOf: c superclass
type: c typeOfClass
instanceVariableNames: KedamaTurtleVectorPlayer2 instanceVariablesString
classVariableNames: KedamaTurtleVectorPlayer2 classVariablesString
poolDictionaries: KedamaTurtleVectorPlayer2 sharedPoolsString
category: Object categoryForUniclasses.
turtles class copyAllCategoriesUnobtrusivelyFrom: KedamaTurtleVectorPlayer2.
sequentialStub ifNotNil: [sequentialStub class copyAllCategoriesUnobtrusivelyFrom: KedamaSequenceExecutionStub].
!
Item was changed:
----- Method: KedamaExamplerPlayer>>createTurtles2 (in category '*Etoys-Squeakland-subclass players management') -----
createTurtles2
+ turtles := self class createTurtleSubclass2 new.
- turtles _ self class createTurtleSubclass2 new.
turtles kedamaWorld: kedamaWorld.
turtles exampler: self.
^ turtles.
!
Item was changed:
----- Method: KedamaExamplerPlayer>>doSequentialCommand: (in category 'command execution') -----
doSequentialCommand: aBlock
| ret pred |
+ ret := self doExamplerCommand: aBlock.
- ret _ self doExamplerCommand: aBlock.
self getGrouped ifFalse: [
+ pred := turtles arrays at: 7.
- pred _ turtles arrays at: 7.
1 to: turtles size do: [:i |
(pred at: i) = 1 ifTrue: [
sequentialStub index: i.
aBlock value: sequentialStub.
].
].
] ifTrue: [
aBlock value: turtles.
].
turtles invalidateTurtleMap.
^ ret.
!
Item was changed:
----- Method: KedamaExamplerPlayer>>vectorizableTheseSelectors: (in category '*Etoys-Squeakland-private') -----
vectorizableTheseSelectors: collection
| removed scripts |
+ scripts := self class scripts keys.
+ removed := collection reject: [:e | (scripts includes: e) or: [#(getTurtleCount setTurtleCount: setGrouped: getGrouped) includes: e]].
- scripts _ self class scripts keys.
- removed _ collection reject: [:e | (scripts includes: e) or: [#(getTurtleCount setTurtleCount: setGrouped: getGrouped) includes: e]].
removed do: [:e |
((#(getX setX: getY setY: setColor: getColor getVisible setVisible: getTurtleVisible setTurtleVisible: getHeading setHeading: getAngleTo: getDistanceTo: getUphillIn: forward: turn: setPatchValueIn:to: beNotZero: getPatchValueIn:),
self userDefinedSlotGetters,
self userDefinedSlotSetters) includes: e) ifFalse: [^ false].
].
^ true.
!
Item was changed:
----- Method: KedamaFloatArray>>\\ (in category 'arithmetic') -----
\\ other
| result |
other isNumber ifTrue: [
+ result := KedamaFloatArray new: self size.
- result _ KedamaFloatArray new: self size.
^ self primRemScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
+ result := KedamaFloatArray new: self size.
- result _ KedamaFloatArray new: self size.
^ self primRemArray: self and: other into: result.
].
^ super \\ other.
!
Item was changed:
----- Method: KedamaFloatArray>>eToysEQ: (in category 'arithmetic') -----
eToysEQ: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primEQScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primEQArray: self and: other into: result.
].
1 to: self size do: [:index |
result at: index put: (self at: index) = (other at: index).
].
!
Item was changed:
----- Method: KedamaFloatArray>>eToysGE: (in category 'arithmetic') -----
eToysGE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGEScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primGEArray: self and: other into: result.
].
^ super >= other.
!
Item was changed:
----- Method: KedamaFloatArray>>eToysGT: (in category 'arithmetic') -----
eToysGT: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGTScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primGTArray: self and: other into: result.
].
^ super > other.
!
Item was changed:
----- Method: KedamaFloatArray>>eToysLE: (in category 'arithmetic') -----
eToysLE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLEScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primLEArray: self and: other into: result.
].
^ super <= other.
!
Item was changed:
----- Method: KedamaFloatArray>>eToysLT: (in category 'arithmetic') -----
eToysLT: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLTScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primLTArray: self and: other into: result.
].
^ super < other.
!
Item was changed:
----- Method: KedamaFloatArray>>eToysNE: (in category 'arithmetic') -----
eToysNE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primNEScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primNEArray: self and: other into: result.
].
1 to: self size do: [:index |
result at: index put: (self at: index) ~= (other at: index).
].
!
Item was changed:
----- Method: KedamaFloatArray>>isDivisibleBy: (in category '*Etoys-Squeakland-arithmetic') -----
isDivisibleBy: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primDVScalar: self and: other into: result.
].
((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [
^ self primDVArray: self and: other into: result.
].
^ super < other.
!
Item was changed:
----- Method: KedamaMorph class>>newSet (in category 'class initialization') -----
newSet
| k p t s w |
Cursor wait showWhile: [
+ k := self new.
- k _ self new.
k assuredPlayer.
+ p := k defaultPatch.
+ t := k assuredPlayer newTurtleForSet.
- p _ k defaultPatch.
- t _ k assuredPlayer newTurtleForSet.
+ s := SelectionMorph new.
- s _ SelectionMorph new.
+ w := PasteUpMorph new.
- w _ PasteUpMorph new.
w extent: (k width * 2 max: 400)@(k height + 50 max: 300).
p position: (k width + 75)@50.
t position: (k width + 75)@175.
k position: 25 at 25.
w addMorph: k.
w addMorph: t.
w addMorph: p.
w addMorph: s.
s bounds: w bounds.
s selectSubmorphsOf: w.
].
^ s.
!
Item was changed:
----- Method: KedamaMorph>>defaultPatch (in category '*Etoys-Squeakland-drawing') -----
defaultPatch
| p |
defaultPatch ifNotNil: [^ defaultPatch].
"For older projects, it trys to extract a reasonable answer from somewhere."
(self player respondsTo: #getPatch) ifTrue: [
+ defaultPatch := self player getPatch costume renderedMorph.
- defaultPatch _ self player getPatch costume renderedMorph.
^ defaultPatch.
].
+ p := KedamaPatchMorph new.
- p _ KedamaPatchMorph new.
p kedamaWorld: self.
p assuredPlayer.
+ defaultPatch := p.
- defaultPatch _ p.
^ defaultPatch.
!
Item was changed:
----- Method: KedamaMorph>>delete (in category 'deleting') -----
delete
| c |
super delete.
turtlesDict keysDo: [:k |
self deleteAllTurtlesOfExampler: k.
+ c := k costume.
- c _ k costume.
c ifNotNil: [c renderedMorph delete].
].
defaultPatch ifNotNil: [defaultPatch delete].
!
Item was changed:
----- Method: KedamaMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| result |
drawRequested ifFalse: [^ self].
+ drawRequested := false.
+ changePending := false.
- drawRequested _ false.
- changePending _ false.
"Time millisecondClockValue printString displayAt: 0 at 0."
self player ifNil: [^ aCanvas fillRectangle: (self bounds) color: self color].
patchVarDisplayForm fillColor: self color.
patchesToDisplay do: [:p |
p displayPatchVariableOn: patchVarDisplayForm.
].
self drawTurtlesOnForm: patchVarDisplayForm.
pixelsPerPatch = 1 ifTrue: [
aCanvas drawImage: patchVarDisplayForm at: bounds origin.
] ifFalse: [
+ result := self zoom: patchVarDisplayForm into: magnifiedDisplayForm factor: pixelsPerPatch.
- result _ self zoom: patchVarDisplayForm into: magnifiedDisplayForm factor: pixelsPerPatch.
result ifNil: [
aCanvas warpImage: patchVarDisplayForm transform: (MatrixTransform2x3 withScale: pixelsPerPatch) at: self innerBounds origin.
] ifNotNil: [
aCanvas drawImage: magnifiedDisplayForm at: bounds origin.
]
].
!
Item was changed:
----- Method: KedamaMorph>>drawRequest (in category 'accessing') -----
drawRequest
changePending ifFalse: [self changed].
+ changePending := true.
- changePending _ true.
!
Item was changed:
----- Method: KedamaMorph>>fullBounds (in category 'drawing') -----
fullBounds
+ drawRequested := true.
- drawRequested _ true.
^ super fullBounds.
!
Item was changed:
----- Method: KedamaMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ drawRequested := true.
+ changePending := false.
+ dimensions := self class defaultDimensions. "dimensions of this StarSqueak world in patches"
+ wrapX := dimensions x asFloat.
+ wrapY := dimensions y asFloat.
+ pixelsPerPatch := (World width min: World height) // 200. "heuristic..."
- drawRequested _ true.
- changePending _ false.
- dimensions _ self class defaultDimensions. "dimensions of this StarSqueak world in patches"
- wrapX _ dimensions x asFloat.
- wrapY _ dimensions y asFloat.
- pixelsPerPatch _ (World width min: World height) // 200. "heuristic..."
super extent: dimensions * pixelsPerPatch.
self assuredPlayer assureUniClass.
self clearAll. "be sure this is done once in case setup fails to do it"
+ autoChanged := true.
- autoChanged _ true.
self leftEdgeMode: #wrap.
self rightEdgeMode: #wrap.
self topEdgeMode: #wrap.
self bottomEdgeMode: #wrap.
+ turtlesDictSemaphore := Semaphore forMutualExclusion.
- turtlesDictSemaphore _ Semaphore forMutualExclusion.
!
Item was changed:
----- Method: KedamaMorph>>initializePatch (in category 'initialization') -----
initializePatch
| f |
+ f := self player addPatchVarNamed: #patch.
+ patchesToDisplay := Array new: 0.
- f _ self player addPatchVarNamed: #patch.
- patchesToDisplay _ Array new: 0.
self addToPatchDisplayList: f.
+ defaultPatch := f.
- defaultPatch _ f.
f kedamaWorld: self.
f formChanged.
^ f.
!
Item was changed:
----- Method: KedamaMorph>>makePrototypeOfExampler:color: (in category 'turtles') -----
makePrototypeOfExampler: examplerPlayer color: cPixel
| array inst info ind |
+ array := examplerPlayer turtles.
+ info := array info.
- array _ examplerPlayer turtles.
- info _ array info.
array size > 0 ifTrue: [
+ inst := array makePrototypeFromFirstInstance.
- inst _ array makePrototypeFromFirstInstance.
cPixel ifNotNil: [inst at: (info at: #color) put: cPixel].
^ inst.
].
+ inst := Array new: array instSize.
- inst _ Array new: array instSize.
info associationsDo: [:assoc |
+ ind := assoc value.
- ind _ assoc value.
(examplerPlayer turtles types at: ind) = #Boolean ifTrue: [
ind = 7
ifTrue: [inst at: ind put: 1]
ifFalse: [
inst at: ind put: ((examplerPlayer perform: (Utilities getterSelectorFor: assoc key)) ifTrue: [1] ifFalse: [0]).
]
] ifFalse: [
inst at: ind put: (examplerPlayer perform: (Utilities getterSelectorFor: assoc key)).
].
].
cPixel ifNotNil: [inst at: (info at: #color) put: cPixel] ifNil: [inst at: (info at: #color) put: ((examplerPlayer getColor pixelValueForDepth: 32) bitAnd: 16rFFFFFF)].
^ inst.
!
Item was changed:
----- Method: KedamaMorph>>random: (in category 'utils') -----
random: range
"Answer a random integer between 0 and range."
| r val |
<primitive: 'randomRange' module: 'KedamaPlugin2'>
+ r := range < 0 ifTrue: [range negated] ifFalse: [range].
+ RandomSeed := ((RandomSeed * 1309) + 13849) bitAnd: 65535.
+ val := (RandomSeed * (r + 1)) >> 16.
- r _ range < 0 ifTrue: [range negated] ifFalse: [range].
- RandomSeed _ ((RandomSeed * 1309) + 13849) bitAnd: 65535.
- val _ (RandomSeed * (r + 1)) >> 16.
^ range < 0 ifTrue: [val negated] ifFalse: [^ val].
!
Item was changed:
----- Method: KedamaMorph>>setKedamaWorldToKnownPatches (in category '*Etoys-Squeakland-utils') -----
setKedamaWorldToKnownPatches
patchesToDisplay do: [:e |
e kedamaWorld: self.
defaultPatch ifNotNil: [^ defaultPatch kedamaWorld: self].
"For older projects, it trys to extract a reasonable answer from somewhere."
(self player respondsTo: #getPatch) ifTrue: [
+ defaultPatch := self player getPatch costume renderedMorph.
- defaultPatch _ self player getPatch costume renderedMorph.
^ defaultPatch kedamaWorld: self.
].
].
!
Item was changed:
----- Method: KedamaMorph>>setScale (in category 'menu') -----
setScale
| reply |
+ reply := FillInTheBlank
- reply _ FillInTheBlank
request: 'Set the number of pixels per patch (a number between 1 and 10)?' translated
initialAnswer: pixelsPerPatch printString.
reply isEmpty ifTrue: [^ self].
self pixelsPerPatch: reply asNumber.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>attributedTree: (in category 'accessing') -----
attributedTree: tree
+ attributedTree := tree.
- attributedTree _ tree.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>createBlockNodeFromMessageNode: (in category 'private') -----
createBlockNodeFromMessageNode: aMessageNode
| newNode argNode statement |
+ argNode := encoder encodeVariable: 'xxxObj'.
+ statement := MessageNode new
- argNode _ encoder encodeVariable: 'xxxObj'.
- statement _ MessageNode new
receiver: argNode
selector: aMessageNode selector
arguments: aMessageNode arguments
precedence: aMessageNode selector precedence
from: encoder.
+ newNode := BlockNode new
- newNode _ BlockNode new
arguments: (Array with: argNode)
statements: (Array with: statement)
returns: false
from: encoder.
^ newNode!
Item was changed:
----- Method: KedamaParseTreeRewriter>>createMessageNode:inParentNode:receiverNode:selector:arguments: (in category 'private') -----
createMessageNode: aMessageNode inParentNode: parentNode receiverNode: receiverNameOrNode selector: selectorSymbolOrNode arguments: argumentsArray
| recv sel n |
+ recv := receiverNameOrNode isString ifTrue: [
- recv _ receiverNameOrNode isString ifTrue: [
TempVariableNode new name: receiverNameOrNode index: 0 type: 2.
"encoder encodeVariable: receiverNameOrNode."
] ifFalse: [
receiverNameOrNode.
].
+ sel := selectorSymbolOrNode isString ifTrue: [
- sel _ selectorSymbolOrNode isString ifTrue: [
selectorSymbolOrNode asSymbol
] ifFalse: [
selectorSymbolOrNode key.
].
+ n := MessageNode new
- n _ MessageNode new
receiver: recv
selector: sel
arguments: argumentsArray
precedence: sel precedence
from: encoder.
^ n!
Item was changed:
----- Method: KedamaParseTreeRewriter>>initialize (in category 'initialization') -----
initialize
super initialize.
+ notedRewrite := IdentityDictionary new.
- notedRewrite _ IdentityDictionary new.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>makeBlockNodeArguments:statements:returns: (in category 'private') -----
makeBlockNodeArguments: args statements: statementsArray returns: returnBool
| realArgs |
+ realArgs := args collect: [:arg |
- realArgs _ args collect: [:arg |
arg isString
ifTrue: [TempVariableNode new name: arg index: 1 type: 2; yourself
"encoder autoBind: arg"]
ifFalse: [arg]
].
^ BlockNode new
arguments: realArgs
statements: statementsArray
returns: returnBool
from: encoder.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>parseTree: (in category 'accessing') -----
parseTree: tree
+ parseTree := tree.
- parseTree _ tree.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>rewriteBlockNode:inParentNode:arguments:statements:returns: (in category 'private') -----
rewriteBlockNode: aBlockNode inParentNode: parentNode arguments: argNodes statements: statementsArray returns: returnBool
| newNode |
+ newNode := BlockNode new
- newNode _ BlockNode new
arguments: argNodes
statements: statementsArray
returns: returnBool
from: encoder.
parentNode replaceNode: aBlockNode with: newNode.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>rewriteMessageNode:inParentNode:receiverNode:selector:arguments: (in category 'private') -----
rewriteMessageNode: aMessageNode inParentNode: parentNode receiverNode: receiverNameOrNode selector: selectorSymbolOrNode arguments: argumentsArray
| newNode |
+ newNode := self createMessageNode: aMessageNode inParentNode: parentNode receiverNode: receiverNameOrNode selector: selectorSymbolOrNode arguments: argumentsArray.
- newNode _ self createMessageNode: aMessageNode inParentNode: parentNode receiverNode: receiverNameOrNode selector: selectorSymbolOrNode arguments: argumentsArray.
parentNode replaceNode: aMessageNode with: newNode.
!
Item was changed:
----- Method: KedamaParseTreeRewriter>>setEncoderFor:in: (in category 'accessing') -----
setEncoderFor: playerScripted in: aWorld
+ encoder := ScriptEncoder new init: playerScripted class context: nil notifying: nil; referenceObject: aWorld.
- encoder _ ScriptEncoder new init: playerScripted class context: nil notifying: nil; referenceObject: aWorld.
!
Item was changed:
----- Method: KedamaPatchMorph>>convertToCurrentVersion:refStream: (in category 'private') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
varDict at: 'useLogDisplay' ifPresent: [ :x |
+ displayType := x = true ifTrue: [#logScale] ifFalse: [#linear].
- displayType _ x = true ifTrue: [#logScale] ifFalse: [#linear].
].
+ displayType ifNil: [displayType := #logScale].
- displayType ifNil: [displayType _ #logScale].
self migrateInstancesWithoutChangePending.
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
Item was changed:
----- Method: KedamaPatchMorph>>displayPatchVariableOn: (in category 'drawing') -----
displayPatchVariableOn: aForm
| patchVar pixelValue |
form ifNil: [^self].
formChanged ifTrue: [
"displayForm fillColor: Color transparent."
+ pixelValue := (self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF.
- pixelValue _ (self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF.
form bits class == ByteArray ifTrue: [form unhibernate].
+ patchVar := form bits.
- patchVar _ form bits.
displayForm bits class == ByteArray ifTrue: [displayForm unhibernate].
displayType = #linear ifTrue: [
self primMakeMaskOf: patchVar in: displayForm bits colorPixel: pixelValue shift: shiftAmount.
].
displayType = #logScale ifTrue: [
self primMakeMaskOf: patchVar in: displayForm bits colorPixel: pixelValue max: displayMax.
].
displayType = #color ifTrue: [
form displayOn: displayForm.
displayForm fixAlpha.
].
].
tmpForm fillColor: Color black.
displayForm displayOn: tmpForm at: 0 at 0 rule: 24.
aForm == tmpForm ifFalse: [
displayForm displayOn: aForm at: 0 at 0 rule: 24.
].
+ formChanged := false.
- formChanged _ false.
!
Item was changed:
----- Method: KedamaPatchMorph>>drawRequest (in category '*Etoys-Squeakland-drawing') -----
drawRequest
changePending ifFalse: [self changed].
+ changePending := true.
- changePending _ true.
!
Item was changed:
----- Method: KedamaPatchMorph>>fullBounds (in category 'drawing') -----
fullBounds
+ formChanged := true.
- formChanged _ true.
^ super fullBounds.
!
Item was changed:
----- Method: KedamaPatchMorph>>initializeForm: (in category 'initialization') -----
initializeForm: aForm
+ changePending := false.
+ form := aForm.
- changePending _ false.
- form _ aForm.
form fillColor: Color transparent.
+ displayForm := (Form extent: aForm extent depth: 32).
+ tmpForm := (Form extent: aForm extent depth: 32).
- displayForm _ (Form extent: aForm extent depth: 32).
- tmpForm _ (Form extent: aForm extent depth: 32).
tmpForm fillColor: Color black.
super extent: form extent.
self changed.
!
Item was changed:
----- Method: KedamaPatchMorph>>pixelAtX:y:put: (in category 'commands and slots') -----
pixelAtX: xPos y: yPos put: value
| x y i v |
+ x := xPos truncated.
+ y := yPos truncated.
+ v := (value asInteger max: 0).
- x _ xPos truncated.
- y _ yPos truncated.
- v _ (value asInteger max: 0).
((x < 0) or: [y < 0]) ifTrue: [^ self].
((x >= form width) or: [y >= form height]) ifTrue: [^ self].
+ i := ((y * form width) + x) + 1.
- i _ ((y * form width) + x) + 1.
form bits class == ByteArray ifTrue: [form unhibernate].
form bits at: i put: v.
self formChanged.
!
Item was changed:
----- Method: KedamaPatchMorph>>primMakeMaskOf:in:colorPixel:max: (in category 'primitives') -----
primMakeMaskOf: dataBits in: maskBits colorPixel: pixel max: max
| highMask alpha maxLog data |
<primitive: 'makeMaskLog' module: 'KedamaPlugin2'>
"^ KedamaSqueakPlugin doPrimitive: #makeMaskLog."
+ highMask := 16rFF000000.
+ "maxLog := self cCode: 'log(max)' inSmalltalk: [max first ln]."
+ maxLog := max first ln.
+ maxLog := 255.0 / maxLog.
- highMask _ 16rFF000000.
- "maxLog _ self cCode: 'log(max)' inSmalltalk: [max first ln]."
- maxLog _ max first ln.
- maxLog _ 255.0 / maxLog.
1 to: dataBits size do: [:i |
+ data := dataBits at: i.
+ data = 0 ifTrue: [alpha := 0] ifFalse: [
+ "alpha := ((255.0 / maxLog) * (self cCode: 'log(data)' inSmalltalk: [data ln])) asInteger."
+ alpha := (maxLog * (data ln)) asInteger.
- data _ dataBits at: i.
- data = 0 ifTrue: [alpha _ 0] ifFalse: [
- "alpha _ ((255.0 / maxLog) * (self cCode: 'log(data)' inSmalltalk: [data ln])) asInteger."
- alpha _ (maxLog * (data ln)) asInteger.
].
+ (alpha > 255) ifTrue: [alpha := 255].
- (alpha > 255) ifTrue: [alpha _ 255].
maskBits at: i put: (((alpha << 24) bitAnd: highMask) bitOr: pixel).
].
^ self.
!
Item was changed:
----- Method: KedamaPatchMorph>>primMakeMaskOf:in:colorPixel:shift: (in category 'primitives') -----
primMakeMaskOf: dataBits in: maskBits colorPixel: pixel shift: shift
| highMask data alpha |
<primitive: 'makeMask' module: 'KedamaPlugin2'>
"^ KedamaSqueakPlugin doPrimitive: #makeMask."
+ highMask := 16rFF000000.
- highMask _ 16rFF000000.
1 to: dataBits size do: [:i |
+ data := dataBits at: i.
+ alpha := data bitShift: shift.
+ (alpha > 255) ifTrue: [alpha := 255].
- data _ dataBits at: i.
- alpha _ data bitShift: shift.
- (alpha > 255) ifTrue: [alpha _ 255].
maskBits at: i put: (((alpha << 24) bitAnd: highMask) bitOr: pixel).
].
^ self.
!
Item was changed:
----- Method: KedamaPatchMorph>>primPixelsAtXArray:yArray:bits:width:height:into: (in category 'primitives') -----
primPixelsAtXArray: xArray yArray: yArray bits: bits width: width height: height into: aWordArray
| x y formIndex val |
<primitive: 'primPixelsAtXY' module: 'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primPixelsAtXY."
1 to: aWordArray size do: [:i |
+ val := nil.
+ x := (xArray at: i) truncated.
+ y := (yArray at: i) truncated.
+ ((x < 0) or: [y < 0]) ifTrue: [val := 0].
+ ((x >= form width) or: [y >= form height]) ifTrue: [val := 0].
- val _ nil.
- x _ (xArray at: i) truncated.
- y _ (yArray at: i) truncated.
- ((x < 0) or: [y < 0]) ifTrue: [val _ 0].
- ((x >= form width) or: [y >= form height]) ifTrue: [val _ 0].
val ifNil: [
+ formIndex := ((y * form width) + x) + 1.
+ val := bits at: formIndex.
- formIndex _ ((y * form width) + x) + 1.
- val _ bits at: formIndex.
].
aWordArray at: i put: val.
].
!
Item was changed:
----- Method: KedamaPatchMorph>>primSetPixelsPredicates:xArray:yArray:bits:width:height:value: (in category '*Etoys-Squeakland-primitives') -----
primSetPixelsPredicates: predicates xArray: xArray yArray: yArray bits: bits width: width height: height value: value
| v |
<primitive: 'primSetPixelsAtXY' module: 'KedamaPlugin2'>
" ^ KedamaPlugin2 doPrimitive: #primSetPixelsAtXY."
+ value isNumber ifTrue: [v := value].
- value isNumber ifTrue: [v _ value].
1 to: xArray size do: [:i |
(predicates at: i) = 1 ifTrue: [
value isNumber ifFalse: [
+ v := value at: i.
- v _ value at: i.
].
self pixelAtX: (xArray at: i) y: (yArray at: i) put: v.
].
].
!
Item was changed:
----- Method: KedamaPatchTile>>initialize (in category 'initialization') -----
initialize
super initialize.
+ type := #objRef.
- type _ #objRef.
self extent: 16 at 16.
!
Item was changed:
----- Method: KedamaPatchTile>>useDefaultPatch: (in category '*Etoys-Squeakland-initialization support') -----
useDefaultPatch: aPatch
| aTile displayer |
self removeAllMorphs.
+ "literal := aPatch."
+ type := #objRef.
+ aTile := KedamaPatchType basicNew newReadoutTile.
+ displayer := UpdatingStringMorph new
- "literal _ aPatch."
- type _ #objRef.
- aTile _ KedamaPatchType basicNew newReadoutTile.
- displayer _ UpdatingStringMorph new
getSelector: #yourself;
target: 'patch';
growable: true;
minimumWidth: 24;
putSelector: nil;
font: Preferences standardEToysFont.
displayer stepTime: 1000.
"Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details"
displayer useStringFormat.
aTile addMorphBack: displayer.
aTile setLiteralInitially: ('patch').
self addMorphBack: aTile.
!
Item was changed:
----- Method: KedamaPatchType>>defaultArgumentTileFor: (in category 'tile protocol') -----
defaultArgumentTileFor: aPlayer
"Answer a tile to represent the type"
| patch morph |
+ patch := KedamaPatchTile new typeColor: self typeColor.
+ morph := aPlayer costume renderedMorph.
- patch _ KedamaPatchTile new typeColor: self typeColor.
- morph _ aPlayer costume renderedMorph.
(morph isKindOf: KedamaTurtleMorph) ifTrue: [
patch useDefaultPatch: aPlayer kedamaWorld defaultPatch player.
].
(morph isKindOf: KedamaMorph) ifTrue: [
patch useDefaultPatch: morph defaultPatch player.
].
(morph isKindOf: KedamaPatchMorph) ifTrue: [
patch useDefaultPatch: morph player.
].
^ patch.
!
Item was changed:
----- Method: KedamaPatchType>>updatingTileForTarget:partName:getter:setter: (in category 'tile protocol') -----
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
| aTile displayer actualSetter |
+ actualSetter := setter ifNotNil:
- actualSetter _ setter ifNotNil:
[(#(none nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]].
+ aTile := self newReadoutTile.
- aTile _ self newReadoutTile.
+ displayer := UpdatingStringMorph new
- displayer _ UpdatingStringMorph new
getSelector: #externalName;
target: aTarget costume renderedMorph;
growable: true;
minimumWidth: 24;
putSelector: nil.
displayer stepTime: 1000.
"Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details"
self setFormatForDisplayer: displayer.
aTile addMorphBack: displayer.
(actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows].
getter numArgs == 0 ifTrue:
[aTile setLiteralInitially: (aTarget perform: getter)].
displayer useStringFormat.
^ aTile
!
Item was changed:
----- Method: KedamaSequenceExecutionStub class>>primForwardAt:xArray:yArray:headingArray:value:destWidth:destHeight:leftEdgeMode:rightEdgeMode:topEdgeMode:bottomEdgeMode: (in category '*Etoys-Squeakland-as yet unclassified') -----
primForwardAt: i xArray: xArray yArray: yArray headingArray: headingArray value: value destWidth: destWidth destHeight: destHeight leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode
| dist newX newY |
<primitive: 'primScalarForward' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #primScalarForward."
+ dist := value.
+ newX := (xArray at: i) + (dist asFloat * (headingArray at: i) cos).
+ newY := (yArray at: i) - (dist asFloat * (headingArray at: i) sin).
- dist _ value.
- newX _ (xArray at: i) + (dist asFloat * (headingArray at: i) cos).
- newY _ (yArray at: i) - (dist asFloat * (headingArray at: i) sin).
KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub class>>primGetAngleToX:toY:fromX:fromY: (in category '*Etoys-Squeakland-as yet unclassified') -----
primGetAngleToX: toX toY: toY fromX: fromX fromY: fromY
| ret |
<primitive: 'scalarGetAngleTo' module:'KedamaPlugin2'>
+ ret := ((toX - fromX)@(toY - fromY)) theta radiansToDegrees + 90.0.
- ret _ ((toX - fromX)@(toY - fromY)) theta radiansToDegrees + 90.0.
ret > 360.0 ifTrue: [^ ret - 360.0].
^ ret.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub class>>primGetHeadingAt:headingArray: (in category '*Etoys-Squeakland-as yet unclassified') -----
primGetHeadingAt: i headingArray: headingArray
| heading |
<primitive: 'getScalarHeading' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #getScalarHeading."
+ heading := headingArray at: i.
+ ^ heading := KedamaMorph radiansToDegrees: heading.
- heading _ headingArray at: i.
- ^ heading _ KedamaMorph radiansToDegrees: heading.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub class>>primSetHeadingAt:headingArray:value: (in category '*Etoys-Squeakland-as yet unclassified') -----
primSetHeadingAt: i headingArray: headingArray value: heading
| rad |
<primitive: 'setScalarHeading' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #setScalarHeading."
+ rad := KedamaMorph degreesToRadians: heading.
- rad _ KedamaMorph degreesToRadians: heading.
headingArray at: i put: rad.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>color: (in category 'player commands') -----
color: cPixel
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
(turtles arrays at: 5) at: i put: cPixel.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>colorFromPatch: (in category 'player commands') -----
colorFromPatch: aPatch
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
(turtles arrays at: 5) at: i put: ((aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i)) bitAnd: 16rFFFFFF).
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>colorToPatch: (in category 'player commands') -----
colorToPatch: aPatch
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: ((turtles arrays at: 5) at: i).
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>compileScalarInstVarAccessorsFor: (in category 'method management') -----
compileScalarInstVarAccessorsFor: varName
| nameString type setPhrase arrayIndex getPhrase |
+ nameString := varName asString capitalized.
+ arrayIndex := turtles info at: varName asSymbol.
- nameString _ varName asString capitalized.
- arrayIndex _ turtles info at: varName asSymbol.
+ type := turtles types at: arrayIndex.
- type _ turtles types at: arrayIndex.
type = #Number ifTrue: [
+ setPhrase := 'setNumberVarAt:'.
+ getPhrase := 'getNumberVarOf:'.
- setPhrase _ 'setNumberVarAt:'.
- getPhrase _ 'getNumberVarOf:'.
].
type = #Boolean ifTrue: [
+ setPhrase := 'setBooleanVarAt:'.
+ getPhrase := 'getBooleanVarOf:'
- setPhrase _ 'setBooleanVarAt:'.
- getPhrase _ 'getBooleanVarOf:'
].
type = #Color ifTrue: [
+ setPhrase := 'setColorVarAt:'.
+ getPhrase := 'getColorVarOf:'
- setPhrase _ 'setColorVarAt:'.
- getPhrase _ 'getColorVarOf:'
].
+ setPhrase ifNil: [setPhrase := 'setObjectVarAt:'].
+ getPhrase ifNil: [getPhrase := 'getObjectVarOf:'].
- setPhrase ifNil: [setPhrase _ 'setObjectVarAt:'].
- getPhrase ifNil: [getPhrase _ 'getObjectVarOf:'].
self class compileSilently: ('get{1}
^ self {2} ((turtles arrays at: {3}) at: self index)' format: {nameString. getPhrase. arrayIndex printString})
"'get', nameString, '
^ self ', getPhrase, '((turtles arrays at: ', arrayIndex printString, ') at: self index)')"
classified: 'access'.
self class compileSilently: ('set{1}: xxxArg
self {2} {3} at: self index put: xxxArg' format: {nameString. setPhrase. arrayIndex printString}
"'set', nameString, ': xxxArg
self ', setPhrase, arrayIndex printString, ' at: self index put: xxxArg'" )
classified: 'access'!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>delete (in category 'deleting') -----
delete
| anInstance |
+ turtles := nil.
+ exampler := nil.
- turtles _ nil.
- exampler _ nil.
self class removeFromSystem: false.
anInstance := UnscriptedPlayer new.
self become: anInstance.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>die (in category 'player commands') -----
die
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
kedamaWorld deleteTurtleID: self getWho of: exampler.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>doDieCommand: (in category 'command execution') -----
doDieCommand: aBlock
| ret |
+ ret := self doExamplerCommand: aBlock.
- ret _ self doExamplerCommand: aBlock.
"sequentialStub index: self index."
aBlock value: self.
^ ret.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>forward: (in category 'player commands') -----
forward: v
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
KedamaSequenceExecutionStub primForwardAt: i xArray: (turtles arrays at: 2) yArray: (turtles arrays at: 3) headingArray: (turtles arrays at: 4) value: v asFloat destWidth: kedamaWorld wrapX destHeight: kedamaWorld wrapY leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>getAngleTo: (in category 'player commands') -----
getAngleTo: aPlayer
| i xy |
+ i := self index.
+ xy := aPlayer getXAndY.
- i _ self index.
- xy _ aPlayer getXAndY.
^ KedamaSequenceExecutionStub primGetAngleToX: xy x toY: xy y fromX: ((turtles arrays at: 2) at: i) fromY: ((turtles arrays at: 3) at: i).
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>getDistanceTo: (in category 'player commands') -----
getDistanceTo: aPlayer
| i xy |
+ i := self index.
+ xy := aPlayer getXAndY.
- i _ self index.
- xy _ aPlayer getXAndY.
^ KedamaSequenceExecutionStub primGetDistanceToX: xy x toY: xy y fromX: ((turtles arrays at: 2) at: i) fromY: ((turtles arrays at: 3) at: i).
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>kedamaWorld: (in category 'accessing') -----
kedamaWorld: k
+ kedamaWorld := k.
- kedamaWorld _ k.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setBlueComponentIn:to: (in category 'player commands') -----
setBlueComponentIn: aPatch to: value
| i pix |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
+ pix := aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
+ pix := (pix bitAnd: 16rFFFF00) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
- pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
- pix _ (pix bitAnd: 16rFFFF00) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: pix.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setColor: (in category 'player commands') -----
setColor: aColor
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
(turtles arrays at: 5) at: i put: ((aColor pixelValueForDepth: 32)).
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setColorVarAt:at:put: (in category 'accessing - private') -----
setColorVarAt: arrayIndex at: i put: v
| val |
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
+ val := v isColor ifTrue: [v pixelValueForDepth: 32] ifFalse: [v].
- val _ v isColor ifTrue: [v pixelValueForDepth: 32] ifFalse: [v].
(turtles arrays at: arrayIndex) at: i put: val.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setHeading: (in category 'player commands') -----
setHeading: degrees
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
^ KedamaSequenceExecutionStub primSetHeadingAt: i headingArray: (turtles arrays at: 4) value: degrees asFloat.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setPatchValueIn:to: (in category 'player commands') -----
setPatchValueIn: aPatch to: value
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: value.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setRedComponentIn:to: (in category 'player commands') -----
setRedComponentIn: aPatch to: value
| i pix |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
+ pix := aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
+ pix := (pix bitAnd: 16rFFFF) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
- pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
- pix _ (pix bitAnd: 16rFFFF) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: pix.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setTurtleCount: (in category 'player protocol') -----
setTurtleCount: aNumber
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
^ exampler setTurtleCount: aNumber.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setTurtleVisible: (in category 'player commands') -----
setTurtleVisible: aBoolean
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
^ (turtles arrays at: 6) at: i put: (aBoolean ifTrue: [1] ifFalse: [0])
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setX: (in category 'player commands') -----
setX: val
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
kedamaWorld drawRequest.
^ KedamaSequenceExecutionStub primSetX: (turtles arrays at: 2) xIndex: i headingArray: (turtles arrays at: 4) value: val asFloat destWidth: kedamaWorld wrapX leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>setY: (in category 'player commands') -----
setY: val
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
kedamaWorld drawRequest.
^ KedamaSequenceExecutionStub primSetY: (turtles arrays at: 3) yIndex: i headingArray: (turtles arrays at: 4) value: val asFloat destHeight: kedamaWorld wrapY topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
!
Item was changed:
----- Method: KedamaSequenceExecutionStub>>show (in category 'player commands') -----
show
| i |
+ i := self index.
- i _ self index.
((turtles arrays at: 7) at: i) = 0 ifTrue: [^ self].
(turtles arrays at: 6) at: i put: 1.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaSetColorComponentTile>>storeCodeOn:indent: (in category 'initialization') -----
storeCodeOn: aStream indent: tabCount
"We have a hidden arg. Output two keywords with interspersed arguments."
| firstKeyword |
(#('redComponentIn:' 'setRedComponentIn:') includes: assignmentRoot) ifTrue: [
+ firstKeyword := 'setRedComponentIn'.
- firstKeyword _ 'setRedComponentIn'.
].
(#('greenComponentIn:' 'setGreenComponentIn:') includes: assignmentRoot) ifTrue: [
+ firstKeyword := 'setGreenComponentIn'
- firstKeyword _ 'setGreenComponentIn'
].
(#('blueComponentIn:' 'setBlueComponentIn:') includes: assignmentRoot) ifTrue: [
+ firstKeyword := 'setBlueComponentIn'
- firstKeyword _ 'setBlueComponentIn'
].
aStream nextPutAll: firstKeyword.
aStream nextPut: $:.
aStream space."Simple assignment, don't need existing value"
patchTile submorphs first storeCodeOn: aStream indent: tabCount.
aStream nextPutAll: ' to: '.
assignmentSuffix = ':'
ifFalse:
["Assignments that require that old values be retrieved"
aStream nextPutAll: '( '.
self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
aStream space.
aStream nextPutAll: 'get', (firstKeyword copyFrom: 4 to: firstKeyword size), ':'.
patchTile submorphs first storeCodeOn: aStream indent: tabCount.
aStream nextPutAll: ')'.
aStream space.
aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
aStream space]!
Item was changed:
----- Method: KedamaTurtleMethodAttributionDefinition2 class>>addNodeInfoTo:receiverObject:stmtChain:scriptReceiver:messageType:isStatement:isInTest:parentNode: (in category 'rules') -----
addNodeInfoTo: dict receiverObject: myReceiverObject stmtChain: myStmtChain scriptReceiver: rec messageType: myMessageType isStatement: myIsStatement isInTest: myIsInTest parentNode: parentNode
| n sym var infos testFlag isInAllTest lastTestStmt readOrWrite patchGet |
+ infos := WriteStream on: (Array new: 2).
+ testFlag := #none.
+ readOrWrite := (Player readOrWriteOrNil: self selector key).
+ isInAllTest := myStmtChain inject: false into: [:subTotal :next | subTotal | (next at: 2)].
+ (isInAllTest and: [myIsInTest not]) ifTrue: [testFlag := #testBody].
+ myIsInTest ifTrue: [testFlag := #testCond].
- infos _ WriteStream on: (Array new: 2).
- testFlag _ #none.
- readOrWrite _ (Player readOrWriteOrNil: self selector key).
- isInAllTest _ myStmtChain inject: false into: [:subTotal :next | subTotal | (next at: 2)].
- (isInAllTest and: [myIsInTest not]) ifTrue: [testFlag _ #testBody].
- myIsInTest ifTrue: [testFlag _ #testCond].
myIsInTest ifTrue: [
+ lastTestStmt := myStmtChain reverse detect: [:e | e second] ifNone: [self halt].
- lastTestStmt _ myStmtChain reverse detect: [:e | e second] ifNone: [self halt].
(dict at: lastTestStmt first) add: (Array with: myReceiverObject with: self selector with: self receiver with: #read with: testFlag).
^ dict
].
self receiver isLeaf ifTrue: [
myReceiverObject isPlayerLike ifTrue: [
(#(#getPatchValueIn: setPatchValueIn:to:) includes: self selector key) ifTrue: [
+ patchGet := self selector key = #getPatchValueIn:.
+ n := self arguments first.
- patchGet _ self selector key = #getPatchValueIn:.
- n _ self arguments first.
n isLeaf ifTrue: [
+ sym := (n key isKindOf: LookupKey) ifTrue: [n key key] ifFalse: [n key].
+ var := Compiler evaluate: sym for: rec notifying: nil logged: false.
- sym _ (n key isKindOf: LookupKey) ifTrue: [n key key] ifFalse: [n key].
- var _ Compiler evaluate: sym for: rec notifying: nil logged: false.
infos nextPut: (Array with: var with: self selector key with: self receiver key with: (patchGet ifTrue: [#read] ifFalse: [#write]) with: testFlag).
infos nextPut: (Array with: myReceiverObject with: self selector key with: self receiver key with: (patchGet ifTrue: [#write] ifFalse: [#read]) with: testFlag).
] ifFalse: [
infos nextPut: (Array with: myReceiverObject with: self selector key with: self receiver key with: #read with: testFlag).
].
] ifFalse: [
infos nextPut: (Array with: myReceiverObject with: self selector key with: self receiver key
with: readOrWrite with: testFlag).
].
].
] ifFalse: [
(myIsStatement and: [myMessageType ~~ #condition]) ifTrue: [
infos nextPut: (Array with: nil with: self selector key with: self receiver
with: readOrWrite with: testFlag).
]
].
infos contents do: [:q |
myStmtChain do: [:stmt |
(dict at: (stmt at: 1)) addFirst: q
].
].
^ dict.!
Item was changed:
----- Method: KedamaTurtleMethodAttributionDefinition2 class>>addToStmtChain:isStatement: (in category 'rules') -----
addToStmtChain: parentStmtChain isStatement: myIsStatement
| isTest |
+ isTest := self messageType value = #condition.
- isTest _ self messageType value = #condition.
myIsStatement ifTrue: [
^ parentStmtChain copyWith: (Array with: self with: isTest).
].
^ parentStmtChain
!
Item was changed:
----- Method: KedamaTurtleMethodAttributionDefinition2 class>>determineStatementType:fromDict:primaryBreedPair:messageType:isStatement:receiverObject: (in category 'rules') -----
determineStatementType: parentStmtType fromDict: dict primaryBreedPair: myPrimaryBreedPair messageType: myMessageType isStatement: myIsStatement receiverObject: myReceiverObject
| vectorTurtle turtleSelectors participants reads writes unknownReceiverSelectors |
"Do the calculation only at the statement level."
myIsStatement ifFalse: [^ parentStmtType].
"If there is a doSequentially: block, the block is sequential."
+ participants := dict at: self.
- participants _ dict at: self.
(participants select: [:e | (e first notNil and: [e first isPrototypeTurtlePlayer])]) size = 0 ifTrue: [^ #none].
myMessageType = #sequential ifTrue: [^ #sequential].
parentStmtType = #sequential ifTrue: [^ #sequential].
"If there is not turtle involved in the statement, it is not transformed."
myPrimaryBreedPair ifNil: [^ #none].
+ vectorTurtle := myPrimaryBreedPair first.
- vectorTurtle _ myPrimaryBreedPair first.
myMessageType = #condition ifTrue: [
+ reads := IdentitySet new.
+ writes := IdentitySet new.
- reads _ IdentitySet new.
- writes _ IdentitySet new.
participants do: [:list |
(((list at: 5) = #testBody or: [(list at: 5) = #testCond]) and: [(list at: 4) ~= #read]) ifTrue: [list first ifNotNil: [writes add: list first]].
(((list at: 5) = #testBody or: [(list at: 5) = #testCond]) and: [(list at: 4) = #read]) ifTrue: [list first ifNotNil: [reads add: list first]].
].
((writes
intersection: reads)
copyWithout: vectorTurtle) ifNotEmpty: [
^ #sequential
].
^ #parallel.
].
+ reads := IdentitySet new.
+ writes := IdentitySet new.
+ turtleSelectors := OrderedCollection new.
+ unknownReceiverSelectors := OrderedCollection new.
- reads _ IdentitySet new.
- writes _ IdentitySet new.
- turtleSelectors _ OrderedCollection new.
- unknownReceiverSelectors _ OrderedCollection new.
participants do: [:list |
list first = vectorTurtle ifTrue: [
((vectorTurtle isBreedSelector: list second) or: [
(vectorTurtle isUserDefinedSelector: list second)]) ifFalse: [
turtleSelectors add: list second
].
].
list first
ifNil: [unknownReceiverSelectors add: list second]
ifNotNil: [
((list at: 4) == #read) ifTrue: [reads add: list first].
((list at: 4) == #read) ifFalse: [writes add: list first].
].
(vectorTurtle containsSequentialSelector: list second) ifTrue: [^ #sequential].
].
(turtleSelectors includes: #die) ifTrue: [^ #die].
(((self isKindOf: AssignmentNode) and: [myReceiverObject = vectorTurtle])
and: [vectorTurtle isBreedSelector: self property property]) ifTrue: [^ #none].
(vectorTurtle areOkaySelectors: unknownReceiverSelectors) ifFalse: [
^ #sequential.
].
(vectorTurtle vectorizableTheseSelectors: turtleSelectors) ifFalse: [^ #sequential].
((reads intersection: writes) copyWithout: vectorTurtle) ifNotEmpty: [^ #sequential].
^ #parallel.
!
Item was changed:
----- Method: KedamaTurtleMethodAttributionDefinition2 class>>primaryBreedPair:fromDict:isStatement: (in category 'rules') -----
primaryBreedPair: parentPrimaryBreedPair fromDict: dict isStatement: myIsStatement
| turtlesInfo n |
myIsStatement ifTrue: [
+ turtlesInfo := (dict at: self) select: [:e | e first notNil and: [(e first isPrototypeTurtlePlayer) and: [(e first isBreedSelector: e second) not]]].
- turtlesInfo _ (dict at: self) select: [:e | e first notNil and: [(e first isPrototypeTurtlePlayer) and: [(e first isBreedSelector: e second) not]]].
(turtlesInfo collect: [:p | p first]) asSet size = 0 ifTrue: [^ parentPrimaryBreedPair].
+ n := turtlesInfo first third.
- n _ turtlesInfo first third.
^ Array with: (turtlesInfo first first) with: ((n isKindOf: LookupKey) ifTrue: [n key] ifFalse: [n]).
].
^ parentPrimaryBreedPair.
!
Item was changed:
----- Method: KedamaTurtleMethodAttributionDefinition2 class>>variableReceiver: (in category 'rules') -----
variableReceiver: rec
| var sym |
+ sym := (self key isKindOf: LookupKey) ifTrue: [^ self key value] ifFalse: [self key].
+ var := Compiler new evaluate: sym asString in: nil to: rec notifying: nil ifFail: [] logged: false.
- sym _ (self key isKindOf: LookupKey) ifTrue: [^ self key value] ifFalse: [self key].
- var _ Compiler new evaluate: sym asString in: nil to: rec notifying: nil ifFail: [] logged: false.
^ var.
!
Item was changed:
----- Method: KedamaTurtleMorph>>install (in category 'initialization') -----
install
| t |
self player kedamaWorld: kedamaWorld.
+ t := self player createTurtles2.
- t _ self player createTurtles2.
kedamaWorld makeTurtles: turtleCount examplerPlayer: self player color: ((self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF) ofPrototype: nil turtles: t randomize: true.
self player createSequenceStub.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primDrawOn:destWidth:destHeight:xArray:yArray:colorArray:visibleArray: (in category 'as yet unclassified') -----
primDrawOn: bits destWidth: dimX destHeight: dimY xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray
| x y visible bitsIndex |
<primitive: 'drawTurtlesInArray' module: 'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #drawTurtlesInArray."
1 to: xArray size do: [:i |
+ x := (xArray at: i) asInteger.
+ y := (yArray at: i) asInteger.
+ visible := (visibleArray at: i).
- x _ (xArray at: i) asInteger.
- y _ (yArray at: i) asInteger.
- visible _ (visibleArray at: i).
(visible ~= 0 and: [((x >= 0) and: [y >= 0]) and: [(x < dimX) and: [y < dimY]]]) ifTrue: [
+ bitsIndex := ((y * dimX) + x) + 1.
- bitsIndex _ ((y * dimX) + x) + 1.
bits at: bitsIndex put: (colorArray at: i).
]
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primDrawPredicate:on:destWidth:destHeight:xArray:yArray:colorArray:visibleArray: (in category 'as yet unclassified') -----
primDrawPredicate: predicate on: bits destWidth: dimX destHeight: dimY xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray
| x y visible bitsIndex |
<primitive: 'drawTurtlesInArray' module: 'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #drawTurtlesInArray."
1 to: xArray size do: [:i |
(predicate at: i) = 1 ifTrue: [
+ x := (xArray at: i) asInteger.
+ y := (yArray at: i) asInteger.
+ visible := (visibleArray at: i).
- x _ (xArray at: i) asInteger.
- y _ (yArray at: i) asInteger.
- visible _ (visibleArray at: i).
(visible ~= 0 and: [((x >= 0) and: [y >= 0]) and: [(x < dimX) and: [y < dimY]]]) ifTrue: [
+ bitsIndex := ((y * dimX) + x) + 1.
- bitsIndex _ ((y * dimX) + x) + 1.
bits at: bitsIndex put: (colorArray at: i).
]
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primForwardPredicate:xArray:yArray:headingArray:value:destWidth:destHeight:leftEdgeMode:rightEdgeMode:topEdgeMode:bottomEdgeMode: (in category 'as yet unclassified') -----
primForwardPredicate: predicate xArray: xArray yArray: yArray headingArray: headingArray value: v destWidth: destWidth destHeight: destHeight leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode
| dist newX newY |
<primitive: 'primTurtlesForward' module: 'KedamaPlugin2'>
"^ KedamaPlugin2 doPrimitive: #primTurtlesForward."
1 to: xArray size do: [:i |
(predicate at: i) = 1 ifTrue: [
v isCollection ifTrue: [
+ dist := (v at: i) asFloat.
- dist _ (v at: i) asFloat.
] ifFalse: [
+ dist := v asFloat.
- dist _ v asFloat.
].
+ newX := (xArray at: i) + (dist * (headingArray at: i) cos).
+ newY := (yArray at: i) - (dist * (headingArray at: i) sin).
- newX _ (xArray at: i) + (dist * (headingArray at: i) cos).
- newY _ (yArray at: i) - (dist * (headingArray at: i) sin).
KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primGetAngleToX:toY:xArray:yArray:resultInto: (in category 'as yet unclassified') -----
primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result
| ppx ppy x y ret |
<primitive: 'vectorGetAngleTo' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #vectorGetAngleTo."
+ ppx := pX.
+ ppy := pY.
- ppx _ pX.
- ppy _ pY.
1 to: result size do: [:index |
pX isCollection ifTrue: [
+ ppx := pX at: index.
+ ppy := pY at: index.
- ppx _ pX at: index.
- ppy _ pY at: index.
].
+ x := ppx - (xArray at: index).
+ y := ppy - (yArray at: index).
+ ret := (x at y) theta radiansToDegrees + 90.0.
+ ret > 360.0 ifTrue: [ret := ret - 360.0].
- x _ ppx - (xArray at: index).
- y _ ppy - (yArray at: index).
- ret _ (x at y) theta radiansToDegrees + 90.0.
- ret > 360.0 ifTrue: [ret _ ret - 360.0].
result at: index put: ret.
].
^ result.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primGetDistanceToX:toY:xArray:yArray:resultInto: (in category 'as yet unclassified') -----
primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result
| ppx ppy |
<primitive: 'vectorGetDistanceTo' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #vectorGetDistanceTo."
+ ppx := pX.
+ ppy := pY.
- ppx _ pX.
- ppy _ pY.
1 to: result size do: [:index |
pX isCollection ifTrue: [
+ ppx := pX at: index.
+ ppy := pY at: index.
- ppx _ pX at: index.
- ppy _ pY at: index.
].
result at: index put: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt.
].
^ result.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primGetHeading:into: (in category 'as yet unclassified') -----
primGetHeading: headingArray into: resultArray
| heading |
<primitive: 'getHeadingArrayInto' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #getHeadingArrayInto."
1 to: headingArray size do: [:i |
+ heading := headingArray at: i.
+ heading := heading / 0.0174532925199433.
+ heading := 90.0 - heading.
+ heading > 0.0 ifFalse: [heading := heading + 360.0].
- heading _ headingArray at: i.
- heading _ heading / 0.0174532925199433.
- heading _ 90.0 - heading.
- heading > 0.0 ifFalse: [heading _ heading + 360.0].
resultArray at: i put: heading.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primSetPredicate:heading:from: (in category 'as yet unclassified') -----
primSetPredicate: predicates heading: headingArray from: val
| heading |
<primitive: 'setHeadingArrayFrom' module:'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #setHeadingArrayFrom."
val isCollection ifFalse: [
+ heading := val asFloat.
+ heading := KedamaMorph degreesToRadians: heading.
- heading _ val asFloat.
- heading _ KedamaMorph degreesToRadians: heading.
].
1 to: headingArray size do: [:i |
(predicates at: i) = 1 ifTrue: [
val isCollection ifTrue: [
+ heading := val at: i.
+ heading := KedamaMorph degreesToRadians: heading.
- heading _ val at: i.
- heading _ KedamaMorph degreesToRadians: heading.
].
headingArray at: i put: heading.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primSetXPredicates:xArray:headingArray:value:destWidth:leftEdgeMode:rightEdgeMode: (in category 'as yet unclassified') -----
primSetXPredicates: predicates xArray: xArray headingArray: headingArray value: v destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode
| val newX |
<primitive: 'turtlesSetX' module: 'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #turtlesSetX."
v isCollection ifFalse: [
+ val := v asFloat.
- val _ v asFloat.
].
1 to: xArray size do: [:i |
(predicates at: i) = 1 ifTrue: [
v isCollection ifTrue: [
+ newX := v at: i.
- newX _ v at: i.
] ifFalse: [
+ newX := val.
- newX _ val.
].
KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>primSetYPredicates:yArray:headingArray:value:destHeight:topEdgeMode:bottomEdgeMode: (in category 'as yet unclassified') -----
primSetYPredicates: predicates yArray: yArray headingArray: headingArray value: v destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode
| val newY |
<primitive: 'turtlesSetY' module: 'KedamaPlugin2'>
"^ KedamaPlugin doPrimitive: #turtlesSetY."
v isCollection ifFalse: [
+ val := v asFloat.
- val _ v asFloat.
].
1 to: yArray size do: [:i |
(predicates at: i) = 1 ifTrue: [
v isCollection ifTrue: [
+ newY := v at: i.
- newY _ v at: i.
] ifFalse: [
+ newY := val.
- newY _ val.
].
KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>randomRange:from:to:intoFloatArray:factor:kedamaWorld: (in category 'as yet unclassified') -----
randomRange: range from: from to: to intoFloatArray: aFloatArray factor: factor kedamaWorld: kedamaWorld
| ret |
+ ret := self primRandomRange: range from: from to: to intoFloatArray: aFloatArray factor: factor.
- ret _ self primRandomRange: range from: from to: to intoFloatArray: aFloatArray factor: factor.
ret ifNil: [
from to: to do: [:index |
aFloatArray at: index put: (kedamaWorld random: range) asFloat * factor.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2 class>>randomRange:from:to:intoIntegerArray:factor:kedamaWorld: (in category 'as yet unclassified') -----
randomRange: range from: from to: to intoIntegerArray: anIntegerArray factor: factor kedamaWorld: kedamaWorld
| ret |
+ ret := self primRandomRange: range from: from to: to intoIntegerArray: anIntegerArray factor: factor.
- ret _ self primRandomRange: range from: from to: to intoIntegerArray: anIntegerArray factor: factor.
ret ifNil: [
from to: to do: [:index |
anIntegerArray at: index put: ((kedamaWorld random: range) asFloat * factor) asInteger.
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>aTurtleAtX:y: (in category 'turtle map') -----
aTurtleAtX: xPos y: yPos
| w x y index who stub |
turtleMapValid ifFalse: [
self makeTurtlesMap.
].
+ w := kedamaWorld dimensions x.
+ x := xPos truncated.
+ y := yPos truncated.
- w _ kedamaWorld dimensions x.
- x _ xPos truncated.
- y _ yPos truncated.
x < 0 ifTrue: [^ nil].
x >= w ifTrue: [^ nil].
y < 0 ifTrue: [^ nil].
y >= kedamaWorld dimensions y ifTrue: [^ nil].
+ index := (w * y) + x + 1.
+ who := turtlesMap at: index.
- index _ (w * y) + x + 1.
- who _ turtlesMap at: index.
who = 0 ifTrue: [^ nil].
who = lastWho ifTrue: [^ lastWhoStub].
+ stub := exampler clonedSequentialStub.
- stub _ exampler clonedSequentialStub.
stub who: who.
+ lastWho := who.
+ ^ lastWhoStub := stub.
- lastWho _ who.
- ^ lastWhoStub _ stub.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>addInstanceVarVectorNamed:withValue: (in category 'player protocol') -----
addInstanceVarVectorNamed: aName withValue: aValue
| newArray |
+ newArray := KedamaFloatArray new: self size.
+ arrays := arrays, (Array with: newArray).
- newArray _ KedamaFloatArray new: self size.
- arrays _ arrays, (Array with: newArray).
newArray atAllPut: aValue.
info at: aName asSymbol put: arrays size.
types at: arrays size put: #Number.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>addTurtlesCount:ofPrototype:for:positionAndColorArray: (in category 'add turtles') -----
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld positionAndColorArray: positionAndColorArray
| index array defaultValue newArray oldCount |
+ oldCount := self size.
- oldCount _ self size.
info associationsDo: [:assoc |
+ index := assoc value.
+ array := arrays at: index.
+ defaultValue := prototype at: index.
+ newArray := array class new: count.
- index _ assoc value.
- array _ arrays at: index.
- defaultValue _ prototype at: index.
- newArray _ array class new: count.
(#(who x y heading color predicate) 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.
].
+ predicate := arrays at: 7.
- predicate _ arrays at: 7.
predicate from: oldCount+1 to: predicate size put: 1.
#(who) do: [:name |
self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld.
].
+ whoTableValid := false.
+ turtleMapValid := false.
- whoTableValid _ false.
- turtleMapValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>addTurtlesCount:ofPrototype:for:randomize: (in category 'add turtles') -----
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld randomize: randomizeFlag
| index array defaultValue newArray oldCount |
+ oldCount := self size.
- oldCount _ self size.
info associationsDo: [:assoc |
+ index := assoc value.
+ array := arrays at: index.
+ defaultValue := prototype at: index.
+ newArray := array class new: count.
- index _ assoc value.
- array _ arrays at: index.
- defaultValue _ prototype at: index.
- newArray _ array class new: count.
newArray atAllPut: defaultValue.
arrays at: index put: (array, newArray).
].
+ predicate := arrays at: 7.
- predicate _ arrays at: 7.
predicate from: oldCount + 1 to: predicate size put: 1.
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.
- whoTableValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>basicMakeTurtlesMap (in category 'turtle map') -----
basicMakeTurtlesMap
| x y xArray yArray width height mapIndex whoArray |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ whoArray := arrays at: 1.
+ width := kedamaWorld dimensions x.
+ height := kedamaWorld dimensions y.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- whoArray _ arrays at: 1.
- width _ kedamaWorld dimensions x.
- height _ kedamaWorld dimensions y.
turtlesMap atAllPut: 0.
1 to: self size do: [:index |
+ x := (xArray at: index) truncated.
+ y := (yArray at: index) truncated.
+ mapIndex := (width * y) + x + 1.
- x _ (xArray at: index) truncated.
- y _ (yArray at: index) truncated.
- mapIndex _ (width * y) + x + 1.
(0 < mapIndex and: [mapIndex <= turtlesMap size]) ifTrue: [
turtlesMap at: mapIndex put: (whoArray at: index).
].
].
+ turtleMapValid := true.
- turtleMapValid _ true.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>colorFromPatch: (in category 'player commands') -----
colorFromPatch: aPatch
| xArray yArray cArray patch |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ cArray := arrays at: 5.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- cArray _ arrays at: 5.
- patch _ aPatch costume renderedMorph.
1 to: self size do: [:i |
(predicate at: i) = 1 ifTrue: [
cArray at: i put: ((patch pixelAtX: (xArray at: i) y: (yArray at: i)) bitAnd: 16rFFFFFF).
].
].
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>colorToPatch: (in category 'player commands') -----
colorToPatch: aPatch
| xArray yArray cArray patch |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ cArray := arrays at: 5.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- cArray _ arrays at: 5.
- patch _ aPatch costume renderedMorph.
1 to: self size do: [:i |
(predicate at: i) = 1 ifTrue: [
patch pixelAtX: (xArray at: i) y: (yArray at: i) put: (cArray at: i).
].
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>compileVectorInstVarAccessorsFor: (in category 'player protocol') -----
compileVectorInstVarAccessorsFor: varName
| nameString index type setPhrase |
+ nameString := varName asString capitalized.
+ index := info at: varName asSymbol.
- nameString _ varName asString capitalized.
- index _ info at: varName asSymbol.
self class compileSilently: ('get', nameString, '
^ ', '(arrays at: ', index printString, ')')
classified: 'access'.
+ type := types at: index.
- type _ types at: index.
type = #Number ifTrue: [
+ setPhrase := 'setNumberVarAt:'.
- setPhrase _ 'setNumberVarAt:'.
].
type = #Boolean ifTrue: [
+ setPhrase := 'setBooleanVarAt:'.
- setPhrase _ 'setBooleanVarAt:'.
].
type = #Color ifTrue: [
+ setPhrase := 'setColorVarAt:'.
- setPhrase _ 'setColorVarAt:'.
].
+ setPhrase ifNil: [setPhrase := 'setObjectVarAt:'].
- setPhrase ifNil: [setPhrase _ 'setObjectVarAt:'].
self class compileSilently: ('set', nameString, ': xxxArg
self ', setPhrase, index printString, ' put: xxxArg')
classified: 'access'!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>delete (in category 'deleting') -----
delete
| anInstance |
+ exampler := nil.
+ arrays := nil.
+ whoTable := nil.
+ turtlesMap := nil.
- exampler _ nil.
- arrays _ nil.
- whoTable _ nil.
- turtlesMap _ nil.
self class removeFromSystem: false.
anInstance := UnscriptedPlayer new.
self become: anInstance.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>deleteTurtleID: (in category 'player commands') -----
deleteTurtleID: who
| whoArray whoIndex newArray |
+ whoArray := arrays at: 1.
+ whoIndex := whoArray indexOf: who ifAbsent: [^ self].
+ deletingIndex := whoIndex - 1.
- whoArray _ arrays at: 1.
- whoIndex _ whoArray indexOf: who ifAbsent: [^ self].
- deletingIndex _ whoIndex - 1.
arrays withIndexDo: [:array :index |
+ newArray := (array copyFrom: 1 to: whoIndex - 1), (array copyFrom: whoIndex + 1 to: array size).
- newArray _ (array copyFrom: 1 to: whoIndex - 1), (array copyFrom: whoIndex + 1 to: array size).
arrays at: index put: newArray.
].
+ predicate := arrays at: 7.
+ whoTableValid := false.
+ turtleMapValid := false.
- predicate _ arrays at: 7.
- whoTableValid _ false.
- turtleMapValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>drawOn: (in category 'displaying') -----
drawOn: aForm
| xArray yArray colorArray visibleArray bits dimX dimY |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ colorArray := arrays at: 5.
+ visibleArray := arrays at: 6.
+ bits := aForm bits.
+ dimX := aForm width.
+ dimY := aForm height.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- colorArray _ arrays at: 5.
- visibleArray _ arrays at: 6.
- bits _ aForm bits.
- dimX _ aForm width.
- dimY _ aForm height.
KedamaTurtleVectorPlayer2 primDrawOn: bits destWidth: dimX destHeight: dimY xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>exampler: (in category 'accessing') -----
exampler: e
+ exampler := e.
- exampler _ e.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>forward: (in category 'player commands') -----
forward: val
exampler getGrouped ifFalse: [
KedamaTurtleVectorPlayer2 primForwardPredicate: predicate xArray: (arrays at: 2) yArray: (arrays at: 3) headingArray: (arrays at: 4) value: (val isNumber ifTrue: [val asFloat] ifFalse: [val]) destWidth: kedamaWorld wrapX asFloat destHeight: kedamaWorld wrapY asFloat leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
] ifTrue: [
self groupForward: val
].
+ turtleMapValid := false.
- turtleMapValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getAngleTo: (in category 'player commands') -----
getAngleTo: players
| p xArray yArray result pX pY xy |
players isCollection ifFalse: [
+ p := players
- p _ players
].
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ result := KedamaFloatArray new: self size.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- result _ KedamaFloatArray new: self size.
players isCollection ifTrue: [
+ pX := KedamaFloatArray new: players size.
+ pY := KedamaFloatArray new: players size.
- pX _ KedamaFloatArray new: players size.
- pY _ KedamaFloatArray new: players size.
1 to: players size do: [:i |
+ xy := (players at: i) getXAndY.
- xy _ (players at: i) getXAndY.
pX at: i put: xy x.
pY at: i put: xy y.
].
] ifFalse: [
+ xy := p getXAndY.
+ pX := xy x.
+ pY := xy y.
- xy _ p getXAndY.
- pX _ xy x.
- pY _ xy y.
].
^ KedamaTurtleVectorPlayer2 primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getBlueComponentIn: (in category 'player commands') -----
getBlueComponentIn: aPatch
| pix xArray yArray patch w |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
+ w := WordArray new: self size.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
- w _ WordArray new: self size.
1 to: self size do: [:i |
+ pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
- pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
w at: i put: (pix bitAnd: 16rFF).
].
^ w.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getDistanceTo: (in category 'player commands') -----
getDistanceTo: players
| p xArray yArray result pX pY xy |
players isCollection ifFalse: [
+ p := players
- p _ players
].
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ result := KedamaFloatArray new: self size.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- result _ KedamaFloatArray new: self size.
players isCollection ifTrue: [
+ pX := KedamaFloatArray new: players size.
+ pY := KedamaFloatArray new: players size.
- pX _ KedamaFloatArray new: players size.
- pY _ KedamaFloatArray new: players size.
1 to: players size do: [:i |
+ xy := (players at: i) getXAndY.
- xy _ (players at: i) getXAndY.
pX at: i put: xy x.
pY at: i put: xy y.
].
] ifFalse: [
+ xy := p getXAndY.
+ pX := xy x.
+ pY := xy y.
- xy _ p getXAndY.
- pX _ xy x.
- pY _ xy y.
].
^ KedamaTurtleVectorPlayer2 primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getGreenComponentIn: (in category 'player commands') -----
getGreenComponentIn: aPatch
| pix xArray yArray patch w |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
+ w := WordArray new: self size.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
- w _ WordArray new: self size.
1 to: self size do: [:i |
+ pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
- pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
w at: i put: ((pix bitShift: -8) bitAnd: 16rFF).
].
^ w.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getHeading (in category 'player commands') -----
getHeading
| heading result ret |
+ heading := (arrays at: 4).
+ result := KedamaFloatArray new: heading size.
+ ret := KedamaTurtleVectorPlayer2 primGetHeading: heading into: result.
- heading _ (arrays at: 4).
- result _ KedamaFloatArray new: heading size.
- ret _ KedamaTurtleVectorPlayer2 primGetHeading: heading into: result.
ret ifNotNil: [^ result].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getPatchValueIn: (in category 'player commands') -----
getPatchValueIn: aPatch
| w patch xArray yArray |
+ w := WordArray new: self size.
+ patch := aPatch costume renderedMorph.
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
- w _ WordArray new: self size.
- patch _ aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
patch pixelsAtXArray: xArray yArray: yArray into: w.
^ w.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getRedComponentIn: (in category 'player commands') -----
getRedComponentIn: aPatch
| pix xArray yArray patch w |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
+ w := WordArray new: self size.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
- w _ WordArray new: self size.
1 to: self size do: [:i |
+ pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
- pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
w at: i put: ((pix bitShift: -16) bitAnd: 16rFF).
].
^ w.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getTurtleAt: (in category 'player commands') -----
getTurtleAt: aPlayer
| xy |
aPlayer isCollection ifTrue: [
self error: 'should not happen'.
].
+ xy := aPlayer getXAndY.
- xy _ aPlayer getXAndY.
^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aPlayer].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getTurtleOf: (in category 'player commands') -----
getTurtleOf: aBreedPlayer
| xy |
aBreedPlayer isCollection ifTrue: [
"self error: 'should not happen'."
^ aBreedPlayer.
].
+ xy := aBreedPlayer getXAndY.
- xy _ aBreedPlayer getXAndY.
^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aBreedPlayer].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getUphillIn: (in category 'player commands') -----
getUphillIn: aPatch
| xArray yArray headingArray result patch |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ headingArray := arrays at: 4.
+ result := KedamaFloatArray new: self size.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- headingArray _ arrays at: 4.
- result _ KedamaFloatArray new: self size.
- patch _ aPatch costume renderedMorph.
1 to: self size do: [:index |
result at: index put: (patch
uphillForTurtleX: (xArray at: index)
turtleY: (yArray at: index)
turtleHeading: (headingArray at: index)).
].
^ result.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getX (in category 'player commands') -----
getX
| xArray |
exampler getGrouped ifFalse: [
^ arrays at: 2.
] ifTrue: [
+ xArray := arrays at: 2.
- xArray _ arrays at: 2.
xArray size = 0 ifTrue: [^ exampler getX].
^ xArray first.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>getY (in category 'player commands') -----
getY
| yArray |
exampler getGrouped ifFalse: [
^ arrays at: 3.
] ifTrue: [
+ yArray := arrays at: 3.
- yArray _ arrays at: 3.
yArray size = 0 ifTrue: [^ exampler getY].
^ yArray first.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>groupForward: (in category 'private') -----
groupForward: dist
| x y headingRadians |
self size = 0 ifTrue: [^ self].
+ x := (arrays at: 2) first.
+ y := (arrays at: 3) first.
+ headingRadians := (arrays at: 4) first.
- x _ (arrays at: 2) first.
- y _ (arrays at: 3) first.
- headingRadians _ (arrays at: 4) first.
self groupSetX: (x + (dist asFloat * headingRadians cos)).
self groupSetY: (y - (dist asFloat * headingRadians sin)).
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>groupSetX: (in category 'private') -----
groupSetX: val
| xArray headingArray origX origHeading leftEdgeMode rightEdgeMode newArray wrapX minX maxX |
self size = 0 ifTrue: [^ self].
+ xArray := arrays at: 2.
+ headingArray := arrays at: 4.
- xArray _ arrays at: 2.
- headingArray _ arrays at: 4.
+ origX := xArray first.
+ origHeading := headingArray first.
- origX _ xArray first.
- origHeading _ headingArray first.
+ leftEdgeMode := kedamaWorld leftEdgeModeMnemonic.
+ rightEdgeMode := kedamaWorld rightEdgeModeMnemonic.
- leftEdgeMode _ kedamaWorld leftEdgeModeMnemonic.
- rightEdgeMode _ kedamaWorld rightEdgeModeMnemonic.
+ newArray := xArray collect: [:e | e + val - origX].
+ wrapX := kedamaWorld wrapX.
+ minX := newArray min.
+ maxX := newArray max.
- newArray _ xArray collect: [:e | e + val - origX].
- wrapX _ kedamaWorld wrapX.
- minX _ newArray min.
- maxX _ newArray max.
((minX < 0.0) not and: [(maxX >= wrapX) not]) ifTrue: [
arrays at: 2 put: newArray.
^ self.
].
minX < 0.0 ifTrue: [
leftEdgeMode = 1 ifTrue: [
newArray withIndexDo: [:e :i |
e < 0.0 ifTrue: [newArray at: i put: e + wrapX].
].
].
leftEdgeMode = 2 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - minX.
].
].
leftEdgeMode = 3 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e + (minX * -2.0).
].
].
].
maxX >= wrapX ifTrue: [
rightEdgeMode = 1 ifTrue: [
newArray withIndexDo: [:e :i |
e >= wrapX ifTrue: [newArray at: i put: e - wrapX].
].
].
rightEdgeMode = 2 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - (maxX - wrapX) - 2.35099e-038.
].
].
rightEdgeMode = 3 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - ((maxX - wrapX) * 2.0) - 2.35099e-038.
].
].
].
arrays at: 2 put: newArray.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>groupSetY: (in category 'private') -----
groupSetY: val
| yArray headingArray origY origHeading topEdgeMode bottomEdgeMode newArray wrapY minY maxY |
self size = 0 ifTrue: [^ self].
+ yArray := arrays at: 3.
+ headingArray := arrays at: 4.
- yArray _ arrays at: 3.
- headingArray _ arrays at: 4.
+ origY := yArray first.
+ origHeading := headingArray first.
- origY _ yArray first.
- origHeading _ headingArray first.
+ topEdgeMode := kedamaWorld topEdgeModeMnemonic.
+ bottomEdgeMode := kedamaWorld bottomEdgeModeMnemonic.
- topEdgeMode _ kedamaWorld topEdgeModeMnemonic.
- bottomEdgeMode _ kedamaWorld bottomEdgeModeMnemonic.
+ newArray := yArray collect: [:e | e + val - origY].
+ wrapY := kedamaWorld wrapY.
+ minY := newArray min.
+ maxY := newArray max.
- newArray _ yArray collect: [:e | e + val - origY].
- wrapY _ kedamaWorld wrapY.
- minY _ newArray min.
- maxY _ newArray max.
((minY < 0.0) not and: [(maxY >= wrapY) not]) ifTrue: [
arrays at: 3 put: newArray.
^ self.
].
minY < 0.0 ifTrue: [
topEdgeMode = 1 ifTrue: [
newArray withIndexDo: [:e :i |
e < 0.0 ifTrue: [newArray at: i put: e + wrapY].
].
].
topEdgeMode = 2 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - minY.
].
].
topEdgeMode = 3 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e + (minY * -2.0).
].
].
].
maxY >= wrapY ifTrue: [
bottomEdgeMode = 1 ifTrue: [
newArray withIndexDo: [:e :i |
e >= wrapY ifTrue: [newArray at: i put: e - wrapY].
].
].
bottomEdgeMode = 2 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - (maxY - wrapY) - 2.35099e-038.
].
].
bottomEdgeMode = 3 ifTrue: [
newArray withIndexDo: [:e :i |
newArray at: i put: e - ((maxY - wrapY) * 2.0) - 2.35099e-038.
].
].
].
arrays at: 3 put: newArray.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>heading: (in category 'player commands') -----
heading: degrees
| deg |
+ deg := degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees].
- deg _ degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees].
KedamaTurtleVectorPlayer2 primSetPredicate: predicate heading: (arrays at: 4) from: deg.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>indexOf: (in category 'enumeration') -----
indexOf: who
| whoArray |
whoTableValid ifTrue: [^ whoTable at: (who - whoTableBase)].
+ whoArray := arrays at: 1.
- whoArray _ arrays at: 1.
whoArray size = 0 ifTrue: [^ 0].
+ whoTableBase := whoArray first - 1.
+ whoTable := WordArray new: whoArray last - whoTableBase.
- whoTableBase _ whoArray first - 1.
- whoTable _ WordArray new: whoArray last - whoTableBase.
1 to: whoArray size do: [:w |
whoTable at: (whoArray at: w) - whoTableBase put: w.
].
+ whoTableValid := true.
- whoTableValid _ true.
^ whoTable at: (who - whoTableBase).
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>initialize (in category 'initialization') -----
initialize
super initialize.
+ info := IdentityDictionary new.
+ predicate := ByteArray new: 0.
- info _ IdentityDictionary new.
- predicate _ ByteArray new: 0.
info at: #who put: 1.
info at: #x put: 2.
info at: #y put: 3.
info at: #heading put: 4.
info at: #color put: 5.
info at: #visible put: 6.
info at: #predicate put: 7.
+ arrays := Array new: 7.
- arrays _ Array new: 7.
arrays at: (info at: #who) put: (WordArray new: 0).
arrays at: (info at: #x) put: (KedamaFloatArray new: 0).
arrays at: (info at: #y) put: (KedamaFloatArray new: 0).
arrays at: (info at: #heading) put: (KedamaFloatArray new: 0).
arrays at: (info at: #color) put: (WordArray new: 0).
arrays at: (info at: #visible) put: (ByteArray new: 0).
arrays at: (info at: #predicate) put: predicate.
+ types := Array new: 64.
- types _ Array new: 64.
types at: 1 put: #Integer.
types at: 2 put: #Number.
types at: 3 put: #Number.
types at: 4 put: #Number.
types at: 5 put: #Color.
types at: 6 put: #Boolean.
types at: 7 put: #Boolean.
+ whoTableValid := false.
+ turtleMapValid := false.
- whoTableValid _ false.
- turtleMapValid _ false.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>initializeDeletingIndex (in category 'enumeration') -----
initializeDeletingIndex
+ deletingIndex := 0.
- deletingIndex _ 0.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>invalidateTurtleMap (in category 'turtle map') -----
invalidateTurtleMap
+ turtleMapValid := false.
- turtleMapValid _ false.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>kedamaWorld: (in category 'accessing') -----
kedamaWorld: k
+ kedamaWorld := k.
- kedamaWorld _ k.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>makeTurtlesMap (in category 'turtle map') -----
makeTurtlesMap
| xArray yArray width height whoArray ret |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ whoArray := arrays at: 1.
+ width := kedamaWorld dimensions x.
+ height := kedamaWorld dimensions y.
+ turtlesMap ifNil: [turtlesMap := WordArray new: width * height].
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- whoArray _ arrays at: 1.
- width _ kedamaWorld dimensions x.
- height _ kedamaWorld dimensions y.
- turtlesMap ifNil: [turtlesMap _ WordArray new: width * height].
+ ret := KedamaTurtleVectorPlayer2 primMakeTurtlesMap: turtlesMap whoArray: whoArray xArray: xArray yArray: yArray width: width height: height.
- ret _ KedamaTurtleVectorPlayer2 primMakeTurtlesMap: turtlesMap whoArray: whoArray xArray: xArray yArray: yArray width: width height: height.
ret ifNil: [self basicMakeTurtlesMap].
+ turtleMapValid := true.
- turtleMapValid _ true.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>nextDeletingIndex (in category 'enumeration') -----
nextDeletingIndex
+ ^ deletingIndex := deletingIndex + 1.
- ^ deletingIndex _ deletingIndex + 1.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>removeVectorSlotNamed: (in category 'player protocol') -----
removeVectorSlotNamed: aSlotName
| index newArrays |
+ index := info at: aSlotName asSymbol ifAbsent: [^ self].
+ newArrays := (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size).
- index _ info at: aSlotName asSymbol ifAbsent: [^ self].
- newArrays _ (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size).
types replaceFrom: index to: types size - 1 with: types startingAt: index + 1.
info removeKey: aSlotName asSymbol.
info associationsDo: [:assoc | assoc value > index ifTrue: [info at: assoc key put: assoc value - 1]].
+ arrays := newArrays.
- arrays _ newArrays.
self class removeSelectorSilently: (Utilities getterSelectorFor: aSlotName).
self class removeSelectorSilently: (Utilities setterSelectorFor: aSlotName).
self compileAllAccessors.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>renameVectorSlot:newSlotName: (in category 'player protocol') -----
renameVectorSlot: oldSlotName newSlotName: newSlotName
| index |
+ index := info at: oldSlotName asSymbol ifAbsent: [^ self].
- index _ info at: oldSlotName asSymbol ifAbsent: [^ self].
info removeKey: oldSlotName asSymbol.
info at: newSlotName put: index.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setBlueComponentIn:to: (in category 'player commands') -----
setBlueComponentIn: aPatch to: value
| pix xArray yArray patch component |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
value isCollection ifFalse: [
+ component := value asInteger bitAnd: 16rFF.
- component _ value asInteger bitAnd: 16rFF.
].
(1 to: self size) do: [:i |
(predicate at: i) = 1 ifTrue: [
value isCollection ifTrue: [
+ component := (value at: i) asInteger bitAnd: 16rFF.
- component _ (value at: i) asInteger bitAnd: 16rFF.
].
+ pix := patch pixelAtX: (xArray at: i) y: (yArray at: i).
+ pix := (pix bitAnd: 16rFFFF00) bitOr: component.
- 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: KedamaTurtleVectorPlayer2>>setGreenComponentIn:to: (in category 'player commands') -----
setGreenComponentIn: aPatch to: value
| pix xArray yArray patch component |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
value isCollection ifFalse: [
+ component := (value asInteger bitAnd: 16rFF) bitShift: 8.
- component _ (value asInteger bitAnd: 16rFF) bitShift: 8.
].
(1 to: self size) do: [:i |
(predicate at: i) = 1 ifTrue: [
value isCollection ifTrue: [
+ component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 8.
- 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.
- 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: KedamaTurtleVectorPlayer2>>setInitialValueOf:from:to:for: (in category 'player commands') -----
setInitialValueOf: name from: from to: to for: aKedamaWorld
| array max |
+ array := arrays at: (info at: name).
- array _ arrays at: (info at: name).
name = #who ifTrue: [
from to: to do: [:index |
array at: index put: (aKedamaWorld nextTurtleID).
].
^ self.
].
name = #x ifTrue: [
+ max := aKedamaWorld dimensions x * 100.
- max _ aKedamaWorld dimensions x * 100.
KedamaTurtleVectorPlayer2 randomRange: max from: from to: to intoFloatArray: array factor: 0.01 kedamaWorld: kedamaWorld.
^ self.
].
name = #y ifTrue: [
+ max := aKedamaWorld dimensions y * 100.
- max _ aKedamaWorld dimensions y * 100.
KedamaTurtleVectorPlayer2 randomRange: max from: from to: to intoFloatArray: array factor: 0.01 kedamaWorld: kedamaWorld.
^ self.
].
name = #heading ifTrue: [
KedamaTurtleVectorPlayer2 randomRange: 36000 from: from to: to intoFloatArray: array factor: (0.01 * 0.0174532925199433) kedamaWorld: kedamaWorld.
^ self.
].
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setPatchValueIn:to: (in category 'player commands') -----
setPatchValueIn: aPatch to: value
| xArray yArray patchMorph |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patchMorph := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patchMorph _ aPatch costume renderedMorph.
patchMorph setPixelsPredicates: predicate xArray: xArray yArray: yArray value: value.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setRedComponentIn:to: (in category 'player commands') -----
setRedComponentIn: aPatch to: value
| pix xArray yArray patch component |
+ xArray := arrays at: 2.
+ yArray := arrays at: 3.
+ patch := aPatch costume renderedMorph.
- xArray _ arrays at: 2.
- yArray _ arrays at: 3.
- patch _ aPatch costume renderedMorph.
value isCollection ifFalse: [
+ component := (value asInteger bitAnd: 16rFF) bitShift: 16.
- component _ (value asInteger bitAnd: 16rFF) bitShift: 16.
].
(1 to: self size) do: [:i |
(predicate at: i) = 1 ifTrue: [
value isCollection ifTrue: [
+ component := ((value at: i) asInteger bitAnd: 16rFF) bitShift: 16.
- 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.
- 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: KedamaTurtleVectorPlayer2>>setTurtleVisible: (in category 'player commands') -----
setTurtleVisible: aValue
| val |
aValue isCollection ifTrue: [
1 to: self size do: [:i |
(predicate at: i) = 1 ifTrue: [
(arrays at: 6) at: i put: ((aValue at: i) ifTrue: [1] ifFalse: [0]).
].
].
] ifFalse: [
+ val := aValue ifTrue: [1] ifFalse: [0].
- val _ aValue ifTrue: [1] ifFalse: [0].
1 to: self size do: [:i |
(predicate at: i) = 1 ifTrue: [
(arrays at: 6) at: i put: (val).
].
].
].
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setTurtlesCount:prototype:for:randomize: (in category 'add turtles') -----
setTurtlesCount: count prototype: prototype for: aKedamaWorld randomize: rondomizeFlag
| anInteger array |
+ anInteger := count.
+ count < 0 ifTrue: [anInteger := 0].
- anInteger _ count.
- count < 0 ifTrue: [anInteger _ 0].
self size > anInteger ifTrue: [
info associationsDo: [:assoc |
+ array := (arrays at: assoc value).
+ array := array copyFrom: 1 to: anInteger.
- array _ (arrays at: assoc value).
- array _ array copyFrom: 1 to: anInteger.
arrays at: assoc value put: array.
].
+ turtleMapValid := false.
+ whoTableValid := false.
+ predicate := arrays at: 7.
- turtleMapValid _ false.
- whoTableValid _ false.
- predicate _ arrays at: 7.
].
self size < anInteger ifTrue: [
self addTurtlesCount: (anInteger - self size) ofPrototype: prototype for: aKedamaWorld randomize: rondomizeFlag.
+ turtleMapValid := false.
+ whoTableValid := false.
- turtleMapValid _ false.
- whoTableValid _ false.
].
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setVectorSlotTypeFor:typeChosen: (in category 'player protocol') -----
setVectorSlotTypeFor: slotName typeChosen: typeChosen
| index initVar |
+ index := info at: slotName asSymbol.
- index _ info at: slotName asSymbol.
index = 0 ifTrue: [^ self].
+ initVar := self initialValueForSlotOfType: typeChosen.
- initVar _ self initialValueForSlotOfType: typeChosen.
types at: index put: typeChosen.
arrays at: index put: (self arrayForType: typeChosen).
self compileVectorInstVarAccessorsFor: slotName.
self perform: ('set', slotName capitalized, ':') asSymbol with: initVar.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setX: (in category 'player commands') -----
setX: v
exampler getGrouped ifFalse: [
KedamaTurtleVectorPlayer2
primSetXPredicates: predicate
xArray: (arrays at: 2)
headingArray: (arrays at: 4)
value: (v isNumber ifTrue: [v asFloat] ifFalse: [v])
destWidth: kedamaWorld wrapX
leftEdgeMode: kedamaWorld leftEdgeModeMnemonic
rightEdgeMode: kedamaWorld rightEdgeModeMnemonic.
] ifTrue: [
self groupSetX: v
].
+ turtleMapValid := false.
- turtleMapValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>setY: (in category 'player commands') -----
setY: v
exampler getGrouped ifFalse: [
KedamaTurtleVectorPlayer2
primSetYPredicates: predicate
yArray: (arrays at: 3)
headingArray: (arrays at: 4)
value: (v isNumber ifTrue: [v asFloat] ifFalse: [v])
destHeight: kedamaWorld wrapY
topEdgeMode: kedamaWorld topEdgeModeMnemonic
bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
] ifTrue: [
self groupSetY: v.
].
+ turtleMapValid := false.
- turtleMapValid _ false.
kedamaWorld drawRequest.
!
Item was changed:
----- Method: KedamaTurtleVectorPlayer2>>test:ifTrue:ifFalse: (in category 'command execution') -----
test: cond ifTrue: trueBlock ifFalse: falseBlock
| origPredicate c |
(cond == true or: [cond == false]) ifTrue: [
^ cond ifTrue: [trueBlock value: self] ifFalse: [falseBlock value: self].
].
+ origPredicate := predicate clone.
- origPredicate _ predicate clone.
predicate bytesAnd: cond.
trueBlock value: self.
+ c := cond clone.
- c _ cond clone.
c not.
predicate replaceFrom: 1 to: (predicate size min: origPredicate size) with: origPredicate startingAt: 1.
predicate bytesAnd: c.
falseBlock value: self.
predicate replaceFrom: 1 to: (predicate size min: origPredicate size) with: origPredicate startingAt: 1.!
Item was changed:
----- Method: KedamaVectorParseTreeRewriter>>visit:andParent: (in category 'entry point') -----
visit: node andParent: parent
| newNode possibleSelector selIndex |
node isLeaf not ifTrue: [
node getAllChildren do: [:child |
self visit: child andParent: node.
].
].
(node rewriteInfoOut notNil) ifTrue: [
((node isMemberOf: VariableNode) or: [node isMemberOf: LiteralVariableNode]) ifTrue: [
+ newNode := TempVariableNode new name: node rewriteInfoOut second index: 0 type: 2.
- newNode _ TempVariableNode new name: node rewriteInfoOut second index: 0 type: 2.
parent replaceNode: node with: newNode.
].
].
(node isMemberOf: MessageNode) ifTrue: [
(node statementType = #sequential) ifTrue: [
node selector key = #doSequentialCommand: ifTrue: [
(node isStatement) ifTrue: [
node receiver: node primaryBreedPair second.
].
]
].
].
(node isMemberOf: MessageNode) ifTrue: [
+ ((selIndex := #(parallel sequential die) indexOf: node statementType) > 0) ifTrue: [
+ possibleSelector := #(doCommand: doSequentialCommand: doDieCommand:) at: selIndex.
- ((selIndex _ #(parallel sequential die) indexOf: node statementType) > 0) ifTrue: [
- possibleSelector _ #(doCommand: doSequentialCommand: doDieCommand:) at: selIndex.
(node messageType = #condition) ifTrue: [
+ newNode := self createMessageNode: node inParentNode: parent receiverNode: (TempVariableNode new name: node rewriteInfoOut second index: 0 type: 2) selector: #test:ifTrue:ifFalse: arguments: (Array with: node receiver with: node arguments first with: node arguments second).
- newNode _ self createMessageNode: node inParentNode: parent receiverNode: (TempVariableNode new name: node rewriteInfoOut second index: 0 type: 2) selector: #test:ifTrue:ifFalse: arguments: (Array with: node receiver with: node arguments first with: node arguments second).
(node isStatement) ifFalse: [
parent replaceNode: node with: newNode.
] ifTrue: [
self rewriteMessageNode: node inParentNode: parent receiverNode: node rewriteInfoIn second selector: possibleSelector arguments: (Array with: (self makeBlockNodeArguments: (Array with: node rewriteInfoOut second) statements: (Array with: newNode) returns: false)).
].
] ifFalse: [
(node isStatement) ifTrue: [
self rewriteMessageNode: node inParentNode: parent receiverNode: node rewriteInfoIn second selector: possibleSelector arguments: (Array with: (self makeBlockNodeArguments: (Array with: node rewriteInfoOut second) statements: (Array with: node) returns: false)).
].
]
].
].
(node isMemberOf: BlockNode) ifTrue: [
(node rewriteInfoOut notNil) ifTrue: [
self rewriteBlockNode: node inParentNode: parent arguments: (Array with: (TempVariableNode new name: node rewriteInfoOut second index: 0 type: 2)) statements: node statements returns: false.
].
].
!
Item was changed:
----- Method: KidNavigationMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
| result |
+ result := GradientFillStyle ramp: {0.0
- result _ GradientFillStyle ramp: {0.0
-> (Color
r: 0.032
g: 0.0
b: 0.484). 1.0
-> (Color
r: 0.194
g: 0.032
b: 1.0)}.
result origin: self bounds topLeft.
result direction: 0 @ 200.
result radial: false.
^ result!
Item was changed:
----- Method: KidNavigationMorph>>mouseUp: (in category 'event handling') -----
mouseUp: evt
+ mouseInside := (mouseInside ifNil: [false]) not.
- mouseInside _ (mouseInside ifNil: [false]) not.
self positionVertically
!
Item was changed:
----- Method: KidNavigationMorph>>quitSqueak (in category 'the actions') -----
quitSqueak
| newProjects limit now msg response |
Preferences checkForUnsavedProjects ifFalse: [^super quitSqueak].
PreExistingProjects ifNil: [^super quitSqueak].
+ limit := 5 * 60.
+ now := Time totalSeconds.
+ newProjects := Project allProjects reject: [ :each | PreExistingProjects includes: each].
+ newProjects := newProjects reject: [ :each |
- limit _ 5 * 60.
- now _ Time totalSeconds.
- newProjects _ Project allProjects reject: [ :each | PreExistingProjects includes: each].
- newProjects _ newProjects reject: [ :each |
((each lastSavedAtSeconds ifNil: [0]) - now) abs < limit
].
newProjects isEmpty ifTrue: [^super quitSqueak].
+ msg := String streamContents: [ :strm |
- msg _ String streamContents: [ :strm |
strm nextPutAll: 'There are some project(s)
that have not been saved recently:
----
'.
newProjects do: [ :each | strm nextPutAll: each name; cr].
strm nextPutAll: '----
What would you like to do?'
].
+ response := PopUpMenu
- response _ PopUpMenu
confirm: msg
trueChoice: 'Go ahead and QUIT'
falseChoice: 'Wait, let me save them first'.
response ifTrue: [^super quitSqueak].
!
Item was changed:
----- Method: KidNavigationMorph>>step (in category 'stepping and presenter') -----
step
super step.
+ PreExistingProjects ifNil: [PreExistingProjects := WeakArray withAll: Project allProjects].!
- PreExistingProjects ifNil: [PreExistingProjects _ WeakArray withAll: Project allProjects].!
Item was changed:
----- Method: LeafNode>>key: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
key: anObject
+ key := anObject.
- key _ anObject.
!
Item was changed:
----- Method: LeafNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
+ childNode = key ifTrue: [key := newNode].
- childNode = key ifTrue: [key _ newNode].
!
Item was changed:
----- Method: LineIntersectionEvent>>crossedEdge: (in category 'accessing') -----
crossedEdge: aSegment
+ crossedEdge := aSegment!
- crossedEdge _ aSegment!
Item was changed:
----- Method: LineIntersectionEvent>>type:position:segment: (in category 'initialize-release') -----
type: aSymbol position: aPoint segment: aSegment
+ type := aSymbol.
+ position := aPoint.
+ segment := aSegment.!
- type _ aSymbol.
- position _ aPoint.
- segment _ aSegment.!
Item was changed:
----- Method: LineIntersectionSegment>>referentEdge: (in category 'accessing') -----
referentEdge: anEdge
+ referentEdge := anEdge!
- referentEdge _ anEdge!
Item was changed:
----- Method: LineIntersections class>>debugMode: (in category 'debug') -----
debugMode: aBool
"LineIntersections debugMode: true"
"LineIntersections debugMode: false"
+ Debug := aBool.!
- Debug _ aBool.!
Item was changed:
----- Method: LineIntersections class>>exampleLines: (in category 'example') -----
exampleLines: n
"LineIntersections exampleLines: 100"
| segments rnd canvas intersections pt p1 p2 |
+ rnd := Random new.
+ segments := (1 to: n) collect:[:i|
+ p1 := (rnd next @ rnd next * 500) asIntegerPoint.
+ [p2 := (rnd next @ rnd next * 200 - 100) asIntegerPoint.
- rnd _ Random new.
- segments _ (1 to: n) collect:[:i|
- p1 _ (rnd next @ rnd next * 500) asIntegerPoint.
- [p2 _ (rnd next @ rnd next * 200 - 100) asIntegerPoint.
p2 isZero] whileTrue.
LineSegment from: p1 to: p1 + p2].
+ canvas := Display getCanvas.
- canvas _ Display getCanvas.
canvas fillRectangle: (0 at 0 extent: 600 at 600) color: Color white.
segments do:[:seg|
canvas line: seg start to: seg end width: 1 color: Color black.
].
+ intersections := LineIntersections of: segments.
- intersections _ LineIntersections of: segments.
intersections do:[:array|
+ pt := array at: 1.
- pt _ array at: 1.
canvas fillRectangle: (pt asIntegerPoint - 2 extent: 5 at 5) color: Color red].
Display restoreAfter:[].!
Item was changed:
----- Method: LineIntersections class>>regularize: (in category 'instance creation') -----
regularize: pointCollection
"Make the pointList non-intersecting, e.g., insert points at intersections and have the outline include those points"
| pointList segments last intersections map pts |
+ pointList := pointCollection collect:[:pt| pt asIntegerPoint].
+ segments := WriteStream on: (Array new: pointList size).
+ last := pointList last.
- pointList _ pointCollection collect:[:pt| pt asIntegerPoint].
- segments _ WriteStream on: (Array new: pointList size).
- last _ pointList last.
pointList do:[:next|
segments nextPut: (LineSegment from: last to: next).
+ last := next.
- last _ next.
].
+ segments := segments contents.
+ intersections := self of: segments.
+ map := IdentityDictionary new: segments size.
- segments _ segments contents.
- intersections _ self of: segments.
- map _ IdentityDictionary new: segments size.
intersections do:[:is|
(map at: is second ifAbsentPut:[WriteStream on: (Array new: 2)]) nextPut: is first.
(map at: is third ifAbsentPut:[WriteStream on: (Array new: 2)]) nextPut: is first.
].
+ pts := WriteStream on: (Array new: pointList size).
- pts _ WriteStream on: (Array new: pointList size).
segments do:[:seg|
+ intersections := (map at: seg) contents.
+ intersections := intersections sort:
- intersections _ (map at: seg) contents.
- intersections _ intersections sort:
[:p1 :p2| (p1 squaredDistanceTo: seg start) <= (p2 squaredDistanceTo: seg start)].
+ last := intersections at: 1.
- last _ intersections at: 1.
pts nextPut: last.
intersections do:[:next|
(next = last and:[next = seg end]) ifFalse:[
pts nextPut: next.
+ last := next]].
- last _ next]].
].
^pts contents collect:[:pt| pt asFloatPoint]!
Item was changed:
----- Method: LineIntersections>>computeIntersectionAt:belowOrRightOf: (in category 'computing') -----
computeIntersectionAt: leftIndex belowOrRightOf: aPoint
| leftEdge rightEdge pt evt |
leftIndex < 1 ifTrue:[^self].
leftIndex >= activeEdges size ifTrue:[^self].
+ leftEdge := activeEdges at: leftIndex.
+ rightEdge := activeEdges at: leftIndex+1.
- leftEdge _ activeEdges at: leftIndex.
- rightEdge _ activeEdges at: leftIndex+1.
Debug == true ifTrue:[
self debugDrawLine: leftEdge with: rightEdge color: Color yellow.
self debugDrawLine: leftEdge with: rightEdge color: Color blue.
self debugDrawLine: leftEdge with: rightEdge color: Color yellow.
self debugDrawLine: leftEdge with: rightEdge color: Color blue.
].
+ pt := self intersectFrom: leftEdge start to: leftEdge end with: rightEdge start to: rightEdge end.
- pt _ self intersectFrom: leftEdge start to: leftEdge end with: rightEdge start to: rightEdge end.
pt ifNil:[^self].
pt y < aPoint y ifTrue:[^self].
(pt y = aPoint y and:[pt x <= aPoint x]) ifTrue:[^self].
Debug == true ifTrue:[self debugDrawPoint: pt].
+ evt := LineIntersectionEvent type: #cross position: pt segment: leftEdge.
- evt _ LineIntersectionEvent type: #cross position: pt segment: leftEdge.
evt crossedEdge: rightEdge.
events add: evt.!
Item was changed:
----- Method: LineIntersections>>computeIntersectionsOf: (in category 'computing') -----
computeIntersectionsOf: anArrayOfLineSegments
+ segments := anArrayOfLineSegments.
- segments _ anArrayOfLineSegments.
self initializeEvents.
self processEvents.
^intersections contents!
Item was changed:
----- Method: LineIntersections>>crossEdgeEvent: (in category 'computing') -----
crossEdgeEvent: evt
| evtPoint edge index other |
lastIntersections
+ ifNil:[lastIntersections := Array with: evt]
- ifNil:[lastIntersections _ Array with: evt]
ifNotNil:[
(lastIntersections anySatisfy:
[:old| old edge == evt edge and:[old crossedEdge == evt crossedEdge]]) ifTrue:[^self].
+ lastIntersections := lastIntersections copyWith: evt].
+ evtPoint := evt position.
+ edge := evt edge.
- lastIntersections _ lastIntersections copyWith: evt].
- evtPoint _ evt position.
- edge _ evt edge.
self recordIntersection: edge with: evt crossedEdge at: evtPoint.
Debug == true ifTrue:[
self debugDrawLine: edge with: evt crossedEdge color: Color red.
self debugDrawLine: edge with: evt crossedEdge color: Color blue.
self debugDrawLine: edge with: evt crossedEdge color: Color red.
self debugDrawLine: edge with: evt crossedEdge color: Color blue].
+ index := self firstIndexForInserting: evtPoint.
+ [other := activeEdges at: index.
+ other == edge] whileFalse:[index := index + 1].
- index _ self firstIndexForInserting: evtPoint.
- [other _ activeEdges at: index.
- other == edge] whileFalse:[index _ index + 1].
"Swap edges at index"
"self assert:[(activeEdges at: index+1) == evt crossedEdge]."
+ other := activeEdges at: index+1.
- other _ activeEdges at: index+1.
activeEdges at: index+1 put: edge.
activeEdges at: index put: other.
"And compute new intersections"
self computeIntersectionAt: index-1 belowOrRightOf: evtPoint.
self computeIntersectionAt: index+1 belowOrRightOf: evtPoint.!
Item was changed:
----- Method: LineIntersections>>endEdgeEvent: (in category 'computing') -----
endEdgeEvent: evt
| evtPoint edge index other |
+ evtPoint := evt position.
+ edge := evt edge.
- evtPoint _ evt position.
- edge _ evt edge.
Debug == true ifTrue:[self debugDrawLine: edge color: Color green].
+ index := self firstIndexForInserting: evtPoint.
+ [other := activeEdges at: index.
+ other == edge] whileFalse:[index := index + 1].
- index _ self firstIndexForInserting: evtPoint.
- [other _ activeEdges at: index.
- other == edge] whileFalse:[index _ index + 1].
"Remove edge at index"
activeEdges removeAt: index.
self computeIntersectionAt: index-1 belowOrRightOf: evtPoint.!
Item was changed:
----- Method: LineIntersections>>firstIndexForInserting: (in category 'private') -----
firstIndexForInserting: aPoint
| index |
+ index := self indexForInserting: aPoint.
- index _ self indexForInserting: aPoint.
[index > 1 and:[((activeEdges at: index-1) sideOfPoint: aPoint) = 0]]
+ whileTrue:[index := index-1].
- whileTrue:[index _ index-1].
^index!
Item was changed:
----- Method: LineIntersections>>indexForInserting: (in category 'private') -----
indexForInserting: aPoint
"Return the appropriate index for inserting the given x value"
| index low high side |
+ low := 1.
+ high := activeEdges size.
+ [index := (high + low) bitShift: -1.
- low _ 1.
- high _ activeEdges size.
- [index _ (high + low) bitShift: -1.
low > high] whileFalse:[
+ side := (activeEdges at: index) sideOfPoint: aPoint.
- side _ (activeEdges at: index) sideOfPoint: aPoint.
side = 0 ifTrue:[^index].
side > 0
+ ifTrue:[high := index - 1]
+ ifFalse:[low := index + 1]].
- ifTrue:[high _ index - 1]
- ifFalse:[low _ index + 1]].
^low!
Item was changed:
----- Method: LineIntersections>>initializeEvents (in category 'computing') -----
initializeEvents
"Initialize the events for all given line segments"
| mySeg pt1 pt2 |
+ events := WriteStream on: (Array new: segments size * 2).
- events _ WriteStream on: (Array new: segments size * 2).
segments do:[:seg|
+ pt1 := seg start asPoint.
+ pt2 := seg end asPoint.
- pt1 _ seg start asPoint.
- pt2 _ seg end asPoint.
(pt1 sortsBefore: pt2)
+ ifTrue:[mySeg := LineIntersectionSegment from: pt1 to: pt2]
+ ifFalse:[mySeg := LineIntersectionSegment from: pt2 to: pt1].
- ifTrue:[mySeg _ LineIntersectionSegment from: pt1 to: pt2]
- ifFalse:[mySeg _ LineIntersectionSegment from: pt2 to: pt1].
mySeg referentEdge: seg.
events nextPut: (LineIntersectionEvent type: #start position: mySeg start segment: mySeg).
events nextPut: (LineIntersectionEvent type: #end position: mySeg end segment: mySeg).
].
+ events := Heap withAll: events contents sortBlock: [:ev1 :ev2| ev1 sortsBefore: ev2].!
- events _ Heap withAll: events contents sortBlock: [:ev1 :ev2| ev1 sortsBefore: ev2].!
Item was changed:
----- Method: LineIntersections>>intersectFrom:to:with:to: (in category 'private') -----
intersectFrom: pt1Start to: pt1End with: pt2Start to: pt2End
| det deltaPt alpha beta pt1Dir pt2Dir |
+ pt1Dir := pt1End - pt1Start.
+ pt2Dir := pt2End - pt2Start.
+ det := (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x).
+ deltaPt := pt2Start - pt1Start.
+ alpha := (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x).
+ beta := (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x).
- pt1Dir _ pt1End - pt1Start.
- pt2Dir _ pt2End - pt2Start.
- det _ (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x).
- deltaPt _ pt2Start - pt1Start.
- alpha _ (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x).
- beta _ (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x).
det = 0 ifTrue:[^nil]. "no intersection"
alpha * det < 0 ifTrue:[^nil].
beta * det < 0 ifTrue:[^nil].
det > 0
ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]]
ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]].
"And compute intersection"
^pt1Start + (alpha * pt1Dir / (det at det))!
Item was changed:
----- Method: LineIntersections>>isLeft:comparedTo: (in category 'private') -----
isLeft: dir1 comparedTo: dir2
"Return true if dir1 is left of dir2"
| det |
+ det := ((dir1 x * dir2 y) - (dir2 x * dir1 y)).
- det _ ((dir1 x * dir2 y) - (dir2 x * dir1 y)).
"det = 0 ifTrue:[self error:'line on line']."
^det <= 0!
Item was changed:
----- Method: LineIntersections>>processEvents (in category 'computing') -----
processEvents
| evt |
+ intersections := WriteStream on: (Array new: segments size).
+ activeEdges := OrderedCollection new.
- intersections _ WriteStream on: (Array new: segments size).
- activeEdges _ OrderedCollection new.
[events isEmpty] whileFalse:[
+ evt := events removeFirst.
- evt _ events removeFirst.
evt type == #start ifTrue:[self startEdgeEvent: evt].
evt type == #end ifTrue:[self endEdgeEvent: evt].
evt type == #cross
ifTrue:[self crossEdgeEvent: evt]
+ ifFalse:[lastIntersections := nil].
- ifFalse:[lastIntersections _ nil].
].!
Item was changed:
----- Method: LineIntersections>>startEdgeEvent: (in category 'computing') -----
startEdgeEvent: evt
| idx edge evtPoint index keepChecking other side |
+ edge := evt segment.
- edge _ evt segment.
Debug == true ifTrue:[self debugDrawLine: edge color: Color blue].
+ evtPoint := evt position.
- evtPoint _ evt position.
"Find left-most insertion point"
+ idx := self firstIndexForInserting: evtPoint.
+ index := idx.
+ keepChecking := true.
- idx _ self firstIndexForInserting: evtPoint.
- index _ idx.
- keepChecking _ true.
"Check all edges containing the same insertion point"
[idx <= activeEdges size
+ ifTrue:[ other := activeEdges at: idx.
+ side := other sideOfPoint: evtPoint]
+ ifFalse:[side := -1].
- ifTrue:[ other _ activeEdges at: idx.
- side _ other sideOfPoint: evtPoint]
- ifFalse:[side _ -1].
side = 0] whileTrue:[
+ idx := idx + 1.
- idx _ idx + 1.
self recordIntersection: edge with: other at: evtPoint.
"Check edges as long as we haven't found the insertion index"
keepChecking ifTrue:[
(self isLeft: other direction comparedTo: edge direction)
+ ifTrue:[index := index + 1]
+ ifFalse:[keepChecking := false]].
- ifTrue:[index _ index + 1]
- ifFalse:[keepChecking _ false]].
].
activeEdges add: edge afterIndex: index-1.
self computeIntersectionAt: index-1 belowOrRightOf: evtPoint.
self computeIntersectionAt: index belowOrRightOf: evtPoint.!
Item was changed:
----- Method: ListComponent>>changeModelSelection: (in category 'model access') -----
changeModelSelection: anInteger
"Change the model's selected item index to be anInteger."
setIndexSelector
ifNil: ["If model is not hooked up to index, then we won't get
an update, so have to do it locally."
self selectionIndex: anInteger]
ifNotNil: [model perform: setIndexSelector with: anInteger].
+ selectedItem := anInteger = 0 ifTrue: [nil] ifFalse: [self getListItem: anInteger].
- selectedItem _ anInteger = 0 ifTrue: [nil] ifFalse: [self getListItem: anInteger].
setSelectionSelector ifNotNil:
[model perform: setSelectionSelector with: selectedItem]!
Item was changed:
----- Method: ListComponent>>initPinSpecs (in category 'components') -----
initPinSpecs
+ pinSpecs := Array
- pinSpecs _ Array
with: (PinSpec new pinName: 'list' direction: #input
localReadSelector: nil localWriteSelector: nil
modelReadSelector: getListSelector modelWriteSelector: nil
defaultValue: #(one two three) pinLoc: 1.5)
with: (PinSpec new pinName: 'index' direction: #inputOutput
localReadSelector: nil localWriteSelector: nil
modelReadSelector: getIndexSelector modelWriteSelector: setIndexSelector
defaultValue: 0 pinLoc: 2.5)
with: (PinSpec new pinName: 'selectedItem' direction: #output
localReadSelector: nil localWriteSelector: nil
modelReadSelector: nil modelWriteSelector: setSelectionSelector
defaultValue: nil pinLoc: 3.5)!
Item was changed:
----- Method: ListComponent>>list: (in category 'initialization') -----
list: listOfItems
super list: listOfItems.
self selectionIndex: 0.
+ selectedItem := nil.
- selectedItem _ nil.
setSelectionSelector ifNotNil:
[model perform: setSelectionSelector with: selectedItem]!
Item was changed:
----- Method: M17nInputInterpreter>>initialize (in category 'as yet unclassified') -----
initialize
+ converter := UTF8TextConverter new.!
- converter _ UTF8TextConverter new.!
Item was changed:
----- Method: M17nInputInterpreter>>nextUtf8Char:firstEvt: (in category 'as yet unclassified') -----
nextUtf8Char: sensor firstEvt: evtBuf
"this code should really go into InputSensor>>fullKey"
| aCollection bytes peekEvent keyValue type stream multiChar evt |
self flag: #fixthis.
+ keyValue := evtBuf third.
+ evtBuf fourth = EventKeyChar ifTrue: [type := #keystroke].
+ peekEvent := sensor peekEvent.
- keyValue _ evtBuf third.
- evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke].
- peekEvent _ sensor peekEvent.
(peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [
sensor nextEvent.
+ peekEvent := sensor peekEvent].
- peekEvent _ sensor peekEvent].
(type == #keystroke
and: [peekEvent notNil
and: [peekEvent first = EventTypeKeyboard
and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [
+ aCollection := OrderedCollection with: keyValue asCharacter.
+ bytes := (keyValue <= 127)
- aCollection _ OrderedCollection with: keyValue asCharacter.
- bytes _ (keyValue <= 127)
ifTrue: [ 0 ]
ifFalse: [ (keyValue bitAnd: 16rE0) = 192
ifTrue: [ 1 ]
ifFalse: [ (keyValue bitAnd: 16rF0) = 224
ifTrue: [ 2 ]
ifFalse: [ 3 ]
]
].
[bytes > 0] whileTrue: [
(evt := sensor nextEvent) fourth = EventKeyChar ifTrue: [
bytes := bytes - 1.
aCollection add: (Character value: evt third)]].
"aCollection do: [ :each | Transcript show: (each asciiValue hex , ' ')].
Transcript show: Character cr."
+ stream := ReadStream on: (String withAll: aCollection).
+ multiChar := converter nextFromStream: stream.
- stream _ ReadStream on: (String withAll: aCollection).
- multiChar _ converter nextFromStream: stream.
multiChar isOctetCharacter ifFalse: [ sensor nextEvent ].
^ multiChar].
^ keyValue asCharacter!
Item was changed:
----- Method: MIDIPianoKeyboardMorph>>closeMIDIPort (in category 'as yet unclassified') -----
closeMIDIPort
+ midiPort := nil.
- midiPort _ nil.
!
Item was changed:
----- Method: MIDIPianoKeyboardMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
SimpleMIDIPort midiIsSupported
+ ifTrue: [midiPort := SimpleMIDIPort openDefault].
+ channel := 1.
+ velocity := 100!
- ifTrue: [midiPort _ SimpleMIDIPort openDefault].
- channel _ 1.
- velocity _ 100!
Item was changed:
----- Method: MIDIPianoKeyboardMorph>>openMIDIPort (in category 'as yet unclassified') -----
openMIDIPort
| portNum |
+ portNum := SimpleMIDIPort outputPortNumFromUser.
- portNum _ SimpleMIDIPort outputPortNumFromUser.
portNum ifNil: [^ self].
+ midiPort := SimpleMIDIPort openOnPortNumber: portNum.
- midiPort _ SimpleMIDIPort openOnPortNumber: portNum.
!
Item was changed:
----- Method: MIDIPianoKeyboardMorph>>turnOffNote (in category 'as yet unclassified') -----
turnOffNote
midiPort notNil & soundPlaying notNil ifTrue: [
soundPlaying isInteger ifTrue: [
midiPort midiCmd: 16r90 channel: channel byte: soundPlaying byte: 0]].
+ soundPlaying := nil.
- soundPlaying _ nil.
!
Item was changed:
----- Method: MIDIPianoKeyboardMorph>>turnOnNote: (in category 'as yet unclassified') -----
turnOnNote: midiKey
midiPort midiCmd: 16r90 channel: channel byte: midiKey byte: velocity.
+ soundPlaying := midiKey.
- soundPlaying _ midiKey.
!
Item was changed:
----- Method: MIMEType class>>fromMIMEString: (in category 'instance creation') -----
fromMIMEString: mimeString
| idx main rest sub parameters |
+ idx := mimeString indexOf: $/.
- idx _ mimeString indexOf: $/.
idx = 0
ifTrue: [self error: 'Illegal mime type string "' , mimeString , '".'].
main := mimeString copyFrom: 1 to: idx-1.
rest := mimeString copyFrom: idx+1 to: mimeString size.
+ idx := mimeString indexOf: $;.
- idx _ mimeString indexOf: $;.
idx = 0
ifTrue: [sub := rest]
ifFalse: [
sub := rest copyFrom: 1 to: idx.
parameters := rest copyFrom: idx+1 to: rest size].
^self
main: main
sub: sub
parameters: parameters
!
Item was changed:
----- Method: MIMEType class>>initializeDefaultSubTypeSuffixes (in category 'class initialization') -----
initializeDefaultSubTypeSuffixes
"MIMEType initializeDefaultSubTypeSuffixes"
| defaultSuffixes |
+ defaultSuffixes := Dictionary new: 43.
- defaultSuffixes _ Dictionary new: 43.
defaultSuffixes
at: 'jpeg' put: 'jpg';
yourself.
^defaultSuffixes!
Item was changed:
----- Method: MIMEType class>>initializeDefaultSuffixes (in category 'class initialization') -----
initializeDefaultSuffixes
"MIMEType initializeDefaultSubTypeSuffixes"
"DefaultSuffixes := nil"
| defaultSuffixes |
+ defaultSuffixes := Dictionary new: 43.
- defaultSuffixes _ Dictionary new: 43.
defaultSuffixes
at: 'image/jpeg' put: 'jpg';
at: 'audio/x-mpeg' put: 'mp3';
at: 'video/x-mpeg' put: 'mpg';
at: 'image/png' put: 'png';
at: 'text/xml' put: 'xml';
yourself.
^defaultSuffixes!
Item was changed:
----- Method: MIMEType class>>initializeStandardMIMETypes (in category 'class initialization') -----
initializeStandardMIMETypes
"MIMEType initializeStandardMIMETypes"
+ StandardMIMEMappings := Dictionary new.
- StandardMIMEMappings _ Dictionary new.
self standardMIMETypes keysAndValuesDo:[:extension :mimeStrings |
StandardMIMEMappings
at: extension asString asLowercase
put: (mimeStrings collect: [:mimeString | MIMEType fromMIMEString: mimeString]).
].!
Item was changed:
----- Method: MIMEType class>>standardMIMETypes (in category 'class initialization') -----
standardMIMETypes
"MIMEType standardMIMETypes"
"We had to split this method because of the 256 literal limit in methods."
| mimeTypes |
+ mimeTypes := self standardMIMETypes2.
- mimeTypes _ self standardMIMETypes2.
mimeTypes
at: 'adr' put: #('application/x-msaddr');
at: 'jpe' put: #('image/jpeg');
at: 'ttf' put: #('application/x-truetypefont');
at: 'wiz' put: #('application/msword');
at: 'xml' put: #('text/xml' 'text/html');
at: 'ppz' put: #('application/vnd.ms-powerpoint');
at: 'rpm' put: #('audio/x-pn-realaudio-plugin');
at: 'rgb' put: #('image/x-rgb');
at: 'mid' put: #('audio/midi' 'audio/x-midi');
at: 'pnm' put: #('image/x-portable-anymap');
at: 'bcpio' put: #('application/x-bcpio');
at: 'pot' put: #('application/vnd.ms-powerpoint');
at: 'o' put: #('application/octet-stream');
at: 'vgp' put: #('video/x-videogram-plugin');
at: 'ua' put: #('text/plain');
at: 'zpa' put: #('application/pcphoto');
at: 'pdf' put: #('application/pdf');
at: 'class' put: #('application/octet-stream');
at: 'ra' put: #('audio/x-realaudio');
at: 'ips' put: #('application/ips');
at: 'uu' put: #('application/octet-stream');
at: 'sh' put: #('application/x-sh');
at: 'ebk' put: #('application/x-expandedbook');
at: 'pbm' put: #('image/x-portable-bitmap');
at: 'ram' put: #('audio/x-pn-realaudio');
at: 'tsv' put: #('text/tab-separated-values');
at: 'dvi' put: #('application/x-dvi');
at: 'lha' put: #('application/octet-stream');
at: 'gif' put: #('image/gif');
at: 'aif' put: #('audio/x-aiff');
at: 'etx' put: #('text/x-setext');
at: 'jfif-tbnl' put: #('image/jpeg');
at: 'pps' put: #('application/vnd.ms-powerpoint');
at: 'mp3' put: #('audio/mpeg' 'audio/x-mpeg');
at: 'pgr' put: #('text/parsnegar-document');
at: 'con' put: #('application/x-connector');
at: 'viv' put: #('video/vnd.vivo');
at: 'latex' put: #('application/x-latex');
at: 'h' put: #('text/plain');
at: 'ms' put: #('application/x-troff-ms');
at: 'zip' put: #('application/zip');
at: 'axs' put: #('application/olescript');
at: 'gtar' put: #('application/x-gtar');
at: 'fhc' put: #('image/x-freehand');
at: 'asf' put: #('video/x-ms-asf');
at: 'm3u' put: #('audio/x-mpeg');
at: 'ai' put: #('application/postscript');
at: 'movie' put: #('video/x-sgi-movie' 'video/x-sgi.movie');
at: 'exe' put: #('application/octet-stream');
at: 'htm' put: #('text/html' 'text/plain');
at: 'a' put: #('application/octet-stream');
at: 'mv' put: #('video/x-sgi-movie');
at: 'fh4' put: #('image/x-freehand');
at: 'avi' put: #('video/avi');
at: 'tiff' put: #('image/tiff');
at: 'mpga' put: #('audio/mpeg');
at: 'mov' put: #('video/mov');
at: 'html' put: #('text/html' 'text/plain');
at: 'hqx' put: #('application/mac-binhex40' 'application/octet-stream');
at: 'ras' put: #('image/x-cmu-rast');
at: 'arc' put: #('application/octet-stream');
at: 'dump' put: #('application/octet-stream');
at: 'jfif' put: #('image/jpeg');
at: 'dus' put: #('audio/x-dspeech');
at: 'me' put: #('application/x-troff-me');
at: 'mime' put: #('message/rfc822');
at: 'gtaru' put: #('application/x-gtar');
at: 'cdf' put: #('application/x-netcdf');
at: 'xpm' put: #('image/x-xpixmap');
at: 'jpg' put: #('image/jpeg');
at: 'dot' put: #('application/msword');
at: 'css' put: #('text/css' 'text/x-css');
at: 'chat' put: #('application/x-chat');
at: 'gz' put: #('application/gzip');
at: 'mp2' put: #('audio/mpeg');
at: 'cpt' put: #('application/mac-compactpro');
at: 'wlt' put: #('application/x-mswallet');
at: 'text' put: #('text/plain');
at: 'wsrc' put: #('application/x-wais-source');
at: 'xwd' put: #('image/x-xwindowdump');
at: 'rm' put: #('audio/x-pn-realaudio');
at: 'wrl' put: #('model/vrml');
at: 'doc' put: #('application/ms-word-document' 'application/msword');
at: 'ustar' put: #('audio/basic');
at: 'js' put: #('application/x-javascript');
at: 'rtx' put: #('application/rtf');
at: 'aam' put: #('application/x-authorware-map');
at: 'oda' put: #('application/oda');
at: 'ppa' put: #('application/vnd.ms-powerpoint');
at: 'xbm' put: #('image/x-xbitmap');
at: 'cpio' put: #('application/x-cpio');
at: 'sv4crc' put: #('application/x-sv4crc');
at: 'mpg' put: #('video/mpg' 'video/mpeg' 'video/x-mpeg');
at: 't' put: #('application/x-troff');
at: 'txt' put: #('text/plain');
at: 'sit' put: #('application/x-stuffit');
at: 'wid' put: #('application/x-DemoShield');
at: 'swf' put: #('application/x-shockwave-flash');
at: 'lzh' put: #('application/octet-stream');
at: 'au' put: #('audio/basic');
at: 'java' put: #('text/plain');
at: 'mpeg' put: #('video/mpeg' 'video/x-mpeg');
at: 'qt' put: #('video/quicktime');
at: 'pgm' put: #('image/x-portable-graymap');
at: 'hdf' put: #('application/x-hdf');
at: 'c' put: #('text/plain');
at: 'cpp' put: #('text/plain');
at: 'vgx' put: #('video/x-videogram');
at: 'aifc' put: #('audio/x-aiff');
at: 'tex' put: #('application/x.tex');
at: 'wav' put: #('audio/wav' 'audio/x-wav');
at: 'ivr' put: #('i-world/i-vrml');
at: 'saveme' put: #('application/octet-stream');
at: 'csh' put: #('application/x-csh');
at: 'aas' put: #('application/x-authorware-map');
at: 'tar' put: #('application/x-tar');
at: 'vivo' put: #('video/vnd.vivo');
yourself.
^mimeTypes!
Item was changed:
----- Method: MIMEType class>>standardMIMETypes2 (in category 'class initialization') -----
standardMIMETypes2
"MIMEType standardMimeTypes2"
"We had to split this method because of the 256 literal limit in methods."
| mimeTypes |
+ mimeTypes := Dictionary new: 100.
- mimeTypes _ Dictionary new: 100.
mimeTypes
at: 'nc' put: #('application/x-netcdf');
at: 'shar' put: #('application/x-shar');
at: 'pgp' put: #('application/x-pgp-plugin');
at: 'texi' put: #('application/x-texinfo');
at: 'z' put: #('application/x-compress');
at: 'aiff' put: #('audio/aiff' 'audio/x-aiff');
at: 'bin' put: #('application/octet-stream');
at: 'pwz' put: #('application/vnd.ms-powerpoint');
at: 'rtc' put: #('application/rtc');
at: 'asx' put: #('video/x-ms-asf');
at: 'ief' put: #('image/ief');
at: 'ps' put: #('application/postscript');
at: 'xls' put: #('application/vnd.ms-excel');
at: 'vrml' put: #('model/vrml');
at: 'jpeg' put: #('image/jpeg');
at: 'dwg' put: #('image/vnd');
at: 'dms' put: #('application/octet-stream');
at: 'tif' put: #('image/tiff');
at: 'roff' put: #('application/x-troff');
at: 'midi' put: #('audio/midi');
at: 'eps' put: #('application/postscript');
at: 'man' put: #('application/x-troff-man');
at: 'sv4cpio' put: #('application/x-sv4cpio');
at: 'tr' put: #('application/x-troff');
at: 'dxf' put: #('image/vnd');
at: 'rtf' put: #('text/rtf' 'application/rtf');
at: 'frl' put: #('application/freeloader');
at: 'xlb' put: #('application/vnd.ms-excel');
at: 'pl' put: #('text/plain');
at: 'snd' put: #('audio/basic');
at: 'texinfo' put: #('application/x-texinfo');
at: 'tbk' put: #('application/toolbook');
at: 'ppm' put: #('image/x-portable-pixmap');
at: 'cht' put: #('audio/x-dspeech');
at: 'bmp' put: #('image/bmp');
at: 'vgm' put: #('video/x-videogram');
at: 'fh5' put: #('image/x-freehand');
at: 'src' put: #('application/x-wais-source');
at: 'm4' put: #('audio/x-mp4-audio');
at: 'm4b' put: #('audio/x-quicktime-protected-b');
at: 'm4p' put: #('audio/x-quicktime-protected');
at: 'mp4v' put: #('video/x-mp4-video');
at: 'm4v' put: #('video/x-mp4-video');
at: 'mp4' put: #('video/x-mp4-video');
at: 'wma' put: #('audio/x-ms-wma');
at: 'wmv' put: #('video/x-ms-wmv');
at: 'wm' put: #('video/x-ms-wm');
at: 'png' put: #('image/png');
yourself.
^mimeTypes
!
Item was changed:
----- Method: MIMEType>>main: (in category 'accessing') -----
main: mainType
+ main := mainType!
- main _ mainType!
Item was changed:
----- Method: MIMEType>>sub: (in category 'accessing') -----
sub: subType
+ sub := subType!
- sub _ subType!
Item was changed:
----- Method: MVCWiWPasteUpMorph>>position: (in category 'geometry') -----
position: aPoint
"Change the position of this morph and and all of its submorphs."
| delta |
+ delta := aPoint - bounds topLeft.
- delta _ aPoint - bounds topLeft.
(delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change"
self changed.
self privateFullMoveBy: delta.
self changed.
!
Item was changed:
----- Method: MVCWiWPasteUpMorph>>revertToParentWorldWithEvent: (in category 'activation') -----
revertToParentWorldWithEvent: evt
">>unused, but we may want some of this later
self damageRecorder reset.
+ World := parentWorld.
- World _ parentWorld.
World assuredCanvas.
World installFlaps.
owner changed.
hostWindow setStripeColorsFrom: Color red.
World restartWorldCycleWithEvent: evt.
<<<"
!
Item was changed:
----- Method: MentoringEventRecorder>>addJournalFile (in category 'initialization') -----
addJournalFile
"In case there is a chance of not regaining control to stop recording and save a file, the EventRecorder can write directly to file as it is recording. This is useful for capturing a sequence that results in a nasty crash."
journalFile ifNotNil: [journalFile close].
+ journalFile := FileStream newFileNamed: (FileDirectory default nextNameFor: 'EventRecorder' extension: 'tape').
- journalFile _ FileStream newFileNamed: (FileDirectory default nextNameFor: 'EventRecorder' extension: 'tape').
journalFile nextPutAll:'Event Tape v1 ASCII'; cr.!
Item was changed:
----- Method: MentoringEventRecorder>>addVoiceControls (in category 'sound') -----
addVoiceControls
"Add voice capabililty by allocating a sound recorder."
+ voiceRecorder := SoundRecorder new
- voiceRecorder _ SoundRecorder new
desiredSampleRate: 11025.0; "<==try real hard to get the low rate"
codec: (GSMCodec new). "<--this should compress better than ADPCM.. is it too slow?"
"codec: (ADPCMCodec new initializeForBitsPerSample: 4 samplesPerFrame: 0)."
+ recordMeter := Morph new extent: 1 at 16; color: Color yellow.
- recordMeter _ Morph new extent: 1 at 16; color: Color yellow.
!
Item was changed:
----- Method: MentoringEventRecorder>>handleEscape (in category 'commands') -----
handleEscape
"The user hit esc to stop recording or playback, so stop."
| interimTape unmatchedMouseDown upEvent |
tapeStream ifNotNil:
[(#(recording recordingWithSound) includes: self state ) ifTrue:
[interimTape := tapeStream contents.
unmatchedMouseDown := nil.
interimTape reversed detect:
[:evt |
evt eventType = #mouseDown
ifTrue:
[unmatchedMouseDown := evt.
true]
ifFalse:
[evt eventType = #mouseUp]]
ifNone:
[nil].
unmatchedMouseDown ifNotNil:
["synthesize a matching up-event"
upEvent := unmatchedMouseDown veryDeepCopy.
upEvent timeStamp: Time millisecondClockValue.
upEvent setType: #mouseUp.
tapeStream nextPut: upEvent].
+ tape := tapeStream contents.
+ saved := false]].
- tape _ tapeStream contents.
- saved _ false]].
self pauseIn: self world.
+ tapeStream := nil.
- tapeStream _ nil.
recordMeter ifNotNil: [recordMeter width: 1].
recordingSpace escapeHitInEventRecorder!
Item was changed:
----- Method: MentoringEventRecorder>>handleListenEvent: (in category 'events-processing') -----
handleListenEvent: anEvent
"Process a listen event."
anEvent hand == recHand ifFalse: [^ self]. "not for me"
(#(recording recordingWithSound) includes: self state) ifFalse:
["If user got an error while recording and deleted recorder, will still be listening"
recHand ifNotNil: [recHand removeEventListener: self].
^ self].
anEvent = lastEvent ifTrue: [^ self].
(anEvent isKeyboard and: [anEvent keyValue = 27 "esc"])
ifTrue: [^ self handleEscape].
+ time := anEvent timeStamp.
- time _ anEvent timeStamp.
tapeStream ifNotNil:
[tapeStream nextPut: (anEvent copy setHand: nil)].
+ lastEvent := anEvent!
- lastEvent _ anEvent!
Item was changed:
----- Method: MentoringEventRecorder>>millisecondsIntoPlayback: (in category 'accessing') -----
millisecondsIntoPlayback: anObject
"Set the value of millisecondsIntoPlayback"
+ millisecondsIntoPlayback := anObject!
- millisecondsIntoPlayback _ anObject!
Item was changed:
----- Method: MentoringEventRecorder>>nextEventToPlay (in category 'event handling') -----
nextEventToPlay
"Return the next event when it is time to be replayed.
If it is not yet time, then return an interpolated mouseMove.
Return nil if nothing has happened.
Return an EOF event if there are no more events to be played."
| nextEvent now nextTime lastP delta |
(tapeStream isNil or:[tapeStream atEnd])
ifTrue:[^MorphicUnknownEvent new setType: #EOF argument: nil].
+ now := Time millisecondClockValue.
+ nextEvent := tapeStream next clone. "always copied"
- now _ Time millisecondClockValue.
- nextEvent _ tapeStream next clone. "always copied"
areaOffset ifNotNil: [nextEvent isMouse ifTrue:
[nextEvent position: nextEvent position + areaOffset]].
nextEvent isKeyboard ifTrue: [ nextEvent setPosition: areaBounds center].
nextEvent type == #noCondense ifTrue: [^nil]. "ignore in playback"
+ deltaTime ifNil:[deltaTime := now - nextEvent timeStamp].
+ nextTime := nextEvent timeStamp + deltaTime.
- deltaTime ifNil:[deltaTime _ now - nextEvent timeStamp].
- nextTime _ nextEvent timeStamp + deltaTime.
now < time ifTrue:["clock rollover"
+ time := now.
+ deltaTime := nil.
- time _ now.
- deltaTime _ nil.
^nil "continue it on next cycle"].
+ time := now.
- time _ now.
(now >= nextTime) ifTrue:[
nextEvent setTimeStamp: nextTime.
+ nextEvent isMouse ifTrue:[lastEvent := nextEvent] ifFalse:[lastEvent := nil].
- nextEvent isMouse ifTrue:[lastEvent _ nextEvent] ifFalse:[lastEvent _ nil].
^nextEvent].
tapeStream skip: -1.
"Not time for the next event yet, but interpolate the mouse.
This allows tapes to be compressed when velocity is fairly constant."
lastEvent ifNil: [^ nil].
now - lastInterpolation < 20 "WorldState minCycleLapse" ifTrue: [^ nil].
+ lastP := lastEvent position.
+ delta := (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp).
- lastP _ lastEvent position.
- delta _ (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp).
(delta dist: lastDelta) < 3 ifTrue: [^ nil]. "Almost no movement"
+ lastDelta := delta.
+ lastInterpolation := now.
- lastDelta _ delta.
- lastInterpolation _ now.
^ MouseMoveEvent new
setType: #mouseMove
startPoint: lastEvent position endPoint: lastP + delta
trail: nil buttons: lastEvent buttons hand: nil stamp: now.!
Item was changed:
----- Method: MentoringEventRecorder>>noteAreaBounds (in category 'commands') -----
noteAreaBounds
"Note the bounds of the content area"
+ areaBounds := recordingSpace contentArea bounds
- areaBounds _ recordingSpace contentArea bounds
!
Item was changed:
----- Method: MentoringEventRecorder>>pauseIn: (in category 'pause/resume') -----
pauseIn: aWorld
"Suspend -- a stop command, typically because an EOF event was found on the event tape being played."
(#(recordingWithSound playbackAddingVoiceover) includes: self state) ifTrue:
[self terminateVoiceRecording.
self state: #atEndOfPlayback.
recHand ifNotNil: [recHand removeEventListener: self].
+ recHand := nil.].
- recHand _ nil.].
(#(playback) includes: self state) ifTrue:
[self state: #suspendedPlay.
playHand ifNotNil:
[playHand halo ifNotNil: [playHand halo delete].
playHand delete].
aWorld removeHand: playHand.
self removeProperty: #suspendedContentArea.
+ playHand := nil.
- playHand _ nil.
recordingSpace playingEnded]
!
Item was changed:
----- Method: MentoringEventRecorder>>play (in category 'commands') -----
play
"Play the movie, as it were."
tape ifNil: [^ self].
+ tapeStream := ReadStream on: tape.
- tapeStream _ ReadStream on: tape.
self resumePlayIn: ActiveWorld
!
Item was changed:
----- Method: MentoringEventRecorder>>readTape (in category 'fileIn/Out') -----
readTape
"Put up a prompt for reading an event tape; if one is provided, read it."
| aFileStream |
+ aFileStream := (FileList2 modalFileSelectorForSuffixes: #('tape' )) .
- aFileStream _ (FileList2 modalFileSelectorForSuffixes: #('tape' )) .
aFileStream ifNotNil: [self readTapeFrom: aFileStream]!
Item was changed:
----- Method: MentoringEventRecorder>>readTape: (in category 'fileIn/Out') -----
readTape: fileName
"Read an event tape from the given file-name. Answer nil if no such file."
| file |
(fileName = '') ifTrue: [^ nil].
"Note that for some reason, (FileStream isAFileNamed: '') always returns true."
self writeCheck.
(FileStream isAFileNamed: fileName) ifFalse: [^ nil].
+ file := FileStream oldFileNamed: fileName.
+ tape := self readFrom: file.
- file _ FileStream oldFileNamed: fileName.
- tape _ self readFrom: file.
file close.
+ saved := true "Still exists on file"!
- saved _ true "Still exists on file"!
Item was changed:
----- Method: MentoringEventRecorder>>readTapeFrom: (in category 'fileIn/Out') -----
readTapeFrom: aFileStream
"Read in the tape from the fileStream provided."
+ tape := self readFrom: aFileStream.
- tape _ self readFrom: aFileStream.
aFileStream close.
+ saved := true "Still exists on file"!
- saved _ true "Still exists on file"!
Item was changed:
----- Method: MentoringEventRecorder>>record (in category 'commands') -----
record
"Commence recording or re-recording."
+ tapeStream := WriteStream on: (Array new: 10000).
- tapeStream _ WriteStream on: (Array new: 10000).
self resumeRecordIn: ActiveWorld
!
Item was changed:
----- Method: MentoringEventRecorder>>recordingSpace: (in category 'accessing') -----
recordingSpace: anObject
"Set the value of recordingSpace"
+ recordingSpace := anObject!
- recordingSpace _ anObject!
Item was changed:
----- Method: MentoringEventRecorder>>resumePlayIn: (in category 'pause/resume') -----
resumePlayIn: aWorld
"Playback"
| anEvent aPosition |
recordingSpace abandonReplayHandsAndHalos.
self flag: #deferred. "I guess it's the above line that messes up the nesting of these guys..."
self state: #playback.
recordingSpace populateControlsPanel.
aWorld doOneCycle.
+ playHand := HandMorphForReplay new recorder: self.
- playHand _ HandMorphForReplay new recorder: self.
[((anEvent := tapeStream next) notNil and: [(anEvent isKindOf: UserInputEvent) not])]
whileTrue: [].
aPosition := anEvent
ifNil:
[recordingSpace contentArea center]
ifNotNil:
[anEvent position].
tapeStream reset.
playHand position: aPosition + recordingSpace areaOffset.
aWorld addHand: playHand.
playHand newKeyboardFocus: aWorld.
playHand userInitials: 'play' andPicture: nil.
+ lastEvent := nil.
+ lastDelta := 0 at 0.
- lastEvent _ nil.
- lastDelta _ 0 at 0.
startPlaybackTime := Time millisecondClockValue.
millisecondsIntoPlayback := 0.
self findPlayOffset.
self synchronize
!
Item was changed:
----- Method: MentoringEventRecorder>>resumePlayingWithoutPassingStop (in category 'commands') -----
resumePlayingWithoutPassingStop
"Like play, but avoids the stop step that does more than we'd like."
+ tapeStream := ReadStream on: tape.
- tapeStream _ ReadStream on: tape.
self resumePlayIn: ActiveWorld
!
Item was changed:
----- Method: MentoringEventRecorder>>resumeRecordIn: (in category 'pause/resume') -----
resumeRecordIn: aWorld
"Start recording, actually."
| anEvent |
+ recHand := aWorld activeHand ifNil: [aWorld primaryHand].
- recHand _ aWorld activeHand ifNil: [aWorld primaryHand].
recHand newKeyboardFocus: aWorld.
recHand addEventListener: self.
+ lastEvent := nil.
- lastEvent _ nil.
self state: #recording.
anEvent := MorphicUnknownEvent new setType: #noteTheatreBounds argument: recordingSpace initialContentArea bounds copy hand: nil stamp: Time millisecondClockValue.
tapeStream nextPut: anEvent.
self synchronize.
!
Item was changed:
----- Method: MentoringEventRecorder>>startRecordingNewSound (in category 'pause/resume') -----
startRecordingNewSound
"Commence the recording of a new sound by way of voiceover."
+ startSoundEvent := MediaPlayEvent new setType: #startSound argument: nil hand: nil stamp: (Time millisecondClockValue - startPlaybackTime).
- startSoundEvent _ MediaPlayEvent new setType: #startSound argument: nil hand: nil stamp: (Time millisecondClockValue - startPlaybackTime).
self state = #recordingWithSound
ifTrue:
[tapeStream nextPut: startSoundEvent].
"If not, then we're recording after-the-fact voiceover; in this case, we hold on to the new event and later on when the sound is complete we merge the event into the tape stream at the appropriate place."
voiceRecorder clearRecordedSound.
voiceRecorder resumeRecording!
Item was changed:
----- Method: MentoringEventRecorder>>stop (in category 'commands') -----
stop
"Stop recording or playing."
tapeStream ifNotNil:
[(#(recording recordingWithSound) includes: self state) ifTrue:
+ [tape := tapeStream contents.
+ saved := false]].
- [tape _ tapeStream contents.
- saved _ false]].
self terminateVoiceRecording. "In case doing"
journalFile ifNotNil:
[journalFile close].
self pauseIn: ActiveWorld.
+ tapeStream := nil.
- tapeStream _ nil.
self state: #atEndOfPlayback.
recordingSpace abandonReplayHandsAndHalos.
recordMeter ifNotNil: [recordMeter width: 1].
!
Item was changed:
----- Method: MentoringEventRecorder>>writeTape (in category 'fileIn/Out') -----
writeTape
"Write the tape."
| args bb aFileName |
+ bb := self findDeepSubmorphThat: [:mm | (mm isKindOf: SimpleButtonMorph)
- bb _ self findDeepSubmorphThat: [:mm | (mm isKindOf: SimpleButtonMorph)
and: [mm label = 'writeTape']]
ifAbsent: [nil].
args := bb ifNil: [#()] ifNotNil: [bb arguments].
(args notEmpty and: [args first notEmpty])
ifTrue:
[args first.
self writeTape: args first]
ifFalse:
[aFileName := self fileNameForTape.
self writeTape: aFileName].!
Item was changed:
----- Method: MenuItemMorph>>drawExtraIconOn:forStringBounds: (in category '*Etoys-Squeakland-drawing') -----
drawExtraIconOn: aCanvas forStringBounds: stringBounds
| ratio drawnIcon map |
self extraIcon ifNil: [^ self].
+ drawnIcon := self extraIcon deepCopy.
- drawnIcon _ self extraIcon deepCopy.
(isSelected & isEnabled) ifTrue: [
+ map := (Color cachedColormapFrom: self extraIcon depth to: self extraIcon depth) copy.
- map _ (Color cachedColormapFrom: self extraIcon depth to: self extraIcon depth) copy.
map at: (Color transparent indexInMap: map) put: (Color black pixelWordForDepth: self extraIcon depth).
map at: (Color black indexInMap: map) put: (Color white pixelWordForDepth: self extraIcon depth).
(BitBlt current toForm: drawnIcon)
sourceForm: self extraIcon;
sourceOrigin: 0 at 0;
combinationRule: Form over;
destX: 0 destY: 0 width: self extraIcon width height: self extraIcon height;
colorMap: map;
copyBits.
].
+ ratio := stringBounds height / drawnIcon height asFloat.
+ drawnIcon := drawnIcon magnifyBy: ratio.
- ratio _ stringBounds height / drawnIcon height asFloat.
- drawnIcon _ drawnIcon magnifyBy: ratio.
aCanvas paintImage: drawnIcon at: stringBounds topRight.
!
Item was changed:
----- Method: MenuMorph>>addUpdating:target:selector:argumentList:extraIcon: (in category '*Etoys-Squeakland-construction') -----
addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList extraIcon: extIcon
"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added."
| item |
+ item := UpdatingMenuItemMorph new
- item _ UpdatingMenuItemMorph new
target: target;
selector: aSymbol;
wordingProvider: target wordingSelector: wordingSelector;
arguments: argList asArray.
self addMorphBack: item.
item extraIcon: extIcon.
^ item
!
Item was changed:
----- Method: MessageNames>>inMorphicWindowWithInitialSearchString: (in category '*Etoys-Squeakland-initialization') -----
inMorphicWindowWithInitialSearchString: initialString
"Answer a morphic window with the given initial search string, nil if none"
"MessageNames openMessageNames"
| window selectorListView firstDivider secondDivider horizDivider typeInPane searchButton plugTextMor |
+ window := (SystemWindow labelled: 'Message Names') model: self.
+ firstDivider := 0.1.
+ secondDivider := 0.5.
+ horizDivider := 0.5.
+ typeInPane := AlignmentMorph newRow vResizing: #spaceFill; height: 14.
- window _ (SystemWindow labelled: 'Message Names') model: self.
- firstDivider _ 0.1.
- secondDivider _ 0.5.
- horizDivider _ 0.5.
- typeInPane _ AlignmentMorph newRow vResizing: #spaceFill; height: 14.
typeInPane hResizing: #spaceFill.
typeInPane listDirection: #leftToRight.
+ plugTextMor := PluggableTextMorph on: self
- plugTextMor _ PluggableTextMorph on: self
text: #searchString accept: #searchString:notifying:
readSelection: nil menu: #codePaneMenu:shifted:.
plugTextMor setProperty: #alwaysAccept toValue: true.
plugTextMor askBeforeDiscardingEdits: false.
plugTextMor acceptOnCR: true.
plugTextMor setTextColor: Color brown.
plugTextMor setNameTo: 'Search'.
plugTextMor vResizing: #spaceFill; hResizing: #spaceFill.
plugTextMor hideScrollBarsIndefinitely.
plugTextMor setTextMorphToSelectAllOnMouseEnter.
+ searchButton := SimpleButtonMorph new
- searchButton _ SimpleButtonMorph new
target: self;
beTransparent;
label: 'Search';
actionSelector: #doSearchFrom:;
arguments: {plugTextMor}.
searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'.
typeInPane addMorphFront: searchButton.
typeInPane addTransparentSpacerOfSize: 6 at 0.
typeInPane addMorphBack: plugTextMor.
initialString isEmptyOrNil ifFalse:
[plugTextMor setText: initialString].
window addMorph: typeInPane frame: (0 at 0 corner: horizDivider @ firstDivider).
+ selectorListView := PluggableListMorph on: self
- selectorListView _ PluggableListMorph on: self
list: #selectorList
selected: #selectorListIndex
changeSelected: #selectorListIndex:
menu: #selectorListMenu:
keystroke: #selectorListKey:from:.
selectorListView menuTitleSelector: #selectorListMenuTitle.
window addMorph: selectorListView frame: (0 @ firstDivider corner: horizDivider @ secondDivider).
window addMorph: self buildMorphicMessageList frame: (horizDivider @ 0 corner: 1@ secondDivider).
self
addLowerPanesTo: window
at: (0 @ secondDivider corner: 1 at 1)
with: nil.
initialString isEmptyOrNil ifFalse:
[self searchString: initialString notifying: nil].
^ window!
Item was changed:
----- Method: MessageNode>>getElderSiblingOf: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
getElderSiblingOf: node
| index |
+ ((index := arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
- ((index _ arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
index = 1 ifTrue: [^ selector].
node = selector ifTrue: [^ receiver].
^ nil.
!
Item was changed:
----- Method: MessageNode>>isEToyBinaryExp (in category '*Etoys-Squeakland-etoys-transform') -----
isEToyBinaryExp
| sel |
+ sel := (sel := self selector) isSymbol ifTrue: [sel] ifFalse: [sel key].
- sel _ (sel _ self selector) isSymbol ifTrue: [sel] ifFalse: [sel key].
^ (#(#+ #- #* #/ #\\ #// #max: #min:) includes: sel).
!
Item was changed:
----- Method: MessageNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
| index |
+ childNode = receiver ifTrue: [receiver := newNode. ^ self].
+ childNode = selector ifTrue: [selector := newNode. ^ self].
+ (index := arguments indexOf: childNode) > 0
- childNode = receiver ifTrue: [receiver _ newNode. ^ self].
- childNode = selector ifTrue: [selector _ newNode. ^ self].
- (index _ arguments indexOf: childNode) > 0
ifTrue: [arguments at: index put: newNode. ^ self].
!
Item was changed:
----- Method: MessageNode>>sizeForValue: (in category '*Etoys-Squeakland-code generation') -----
sizeForValue: encoder
| total argSize |
special > 0
ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
receiver == NodeSuper
+ ifTrue: [selector := selector copy "only necess for splOops"].
+ total := selector size: encoder args: arguments size super: receiver == NodeSuper.
- ifTrue: [selector _ selector copy "only necess for splOops"].
- total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
receiver == nil
+ ifFalse: [total := total + (receiver sizeForValue: encoder)].
+ sizes := arguments collect:
- ifFalse: [total _ total + (receiver sizeForValue: encoder)].
- sizes _ arguments collect:
[:arg |
+ argSize := arg sizeForValue: encoder.
+ total := total + argSize.
- argSize _ arg sizeForValue: encoder.
- total _ total + argSize.
argSize].
^total!
Item was changed:
----- Method: MessageNode>>sizeIf:value: (in category '*Etoys-Squeakland-code generation') -----
sizeIf: encoder value: forValue
| thenExpr elseExpr branchSize thenSize elseSize |
+ thenExpr := arguments at: 1.
+ elseExpr := arguments at: 2.
- thenExpr _ arguments at: 1.
- elseExpr _ arguments at: 2.
(forValue
or: [(thenExpr isJust: NodeNil)
or: [elseExpr isJust: NodeNil]]) not
"(...not ifTrue: avoids using ifFalse: alone during this compile)"
ifTrue: "Two-armed IFs forEffect share a single pop"
[^ super sizeForEffect: encoder].
forValue
ifTrue: "Code all forValue as two-armed"
+ [elseSize := elseExpr sizeForEvaluatedValue: encoder.
+ thenSize := (thenExpr sizeForEvaluatedValue: encoder)
- [elseSize _ elseExpr sizeForEvaluatedValue: encoder.
- thenSize _ (thenExpr sizeForEvaluatedValue: encoder)
+ (thenExpr returns
ifTrue: [0] "Elide jump over else after a return"
ifFalse: [self sizeJump: elseSize]).
+ branchSize := self sizeBranchOn: false dist: thenSize]
- branchSize _ self sizeBranchOn: false dist: thenSize]
ifFalse: "One arm is empty here (two-arms code forValue)"
[(elseExpr isJust: NodeNil)
ifTrue:
+ [elseSize := 0.
+ thenSize := thenExpr sizeForEvaluatedEffect: encoder.
+ branchSize := self sizeBranchOn: false dist: thenSize]
- [elseSize _ 0.
- thenSize _ thenExpr sizeForEvaluatedEffect: encoder.
- branchSize _ self sizeBranchOn: false dist: thenSize]
ifFalse:
+ [thenSize := 0.
+ elseSize := elseExpr sizeForEvaluatedEffect: encoder.
+ branchSize := self sizeBranchOn: true dist: elseSize]].
+ sizes := Array with: thenSize with: elseSize.
- [thenSize _ 0.
- elseSize _ elseExpr sizeForEvaluatedEffect: encoder.
- branchSize _ self sizeBranchOn: true dist: elseSize]].
- sizes _ Array with: thenSize with: elseSize.
^ (receiver sizeForValue: encoder) + branchSize
+ thenSize + elseSize!
Item was changed:
----- Method: MessageNode>>sizeToDo:value: (in category '*Etoys-Squeakland-code generation') -----
sizeToDo: encoder value: forValue
+ " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
- " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
| loopSize initStmt test block incStmt blockSize blockVar initSize limitInit |
+ block := arguments at: 3.
+ blockVar := block firstArgument.
+ initStmt := arguments at: 4.
+ test := arguments at: 5.
+ incStmt := arguments at: 6.
+ limitInit := arguments at: 7.
+ initSize := initStmt sizeForEffect: encoder.
- block _ arguments at: 3.
- blockVar _ block firstArgument.
- initStmt _ arguments at: 4.
- test _ arguments at: 5.
- incStmt _ arguments at: 6.
- limitInit _ arguments at: 7.
- initSize _ initStmt sizeForEffect: encoder.
limitInit == nil
+ ifFalse: [initSize := initSize + (limitInit sizeForEffect: encoder)].
+ blockSize := (block sizeForEvaluatedEffect: encoder)
- ifFalse: [initSize _ initSize + (limitInit sizeForEffect: encoder)].
- blockSize _ (block sizeForEvaluatedEffect: encoder)
+ (incStmt sizeForEffect: encoder) + 2. "+2 for Jmp backward"
+ loopSize := (test sizeForValue: encoder)
- loopSize _ (test sizeForValue: encoder)
+ (self sizeBranchOn: false dist: blockSize)
+ blockSize.
+ sizes := Array with: blockSize with: loopSize.
- sizes _ Array with: blockSize with: loopSize.
^ initSize + loopSize
+ (forValue ifTrue: [1] ifFalse: [0]) " +1 for value (push nil) "!
Item was changed:
----- Method: MessageNode>>sizeWhile:value: (in category '*Etoys-Squeakland-code generation') -----
sizeWhile: encoder value: forValue
"L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only);
justStmt, wholeLoop, justJump."
| cond stmt stmtSize loopSize branchSize |
+ cond := receiver.
+ stmt := arguments at: 1.
+ stmtSize := (stmt sizeForEvaluatedEffect: encoder) + 2.
+ branchSize := self sizeBranchOn: (selector key == #whileFalse:) "Btp for whileFalse"
- cond _ receiver.
- stmt _ arguments at: 1.
- stmtSize _ (stmt sizeForEvaluatedEffect: encoder) + 2.
- branchSize _ self sizeBranchOn: (selector key == #whileFalse:) "Btp for whileFalse"
dist: stmtSize.
+ loopSize := (cond sizeForEvaluatedValue: encoder)
- loopSize _ (cond sizeForEvaluatedValue: encoder)
+ branchSize + stmtSize.
+ sizes := Array with: stmtSize with: loopSize.
- sizes _ Array with: stmtSize with: loopSize.
^ loopSize " +1 for value (push nil) "
+ (forValue ifTrue: [1] ifFalse: [0])!
Item was changed:
----- Method: MethodHolder>>contents:notifying:forInstance: (in category '*Etoys-Squeakland-contents') -----
contents: input notifying: aController forInstance: aPlayer
| selector |
+ (selector := Parser new parseSelector: input asText) ifNil:
- (selector _ Parser new parseSelector: input asText) ifNil:
[self inform: 'Sorry - invalid format for the
method name and arguments -- cannot accept.'.
^ false].
selector == methodSelector ifFalse:
[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
^ false].
+ selector := methodClass
- selector _ methodClass
compileSilently: input asText
classified: self selectedMessageCategoryName
notifying: aController
for: aPlayer.
selector == nil ifTrue: [^ false].
+ contents := input asString copy.
+ currentCompiledMethod := methodClass compiledMethodAt: methodSelector.
- contents _ input asString copy.
- currentCompiledMethod _ methodClass compiledMethodAt: methodSelector.
^ true!
Item was changed:
----- Method: MethodNode>>getElderSiblingOf: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
getElderSiblingOf: node
| index |
temporaries ifNotNil: [
+ ((index := temporaries indexOf: node) > 1) ifTrue: [^ temporaries at: index - 1].
- ((index _ temporaries indexOf: node) > 1) ifTrue: [^ temporaries at: index - 1].
index = 1 ifTrue: [^ block].
].
node = block ifTrue: [
arguments size > 0 ifTrue: [^ arguments last].
].
+ ((index := arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
- ((index _ arguments indexOf: node) > 1) ifTrue: [^ arguments at: index - 1].
^ nil.
!
Item was changed:
----- Method: MethodNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
| index |
+ (index := arguments indexOf: childNode) > 0
- (index _ arguments indexOf: childNode) > 0
ifTrue: [arguments at: index put: newNode. ^ self].
+ childNode = block ifTrue: [block := newNode. ^ self].
- childNode = block ifTrue: [block _ newNode. ^ self].
temporaries ifNotNil: [
+ (index := temporaries indexOf: childNode) > 0
- (index _ temporaries indexOf: childNode) > 0
ifTrue: [temporaries at: index put: newNode. ^ self].
].
!
Item was changed:
----- Method: MethodNode>>sourceMap (in category '*Etoys-Squeakland-code generation') -----
sourceMap
"Answer a SortedCollection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text."
| methNode |
+ methNode := self.
- methNode _ self.
sourceText ifNil: [
"No source, use decompile string as source to map from"
+ methNode := self parserClass new
- methNode _ self parserClass new
parse: self decompileString
class: self methodClass
].
methNode generate: CompiledMethodTrailer empty. "set bytecodes to map to"
^ methNode encoder sourceMap!
Item was changed:
----- Method: MethodWithInterface>>renameScript:fromPlayer: (in category 'rename') -----
renameScript: newSelector fromPlayer: aPlayer
"The receiver's selector has changed to the new selector. Get various things right, including the physical appearance of any Scriptor open on this method"
self allScriptEditors do:
[:aScriptEditor | aScriptEditor renameScriptTo: newSelector].
(selector numArgs = 0 and: [newSelector numArgs = 1])
ifTrue:
[self argumentVariables: (OrderedCollection with:
(Variable new name: #parameter type: #Number))].
(selector numArgs = 1 and: [newSelector numArgs = 0])
ifTrue:
[self argumentVariables: OrderedCollection new].
+ selector := newSelector asSymbol.
- selector _ newSelector asSymbol.
self bringUpToDate.
self playerClass atSelector: selector putScript: self.
self allScriptGoverningButtons do:
[:aButton | aButton bringUpToDate].
!
Item was changed:
----- Method: MidiInputMorph>>addChannel (in category 'as yet unclassified') -----
addChannel
"Add a set of controls for another channel. Prompt the user for the channel number."
| menu existingChannels newChannel |
+ menu := CustomMenu new.
+ existingChannels := Set new.
- menu _ CustomMenu new.
- existingChannels _ Set new.
1 to: 16 do: [:ch | (instrumentSelector at: ch) ifNotNil: [existingChannels add: ch]].
1 to: 16 do: [:ch |
(existingChannels includes: ch) ifFalse: [
menu add: ch printString action: ch]].
+ newChannel := menu startUp.
- newChannel _ menu startUp.
newChannel ifNotNil: [self addChannelControlsFor: newChannel].
!
Item was changed:
----- Method: MidiInputMorph>>addChannelControlsFor: (in category 'as yet unclassified') -----
addChannelControlsFor: channelIndex
| r divider col |
+ r := self makeRow
- r _ self makeRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap.
r addMorphBack: (self channelNumAndMuteButtonFor: channelIndex).
r addMorphBack: (Morph new extent: 10 at 5; color: color). "spacer"
r addMorphBack: (self panAndVolControlsFor: channelIndex).
+ divider := AlignmentMorph new
- divider _ AlignmentMorph new
extent: 10 at 1;
borderWidth: 1;
layoutInset: 0;
borderColor: #raised;
color: color;
hResizing: #spaceFill;
vResizing: #rigid.
+ col := self lastSubmorph.
- col _ self lastSubmorph.
col addMorphBack: divider.
col addMorphBack: r.
!
Item was changed:
----- Method: MidiInputMorph>>channelNumAndMuteButtonFor: (in category 'as yet unclassified') -----
channelNumAndMuteButtonFor: channelIndex
| muteButton instSelector r |
+ muteButton := SimpleSwitchMorph new
- muteButton _ SimpleSwitchMorph new
onColor: (Color r: 1.0 g: 0.6 b: 0.6);
offColor: color;
color: color;
label: 'Mute';
target: midiSynth;
actionSelector: #mutedForChannel:put:;
arguments: (Array with: channelIndex).
+ instSelector := PopUpChoiceMorph new
- instSelector _ PopUpChoiceMorph new
extent: 95 at 14;
contentsClipped: 'oboe1';
target: self;
actionSelector: #atChannel:from:selectInstrument:;
getItemsSelector: #instrumentChoicesForChannel:;
getItemsArgs: (Array with: channelIndex).
instSelector arguments:
(Array with: channelIndex with: instSelector).
instrumentSelector at: channelIndex put: instSelector.
+ r := self makeRow
- r _ self makeRow
hResizing: #rigid;
vResizing: #spaceFill;
extent: 70 at 10.
r addMorphBack:
(StringMorph
contents: channelIndex printString
font: (TextStyle default fontOfSize: 24)).
channelIndex < 10
ifTrue: [r addMorphBack: (Morph new color: color; extent: 19 at 8)] "spacer"
ifFalse: [r addMorphBack: (Morph new color: color; extent: 8 at 8)]. "spacer"
r addMorphBack: instSelector.
r addMorphBack: (AlignmentMorph newRow color: color). "spacer"
r addMorphBack: muteButton.
^ r
!
Item was changed:
----- Method: MidiInputMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
wrapCentering: #center;
cellPositioning: #topCenter;
hResizing: #spaceFill;
vResizing: #spaceFill;
layoutInset: 3.
+ midiPortNumber := nil.
+ midiSynth := MIDISynth new.
+ instrumentSelector := Array new: 16.
- midiPortNumber _ nil.
- midiSynth _ MIDISynth new.
- instrumentSelector _ Array new: 16.
self removeAllMorphs.
self addMorphBack: self makeControls.
self addMorphBack: (AlignmentMorph newColumn color: color;
layoutInset: 0).
self addChannelControlsFor: 1.
self extent: 20 @ 20!
Item was changed:
----- Method: MidiInputMorph>>instrumentChoicesForChannel: (in category 'as yet unclassified') -----
instrumentChoicesForChannel: channelIndex
| names inst |
+ names := AbstractSound soundNames asOrderedCollection.
+ names := names collect: [:n |
+ inst := AbstractSound soundNamed: n.
- names _ AbstractSound soundNames asOrderedCollection.
- names _ names collect: [:n |
- inst _ AbstractSound soundNamed: n.
(inst isKindOf: UnloadedSound)
ifTrue: [n, '(out)']
ifFalse: [n]].
names add: 'clink'.
names add: 'edit ', (instrumentSelector at: channelIndex) contents.
^ names asArray
!
Item was changed:
----- Method: MidiInputMorph>>invokeMenu (in category 'as yet unclassified') -----
invokeMenu
"Invoke a menu of additonal commands."
| aMenu |
+ aMenu := CustomMenu new.
- aMenu _ CustomMenu new.
aMenu add: 'add channel' translated action: #addChannel.
aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers.
midiSynth isOn ifFalse: [
aMenu add: 'set MIDI port' translated action: #setMIDIPort.
midiSynth midiPort
ifNotNil: [aMenu add: 'close MIDI port' translated action: #closeMIDIPort]].
aMenu invokeOn: self defaultSelection: nil.
!
Item was changed:
----- Method: MidiInputMorph>>makeControls (in category 'as yet unclassified') -----
makeControls
| bb r reverbSwitch onOffSwitch |
+ bb := SimpleButtonMorph new
- bb _ SimpleButtonMorph new
target: self;
borderColor: #raised;
borderWidth: 2;
color: color.
+ r := AlignmentMorph newRow.
- r _ AlignmentMorph newRow.
r color: bb color; borderWidth: 0; layoutInset: 0.
r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 at 5.
r addMorphBack: (
bb label: '<>';
actWhen: #buttonDown;
actionSelector: #invokeMenu).
+ onOffSwitch := SimpleSwitchMorph new
- onOffSwitch _ SimpleSwitchMorph new
offColor: color;
onColor: (Color r: 1.0 g: 0.6 b: 0.6);
borderWidth: 2;
label: 'On';
actionSelector: #toggleOnOff;
target: self;
setSwitchState: false.
r addMorphBack: onOffSwitch.
+ reverbSwitch := SimpleSwitchMorph new
- reverbSwitch _ SimpleSwitchMorph new
offColor: color;
onColor: (Color r: 1.0 g: 0.6 b: 0.6);
borderWidth: 2;
label: 'Reverb Disable';
actionSelector: #disableReverb:;
target: self;
setSwitchState: SoundPlayer isReverbOn not.
r addMorphBack: reverbSwitch.
^ r
!
Item was changed:
----- Method: MidiInputMorph>>panAndVolControlsFor: (in category 'as yet unclassified') -----
panAndVolControlsFor: channelIndex
| volSlider panSlider c r middleLine |
+ volSlider := SimpleSliderMorph new
- volSlider _ SimpleSliderMorph new
color: color;
extent: 101 at 2;
target: midiSynth;
arguments: (Array with: channelIndex);
actionSelector: #volumeForChannel:put:;
minVal: 0.0;
maxVal: 1.0;
adjustToValue: (midiSynth volumeForChannel: channelIndex).
+ panSlider := SimpleSliderMorph new
- panSlider _ SimpleSliderMorph new
color: color;
extent: 101 at 2;
target: midiSynth;
arguments: (Array with: channelIndex);
actionSelector: #panForChannel:put:;
minVal: 0.0;
maxVal: 1.0;
adjustToValue: (midiSynth panForChannel: channelIndex).
+ c := AlignmentMorph newColumn
- c _ AlignmentMorph newColumn
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #spaceFill;
vResizing: #shrinkWrap.
+ middleLine := Morph new "center indicator for pan slider"
- middleLine _ Morph new "center indicator for pan slider"
color: (Color r: 0.4 g: 0.4 b: 0.4);
extent: 1@(panSlider height - 4);
position: panSlider center x@(panSlider top + 2).
panSlider addMorphBack: middleLine.
+ r := self makeRow.
- r _ self makeRow.
r addMorphBack: (StringMorph contents: '0').
r addMorphBack: volSlider.
r addMorphBack: (StringMorph contents: '10').
c addMorphBack: r.
+ r := self makeRow.
- r _ self makeRow.
r addMorphBack: (StringMorph contents: 'L').
r addMorphBack: panSlider.
r addMorphBack: (StringMorph contents: 'R').
c addMorphBack: r.
^ c
!
Item was changed:
----- Method: MidiInputMorph>>setMIDIPort (in category 'as yet unclassified') -----
setMIDIPort
| portNum |
+ portNum := SimpleMIDIPort outputPortNumFromUser.
- portNum _ SimpleMIDIPort outputPortNumFromUser.
portNum ifNil: [^ self].
+ midiPortNumber := portNum.
- midiPortNumber _ portNum.
!
Item was changed:
----- Method: MidiInputMorph>>toggleOnOff (in category 'as yet unclassified') -----
toggleOnOff
midiSynth isOn
ifTrue: [
midiSynth stopMIDITracking]
ifFalse: [
midiPortNumber ifNil: [self setMIDIPort].
+ midiPortNumber ifNil: [midiPortNumber := 0].
- midiPortNumber ifNil: [midiPortNumber _ 0].
midiSynth midiPort: (SimpleMIDIPort openOnPortNumber: midiPortNumber).
midiSynth startMIDITracking].
!
Item was changed:
----- Method: MidiInputMorph>>updateInstrumentsFromLibraryExcept: (in category 'as yet unclassified') -----
updateInstrumentsFromLibraryExcept: soundsBeingEdited
"The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."
"soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor). If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."
| unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
+ unloadPostfix := '(out)'.
+ myInstruments := Dictionary new.
- unloadPostfix _ '(out)'.
- myInstruments _ Dictionary new.
1 to: instrumentSelector size do: [:i |
+ name := (instrumentSelector at: i) contents.
+ displaysAsUnloaded := name endsWith: unloadPostfix.
- name _ (instrumentSelector at: i) contents.
- displaysAsUnloaded _ name endsWith: unloadPostfix.
displaysAsUnloaded ifTrue: [
+ name := name copyFrom: 1 to: name size - unloadPostfix size].
- name _ name copyFrom: 1 to: name size - unloadPostfix size].
(myInstruments includesKey: name) ifFalse: [
myInstruments at: name put:
(name = 'clink'
ifTrue: [
(SampledSound
samples: SampledSound coffeeCupClink
samplingRate: 11025) copy]
ifFalse: [
(AbstractSound
soundNamed: name
ifAbsent: [
(instrumentSelector at: i) contentsClipped: 'default'.
FMSound default]) copy])].
(soundsBeingEdited includes: (midiSynth instrumentForChannel: i)) ifFalse:
["Do not update any instrument that is currently being edited"
midiSynth instrumentForChannel: i put: (myInstruments at: name)].
"update loaded/unloaded status in instrumentSelector if necessary"
+ isUnloaded := (myInstruments at: name) isKindOf: UnloadedSound.
- isUnloaded _ (myInstruments at: name) isKindOf: UnloadedSound.
(displaysAsUnloaded and: [isUnloaded not])
ifTrue: [(instrumentSelector at: i) contentsClipped: name].
(displaysAsUnloaded not and: [isUnloaded])
ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
!
Item was changed:
----- Method: Mines>>board (in category 'access') -----
board
board ifNil:
+ [board := MinesBoard new
- [board _ MinesBoard new
target: self;
actionSelector: #selection].
^ board!
Item was changed:
----- Method: Mines>>buildButton:target:label:selector: (in category 'initialize') -----
buildButton: aButton target: aTarget label: aLabel selector: aSelector
"wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
| a |
aButton
target: aTarget;
label: aLabel;
actionSelector: aSelector;
borderColor: #raised;
borderWidth: 2;
color: color.
+ a := AlignmentMorph newColumn
- a _ AlignmentMorph newColumn
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #spaceFill;
vResizing: #shrinkWrap;
color: color.
a addMorph: aButton.
^ a
!
Item was changed:
----- Method: Mines>>helpText (in category 'access') -----
helpText
helpText ifNil:
+ [helpText := PluggableTextMorph new
- [helpText _ PluggableTextMorph new
width: self width; "board width;"
editString: self helpString].
^ helpText!
Item was changed:
----- Method: Mines>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
wrapCentering: #center;
cellPositioning: #topCenter;
vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
layoutInset: 3;
addMorph: self makeControls;
addMorph: self board.
+ helpText := nil.
- helpText _ nil.
self newGame!
Item was changed:
----- Method: Mines>>wrapPanel:label: (in category 'initialize') -----
wrapPanel: anLedPanel label: aLabel
"wrap an LED panel in an alignmentMorph with a label to its left"
| a |
+ a := AlignmentMorph newRow
- a _ AlignmentMorph newRow
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 0;
layoutInset: 3;
color: color lighter.
a addMorph: anLedPanel.
a addMorph: (StringMorph contents: aLabel).
^ a
!
Item was changed:
----- Method: MinesBoard>>actionSelector: (in category 'accessing') -----
actionSelector: aSymbolOrString
(nil = aSymbolOrString or:
['nil' = aSymbolOrString or:
[aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
- ifTrue: [^ actionSelector _ nil].
+ actionSelector := aSymbolOrString asSymbol.
- actionSelector _ aSymbolOrString asSymbol.
!
Item was changed:
----- Method: MinesBoard>>adjustTiles (in category 'accessing') -----
adjustTiles
"reset tiles"
| newSubmorphs count r c |
submorphs do: "clear out all of the tiles."
[:m | m privateOwner: nil].
+ newSubmorphs := OrderedCollection new.
- newSubmorphs _ OrderedCollection new.
+ r := 0.
+ c := 0.
+ count := columns * rows.
- r _ 0.
- c _ 0.
- count _ columns * rows.
1 to: count do:
[:m |
newSubmorphs add:
(protoTile copy
position: self position + (self protoTile extent * (c @ r));
actionSelector: #tileClickedAt:newSelection:modifier:;
arguments: (Array with: (c+1) @ (r+1));
target: self;
privateOwner: self).
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]].
+ submorphs := newSubmorphs asArray.
- c _ c + 1.
- c >= columns ifTrue: [c _ 0. r _ r + 1]].
- submorphs _ newSubmorphs asArray.
!
Item was changed:
----- Method: MinesBoard>>blowUp (in category 'actions') -----
blowUp
owner timeDisplay stop.
self submorphsDo:
[:m |
m isMine ifTrue:
[m switchState: true.].
].
+ flashCount := 2.
+ gameOver := true.!
- flashCount _ 2.
- gameOver _ true.!
Item was changed:
----- Method: MinesBoard>>clearMines: (in category 'actions') -----
clearMines: location
| al tile |
(self countFlags: location) = (self findMines: location) ifTrue:
[
{-1@ -1. -1 at 0. -1 at 1. 0 at 1. 1 at 1. 1 at 0. 1@ -1. 0@ -1} do:
[:offsetPoint |
+ al := location + offsetPoint.
- al _ location + offsetPoint.
((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue: [
+ tile := self tileAt: al.
- tile _ self tileAt: al.
(tile mineFlag or: [tile switchState]) ifFalse:[
self stepOnTile: al].].].
].!
Item was changed:
----- Method: MinesBoard>>countFlags: (in category 'actions') -----
countFlags: location
| al at flags |
+ flags := 0.
- flags _ 0.
{-1@ -1. -1 at 0. -1 at 1. 0 at 1. 1 at 1. 1 at 0. 1@ -1. 0@ -1} do:
[:offsetPoint |
+ al := location + offsetPoint.
- al _ location + offsetPoint.
((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
- [at _ self tileAt: al.
(at mineFlag ) ifTrue:
+ [flags := flags+1]]].
- [flags _ flags+1]]].
^flags.!
Item was changed:
----- Method: MinesBoard>>findMines: (in category 'actions') -----
findMines: location
| al at mines |
+ mines := 0.
- mines _ 0.
{-1@ -1. -1 at 0. -1 at 1. 0 at 1. 1 at 1. 1 at 0. 1@ -1. 0@ -1} do:
[:offsetPoint |
+ al := location + offsetPoint.
- al _ location + offsetPoint.
((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
- [at _ self tileAt: al.
(at isMine ) ifTrue:
+ [mines := mines+1]]].
- [mines _ mines+1]]].
^mines.!
Item was changed:
----- Method: MinesBoard>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ target := nil.
+ actionSelector := #selection.
+ arguments := #().
- target _ nil.
- actionSelector _ #selection.
- arguments _ #().
""
self layoutPolicy: nil;
hResizing: #rigid;
vResizing: #rigid.
""
+ rows := self preferredRows.
+ columns := self preferredColumns.
+ flashCount := 0.
- rows _ self preferredRows.
- columns _ self preferredColumns.
- flashCount _ 0.
""
self extent: self protoTile extent * (columns @ rows).
self adjustTiles.
self resetBoard!
Item was changed:
----- Method: MinesBoard>>protoTile (in category 'accessing') -----
protoTile
+ protoTile ifNil: [protoTile := MinesTile new].
- protoTile ifNil: [protoTile _ MinesTile new].
^ protoTile!
Item was changed:
----- Method: MinesBoard>>protoTile: (in category 'accessing') -----
protoTile: aTile
+ protoTile := aTile!
- protoTile _ aTile!
Item was changed:
----- Method: MinesBoard>>resetBoard (in category 'initialization') -----
resetBoard
+ gameStart := false.
+ gameOver := false.
- gameStart _ false.
- gameOver _ false.
[flashCount = 0] whileFalse: [self step].
+ flashCount := 0.
+ tileCount := 0.
- flashCount _ 0.
- tileCount _ 0.
Collection initialize. "randomize the Collection class"
self purgeAllCommands.
self submorphsDo: "set tiles to original state."
[:m | m privateOwner: nil. "Don't propagate all these changes..."
m mineFlag: false.
m disabled: false.
m switchState: false.
m isMine: false.
m privateOwner: self].
self changed "Now note the change in bulk"!
Item was changed:
----- Method: MinesBoard>>selectTilesAdjacentTo: (in category 'actions') -----
selectTilesAdjacentTo: location
| al at mines |
" {-1 at 0. 0@ -1. 1 at 0. 0 at 1} do:"
{-1@ -1. -1 at 0. -1 at 1. 0 at 1. 1 at 1. 1 at 0. 1@ -1. 0@ -1} do:
[:offsetPoint |
+ al := location + offsetPoint.
- al _ location + offsetPoint.
((al x between: 1 and: columns) and: [al y between: 1 and: rows]) ifTrue:
+ [at := self tileAt: al.
- [at _ self tileAt: al.
(at switchState not and: [at disabled not]) ifTrue:
[
+ mines := (self tileAt: al) nearMines.
- mines _ (self tileAt: al) nearMines.
at mineFlag ifTrue: [at mineFlag: false.]. "just in case we flagged it as a mine."
at switchState: true.
+ tileCount := tileCount + 1.
- tileCount _ tileCount + 1.
mines=0 ifTrue: [self selectTilesAdjacentTo: al]]]]
!
Item was changed:
----- Method: MinesBoard>>setMines: (in category 'initialization') -----
setMines: notHere
| count total c r sm |
+ count := 0.
+ total := self preferredMines.
- count _ 0.
- total _ self preferredMines.
[count < total] whileTrue:[
+ c := columns atRandom.
+ r := rows atRandom.
- c _ columns atRandom.
- r _ rows atRandom.
c at r = notHere ifFalse: [
+ sm := self tileAt: c at r.
- sm _ self tileAt: c at r.
sm isMine ifFalse: [
"sm color: Color red lighter lighter lighter lighter."
sm isMine: true.
+ count := count + 1.]]
- count _ count + 1.]]
].
1 to: columns do: [ :col |
1 to: rows do: [ :row |
(self tileAt: col @ row) nearMines: (self findMines: (col @ row))
]].
!
Item was changed:
----- Method: MinesBoard>>step (in category 'stepping and presenter') -----
step
flashCount = 0 ifFalse: [
self submorphsDo:
[:m |
m color: m color negated.].
+ flashCount := flashCount - 1.
- flashCount _ flashCount - 1.
].
!
Item was changed:
----- Method: MinesBoard>>stepOnTile: (in category 'actions') -----
stepOnTile: location
| mines tile |
+ tile := self tileAt: location.
- tile _ self tileAt: location.
tile mineFlag ifFalse:[
tile isMine ifTrue: [tile color: Color gray darker darker. self blowUp. ^false.]
ifFalse:[
+ mines := self findMines: location.
- mines _ self findMines: location.
tile switchState: true.
+ tileCount := tileCount + 1.
- tileCount _ tileCount + 1.
mines = 0 ifTrue:
[self selectTilesAdjacentTo: location]].
+ tileCount = ((columns*rows) - self preferredMines) ifTrue:[ gameOver := true. flashCount := 2. owner timeDisplay stop.].
- tileCount = ((columns*rows) - self preferredMines) ifTrue:[ gameOver _ true. flashCount _ 2. owner timeDisplay stop.].
^ true.]
ifTrue: [^ false.]
!
Item was changed:
----- Method: MinesBoard>>target: (in category 'accessing') -----
target: anObject
+ target := anObject!
- target _ anObject!
Item was changed:
----- Method: MinesBoard>>tileClickedAt:newSelection:modifier: (in category 'actions') -----
tileClickedAt: location newSelection: isNewSelection modifier: mod
| tile |
"self halt."
gameOver ifTrue: [^ false].
+ tile := self tileAt: location.
- tile _ self tileAt: location.
isNewSelection ifFalse: [
mod ifTrue: [
tile mineFlag: ((tile mineFlag) not).
tile mineFlag ifTrue: [owner minesDisplay value: (owner minesDisplay value - 1)]
ifFalse: [owner minesDisplay value: (owner minesDisplay value + 1)].
^ true.].
gameStart ifFalse: [
self setMines: location.
+ gameStart := true.
- gameStart _ true.
owner timeDisplay start.].
^ self stepOnTile: location.
]
ifTrue:[ self clearMines: location.].!
Item was changed:
----- Method: MinesTile>>color: (in category 'accessing') -----
color: aColor
super color: aColor.
+ onColor := aColor.
+ offColor := aColor.
- onColor _ aColor.
- offColor _ aColor.
self changed!
Item was changed:
----- Method: MinesTile>>disabled: (in category 'accessing') -----
disabled: aBoolean
+ disabled := aBoolean.
- disabled _ aBoolean.
disabled
ifTrue:
[self color: owner color.
self borderColor: owner color]
ifFalse:
[self setSwitchState: self switchState]!
Item was changed:
----- Method: MinesTile>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Draw a rectangle with a solid, inset, or raised border.
Note: the raised border color *and* the inset border color are generated
from the receiver's own color, instead of having the inset border color
generated from the owner's color, as in BorderedMorph."
| font rct |
borderWidth = 0 ifTrue: [ "no border"
aCanvas fillRectangle: bounds color: color.
^ self.].
borderColor == #raised ifTrue: [
^ aCanvas frameAndFillRectangle: bounds
fillColor: color
borderWidth: borderWidth
topLeftColor: color lighter lighter
bottomRightColor: color darker darker darker].
borderColor == #inset ifTrue: [
aCanvas frameAndFillRectangle: bounds
fillColor: color
borderWidth: 1 " borderWidth"
topLeftColor: (color darker darker darker)
bottomRightColor: color lighter.
self isMine ifTrue: [
+ font := StrikeFont familyName: 'Atlanta' size: 22 emphasized: 1.
+ rct := bounds insetBy: ((bounds width) - (font widthOfString: '*'))/2 at 0.
+ rct := rct top: rct top + 1.
- font _ StrikeFont familyName: 'Atlanta' size: 22 emphasized: 1.
- rct _ bounds insetBy: ((bounds width) - (font widthOfString: '*'))/2 at 0.
- rct _ rct top: rct top + 1.
aCanvas drawString: '*' in: (rct translateBy: 1 at 1) font: font color: Color black.
^ aCanvas drawString: '*' in: rct font: font color: Color red .].
self nearMines > 0 ifTrue: [
+ font := StrikeFont familyName: 'ComicBold' size: 22 emphasized: 1.
+ rct := bounds insetBy: ((bounds width) - (font widthOfString: nearMines asString))/2 at 0.
+ rct := rct top: rct top + 1.
- font _ StrikeFont familyName: 'ComicBold' size: 22 emphasized: 1.
- rct _ bounds insetBy: ((bounds width) - (font widthOfString: nearMines asString))/2 at 0.
- rct _ rct top: rct top + 1.
aCanvas drawString: nearMines asString in: (rct translateBy: 1 at 1) font: font color: Color black.
^ aCanvas drawString: nearMines asString in: rct font: font color: ((palette at: nearMines) ) .].
^self. ].
"solid color border"
aCanvas frameAndFillRectangle: bounds
fillColor: color
borderWidth: borderWidth
borderColor: borderColor.!
Item was changed:
----- Method: MinesTile>>initialize (in category 'initialization') -----
initialize
super initialize.
self label: ''.
self borderWidth: 3.
+ bounds := 0 at 0 corner: 20 at 20.
+ offColor := self preferredColor.
+ onColor := self preferredColor.
+ switchState := false.
+ oldSwitchState := false.
+ disabled := false.
+ isMine := false.
+ nearMines := 0.
- bounds _ 0 at 0 corner: 20 at 20.
- offColor _ self preferredColor.
- onColor _ self preferredColor.
- switchState _ false.
- oldSwitchState _ false.
- disabled _ false.
- isMine _ false.
- nearMines _ 0.
self useSquareCorners.
+ palette := (Color wheel: 8) asOrderedCollection reverse.
+ " flashColor := palette removeLast."
- palette _ (Color wheel: 8) asOrderedCollection reverse.
- " flashColor _ palette removeLast."
!
Item was changed:
----- Method: MinesTile>>isMine: (in category 'accessing') -----
isMine: aBoolean
+ isMine := aBoolean.
- isMine _ aBoolean.
!
Item was changed:
----- Method: MinesTile>>mineFlag: (in category 'accessing') -----
mineFlag: boolean
+ mineFlag := boolean.
- mineFlag _ boolean.
mineFlag ifTrue: [
self color: Color red lighter lighter lighter lighter.]
ifFalse: [
self color: self preferredColor.].
^ mineFlag.
!
Item was changed:
----- Method: MinesTile>>mouseDown: (in category 'event handling') -----
mouseDown: evt
"The only real alternative mouse clicks are the yellow button or the shift key. I will treat them as the same thing, and ignore two button presses for now. I am keeping this code around, because it is the only documentation I have of MouseButtonEvent."
| mod |
" Transcript show: 'anyModifierKeyPressed - '; show: evt anyModifierKeyPressed printString ; cr;
show: 'commandKeyPressed - '; show: evt commandKeyPressed printString ; cr;
show: 'controlKeyPressed - '; show:evt controlKeyPressed printString ; cr;
show: 'shiftPressed - '; show: evt shiftPressed printString ; cr;
show: 'buttons - '; show: evt buttons printString ; cr;
show: 'handler - '; show: evt handler printString ; cr;
show: 'position - '; show: evt position printString ; cr;
show: 'type - '; show: evt type printString ; cr;
show: 'anyButtonPressed - '; show: evt anyButtonPressed printString ; cr;
show: 'blueButtonPressed - '; show: evt blueButtonPressed printString ; cr;
show: 'redButtonPressed - '; show: evt redButtonPressed printString ; cr;
show: 'yellowButtonPressed - '; show: evt yellowButtonPressed printString ; cr; cr; cr."
+ mod := (evt yellowButtonPressed) | (evt shiftPressed).
- mod _ (evt yellowButtonPressed) | (evt shiftPressed).
switchState ifFalse:[
(self doButtonAction: mod) ifTrue:
[mod ifFalse: [ self setSwitchState: true. ].].
] ifTrue: [
self doButtonAction: mod.].!
Item was changed:
----- Method: MinesTile>>nearMines: (in category 'accessing') -----
nearMines: nMines
+ nearMines := nMines.
- nearMines _ nMines.
!
Item was changed:
----- Method: MinesTile>>preferredColor (in category 'initialization') -----
preferredColor
+ "PreferredColor := nil <-- to reset cache"
- "PreferredColor _ nil <-- to reset cache"
PreferredColor ifNil:
["This actually takes a while to compute..."
+ PreferredColor := Color gray lighter lighter lighter].
- PreferredColor _ Color gray lighter lighter lighter].
^ PreferredColor!
Item was changed:
----- Method: MinesTile>>switchState: (in category 'accessing') -----
switchState: aBoolean
+ switchState := aBoolean.
- switchState _ aBoolean.
disabled ifFalse:
[switchState
ifTrue:[
"flag ifTrue: [self setFlag]." "if this is a flagged tile, unflag it."
self borderColor: #inset.
self color: onColor]
ifFalse:[
self borderColor: #raised.
self color: offColor]]!
Item was changed:
----- Method: MonthMorph>>chooseYear (in category 'controls') -----
chooseYear
| newYear yearString |
+ newYear := (SelectionMenu selections:
- newYear _ (SelectionMenu selections:
{'today'} , (month year - 5 to: month year + 5) , {'other...'})
startUpWithCaption: 'Choose another year' translated.
newYear ifNil: [^ self].
newYear isNumber ifTrue:
[^ self month: (Month month: month monthName year: newYear)].
newYear = 'today' ifTrue:
[^ self month: (Month starting: Date today)].
+ yearString := FillInTheBlank
- yearString _ FillInTheBlank
request: 'Type in a year' translated initialAnswer: Date today year asString.
yearString ifNil: [^ self].
+ newYear := yearString asNumber.
- newYear _ yearString asNumber.
(newYear between: 0 and: 9999) ifTrue:
[^ self month: (Month month: month monthName year: newYear)].
!
Item was changed:
----- Method: MonthMorph>>highlightToday (in category 'initialization') -----
highlightToday
+ todayCache := Date today.
- todayCache _ Date today.
self allMorphsDo:
[:m | (m isKindOf: SimpleSwitchMorph) ifTrue:
[(m arguments isEmpty not and: [m arguments first = todayCache])
ifTrue: [m borderWidth: 2; borderColor: Color yellow]
ifFalse: [m borderWidth: 1; setSwitchState: m color = m onColor]]].
!
Item was changed:
----- Method: MonthMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ tileRect := 0 @ 0 extent: 23 @ 19.
- tileRect _ 0 @ 0 extent: 23 @ 19.
self
layoutInset: 1;
listDirection: #topToBottom;
vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
month: Month current.
self rubberBandCells: false.
self extent: 160 @ 130!
Item was changed:
----- Method: MonthMorph>>initializeWeeks (in category 'initialization') -----
initializeWeeks
| weeks |
self removeAllMorphs.
+ weeks := OrderedCollection new.
- weeks _ OrderedCollection new.
month weeksDo:
[ :w |
weeks add: (WeekMorph newWeek: w month: month tileRect: tileRect model: model)].
weeks reverseDo:
[ :w |
w hResizing: #spaceFill; vResizing: #spaceFill.
"should be done by WeekMorph but isn't"
w submorphsDo:[ :m | m hResizing: #spaceFill; vResizing: #spaceFill ].
self addMorph: w ].
self
initializeHeader;
highlightToday.
!
Item was changed:
----- Method: MonthMorph>>model: (in category 'initialization') -----
model: aModel
+ model := aModel!
- model _ aModel!
Item was changed:
----- Method: MonthMorph>>month: (in category 'controls') -----
month: aMonth
+ month := aMonth.
- month _ aMonth.
model ifNotNil: [model setDate: nil fromButton: nil down: false].
self initializeWeeks!
Item was changed:
----- Method: MonthMorph>>selectedDates (in category 'access') -----
selectedDates
| answer |
+ answer := SortedCollection new.
- answer _ SortedCollection new.
self submorphsDo:
[:each |
(each isKindOf: WeekMorph) ifTrue: [answer addAll: each selectedDates]].
^ answer !
Item was changed:
----- Method: Morph class>>inARow: (in category '*Etoys-Squeakland-instance creation') -----
inARow: aCollectionOfMorphs
"Answer an instance of the receiver, a row morph, with the given collection as its submorphs, and transparent in color. Interpret the symbol #spacer in the incoming list as a request for a variable transparent spacer."
| row |
+ row := self new.
- row _ self new.
row layoutPolicy: TableLayout new.
row
listDirection: #leftToRight;
vResizing: #shrinkWrap;
hResizing: #spaceFill;
layoutInset: 0;
cellPositioning: #center;
borderWidth: 0;
color: Color transparent.
aCollectionOfMorphs do:
[ :each | | toAdd |
toAdd := each == #spacer
ifTrue:
[AlignmentMorph newVariableTransparentSpacer]
ifFalse:
[each].
row addMorphBack: toAdd].
^ row
!
Item was changed:
----- Method: Morph>>addLockingItemsTo: (in category '*Etoys-Squeakland-menu & halo') -----
addLockingItemsTo: aMenu
"Add locking-related items to the given menu. If any items are needed, a line will be added before them, and it is incumbent on the sender to add a line after them, if required."
| unlockables |
+ unlockables := self submorphs select:
- unlockables _ self submorphs select:
[:m | m isLocked].
unlockables size = 0 ifTrue: [^ self].
aMenu addLine.
unlockables size == 1 ifTrue:
[aMenu add: ('unlock "{1}"' translated format:{unlockables first externalName})action: #unlockContents].
unlockables size > 1 ifTrue:
[aMenu add: 'unlock all contents' translated action: #unlockContents.
aMenu add: 'unlock...' translated action: #unlockOneSubpart].!
Item was changed:
----- Method: Morph>>addMorphInLayer:centeredNear: (in category '*Etoys-Squeakland-WiW support') -----
addMorphInLayer: aMorph centeredNear: aPoint
"Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world."
| trialRect delta |
+ trialRect := Rectangle center: aPoint extent: aMorph fullBounds extent.
+ delta := trialRect amountToTranslateWithin: bounds.
- trialRect _ Rectangle center: aPoint extent: aMorph fullBounds extent.
- delta _ trialRect amountToTranslateWithin: bounds.
aMorph position: trialRect origin + delta.
self addMorphInLayer: aMorph.
!
Item was changed:
----- Method: Morph>>addPlayerItemsTo: (in category '*Etoys') -----
addPlayerItemsTo: aMenu
"Add player-related items to the menu if appropriate"
| aPlayer subMenu |
self couldMakeSibling ifFalse: [^ self].
+ aPlayer := self topRendererOrSelf player.
+ subMenu := MenuMorph new defaultTarget: self.
- aPlayer _ self topRendererOrSelf player.
- subMenu _ MenuMorph new defaultTarget: self.
subMenu add: 'make a sibling instance' translated target: self action: #makeNewPlayerInstance:.
subMenu balloonTextForLastItem: 'Makes another morph whose player is of the same class as this one. Both siblings will share the same scripts' translated.
subMenu add: 'make multiple siblings...' translated target: self action: #makeMultipleSiblings:.
subMenu balloonTextForLastItem: 'Make any number of sibling instances all at once' translated.
(aPlayer belongsToUniClass and: [aPlayer class instanceCount > 1]) ifTrue:
[subMenu addLine.
self renderedMorph isSketchMorph ifTrue:
[subMenu add: 'make all siblings look like me' translated target: self action: #makeSiblingsLookLikeMe:.
subMenu balloonTextForLastItem: 'make all my sibling instances look like me.' translated].
subMenu add: 'bring all siblings to my location' translated target: self action: #bringAllSiblingsToMe:.
subMenu balloonTextForLastItem: 'find all sibling instances and bring them to me' translated.
subMenu add: 'apply status to all siblngs' translated target: self action: #applyStatusToAllSiblings:.
subMenu balloonTextForLastItem: 'apply the current status of all of my scripts to the scripts of all my siblings' translated].
subMenu add: 'indicate all siblings' translated target: self action: #indicateAllSiblings.
subMenu balloonTextForLastItem: 'momentarily show, by flashing , all of my visible siblings.' translated.
aMenu add: 'siblings...' translated subMenu: subMenu
!
Item was changed:
----- Method: Morph>>changeColorTarget:selector:originalColor:hand:showPalette: (in category '*Etoys-Squeakland-meta-actions') -----
changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand showPalette: showPalette
"Put up a color picker for changing some kind of color. May be modal or modeless, depending on #modalColorPickers setting"
| c aRectangle |
self flag: #arNote. "Simplify this due to anObject == self for almost all cases"
+ c := ColorPickerMorph new.
- c _ ColorPickerMorph new.
c
choseModalityFromPreference;
sourceHand: aHand;
target: anObject;
selector: aSymbol;
originalColor: aColor.
showPalette ifFalse: [c initializeForJustCursor].
aRectangle := (anObject == ActiveWorld)
ifTrue:
[ActiveHand position extent: (20 at 20)]
ifFalse:
[anObject isMorph
ifFalse:
[Rectangle center: self position extent: (20 at 20)]
ifTrue:
[anObject fullBoundsInWorld]].
c putUpFor: anObject near: aRectangle!
Item was changed:
----- Method: Morph>>definePath (in category '*Etoys-support') -----
definePath
| points lastPoint aForm offset currentPoint dwell ownerPosition |
+ points := OrderedCollection new: 70.
+ lastPoint := nil.
+ aForm := self imageForm.
+ offset := aForm extent // 2.
+ ownerPosition := owner position.
- points _ OrderedCollection new: 70.
- lastPoint _ nil.
- aForm _ self imageForm.
- offset _ aForm extent // 2.
- ownerPosition _ owner position.
Cursor move show.
Sensor waitButton.
[Sensor anyButtonPressed and: [points size < 100]] whileTrue:
+ [currentPoint := Sensor cursorPoint.
+ dwell := 0.
- [currentPoint _ Sensor cursorPoint.
- dwell _ 0.
currentPoint = lastPoint
ifTrue:
+ [dwell := dwell + 1.
- [dwell _ dwell + 1.
((dwell \\ 1000) = 0) ifTrue:
[Beeper beep]]
ifFalse:
[self position: (currentPoint - offset).
self world displayWorld.
(Delay forMilliseconds: 20) wait.
points add: currentPoint.
+ lastPoint := currentPoint]].
- lastPoint _ currentPoint]].
points size > 1
ifFalse:
[self inform: 'no path obtained' translated]
ifTrue:
[points size = 100 ifTrue: [self playSoundNamed: 'croak'].
"Transcript cr; show: 'path defined with
', points size printString, ' points'."
self renderedMorph setProperty: #pathPoints toValue:
(points collect: [:p | p - ownerPosition])].
Cursor normal show
!
Item was changed:
----- Method: Morph>>editMenuButtonDefinition (in category '*Etoys-Squeakland-display') -----
editMenuButtonDefinition
"Open up a single-method browser on the method that defines the menu of the receiver obtained by clicking on the receiver's menuButton"
| mr |
+ mr := MethodReference new setStandardClass: self class methodSymbol: #addMenuButtonItemsTo:.
- mr _ MethodReference new setStandardClass: self class methodSymbol: #addMenuButtonItemsTo:.
self systemNavigation browseMessageList: {mr} name: self class name, ' menu definition' translated autoSelect: nil!
Item was changed:
----- Method: Morph>>followPath (in category '*Etoys-support') -----
followPath
"Follow a prebuilt path."
| pathPoints offset morphToMove |
self isRenderer ifTrue: [^ self renderedMorph followPath].
(self hasProperty: #followingPath) ifTrue: [^ self]. "Don't let them build up."
+ (pathPoints := self valueOfProperty: #pathPoints) ifNil: [^ self].
- (pathPoints _ self valueOfProperty: #pathPoints) ifNil: [^ self].
self setProperty: #followingPath toValue: true.
morphToMove := self topRendererOrSelf.
+ offset := morphToMove owner position - (morphToMove extent // 2).
- offset _ morphToMove owner position - (morphToMove extent // 2).
[[pathPoints do:
[:aPoint |
morphToMove position: aPoint + offset.
self world displayWorld.
(Delay forMilliseconds: 20) wait]]
ensure:
[self removeProperty: #followingPath]] fork!
Item was changed:
----- Method: Morph>>menuButton (in category '*Etoys-Squeakland-menu & halo') -----
menuButton
"Answer a button that brings up a menu."
| aButton form |
+ aButton := IconicButton new target: self;
- aButton _ IconicButton new target: self;
borderWidth: 0;
labelGraphic: (form := ScriptingSystem formAtKey: #MenuIcon);
color: Color transparent;
actWhen: #buttonDown;
actionSelector: #offerMenu;
extent: form extent;
yourself.
aButton setBalloonText: 'click here to get a menu with further options' translated.
^ aButton
!
Item was changed:
----- Method: Morph>>offerMenu (in category '*Etoys-Squeakland-menu & halo') -----
offerMenu
"A menu button was hit. Offer a menu of options for the receiver."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
self addMenuButtonItemsTo: aMenu.
aMenu popUpInWorld!
Item was changed:
----- Method: Morph>>removeViewersOnSubsIn: (in category '*Etoys-Squeakland-e-toy support') -----
removeViewersOnSubsIn: aPresenter
"If any viewer is on a morph that is a submorph of me, delete it and its flap tab. Good for deleting a book page."
| flapList morphList |
"enumerate referents of tabs"
+ flapList := aPresenter associatedMorph submorphs select: [:mm | mm isKindOf: ViewerFlapTab].
+ morphList := flapList collect: [:ff | ff scriptedPlayer costume].
- flapList _ aPresenter associatedMorph submorphs select: [:mm | mm isKindOf: ViewerFlapTab].
- morphList _ flapList collect: [:ff | ff scriptedPlayer costume].
"see if I am in owner chain of its morph"
morphList with: flapList do: [:mmm :aflap | (mmm hasOwner: self) ifTrue: [
aflap referent delete.
aflap delete]].!
Item was changed:
----- Method: Morph>>showWillingnessToAcceptDropFeedback (in category '*Etoys-Squeakland-e-toy support') -----
showWillingnessToAcceptDropFeedback
"Make the receiver look ready to show show some welcoming feedback"
| aMorph |
+ aMorph := RectangleMorph new bounds: self bounds..
- aMorph _ RectangleMorph new bounds: self bounds..
aMorph beTransparent; borderWidth: 4; borderColor: (Color green); lock.
aMorph setProperty: #affilliatedPad toValue: (self ownerThatIsA: TilePadMorph).
ActiveWorld addHighlightMorph: aMorph for: self outmostScriptEditor!
Item was changed:
----- Method: Morph>>unembedSubmorphsInWindow (in category '*Etoys-Squeakland-e-toy support') -----
unembedSubmorphsInWindow
| p |
self submorphs do: [:each |
(each hasProperty: #morphEmbeddedWindow) ifTrue: [
+ p := each findA: PasteUpMorph.
- p _ each findA: PasteUpMorph.
p ifNotNil: [
p submorphs do: [:s | self addMorph: s behind: each].
each delete.
]
]
].
!
Item was changed:
----- Method: MorphExample>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ phase := 1.
- phase _ 1.
self extent: 200 @ 200.
+ ball := EllipseMorph new extent: 30 @ 30.
- ball _ EllipseMorph new extent: 30 @ 30.
self
+ addMorph: ((star := StarMorph new extent: 150 @ 150) center: self center)!
- addMorph: ((star _ StarMorph new extent: 150 @ 150) center: self center)!
Item was changed:
----- Method: MorphExample>>step (in category 'stepping and presenter') -----
step
+ phase := phase\\8 + 1.
- phase _ phase\\8 + 1.
phase = 1 ifTrue: [^ ball delete].
phase < 4 ifTrue:[^self].
phase = 4 ifTrue: [self addMorph: ball].
ball align: ball center with: (star vertices at: (phase-3*2)).!
Item was changed:
----- Method: MorphExtension>>inspectAllPropertiesOf: (in category '*Etoys-Squeakland-inspecting') -----
inspectAllPropertiesOf: aMorph
"Open an Inspector on all the properties. This lets you see them but not in the initial instance actually modify them."
| aDict |
+ aDict := otherProperties
- aDict _ otherProperties
ifNil:
[IdentityDictionary new]
ifNotNil:
[otherProperties copy].
((self class allInstVarNames reject: [:e | e = 'otherProperties']) collect: [:e | e asSymbol]) do:
[:var | (self instVarNamed: var) ifNotNilDo:
[:val | aDict add: (var -> val)]].
aDict inspectWithLabel: 'Properties of ', aMorph defaultLabelForInspector!
Item was changed:
----- Method: MorphExtension>>inspectElementFor: (in category '*Etoys-Squeakland-inspecting') -----
inspectElementFor: aMorph
"Create and schedule an Inspector on the otherProperties and the
named properties, on behalf of the given morph"
| key obj names toInspect |
+ (names := self sortedPropertyNames) ifEmpty: [^ self].
+ key := (SelectionMenu selections: names)
- (names _ self sortedPropertyNames) ifEmpty: [^ self].
- key _ (SelectionMenu selections: names)
startUpWithCaption: 'Inspect which property?'.
key
ifNil: [^ self].
obj := otherProperties
ifNil:
['nOT a vALuE']
ifNotNil:
[otherProperties
at: key
ifAbsent: ['nOT a vALuE']].
toInspect := obj = 'nOT a vALuE'
ifTrue: [(self perform: key) "named properties"]
ifFalse: [obj ].
toInspect inspectWithLabel: 'value of ', key, ' in ', aMorph defaultLabelForInspector!
Item was changed:
----- Method: MorphWorldController>>controlLoop (in category 'basic control sequence') -----
controlLoop
"Overridden to keep control active when the hand goes out of the view"
| db |
[self viewHasCursor "working in the window"
or: [Sensor noButtonPressed "wandering with no button pressed"
or: [model primaryHand submorphs size > 0 "dragging something outside"]]]
whileTrue: "... in other words anything but clicking outside"
[self controlActivity.
"Check for reframing since we hold control here"
+ db := view superView displayBox.
- db _ view superView displayBox.
view superView controller checkForReframe.
db = view superView displayBox ifFalse:
[self controlInitialize "reframe world if bounds changed"]].
!
Item was changed:
----- Method: MorphWorldController>>controlTerminate (in category 'basic control sequence') -----
controlTerminate
"This window is becoming inactive; restore the normal cursor."
Cursor normal show.
+ ActiveWorld := ActiveHand := ActiveEvent := nil!
- ActiveWorld _ ActiveHand _ ActiveEvent _ nil!
Item was changed:
----- Method: MorphWorldView class>>fullColorWhenInactive (in category 'instance creation') -----
fullColorWhenInactive
+ FullColorWhenInactive ifNil: [FullColorWhenInactive := true].
- FullColorWhenInactive ifNil: [FullColorWhenInactive _ true].
^ FullColorWhenInactive
!
Item was changed:
----- Method: MorphWorldView class>>fullColorWhenInactive: (in category 'instance creation') -----
fullColorWhenInactive: fullColor
"MorphWorldView fullColorWhenInactive: true"
"If FullColorWhenInactive is true then WorldMorphViews will created inside StandardSystemViews that cache their contents in full-color when the window is inactive. If it is false, only a half-tone gray approximation of the colors will be cached to save space."
+ FullColorWhenInactive := fullColor.
- FullColorWhenInactive _ fullColor.
"Retroactively convert all extant windows"
((fullColor ifTrue: [StandardSystemView] ifFalse: [ColorSystemView])
allInstances select:
[:v | v subViews notNil and: [v subViews isEmpty not and: [v firstSubView isKindOf: MorphWorldView]]])
do: [:v | v uncacheBits.
v controller toggleTwoTone]!
Item was changed:
----- Method: MorphWorldView class>>openOn:label:cautionOnClose: (in category 'instance creation') -----
openOn: aWorldMorph label: aString cautionOnClose: aBoolean
"Open a view with the given label on the given WorldMorph."
| aModel |
+ aModel := aBoolean
- aModel _ aBoolean
ifTrue: [CautiousModel new]
ifFalse: [WorldViewModel new].
^ self openOn: aWorldMorph label: aString model: (aModel initialExtent: aWorldMorph initialExtent)!
Item was changed:
----- Method: MorphWorldView class>>openWorld (in category 'instance creation') -----
openWorld
| w |
+ (w := MVCWiWPasteUpMorph newWorldForProject: nil).
- (w _ MVCWiWPasteUpMorph newWorldForProject: nil).
w bounds: (0 at 0 extent: 400 at 300).
self openOn: w
label: 'A Morphic World'
extent: w fullBounds extent + 2.
!
Item was changed:
----- Method: MorphWorldView class>>openWorldWith:labelled: (in category 'instance creation') -----
openWorldWith: aMorph labelled: labelString
| w |
+ (w := MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph.
- (w _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph.
w extent: aMorph fullBounds extent.
w startSteppingSubmorphsOf: aMorph.
self openOn: w
label: labelString
extent: w fullBounds extent + 2.
!
Item was changed:
----- Method: MorphWorldView>>displayView (in category 'displaying') -----
displayView
"This method is called by the system when the top view is framed or moved."
| topView |
model viewBox: self insetDisplayBox.
self updateSubWindowExtent.
+ topView := self topView.
- topView _ self topView.
(topView == ScheduledControllers scheduledControllers first view
or: [topView cacheBitsAsTwoTone not])
ifTrue: [model displayWorldSafely]
ifFalse: [model displayWorldAsTwoTone]. "just restoring the screen"!
Item was changed:
----- Method: MorphicEventDispatcher>>relocateMorphIfnecessary:within: (in category '*Etoys-Squeakland-private') -----
relocateMorphIfnecessary: aMorph within: aWorldMorph
| morphBounds morphCenter worldBounds |
+ morphBounds := aMorph bounds.
+ worldBounds := aWorldMorph bounds.
- morphBounds _ aMorph bounds.
- worldBounds _ aWorldMorph bounds.
(morphBounds intersects: (worldBounds insetBy: 4)) ifFalse: [
+ morphCenter := morphBounds center.
- morphCenter _ morphBounds center.
(morphCenter x < worldBounds left) ifTrue: [
aMorph right: worldBounds left + 16.
].
(morphCenter x > worldBounds right) ifTrue: [
aMorph left: worldBounds right - 16
].
(morphCenter y < worldBounds top) ifTrue: [
aMorph bottom: worldBounds top + 16.
].
(morphCenter y > worldBounds bottom) ifTrue: [
aMorph top: worldBounds bottom - 16
].
].
!
Item was changed:
----- Method: MouseActionIndicatorMorph class>>world:inner:outer:color: (in category 'as yet unclassified') -----
world: aWorld inner: innerRectangle outer: outerRectangle color: aColor
| allRects allMorphs |
+ allRects := outerRectangle areasOutside: innerRectangle.
+ allMorphs := allRects collect: [ :each |
- allRects _ outerRectangle areasOutside: innerRectangle.
- allMorphs _ allRects collect: [ :each |
self new bounds: each; color: aColor
].
allMorphs do: [ :each |
each siblings: allMorphs; openInWorld: aWorld
].
^allMorphs
!
Item was changed:
----- Method: MouseActionIndicatorMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ siblings := #().!
- siblings _ #().!
Item was changed:
----- Method: MouseActionIndicatorMorph>>siblings: (in category 'as yet unclassified') -----
siblings: aCollection
+ siblings := aCollection.
- siblings _ aCollection.
!
Item was changed:
----- Method: MouseDownMorph>>plugMouseDownToModel (in category 'menu') -----
plugMouseDownToModel
+ mouseDownSelector := (self knownName , 'MouseDown:event:') asSymbol.
- mouseDownSelector _ (self knownName , 'MouseDown:event:') asSymbol.
model class compile: (
'&nameMouseDown: trueOrFalse event: event
"A mouseDown event has occurred.
Add code to handle it here below..."'
copyReplaceAll: '&name' with: self knownName)
classified: 'input events' notifying: nil!
Item was changed:
----- Method: MouseDownMorph>>plugMouseDownToSlot (in category 'menu') -----
plugMouseDownToSlot
| varName |
+ mouseDownSelector := (self knownName , 'MouseDown:event:') asSymbol.
+ varName := self knownName , 'MouseDown'.
- mouseDownSelector _ (self knownName , 'MouseDown:event:') asSymbol.
- varName _ self knownName , 'MouseDown'.
model class addSlotNamed: varName.
model class compile: (
'&name: trueOrFalse event: event
"A mouseDown event has occurred.
Add code to handle it here below..."
+ &name := trueOrFalse.'
- &name _ trueOrFalse.'
copyReplaceAll: '&name' with: varName)
classified: 'input events' notifying: nil!
Item was changed:
----- Method: MouseDownMorph>>plugMouseMoveToModel (in category 'menu') -----
plugMouseMoveToModel
+ mouseMoveSelector := (self knownName , 'MouseMove:event:') asSymbol.
- mouseMoveSelector _ (self knownName , 'MouseMove:event:') asSymbol.
model class compile: (
'&nameMouseMove: location event: event
"A mouseMove event has occurred.
Add code to handle it here below..."'
copyReplaceAll: '&name' with: self knownName)
classified: 'input events' notifying: nil!
Item was changed:
----- Method: MouseDownMorph>>plugMouseMoveToSlot (in category 'menu') -----
plugMouseMoveToSlot
| varName |
+ mouseMoveSelector := (self knownName , 'MouseMove:event:') asSymbol.
+ varName := self knownName , 'MouseMove'.
- mouseMoveSelector _ (self knownName , 'MouseMove:event:') asSymbol.
- varName _ self knownName , 'MouseMove'.
model class addSlotNamed: varName.
model class compile: (
'&name: location event: event
"A mouseMove event has occurred.
Add code to handle it here below..."
+ &name := location.'
- &name _ location.'
copyReplaceAll: '&name' with: varName)
classified: 'input events' notifying: nil!
Item was changed:
----- Method: MovingEyeMorph class>>initialize (in category 'class initialization') -----
initialize
"
MovingEyeMorph initialize
"
+ IrisSize := (0.42 at 0.50).!
- IrisSize _ (0.42 at 0.50).!
Item was changed:
----- Method: MovingEyeMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ inner := EllipseMorph new.
- inner _ EllipseMorph new.
inner color: self color.
inner extent: (self extent * (1.0 @ 1.0 - IrisSize)) asIntegerPoint.
inner borderColor: self color.
inner borderWidth: 0.
""
+ iris := EllipseMorph new.
- iris _ EllipseMorph new.
iris color: Color white.
iris extent: (self extent * IrisSize) asIntegerPoint.
""
self addMorphCentered: inner.
inner addMorphCentered: iris.
""
self extent: 26 @ 33!
Item was changed:
----- Method: MovingEyeMorph>>irisPos: (in category 'as yet unclassified') -----
irisPos: cp
| a b theta x y |
+ theta := (cp - self center) theta.
+ a := inner width // 2.
+ b := inner height // 2.
+ x := a * (theta cos).
+ y := b * (theta sin).
- theta _ (cp - self center) theta.
- a _ inner width // 2.
- b _ inner height // 2.
- x _ a * (theta cos).
- y _ b * (theta sin).
iris position: ((x at y) asIntegerPoint) + self center - (iris extent // 2).!
Item was changed:
----- Method: MovingEyeMorph>>step (in category 'stepping and presenter') -----
step
| cp |
+ cp := self globalPointToLocal: World primaryHand position.
- cp _ self globalPointToLocal: World primaryHand position.
(inner containsPoint: cp)
ifTrue: [iris position: (cp - (iris extent // 2))]
ifFalse: [self irisPos: cp].
self changed "cover up gribblies if embedded in Flash"!
Item was changed:
----- Method: MswUrl>>query (in category 'access') -----
query
"return the query. There is never a MuSwiki URL without a query; the query defaults to 'top' if none is explicitly specified"
| q |
+ q := super query.
+ q isNil ifTrue: [ q := 'top' ].
- q _ super query.
- q isNil ifTrue: [ q _ 'top' ].
^q!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>canvas: (in category 'accessing') -----
canvas: aCanvas
"set the canvas to draw on"
canvas ifNotNil: [ self inform: 'initializing twice!!' ].
+ canvas := aCanvas!
- canvas _ aCanvas!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>cr (in category 'stop conditions') -----
cr
"When a carriage return is encountered, simply increment the pointer
into the paragraph."
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^false!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>displayLine:offset:leftInRun: (in category 'scanning') -----
displayLine: textLine offset: offset leftInRun: leftInRun
| nowLeftInRun done startLoc startIndex stopCondition |
"largely copied from DisplayScanner's routine"
+ line := textLine.
+ foregroundColor ifNil: [ foregroundColor := Color black ].
+ leftMargin := (line leftMarginForAlignment: alignment) + offset x.
- line _ textLine.
- foregroundColor ifNil: [ foregroundColor _ Color black ].
- leftMargin _ (line leftMarginForAlignment: alignment) + offset x.
+ rightMargin := line rightMargin + offset x.
+ lineY := line top + offset y.
+ lastIndex := textLine first.
- rightMargin _ line rightMargin + offset x.
- lineY _ line top + offset y.
- lastIndex _ textLine first.
leftInRun <= 0
ifTrue: [self setStopConditions. "also sets the font"
+ nowLeftInRun := text runLengthFor: lastIndex]
+ ifFalse: [nowLeftInRun := leftInRun].
+ runX := destX := leftMargin.
- nowLeftInRun _ text runLengthFor: lastIndex]
- ifFalse: [nowLeftInRun _ leftInRun].
- runX _ destX _ leftMargin.
+ runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last.
+ spaceCount := 0.
+ done := false.
- runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
- spaceCount _ 0.
- done _ false.
[done] whileFalse: [
"remember where this portion of the line starts"
+ startLoc := destX at destY.
+ startIndex := lastIndex.
- startLoc _ destX at destY.
- startIndex _ lastIndex.
"find the end of this portion of the line"
+ stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
- stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
in: text string rightX: rightMargin stopConditions: stopConditions
kern: kern "displaying: false".
"display that portion of the line"
canvas drawString: text string
from: startIndex to: lastIndex
at: startLoc
font: font
color: foregroundColor.
"handle the stop condition"
+ done := self perform: stopCondition
- done _ self perform: stopCondition
].
^runStopIndex - lastIndex!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>endOfRun (in category 'stop conditions') -----
endOfRun
"The end of a run in the display case either means that there is actually
a change in the style (run code) to be associated with the string or the
end of this line has been reached."
| runLength |
lastIndex = line last ifTrue: [^true].
+ runX := destX.
+ runLength := text runLengthFor: (lastIndex := lastIndex + 1).
+ runStopIndex := lastIndex + (runLength - 1) min: line last.
- runX _ destX.
- runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
- runStopIndex _ lastIndex + (runLength - 1) min: line last.
self setStopConditions.
^ false!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>paddedSpace (in category 'stop conditions') -----
paddedSpace
"Each space is a stop condition when the alignment is right justified.
Padding must be added to the base width of the space according to
which space in the line this space is and according to the amount of
space that remained at the end of the line when it was composed."
+ destX := destX + spaceWidth + (line justifiedPadFor: spaceCount).
- destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^ false!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>setFont (in category 'private') -----
setFont
+ foregroundColor ifNil: [foregroundColor := Color black].
- foregroundColor ifNil: [foregroundColor _ Color black].
super setFont.
+ baselineY := lineY + line baseline.
+ destY := baselineY - font ascent.!
- baselineY _ lineY + line baseline.
- destY _ baselineY - font ascent.!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>tab (in category 'stop conditions') -----
tab
+ destX := (alignment == Justified and: [self leadingTab not])
- destX _ (alignment == Justified and: [self leadingTab not])
ifTrue: "imbedded tabs in justified text are weird"
[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
ifFalse:
[textStyle nextTabXFrom: destX
leftMargin: leftMargin
rightMargin: rightMargin].
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^ false!
Item was changed:
----- Method: MultiCanvasCharacterScanner>>textColor: (in category 'private') -----
textColor: color
+ foregroundColor := color!
- foregroundColor _ color!
Item was changed:
----- Method: MultiCharacterBlockScanner>>buildCharacterBlockIn: (in category 'private') -----
buildCharacterBlockIn: para
| lineIndex runLength lineStop done stopCondition |
"handle nullText"
(para numberOfLines = 0 or: [text size = 0])
ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string"
text: para text
topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment]))
@ para compositionRectangle top
extent: 0 @ textStyle lineGrid].
"find the line"
+ lineIndex := para lineIndexOfTop: characterPoint y.
+ destY := para topAtLineIndex: lineIndex.
+ line := para lines at: lineIndex.
+ rightMargin := para rightMarginForDisplay.
- lineIndex _ para lineIndexOfTop: characterPoint y.
- destY _ para topAtLineIndex: lineIndex.
- line _ para lines at: lineIndex.
- rightMargin _ para rightMarginForDisplay.
(lineIndex = para numberOfLines and:
[(destY + line lineHeight) < characterPoint y])
ifTrue: ["if beyond lastLine, force search to last character"
self characterPointSetX: rightMargin]
ifFalse: [characterPoint y < (para compositionRectangle) top
ifTrue: ["force search to first line"
+ characterPoint := (para compositionRectangle) topLeft].
- characterPoint _ (para compositionRectangle) topLeft].
characterPoint x > rightMargin
ifTrue: [self characterPointSetX: rightMargin]].
+ destX := (leftMargin := para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])).
+ nextLeftMargin := para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]).
+ lastIndex := line first.
- destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])).
- nextLeftMargin _ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]).
- lastIndex _ line first.
self setStopConditions. "also sets font"
+ runLength := (text runLengthFor: line first).
- runLength _ (text runLengthFor: line first).
characterIndex == nil
+ ifTrue: [lineStop := line last "characterBlockAtPoint"]
+ ifFalse: [lineStop := characterIndex "characterBlockForIndex"].
+ (runStopIndex := lastIndex + (runLength - 1)) > lineStop
+ ifTrue: [runStopIndex := lineStop].
+ lastCharacterExtent := 0 @ line lineHeight.
+ spaceCount := 0. done := false.
- ifTrue: [lineStop _ line last "characterBlockAtPoint"]
- ifFalse: [lineStop _ characterIndex "characterBlockForIndex"].
- (runStopIndex _ lastIndex + (runLength - 1)) > lineStop
- ifTrue: [runStopIndex _ lineStop].
- lastCharacterExtent _ 0 @ line lineHeight.
- spaceCount _ 0. done _ false.
self handleIndentation.
[done]
whileFalse:
+ [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
- [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
in: text string rightX: characterPoint x
stopConditions: stopConditions kern: kern.
"see setStopConditions for stopping conditions for character block operations."
self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).
(self perform: stopCondition) ifTrue:
[characterIndex == nil
ifTrue: ["characterBlockAtPoint"
^ CharacterBlock new stringIndex: lastIndex text: text
topLeft: characterPoint + (font descentKern @ 0)
extent: lastCharacterExtent]
ifFalse: ["characterBlockForIndex"
^ CharacterBlock new stringIndex: lastIndex text: text
topLeft: characterPoint + ((font descentKern) - kern @ 0)
extent: lastCharacterExtent]]]!
Item was changed:
----- Method: MultiCharacterBlockScanner>>characterBlockAtPoint:in: (in category 'scanning') -----
characterBlockAtPoint: aPoint in: aParagraph
"Answer a CharacterBlock for character in aParagraph at point aPoint. It
is assumed that aPoint has been transformed into coordinates appropriate
to the text's destination form rectangle and the composition rectangle."
self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
+ characterPoint := aPoint.
- characterPoint _ aPoint.
^self buildCharacterBlockIn: aParagraph!
Item was changed:
----- Method: MultiCharacterBlockScanner>>characterBlockForIndex:in: (in category 'scanning') -----
characterBlockForIndex: targetIndex in: aParagraph
"Answer a CharacterBlock for character in aParagraph at targetIndex. The
coordinates in the CharacterBlock will be appropriate to the intersection
of the destination form rectangle and the composition rectangle."
self
initializeFromParagraph: aParagraph
clippedBy: aParagraph clippingRectangle.
+ characterIndex := targetIndex.
+ characterPoint :=
- characterIndex _ targetIndex.
- characterPoint _
aParagraph rightMarginForDisplay @
(aParagraph topAtLineIndex:
(aParagraph lineIndexOfCharacterIndex: characterIndex)).
^self buildCharacterBlockIn: aParagraph!
Item was changed:
----- Method: MultiCharacterBlockScanner>>characterPointSetX: (in category 'private') -----
characterPointSetX: xVal
+ characterPoint := xVal @ characterPoint y!
- characterPoint _ xVal @ characterPoint y!
Item was changed:
----- Method: MultiCharacterBlockScanner>>cr (in category 'stop conditions') -----
cr
"Answer a CharacterBlock that specifies the current location of the mouse
relative to a carriage return stop condition that has just been
encountered. The ParagraphEditor convention is to denote selections by
CharacterBlocks, sometimes including the carriage return (cursor is at
the end) and sometimes not (cursor is in the middle of the text)."
((characterIndex ~= nil
and: [characterIndex > text size])
or: [(line last = text size)
and: [(destY + line lineHeight) < characterPoint y]])
ifTrue: ["When off end of string, give data for next character"
+ destY := destY + line lineHeight.
+ baselineY := line lineHeight.
+ lastCharacter := nil.
+ characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ destY.
+ lastIndex := lastIndex + 1.
- destY _ destY + line lineHeight.
- baselineY _ line lineHeight.
- lastCharacter _ nil.
- characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY.
- lastIndex _ lastIndex + 1.
self lastCharacterExtentSetX: 0.
^ true].
+ lastCharacter := CR.
+ characterPoint := destX @ destY.
- lastCharacter _ CR.
- characterPoint _ destX @ destY.
self lastCharacterExtentSetX: rightMargin - destX.
^true!
Item was changed:
----- Method: MultiCharacterBlockScanner>>crossedX (in category 'stop conditions') -----
crossedX
"Text display has wrapping. The scanner just found a character past the x
location of the cursor. We know that the cursor is pointing at a character
or before one."
| leadingTab currentX |
characterIndex == nil ifFalse: [
"If the last character of the last line is a space,
and it crosses the right margin, then locating
the character block after it is impossible without this hack."
characterIndex > text size ifTrue: [
+ lastIndex := characterIndex.
+ characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight).
- lastIndex _ characterIndex.
- characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight).
^true]].
characterPoint x <= (destX + (lastCharacterExtent x // 2))
+ ifTrue: [lastCharacter := (text at: lastIndex).
+ characterPoint := destX @ destY.
- ifTrue: [lastCharacter _ (text at: lastIndex).
- characterPoint _ destX @ destY.
^true].
lastIndex >= line last
+ ifTrue: [lastCharacter := (text at: line last).
+ characterPoint := destX @ destY.
- ifTrue: [lastCharacter _ (text at: line last).
- characterPoint _ destX @ destY.
^true].
"Pointing past middle of a character, return the next character."
+ lastIndex := lastIndex + 1.
+ lastCharacter := text at: lastIndex.
+ currentX := destX + lastCharacterExtent x + kern.
- lastIndex _ lastIndex + 1.
- lastCharacter _ text at: lastIndex.
- currentX _ destX + lastCharacterExtent x + kern.
self lastCharacterExtentSetX: (font widthOf: lastCharacter).
+ characterPoint := currentX @ destY.
- characterPoint _ currentX @ destY.
lastCharacter = Space ifFalse: [^ true].
"Yukky if next character is space or tab."
alignment = Justified ifTrue:
[self lastCharacterExtentSetX:
(lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))).
^ true].
true ifTrue: [^ true].
"NOTE: I find no value to the following code, and so have defeated it - DI"
"See tabForDisplay for illumination on the following awfulness."
+ leadingTab := true.
- leadingTab _ true.
line first to: lastIndex - 1 do:
+ [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]].
- [:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]].
(alignment ~= Justified or: [leadingTab])
ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX
leftMargin: leftMargin rightMargin: rightMargin) -
currentX]
ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth -
(line justifiedTabDeltaFor: spaceCount))) -
currentX) max: 0)].
^ true!
Item was changed:
----- Method: MultiCharacterBlockScanner>>endOfRun (in category 'stop conditions') -----
endOfRun
"Before arriving at the cursor location, the selection has encountered an
end of run. Answer false if the selection continues, true otherwise. Set
up indexes for building the appropriate CharacterBlock."
| runLength lineStop |
(((characterIndex ~~ nil and:
[runStopIndex < characterIndex and: [runStopIndex < text size]])
or: [characterIndex == nil and: [lastIndex < line last]]) or: [
((lastIndex < line last)
and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar)
and: [lastIndex ~= characterIndex]])])
ifTrue: ["We're really at the end of a real run."
+ runLength := (text runLengthFor: (lastIndex := lastIndex + 1)).
- runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
characterIndex ~~ nil
+ ifTrue: [lineStop := characterIndex "scanning for index"]
+ ifFalse: [lineStop := line last "scanning for point"].
+ (runStopIndex := lastIndex + (runLength - 1)) > lineStop
+ ifTrue: [runStopIndex := lineStop].
- ifTrue: [lineStop _ characterIndex "scanning for index"]
- ifFalse: [lineStop _ line last "scanning for point"].
- (runStopIndex _ lastIndex + (runLength - 1)) > lineStop
- ifTrue: [runStopIndex _ lineStop].
self setStopConditions.
^false].
+ lastCharacter := text at: lastIndex.
+ characterPoint := destX @ destY.
- lastCharacter _ text at: lastIndex.
- characterPoint _ destX @ destY.
((lastCharacter = Space and: [alignment = Justified])
or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])
+ ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent].
- ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
characterIndex ~~ nil
ifTrue: ["If scanning for an index and we've stopped on that index,
then we back destX off by the width of the character stopped on
(it will be pointing at the right side of the character) and return"
runStopIndex = characterIndex
ifTrue: [self characterPointSetX: destX - lastCharacterExtent x.
^true].
"Otherwise the requested index was greater than the length of the
string. Return string size + 1 as index, indicate further that off the
string by setting character to nil and the extent to 0."
+ lastIndex := lastIndex + 1.
+ lastCharacter := nil.
- lastIndex _ lastIndex + 1.
- lastCharacter _ nil.
self lastCharacterExtentSetX: 0.
^true].
"Scanning for a point and either off the end of the line or off the end of the string."
runStopIndex = text size
ifTrue: ["off end of string"
+ lastIndex := lastIndex + 1.
+ lastCharacter := nil.
- lastIndex _ lastIndex + 1.
- lastCharacter _ nil.
self lastCharacterExtentSetX: 0.
^true].
"just off end of line without crossing x"
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^true!
Item was changed:
----- Method: MultiCharacterBlockScanner>>indentationLevel: (in category 'scanning') -----
indentationLevel: anInteger
super indentationLevel: anInteger.
+ nextLeftMargin := leftMargin.
- nextLeftMargin _ leftMargin.
indentationLevel timesRepeat: [
+ nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin
- nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin
leftMargin: leftMargin
rightMargin: rightMargin]!
Item was changed:
----- Method: MultiCharacterBlockScanner>>lastCharacterExtentSetX: (in category 'private') -----
lastCharacterExtentSetX: xVal
+ lastCharacterExtent := xVal @ lastCharacterExtent y!
- lastCharacterExtent _ xVal @ lastCharacterExtent y!
Item was changed:
----- Method: MultiCharacterBlockScanner>>lastSpaceOrTabExtentSetX: (in category 'private') -----
lastSpaceOrTabExtentSetX: xVal
+ lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y!
- lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y!
Item was changed:
----- Method: MultiCharacterBlockScanner>>paddedSpace (in category 'stop conditions') -----
paddedSpace
"When the line is justified, the spaces will not be the same as the font's
space character. A padding of extra space must be considered in trying
to find which character the cursor is pointing at. Answer whether the
scanning has crossed the cursor."
| pad |
+ pad := 0.
+ spaceCount := spaceCount + 1.
+ pad := line justifiedPadFor: spaceCount.
+ lastSpaceOrTabExtent := lastCharacterExtent copy.
- pad _ 0.
- spaceCount _ spaceCount + 1.
- pad _ line justifiedPadFor: spaceCount.
- lastSpaceOrTabExtent _ lastCharacterExtent copy.
self lastSpaceOrTabExtentSetX: spaceWidth + pad.
(destX + lastSpaceOrTabExtent x) >= characterPoint x
+ ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy.
- ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
^self crossedX].
+ lastIndex := lastIndex + 1.
+ destX := destX + lastSpaceOrTabExtent x.
- lastIndex _ lastIndex + 1.
- destX _ destX + lastSpaceOrTabExtent x.
^ false
!
Item was changed:
----- Method: MultiCharacterBlockScanner>>placeEmbeddedObject: (in category 'scanning') -----
placeEmbeddedObject: anchoredMorph
"Workaround: The following should really use #textAnchorType"
anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
+ specialWidth := anchoredMorph width.
- specialWidth _ anchoredMorph width.
^ true!
Item was changed:
----- Method: MultiCharacterBlockScanner>>scanMultiCharactersCombiningFrom:to:in:rightX:stopConditions:kern: (in category 'scanning') -----
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| encoding f nextDestX maxAscii startEncoding char charValue |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
[lastIndex <= stopIndex] whileTrue: [
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ char := (sourceString at: lastIndex).
+ charValue := char charCode.
+ charValue > maxAscii ifTrue: [charValue := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- char _ (sourceString at: lastIndex).
- charValue _ char charCode.
- charValue > maxAscii ifTrue: [charValue _ maxAscii].
(encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [
^ stops at: charValue + 1
].
+ nextDestX := destX + (self widthOf: char inFont: font).
- nextDestX _ destX + (self widthOf: char inFont: font).
nextDestX > rightX ifTrue: [^ stops at: CrossedX].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterBlockScanner>>setFont (in category 'stop conditions') -----
setFont
+ specialWidth := nil.
- specialWidth _ nil.
super setFont!
Item was changed:
----- Method: MultiCharacterBlockScanner>>tab (in category 'stop conditions') -----
tab
| currentX |
+ currentX := (alignment == Justified and: [self leadingTab not])
- currentX _ (alignment == Justified and: [self leadingTab not])
ifTrue: "imbedded tabs in justified text are weird"
[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
ifFalse:
[textStyle
nextTabXFrom: destX
leftMargin: leftMargin
rightMargin: rightMargin].
+ lastSpaceOrTabExtent := lastCharacterExtent copy.
- lastSpaceOrTabExtent _ lastCharacterExtent copy.
self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
currentX >= characterPoint x
ifTrue:
+ [lastCharacterExtent := lastSpaceOrTabExtent copy.
- [lastCharacterExtent _ lastSpaceOrTabExtent copy.
^ self crossedX].
+ destX := currentX.
+ lastIndex := lastIndex + 1.
- destX _ currentX.
- lastIndex _ lastIndex + 1.
^false!
Item was changed:
----- Method: MultiCharacterScanner class>>initialize (in category 'class initialization') -----
initialize
"
MultiCharacterScanner initialize
"
| a |
+ a := Array new: 258.
- a _ Array new: 258.
a at: 1 + 1 put: #embeddedObject.
a at: Tab asciiValue + 1 put: #tab.
a at: CR asciiValue + 1 put: #cr.
a at: EndOfRun put: #endOfRun.
a at: CrossedX put: #crossedX.
+ NilCondition := a copy.
+ DefaultStopConditions := a copy.
- NilCondition _ a copy.
- DefaultStopConditions _ a copy.
+ PaddedSpaceCondition := a copy.
- PaddedSpaceCondition _ a copy.
PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace.
+ SpaceCondition := a copy.
- SpaceCondition _ a copy.
SpaceCondition at: Space asciiValue + 1 put: #space.
!
Item was changed:
----- Method: MultiCharacterScanner>>addEmphasis: (in category 'private') -----
addEmphasis: code
"Set the bold-ital-under-strike emphasis."
+ emphasisCode := emphasisCode bitOr: code!
- emphasisCode _ emphasisCode bitOr: code!
Item was changed:
----- Method: MultiCharacterScanner>>addKern: (in category 'private') -----
addKern: kernDelta
"Set the current kern amount."
+ kern := kern + kernDelta!
- kern _ kern + kernDelta!
Item was changed:
----- Method: MultiCharacterScanner>>basicScanCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanning') -----
basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
"Primitive. This is the inner loop of text display--but see
scanCharactersFrom: to:rightX: which would get the string,
stopConditions and displaying from the instance. March through source
String from startIndex to stopIndex. If any character is flagged with a
non-nil entry in stops, then return the corresponding value. Determine
width of each character from xTable, indexed by map.
If dextX would exceed rightX, then return stops at: 258.
Advance destX by the width of the character. If stopIndex has been
reached, then return stops at: 257. Optional.
See Object documentation whatIsAPrimitive."
| ascii nextDestX char |
<primitive: 103>
+ lastIndex := startIndex.
- lastIndex _ startIndex.
[lastIndex <= stopIndex]
whileTrue:
+ [char := (sourceString at: lastIndex).
+ ascii := char asciiValue + 1.
- [char _ (sourceString at: lastIndex).
- ascii _ char asciiValue + 1.
(stops at: ascii) == nil ifFalse: [^stops at: ascii].
"Note: The following is querying the font about the width
since the primitive may have failed due to a non-trivial
mapping of characters to glyphs or a non-existing xTable."
+ nextDestX := destX + (font widthOf: char).
- nextDestX _ destX + (font widthOf: char).
nextDestX > rightX ifTrue: [^stops at: CrossedX].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1].
+ lastIndex := stopIndex.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1].
- lastIndex _ stopIndex.
^stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>embeddedObject (in category 'scanning') -----
embeddedObject
| savedIndex |
+ savedIndex := lastIndex.
- savedIndex _ lastIndex.
text attributesAt: lastIndex do:[:attr|
attr anchoredMorph ifNotNil:[
"Following may look strange but logic gets reversed.
If the morph fits on this line we're not done (return false for true)
and if the morph won't fit we're done (return true for false)"
(self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]].
+ lastIndex := savedIndex + 1. "for multiple(!!) embedded morphs"
- lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs"
^false!
Item was changed:
----- Method: MultiCharacterScanner>>indentationLevel: (in category 'scanning') -----
indentationLevel: anInteger
"set the number of tabs to put at the beginning of each line"
+ indentationLevel := anInteger!
- indentationLevel _ anInteger!
Item was changed:
----- Method: MultiCharacterScanner>>initialize (in category 'initialize') -----
initialize
+ destX := destY := leftMargin := 0.!
- destX _ destY _ leftMargin _ 0.!
Item was changed:
----- Method: MultiCharacterScanner>>initializeFromParagraph:clippedBy: (in category 'private') -----
initializeFromParagraph: aParagraph clippedBy: clippingRectangle
+ text := aParagraph text.
+ textStyle := aParagraph textStyle.
- text _ aParagraph text.
- textStyle _ aParagraph textStyle.
!
Item was changed:
----- Method: MultiCharacterScanner>>initializeStringMeasurer (in category 'initialize') -----
initializeStringMeasurer
+ stopConditions := Array new: 258.
- stopConditions _ Array new: 258.
stopConditions at: CrossedX put: #crossedX.
stopConditions at: EndOfRun put: #endOfRun.
!
Item was changed:
----- Method: MultiCharacterScanner>>measureString:inFont:from:to: (in category 'scanning') -----
measureString: aString inFont: aFont from: startIndex to: stopIndex
"WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer"
+ destX := destY := lastIndex := 0.
+ baselineY := aFont ascent.
+ xTable := aFont xTable.
- destX _ destY _ lastIndex _ 0.
- baselineY _ aFont ascent.
- xTable _ aFont xTable.
font := aFont. " added Dec 03, 2004 "
+ " map := aFont characterToGlyphMap."
- " map _ aFont characterToGlyphMap."
self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0.
^destX!
Item was changed:
----- Method: MultiCharacterScanner>>placeEmbeddedObject: (in category 'scanning') -----
placeEmbeddedObject: anchoredMorph
"Place the anchoredMorph or return false if it cannot be placed.
In any event, advance destX by its width."
| w |
"Workaround: The following should really use #textAnchorType"
anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
+ destX := destX + (w := anchoredMorph width).
- destX _ destX + (w _ anchoredMorph width).
(destX > rightMargin and: [(leftMargin + w) <= rightMargin])
ifTrue: ["Won't fit, but would on next line"
^ false].
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
self setFont. "Force recalculation of emphasis for next run"
^ true!
Item was changed:
----- Method: MultiCharacterScanner>>plainTab (in category 'scanning') -----
plainTab
"This is the basic method of adjusting destX for a tab."
+ destX := (alignment == Justified and: [self leadingTab not])
- destX _ (alignment == Justified and: [self leadingTab not])
ifTrue: "embedded tabs in justified text are weird"
[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
ifFalse:
[textStyle nextTabXFrom: destX
leftMargin: leftMargin
rightMargin: rightMargin]!
Item was changed:
----- Method: MultiCharacterScanner>>scanCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanning') -----
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| startEncoding selector |
(sourceString isByteString) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.].
(sourceString isWideString) ifTrue: [
+ startIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ selector := EncodedCharSet scanSelectorAt: startEncoding.
- startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- selector _ EncodedCharSet scanSelectorAt: startEncoding.
^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta).
].
^ stops at: EndOfRun
!
Item was changed:
----- Method: MultiCharacterScanner>>scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanner methods') -----
scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| ascii encoding f nextDestX maxAscii startEncoding |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ "xTable := f xTable.
+ maxAscii := xTable size - 2."
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- "xTable _ f xTable.
- maxAscii _ xTable size - 2."
- spaceWidth _ f widthOf: Space.
] ifFalse: [
(font isMemberOf: HostFont) ifTrue: [
+ f := font.
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- f _ font.
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
].
[lastIndex <= stopIndex] whileTrue: [
"self halt."
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ ascii := (sourceString at: lastIndex) charCode.
+ ascii > maxAscii ifTrue: [ascii := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- ascii _ (sourceString at: lastIndex) charCode.
- ascii > maxAscii ifTrue: [ascii _ maxAscii].
(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
(self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [
self registerBreakableIndex.
].
+ nextDestX := destX + (font widthOf: (sourceString at: lastIndex)).
- nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops at: CrossedX]].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>scanMultiCharactersCombiningFrom:to:in:rightX:stopConditions:kern: (in category 'scanner methods') -----
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| charCode encoding f maxAscii startEncoding combining combined combiningIndex c |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ spaceWidth := font widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- spaceWidth _ font widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
+ spaceWidth := font widthOf: Space.
- maxAscii _ font maxAscii.
- spaceWidth _ font widthOf: Space.
].
+ combining := nil.
- combining _ nil.
[lastIndex <= stopIndex] whileTrue: [
+ charCode := (sourceString at: lastIndex) charCode.
+ c := (sourceString at: lastIndex).
- charCode _ (sourceString at: lastIndex) charCode.
- c _ (sourceString at: lastIndex).
combining ifNil: [
+ combining := CombinedChar new.
- combining _ CombinedChar new.
combining add: c.
+ combiningIndex := lastIndex.
+ lastIndex := lastIndex + 1.
- combiningIndex _ lastIndex.
- lastIndex _ lastIndex + 1.
] ifNotNil: [
(combining add: c) ifFalse: [
+ self addCharToPresentation: (combined := combining combined).
+ combining := CombinedChar new.
- self addCharToPresentation: (combined _ combining combined).
- combining _ CombinedChar new.
combining add: c.
+ charCode := combined charCode.
+ encoding := combined leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1.
- charCode _ combined charCode.
- encoding _ combined leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1.
(encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [
^ stops at: charCode + 1
] ifFalse: [
^ stops at: EndOfRun
].
].
+ charCode > maxAscii ifTrue: [charCode := maxAscii].
- charCode > maxAscii ifTrue: [charCode _ maxAscii].
""
(encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [
combining ifNotNil: [
self addCharToPresentation: (combining combined).
].
^ stops at: charCode + 1
].
(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
self registerBreakableIndex.
].
destX > rightX ifTrue: [
destX ~= firstDestX ifTrue: [
+ lastIndex := combiningIndex.
- lastIndex _ combiningIndex.
self removeLastCharFromPresentation.
^ stops at: CrossedX]].
+ combiningIndex := lastIndex.
+ lastIndex := lastIndex + 1.
- combiningIndex _ lastIndex.
- lastIndex _ lastIndex + 1.
] ifTrue: [
+ lastIndex := lastIndex + 1.
+ numOfComposition := numOfComposition + 1.
- lastIndex _ lastIndex + 1.
- numOfComposition _ numOfComposition + 1.
].
].
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
combining ifNotNil: [
+ combined := combining combined.
- combined _ combining combined.
self addCharToPresentation: combined.
"assuming that there is always enough space for at least one character".
+ destX := destX + (self widthOf: combined inFont: font).
- destX _ destX + (self widthOf: combined inFont: font).
].
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>scanMultiCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanning') -----
scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| ascii encoding f nextDestX maxAscii startEncoding |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
[lastIndex <= stopIndex] whileTrue: [
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ ascii := (sourceString at: lastIndex) charCode.
+ ascii > maxAscii ifTrue: [ascii := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- ascii _ (sourceString at: lastIndex) charCode.
- ascii > maxAscii ifTrue: [ascii _ maxAscii].
(encoding = 0 and: [ascii < stopConditions size and: [(stopConditions at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1].
(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
self registerBreakableIndex.
].
+ nextDestX := destX + (font widthOf: (sourceString at: lastIndex)).
- nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
nextDestX > rightX ifTrue: [destX ~= firstDestX ifTrue: [^ stops at: CrossedX]].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>scanMultiCharactersR2LFrom:to:in:rightX:stopConditions:kern: (in category 'scanner methods') -----
scanMultiCharactersR2LFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
"Note that 'rightX' really means 'endX' in R2L context. Ie. rightX is usually smaller than destX."
| ascii encoding f nextDestX maxAscii startEncoding |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
[lastIndex <= stopIndex] whileTrue: [
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ ascii := (sourceString at: lastIndex) charCode.
+ ascii > maxAscii ifTrue: [ascii := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- ascii _ (sourceString at: lastIndex) charCode.
- ascii > maxAscii ifTrue: [ascii _ maxAscii].
(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
self registerBreakableIndex.
].
+ nextDestX := destX - (font widthOf: (sourceString at: lastIndex)).
- nextDestX _ destX - (font widthOf: (sourceString at: lastIndex)).
nextDestX < rightX ifTrue: [^ stops at: CrossedX].
+ destX := nextDestX - kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX - kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>scanSimChineseCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanner methods') -----
scanSimChineseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| ascii encoding f nextDestX maxAscii startEncoding |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ "xTable := f xTable.
+ maxAscii := xTable size - 2."
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- "xTable _ f xTable.
- maxAscii _ xTable size - 2."
- spaceWidth _ f widthOf: Space.
] ifFalse: [
(font isMemberOf: HostFont) ifTrue: [
+ f := font.
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- f _ font.
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
].
[lastIndex <= stopIndex] whileTrue: [
"self halt."
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ ascii := (sourceString at: lastIndex) charCode.
+ ascii > maxAscii ifTrue: [ascii := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- ascii _ (sourceString at: lastIndex) charCode.
- ascii > maxAscii ifTrue: [ascii _ maxAscii].
(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
(self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [
self registerBreakableIndex.
].
+ nextDestX := destX + (font widthOf: (sourceString at: lastIndex)).
- nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops at: CrossedX]].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiCharacterScanner>>setActualFont: (in category 'private') -----
setActualFont: aFont
"Set the basal font to an isolated font reference."
+ font := aFont!
- font _ aFont!
Item was changed:
----- Method: MultiCharacterScanner>>setAlignment: (in category 'private') -----
setAlignment: style
+ alignment := style.
- alignment _ style.
!
Item was changed:
----- Method: MultiCharacterScanner>>setConditionArray: (in category 'private') -----
setConditionArray: aSymbol
+ aSymbol == #paddedSpace ifTrue: [^stopConditions := PaddedSpaceCondition "copy"].
+ "aSymbol == #space ifTrue: [^stopConditions := SpaceCondition copy]."
+ aSymbol == nil ifTrue: [^stopConditions := NilCondition "copy"].
- aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition "copy"].
- "aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy]."
- aSymbol == nil ifTrue: [^stopConditions _ NilCondition "copy"].
self error: 'undefined stopcondition for space character'.
!
Item was changed:
----- Method: MultiCharacterScanner>>setFont (in category 'private') -----
setFont
| priorFont |
"Set the font and other emphasis."
+ priorFont := font.
- priorFont _ font.
text == nil ifFalse:[
+ emphasisCode := 0.
+ kern := 0.
+ indentationLevel := 0.
+ alignment := textStyle alignment.
+ font := nil.
- emphasisCode _ 0.
- kern _ 0.
- indentationLevel _ 0.
- alignment _ textStyle alignment.
- font _ nil.
(text attributesAt: lastIndex forStyle: textStyle)
do: [:att | att emphasizeScanner: self]].
font == nil ifTrue:
[self setFont: textStyle defaultFontIndex].
+ font := font emphasized: emphasisCode.
+ priorFont ifNotNil: [destX := destX + priorFont descentKern].
+ destX := destX - font descentKern.
- font _ font emphasized: emphasisCode.
- priorFont ifNotNil: [destX _ destX + priorFont descentKern].
- destX _ destX - font descentKern.
"NOTE: next statement should be removed when clipping works"
+ leftMargin ifNotNil: [destX := destX max: leftMargin].
+ kern := kern - font baseKern.
- leftMargin ifNotNil: [destX _ destX max: leftMargin].
- kern _ kern - font baseKern.
"Install various parameters from the font."
+ spaceWidth := font widthOf: Space.
+ xTable := font xTable.
+ " map := font characterToGlyphMap."
+ stopConditions := DefaultStopConditions.!
- spaceWidth _ font widthOf: Space.
- xTable _ font xTable.
- " map _ font characterToGlyphMap."
- stopConditions _ DefaultStopConditions.!
Item was changed:
----- Method: MultiCharacterScanner>>text:textStyle: (in category 'private') -----
text: t textStyle: ts
+ text := t.
+ textStyle := ts!
- text _ t.
- textStyle _ ts!
Item was changed:
----- Method: MultiCharacterScanner>>wantsColumnBreaks: (in category 'initialize') -----
wantsColumnBreaks: aBoolean
+ wantsColumnBreaks := aBoolean!
- wantsColumnBreaks _ aBoolean!
Item was changed:
----- Method: MultiCompositionScanner>>addCharToPresentation: (in category 'multilingual scanning') -----
addCharToPresentation: char
presentation nextPut: char.
+ lastWidth := self widthOf: char inFont: font.
+ destX := destX + lastWidth.
- lastWidth _ self widthOf: char inFont: font.
- destX _ destX + lastWidth.
!
Item was changed:
----- Method: MultiCompositionScanner>>columnBreak (in category 'stop conditions') -----
columnBreak
"Answer true. Set up values for the text line interval currently being
composed."
line stop: lastIndex.
presentationLine stop: lastIndex - numOfComposition.
+ spaceX := destX.
- spaceX _ destX.
line paddingWidth: rightMargin - spaceX.
presentationLine paddingWidth: rightMargin - spaceX.
^true!
Item was changed:
----- Method: MultiCompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category 'scanning') -----
composeFrom: startIndex inRectangle: lineRectangle
firstLine: firstLine leftSide: leftSide rightSide: rightSide
"Answer an instance of TextLineInterval that represents the next line in the paragraph."
| runLength done stopCondition |
"Set up margins"
+ leftMargin := lineRectangle left.
+ leftSide ifTrue: [leftMargin := leftMargin +
- leftMargin _ lineRectangle left.
- leftSide ifTrue: [leftMargin _ leftMargin +
(firstLine ifTrue: [textStyle firstIndent]
ifFalse: [textStyle restIndent])].
+ destX := spaceX := leftMargin.
+ firstDestX := destX.
+ rightMargin := lineRectangle right.
+ rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent].
+ lastIndex := startIndex. "scanning sets last index"
+ destY := lineRectangle top.
+ lineHeight := baseline := 0. "Will be increased by setFont"
- destX _ spaceX _ leftMargin.
- firstDestX _ destX.
- rightMargin _ lineRectangle right.
- rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent].
- lastIndex _ startIndex. "scanning sets last index"
- destY _ lineRectangle top.
- lineHeight _ baseline _ 0. "Will be increased by setFont"
self setStopConditions. "also sets font"
+ runLength := text runLengthFor: startIndex.
+ runStopIndex := (lastIndex := startIndex) + (runLength - 1).
+ line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
- runLength _ text runLengthFor: startIndex.
- runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
- line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
rectangle: lineRectangle.
+ presentationLine := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
- presentationLine _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
rectangle: lineRectangle.
+ numOfComposition := 0.
+ spaceCount := 0.
- numOfComposition _ 0.
- spaceCount _ 0.
self handleIndentation.
+ leftMargin := destX.
- leftMargin _ destX.
line leftMargin: leftMargin.
presentationLine leftMargin: leftMargin.
+ presentation := TextStream on: (Text fromString: (WideString new: text size)).
- presentation _ TextStream on: (Text fromString: (WideString new: text size)).
+ done := false.
- done _ false.
[done]
whileFalse:
+ [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
- [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
in: text string rightX: rightMargin stopConditions: stopConditions
kern: kern.
"See setStopConditions for stopping conditions for composing."
(self perform: stopCondition)
ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading
baseline: baseline + textStyle leading.
^ line lineHeight: lineHeight + textStyle leading
baseline: baseline + textStyle leading]]!
Item was changed:
----- Method: MultiCompositionScanner>>composeLine:fromCharacterIndex:inParagraph: (in category 'scanning') -----
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph
"Answer an instance of TextLineInterval that represents the next line in the paragraph."
| runLength done stopCondition |
+ destX := spaceX := leftMargin := aParagraph leftMarginForCompositionForLine: lineIndex.
+ destY := 0.
+ rightMargin := aParagraph rightMarginForComposition.
- destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
- destY _ 0.
- rightMargin _ aParagraph rightMarginForComposition.
leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
+ lastIndex := startIndex. "scanning sets last index"
+ lineHeight := textStyle lineGrid. "may be increased by setFont:..."
+ baseline := textStyle baseline.
+ baselineY := destY + baseline.
- lastIndex _ startIndex. "scanning sets last index"
- lineHeight _ textStyle lineGrid. "may be increased by setFont:..."
- baseline _ textStyle baseline.
- baselineY _ destY + baseline.
self setStopConditions. "also sets font"
self handleIndentation.
+ runLength := text runLengthFor: startIndex.
+ runStopIndex := (lastIndex := startIndex) + (runLength - 1).
+ line := TextLineInterval
- runLength _ text runLengthFor: startIndex.
- runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
- line _ TextLineInterval
start: lastIndex
stop: 0
internalSpaces: 0
paddingWidth: 0.
+ presentationLine := TextLineInterval
- presentationLine _ TextLineInterval
start: lastIndex
stop: 0
internalSpaces: 0
paddingWidth: 0.
+ numOfComposition := 0.
+ presentation := TextStream on: (Text fromString: (WideString new: text size)).
+ spaceCount := 0.
+ done := false.
- numOfComposition _ 0.
- presentation _ TextStream on: (Text fromString: (WideString new: text size)).
- spaceCount _ 0.
- done _ false.
[done]
whileFalse:
+ [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
- [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
in: text string rightX: rightMargin stopConditions: stopConditions
kern: kern.
"See setStopConditions for stopping conditions for composing."
(self perform: stopCondition)
ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading
baseline: baseline + textStyle leading.
^line lineHeight: lineHeight + textStyle leading
baseline: baseline + textStyle leading]]!
Item was changed:
----- Method: MultiCompositionScanner>>cr (in category 'stop conditions') -----
cr
"Answer true. Set up values for the text line interval currently being
composed."
line stop: lastIndex.
presentationLine stop: lastIndex - numOfComposition.
+ spaceX := destX.
- spaceX _ destX.
line paddingWidth: rightMargin - spaceX.
presentationLine paddingWidth: rightMargin - spaceX.
^true!
Item was changed:
----- Method: MultiCompositionScanner>>crossedX (in category 'stop conditions') -----
crossedX
"There is a word that has fallen across the right edge of the composition
rectangle. This signals the need for wrapping which is done to the last
space that was encountered, as recorded by the space stop condition."
(breakAtSpace) ifTrue: [
spaceCount >= 1 ifTrue:
["The common case. First back off to the space at which we wrap."
line stop: breakableIndex.
presentationLine stop: breakableIndex - numOfComposition.
+ lineHeight := lineHeightAtBreak.
+ baseline := baselineAtBreak.
+ spaceCount := spaceCount - 1.
+ breakableIndex := breakableIndex - 1.
- lineHeight _ lineHeightAtBreak.
- baseline _ baselineAtBreak.
- spaceCount _ spaceCount - 1.
- breakableIndex _ breakableIndex - 1.
"Check to see if any spaces preceding the one at which we wrap.
Double space after punctuation, most likely."
[(spaceCount > 1 and: [(text at: breakableIndex) = Space])]
whileTrue:
+ [spaceCount := spaceCount - 1.
- [spaceCount _ spaceCount - 1.
"Account for backing over a run which might
change width of space."
+ font := text fontAt: breakableIndex withStyle: textStyle.
+ breakableIndex := breakableIndex - 1.
+ spaceX := spaceX - (font widthOf: Space)].
- font _ text fontAt: breakableIndex withStyle: textStyle.
- breakableIndex _ breakableIndex - 1.
- spaceX _ spaceX - (font widthOf: Space)].
line paddingWidth: rightMargin - spaceX.
presentationLine paddingWidth: rightMargin - spaceX.
presentationLine internalSpaces: spaceCount.
line internalSpaces: spaceCount]
ifFalse:
["Neither internal nor trailing spaces -- almost never happens."
+ lastIndex := lastIndex - 1.
- lastIndex _ lastIndex - 1.
[destX <= rightMargin]
whileFalse:
+ [destX := destX - (font widthOf: (text at: lastIndex)).
+ lastIndex := lastIndex - 1].
+ spaceX := destX.
- [destX _ destX - (font widthOf: (text at: lastIndex)).
- lastIndex _ lastIndex - 1].
- spaceX _ destX.
line paddingWidth: rightMargin - destX.
presentationLine paddingWidth: rightMargin - destX.
presentationLine stop: (lastIndex max: line first).
line stop: (lastIndex max: line first)].
^true
].
(breakableIndex isNil or: [breakableIndex < line first]) ifTrue: [
"Any breakable point in this line. Just wrap last character."
+ breakableIndex := lastIndex - 1.
+ lineHeightAtBreak := lineHeight.
+ baselineAtBreak := baseline.
- breakableIndex _ lastIndex - 1.
- lineHeightAtBreak _ lineHeight.
- baselineAtBreak _ baseline.
].
"It wasn't a space, but anyway this is where we break the line."
line stop: breakableIndex.
presentationLine stop: breakableIndex.
+ lineHeight := lineHeightAtBreak.
+ baseline := baselineAtBreak.
- lineHeight _ lineHeightAtBreak.
- baseline _ baselineAtBreak.
^ true.
!
Item was changed:
----- Method: MultiCompositionScanner>>endOfRun (in category 'stop conditions') -----
endOfRun
"Answer true if scanning has reached the end of the paragraph.
Otherwise step conditions (mostly install potential new font) and answer
false."
| runLength |
lastIndex = text size
ifTrue: [line stop: lastIndex.
presentationLine stop: lastIndex - numOfComposition.
+ spaceX := destX.
- spaceX _ destX.
line paddingWidth: rightMargin - destX.
presentationLine paddingWidth: rightMargin - destX.
^true]
ifFalse: [
+ "(text at: lastIndex) charCode = 32 ifTrue: [destX := destX + spaceWidth]."
+ runLength := (text runLengthFor: (lastIndex := lastIndex + 1)).
+ runStopIndex := lastIndex + (runLength - 1).
- "(text at: lastIndex) charCode = 32 ifTrue: [destX _ destX + spaceWidth]."
- runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
- runStopIndex _ lastIndex + (runLength - 1).
self setStopConditions.
^false]
!
Item was changed:
----- Method: MultiCompositionScanner>>placeEmbeddedObject: (in category 'stop conditions') -----
placeEmbeddedObject: anchoredMorph
| descent |
"Workaround: The following should really use #textAnchorType"
anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
(super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit"
"But if it's the first character then leave it here"
lastIndex < line first ifFalse:[
line stop: lastIndex-1.
^ false]].
+ descent := lineHeight - baseline.
+ lineHeight := lineHeight max: anchoredMorph height.
+ baseline := lineHeight - descent.
- descent _ lineHeight - baseline.
- lineHeight _ lineHeight max: anchoredMorph height.
- baseline _ lineHeight - descent.
line stop: lastIndex.
presentationLine stop: lastIndex - numOfComposition.
^ true!
Item was changed:
----- Method: MultiCompositionScanner>>registerBreakableIndex (in category 'multilingual scanning') -----
registerBreakableIndex
"Record left x and character index of the line-wrappable point.
Used for wrap-around. Answer whether the character has crossed the
right edge of the composition rectangle of the paragraph."
(text at: lastIndex) = Character space ifTrue: [
+ breakAtSpace := true.
+ spaceX := destX.
+ spaceCount := spaceCount + 1.
+ lineHeightAtBreak := lineHeight.
+ baselineAtBreak := baseline.
+ breakableIndex := lastIndex.
- breakAtSpace _ true.
- spaceX _ destX.
- spaceCount _ spaceCount + 1.
- lineHeightAtBreak _ lineHeight.
- baselineAtBreak _ baseline.
- breakableIndex _ lastIndex.
destX > rightMargin ifTrue: [^self crossedX].
] ifFalse: [
+ breakAtSpace := false.
+ lineHeightAtBreak := lineHeight.
+ baselineAtBreak := baseline.
+ breakableIndex := lastIndex - 1.
- breakAtSpace _ false.
- lineHeightAtBreak _ lineHeight.
- baselineAtBreak _ baseline.
- breakableIndex _ lastIndex - 1.
].
^ false.
!
Item was changed:
----- Method: MultiCompositionScanner>>removeLastCharFromPresentation (in category 'multilingual scanning') -----
removeLastCharFromPresentation
presentation ifNotNil: [
presentation position: presentation position - 1.
].
+ destX := destX - lastWidth.
- destX _ destX - lastWidth.
!
Item was changed:
----- Method: MultiCompositionScanner>>setActualFont: (in category 'scanning') -----
setActualFont: aFont
"Keep track of max height and ascent for auto lineheight"
| descent |
super setActualFont: aFont.
"' ', lastIndex printString, ' ' displayAt: (lastIndex * 15)@0."
lineHeight == nil
+ ifTrue: [descent := font descent.
+ baseline := font ascent.
+ lineHeight := baseline + descent]
+ ifFalse: [descent := lineHeight - baseline max: font descent.
+ baseline := baseline max: font ascent.
+ lineHeight := lineHeight max: baseline + descent]!
- ifTrue: [descent _ font descent.
- baseline _ font ascent.
- lineHeight _ baseline + descent]
- ifFalse: [descent _ lineHeight - baseline max: font descent.
- baseline _ baseline max: font ascent.
- lineHeight _ lineHeight max: baseline + descent]!
Item was changed:
----- Method: MultiCompositionScanner>>setFont (in category 'stop conditions') -----
setFont
super setFont.
+ breakAtSpace := false.
- breakAtSpace _ false.
wantsColumnBreaks == true ifTrue: [
+ stopConditions := stopConditions copy.
- stopConditions _ stopConditions copy.
stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak.
].
!
Item was changed:
----- Method: MultiCompositionScanner>>tab (in category 'stop conditions') -----
tab
"Advance destination x according to tab settings in the paragraph's
textStyle. Answer whether the character has crossed the right edge of
the composition rectangle of the paragraph."
+ destX := textStyle
- destX _ textStyle
nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin.
destX > rightMargin ifTrue: [^self crossedX].
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^false
!
Item was changed:
----- Method: MultiDisplayScanner>>cr (in category 'stop conditions') -----
cr
"When a carriage return is encountered, simply increment the pointer
into the paragraph."
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^false!
Item was changed:
----- Method: MultiDisplayScanner>>displayLines:in:clippedBy: (in category 'MVC-compatibility') -----
displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle
"The central display routine. The call on the primitive
(scanCharactersFrom:to:in:rightX:) will be interrupted according to an
array of stop conditions passed to the scanner at which time the code to
handle the stop condition is run and the call on the primitive continued
until a stop condition returns true (which means the line has
terminated)."
| runLength done stopCondition leftInRun startIndex string lastPos |
"leftInRun is the # of characters left to scan in the current run;
when 0, it is time to call 'self setStopConditions'"
+ morphicOffset := 0 at 0.
+ leftInRun := 0.
- morphicOffset _ 0 at 0.
- leftInRun _ 0.
self initializeFromParagraph: aParagraph clippedBy: visibleRectangle.
+ ignoreColorChanges := false.
+ paragraph := aParagraph.
+ foregroundColor := paragraphColor := aParagraph foregroundColor.
+ backgroundColor := aParagraph backgroundColor.
- ignoreColorChanges _ false.
- paragraph _ aParagraph.
- foregroundColor _ paragraphColor _ aParagraph foregroundColor.
- backgroundColor _ aParagraph backgroundColor.
aParagraph backgroundColor isTransparent
+ ifTrue: [fillBlt := nil]
+ ifFalse: [fillBlt := bitBlt copy. "Blt to fill spaces, tabs, margins"
- ifTrue: [fillBlt _ nil]
- ifFalse: [fillBlt _ bitBlt copy. "Blt to fill spaces, tabs, margins"
fillBlt sourceForm: nil; sourceOrigin: 0 at 0.
fillBlt fillColor: aParagraph backgroundColor].
+ rightMargin := aParagraph rightMarginForDisplay.
+ lineY := aParagraph topAtLineIndex: linesInterval first.
- rightMargin _ aParagraph rightMarginForDisplay.
- lineY _ aParagraph topAtLineIndex: linesInterval first.
bitBlt destForm deferUpdatesIn: visibleRectangle while: [
linesInterval do:
[:lineIndex |
+ leftMargin := aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]).
+ destX := (runX := leftMargin).
+ line := aParagraph lines at: lineIndex.
+ lineHeight := line lineHeight.
- leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]).
- destX _ (runX _ leftMargin).
- line _ aParagraph lines at: lineIndex.
- lineHeight _ line lineHeight.
fillBlt == nil ifFalse:
[fillBlt destX: visibleRectangle left destY: lineY
width: visibleRectangle width height: lineHeight; copyBits].
+ lastIndex := line first.
- lastIndex _ line first.
leftInRun <= 0
ifTrue: [self setStopConditions. "also sets the font"
+ leftInRun := text runLengthFor: line first].
+ baselineY := lineY + line baseline.
+ destY := baselineY - font ascent. "Should have happened in setFont"
+ runLength := leftInRun.
+ runStopIndex := lastIndex + (runLength - 1) min: line last.
+ leftInRun := leftInRun - (runStopIndex - lastIndex + 1).
+ spaceCount := 0.
+ done := false.
+ string := text string.
- leftInRun _ text runLengthFor: line first].
- baselineY _ lineY + line baseline.
- destY _ baselineY - font ascent. "Should have happened in setFont"
- runLength _ leftInRun.
- runStopIndex _ lastIndex + (runLength - 1) min: line last.
- leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).
- spaceCount _ 0.
- done _ false.
- string _ text string.
self handleIndentation.
[done] whileFalse:[
+ startIndex := lastIndex.
+ lastPos := destX at destY.
+ stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
- startIndex _ lastIndex.
- lastPos _ destX at destY.
- stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
in: string rightX: rightMargin stopConditions: stopConditions
kern: kern.
lastIndex >= startIndex ifTrue:[
font displayString: string on: bitBlt
from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY].
"see setStopConditions for stopping conditions for displaying."
+ done := self perform: stopCondition].
- done _ self perform: stopCondition].
fillBlt == nil ifFalse:
[fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits].
+ lineY := lineY + lineHeight]]!
- lineY _ lineY + lineHeight]]!
Item was changed:
----- Method: MultiDisplayScanner>>endOfRun (in category 'stop conditions') -----
endOfRun
"The end of a run in the display case either means that there is actually
a change in the style (run code) to be associated with the string or the
end of this line has been reached."
| runLength |
lastIndex = line last ifTrue: [^true].
+ runX := destX.
+ runLength := text runLengthFor: (lastIndex := lastIndex + 1).
+ runStopIndex := lastIndex + (runLength - 1) min: line last.
- runX _ destX.
- runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
- runStopIndex _ lastIndex + (runLength - 1) min: line last.
self setStopConditions.
^ false!
Item was changed:
----- Method: MultiDisplayScanner>>initializeFromParagraph:clippedBy: (in category 'MVC-compatibility') -----
initializeFromParagraph: aParagraph clippedBy: clippingRectangle
super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
+ bitBlt := BitBlt asGrafPort toForm: aParagraph destinationForm.
- bitBlt _ BitBlt asGrafPort toForm: aParagraph destinationForm.
bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail"
bitBlt combinationRule: Form paint.
bitBlt colorMap:
(Bitmap with: 0 "Assumes 1-bit deep fonts"
with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)).
bitBlt clipRect: clippingRectangle.
!
Item was changed:
----- Method: MultiDisplayScanner>>paddedSpace (in category 'stop conditions') -----
paddedSpace
"Each space is a stop condition when the alignment is right justified.
Padding must be added to the base width of the space according to
which space in the line this space is and according to the amount of
space that remained at the end of the line when it was composed."
+ spaceCount := spaceCount + 1.
+ destX := destX + spaceWidth + (line justifiedPadFor: spaceCount).
+ lastIndex := lastIndex + 1.
- spaceCount _ spaceCount + 1.
- destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
- lastIndex _ lastIndex + 1.
^ false!
Item was changed:
----- Method: MultiDisplayScanner>>placeEmbeddedObject: (in category 'scanning') -----
placeEmbeddedObject: anchoredMorph
anchoredMorph relativeTextAnchorPosition ifNotNil:[
anchoredMorph position:
anchoredMorph relativeTextAnchorPosition +
(anchoredMorph owner textBounds origin x @ 0)
- (0 at morphicOffset y) + (0 at lineY).
^true
].
(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
anchoredMorph isMorph ifTrue: [
anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset
] ifFalse: [
+ destY := lineY.
+ baselineY := lineY + anchoredMorph height..
+ runX := destX.
- destY _ lineY.
- baselineY _ lineY + anchoredMorph height..
- runX _ destX.
anchoredMorph
displayOn: bitBlt destForm
at: destX - anchoredMorph width @ destY
clippingBox: bitBlt clipRect
].
^ true!
Item was changed:
----- Method: MultiDisplayScanner>>plainTab (in category 'stop conditions') -----
plainTab
| oldX |
+ oldX := destX.
- oldX _ destX.
super plainTab.
fillBlt == nil ifFalse:
[fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]!
Item was changed:
----- Method: MultiDisplayScanner>>presentationText: (in category 'private') -----
presentationText: t
+ text := t.
- text _ t.
!
Item was changed:
----- Method: MultiDisplayScanner>>scanMultiCharactersCombiningFrom:to:in:rightX:stopConditions:kern: (in category 'multilingual scanning') -----
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
| encoding f nextDestX maxAscii startEncoding char charValue |
+ lastIndex := startIndex.
+ lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun].
+ startEncoding := (sourceString at: startIndex) leadingChar.
+ font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
- lastIndex _ startIndex.
- lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
- startEncoding _ (sourceString at: startIndex) leadingChar.
- font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
+ [f := font fontArray at: startEncoding + 1]
+ on: Exception do: [:ex | f := font fontArray at: 1].
+ f ifNil: [ f := font fontArray at: 1].
+ maxAscii := f maxAscii.
+ spaceWidth := f widthOf: Space.
- [f _ font fontArray at: startEncoding + 1]
- on: Exception do: [:ex | f _ font fontArray at: 1].
- f ifNil: [ f _ font fontArray at: 1].
- maxAscii _ f maxAscii.
- spaceWidth _ f widthOf: Space.
] ifFalse: [
+ maxAscii := font maxAscii.
- maxAscii _ font maxAscii.
].
[lastIndex <= stopIndex] whileTrue: [
+ encoding := (sourceString at: lastIndex) leadingChar.
+ encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun].
+ char := (sourceString at: lastIndex).
+ charValue := char charCode.
+ charValue > maxAscii ifTrue: [charValue := maxAscii].
- encoding _ (sourceString at: lastIndex) leadingChar.
- encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
- char _ (sourceString at: lastIndex).
- charValue _ char charCode.
- charValue > maxAscii ifTrue: [charValue _ maxAscii].
(encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [
^ stops at: charValue + 1
].
+ nextDestX := destX + (self widthOf: char inFont: font).
- nextDestX _ destX + (self widthOf: char inFont: font).
nextDestX > rightX ifTrue: [^ stops at: CrossedX].
+ destX := nextDestX + kernDelta.
+ lastIndex := lastIndex + 1.
- destX _ nextDestX + kernDelta.
- lastIndex _ lastIndex + 1.
].
+ lastIndex := stopIndex.
- lastIndex _ stopIndex.
^ stops at: EndOfRun!
Item was changed:
----- Method: MultiDisplayScanner>>setFont (in category 'private') -----
setFont
+ foregroundColor := paragraphColor.
- foregroundColor _ paragraphColor.
super setFont. "Sets font and emphasis bits, and maybe foregroundColor"
font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent.
text ifNotNil:[
+ baselineY := lineY + line baseline.
+ destY := baselineY - font ascent].
- baselineY _ lineY + line baseline.
- destY _ baselineY - font ascent].
!
Item was changed:
----- Method: MultiDisplayScanner>>setPort: (in category 'private') -----
setPort: aBitBlt
"Install the BitBlt to use"
+ bitBlt := aBitBlt.
- bitBlt _ aBitBlt.
bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail"
bitBlt sourceForm: nil. "Make sure font installation won't be confused"
!
Item was changed:
----- Method: MultiDisplayScanner>>setStopConditions (in category 'stop conditions') -----
setStopConditions
"Set the font and the stop conditions for the current run."
self setFont.
self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).
"
alignment = Justified ifTrue: [
stopConditions == DefaultStopConditions
+ ifTrue:[stopConditions := stopConditions copy].
- ifTrue:[stopConditions _ stopConditions copy].
stopConditions at: Space asciiValue + 1 put: #paddedSpace]
"!
Item was changed:
----- Method: MultiDisplayScanner>>tab (in category 'stop conditions') -----
tab
self plainTab.
+ lastIndex := lastIndex + 1.
- lastIndex _ lastIndex + 1.
^ false!
Item was changed:
----- Method: MultiDisplayScanner>>text:textStyle:foreground:background:fillBlt:ignoreColorChanges: (in category 'private') -----
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
+ text := t.
+ textStyle := ts.
+ foregroundColor := paragraphColor := foreColor.
+ (backgroundColor := backColor) isTransparent ifFalse:
+ [fillBlt := blt.
- text _ t.
- textStyle _ ts.
- foregroundColor _ paragraphColor _ foreColor.
- (backgroundColor _ backColor) isTransparent ifFalse:
- [fillBlt _ blt.
fillBlt fillColor: backgroundColor].
+ ignoreColorChanges := shadowMode!
- ignoreColorChanges _ shadowMode!
Item was changed:
----- Method: MultiDisplayScanner>>textColor: (in category 'private') -----
textColor: textColor
ignoreColorChanges ifTrue: [^ self].
+ foregroundColor := textColor!
- foregroundColor _ textColor!
Item was changed:
----- Method: MultiNewParagraph>>displayOn:using:at: (in category 'fonts-display') -----
displayOn: aCanvas using: displayScanner at: somePosition
"Send all visible lines to the displayScanner for display"
| visibleRectangle offset leftInRun line |
+ visibleRectangle := aCanvas clipRect.
+ offset := somePosition - positionWhenComposed.
+ leftInRun := 0.
- visibleRectangle _ aCanvas clipRect.
- offset _ somePosition - positionWhenComposed.
- leftInRun _ 0.
(self lineIndexForPoint: visibleRectangle topLeft)
to: (self lineIndexForPoint: visibleRectangle bottomRight)
+ do: [:i | line := lines at: i.
- do: [:i | line _ lines at: i.
self displaySelectionInLine: line on: aCanvas.
line first <= line last ifTrue:
+ [leftInRun := displayScanner displayLine: line
- [leftInRun _ displayScanner displayLine: line
offset: offset leftInRun: leftInRun]].
!
Item was changed:
----- Method: MultiNewParagraph>>displayOnTest:using:at: (in category 'fonts-display') -----
displayOnTest: aCanvas using: displayScanner at: somePosition
"Send all visible lines to the displayScanner for display"
| visibleRectangle offset leftInRun line |
(presentationText isNil or: [presentationLines isNil]) ifTrue: [
^ self displayOn: aCanvas using: displayScanner at: somePosition.
].
+ visibleRectangle := aCanvas clipRect.
+ offset := somePosition - positionWhenComposed.
+ leftInRun := 0.
- visibleRectangle _ aCanvas clipRect.
- offset _ somePosition - positionWhenComposed.
- leftInRun _ 0.
(self lineIndexForPoint: visibleRectangle topLeft)
to: (self lineIndexForPoint: visibleRectangle bottomRight)
+ do: [:i | line := presentationLines at: i.
- do: [:i | line _ presentationLines at: i.
self displaySelectionInLine: line on: aCanvas.
line first <= line last ifTrue:
+ [leftInRun := displayScanner displayLine: line
- [leftInRun _ displayScanner displayLine: line
offset: offset leftInRun: leftInRun]].
!
Item was changed:
----- Method: MultiNewParagraph>>multiComposeLinesFrom:to:delta:into:priorLines:atY: (in category 'composition') -----
multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
atY: startingY
"While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"
| newResult composer presentationInfo |
+ composer := MultiTextComposer new.
+ presentationLines := nil.
+ presentationText := nil.
+ newResult := composer
- composer _ MultiTextComposer new.
- presentationLines _ nil.
- presentationText _ nil.
- newResult _ composer
multiComposeLinesFrom: start
to: stop
delta: delta
into: lineColl
priorLines: priorLines
atY: startingY
textStyle: textStyle
text: text
container: container
wantsColumnBreaks: wantsColumnBreaks == true.
+ lines := newResult first asArray.
+ maxRightX := newResult second.
+ presentationInfo := composer getPresentationInfo.
+ presentationLines := presentationInfo first asArray.
+ presentationText := presentationInfo second.
- lines _ newResult first asArray.
- maxRightX _ newResult second.
- presentationInfo _ composer getPresentationInfo.
- presentationLines _ presentationInfo first asArray.
- presentationText _ presentationInfo second.
"maxRightX printString displayAt: 0 at 0."
^maxRightX
!
Item was changed:
----- Method: MultiTextComposer>>composeEachRectangleIn: (in category 'as yet unclassified') -----
composeEachRectangleIn: rectangles
| myLine lastChar |
1 to: rectangles size do: [:i |
currCharIndex <= theText size ifFalse: [^false].
+ myLine := scanner
- myLine _ scanner
composeFrom: currCharIndex
inRectangle: (rectangles at: i)
firstLine: isFirstLine
leftSide: i=1
rightSide: i=rectangles size.
lines addLast: myLine.
presentationLines addLast: scanner getPresentationLine.
+ presentation ifNil: [presentation := scanner getPresentation]
+ ifNotNil: [presentation := presentation, scanner getPresentation].
+ actualHeight := actualHeight max: myLine lineHeight. "includes font changes"
+ currCharIndex := myLine last + 1.
+ lastChar := theText at: myLine last.
- presentation ifNil: [presentation _ scanner getPresentation]
- ifNotNil: [presentation _ presentation, scanner getPresentation].
- actualHeight _ actualHeight max: myLine lineHeight. "includes font changes"
- currCharIndex _ myLine last + 1.
- lastChar _ theText at: myLine last.
lastChar = Character cr ifTrue: [^#cr].
wantsColumnBreaks ifTrue: [
lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak].
].
].
^false!
Item was changed:
----- Method: MultiTextComposer>>multiComposeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:wantsColumnBreaks: (in category 'as yet unclassified') -----
multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks
+ wantsColumnBreaks := argWantsColumnBreaks.
+ lines := argLinesCollection.
+ presentationLines := argLinesCollection copy.
+ theTextStyle := argTextStyle.
+ theText := argText.
+ theContainer := argContainer.
+ deltaCharIndex := argDelta.
+ currCharIndex := startCharIndex := argStart.
+ stopCharIndex := argStop.
+ prevLines := argPriorLines.
+ currentY := argStartY.
+ defaultLineHeight := theTextStyle lineGrid.
+ maxRightX := theContainer left.
+ possibleSlide := stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle].
+ nowSliding := false.
+ prevIndex := 1.
+ scanner := MultiCompositionScanner new text: theText textStyle: theTextStyle.
- wantsColumnBreaks _ argWantsColumnBreaks.
- lines _ argLinesCollection.
- presentationLines _ argLinesCollection copy.
- theTextStyle _ argTextStyle.
- theText _ argText.
- theContainer _ argContainer.
- deltaCharIndex _ argDelta.
- currCharIndex _ startCharIndex _ argStart.
- stopCharIndex _ argStop.
- prevLines _ argPriorLines.
- currentY _ argStartY.
- defaultLineHeight _ theTextStyle lineGrid.
- maxRightX _ theContainer left.
- possibleSlide _ stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle].
- nowSliding _ false.
- prevIndex _ 1.
- scanner _ MultiCompositionScanner new text: theText textStyle: theTextStyle.
scanner wantsColumnBreaks: wantsColumnBreaks.
+ isFirstLine := true.
- isFirstLine _ true.
self composeAllLines.
isFirstLine ifTrue: ["No space in container or empty text"
self
addNullLineWithIndex: startCharIndex
andRectangle: (theContainer topLeft extent: 0 at defaultLineHeight)
] ifFalse: [
self fixupLastLineIfCR
].
^{lines asArray. maxRightX}
!
Item was changed:
----- Method: MultiuserTinyPaint class>>initialize (in category 'class initialization') -----
initialize
"MultiuserTinyPaint initialize"
"indices into the state array for a given hand"
+ PenIndex := 1.
+ PenSizeIndex := 2.
+ PenColorIndex := 3.
+ LastMouseIndex := 4.
- PenIndex _ 1.
- PenSizeIndex _ 2.
- PenColorIndex _ 3.
- LastMouseIndex _ 4.
!
Item was changed:
----- Method: MultiuserTinyPaint>>brushColor:hand: (in category 'menu') -----
brushColor: aColor hand: hand
| state |
(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
+ state := drawState at: hand.
- state _ drawState at: hand.
(state at: PenIndex) color: aColor.
state at: PenColorIndex put: aColor.
!
Item was changed:
----- Method: MultiuserTinyPaint>>clear (in category 'menu') -----
clear
| newPen |
self form: ((Form extent: 400 at 300 depth: 8) fillColor: color).
drawState do: [:state |
+ newPen := Pen newOnForm: originalForm.
- newPen _ Pen newOnForm: originalForm.
newPen roundNib: (state at: PenSizeIndex).
newPen color: (state at: PenColorIndex).
state at: PenIndex put: newPen].
!
Item was changed:
----- Method: MultiuserTinyPaint>>createDrawStateFor: (in category 'private') -----
createDrawStateFor: aHand
| pen state |
+ pen := Pen newOnForm: originalForm.
+ state := Array new: 4.
- pen _ Pen newOnForm: originalForm.
- state _ Array new: 4.
state at: PenIndex put: pen.
state at: PenSizeIndex put: 3.
state at: PenColorIndex put: Color red.
state at: LastMouseIndex put: nil.
drawState at: aHand put: state.
!
Item was changed:
----- Method: MultiuserTinyPaint>>fill: (in category 'menu') -----
fill: evt
| state fillPt |
(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
+ state := drawState at: evt hand.
- state _ drawState at: evt hand.
Cursor blank show.
Cursor crossHair showWhile:
+ [fillPt := Sensor waitButton - self position].
- [fillPt _ Sensor waitButton - self position].
originalForm shapeFill: (state at: PenColorIndex) interiorPoint: fillPt.
self changed.
!
Item was changed:
----- Method: MultiuserTinyPaint>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ drawState := IdentityDictionary new.
- drawState _ IdentityDictionary new.
self clear!
Item was changed:
----- Method: MultiuserTinyPaint>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| state |
(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
+ state := drawState at: evt hand.
- state _ drawState at: evt hand.
state at: LastMouseIndex put: evt cursorPoint.
!
Item was changed:
----- Method: MultiuserTinyPaint>>mouseMove: (in category 'event handling') -----
mouseMove: evt
| state lastP p pen |
+ state := drawState at: evt hand ifAbsent: [^ self].
+ lastP := state at: LastMouseIndex.
+ p := evt cursorPoint.
- state _ drawState at: evt hand ifAbsent: [^ self].
- lastP _ state at: LastMouseIndex.
- p _ evt cursorPoint.
p = lastP ifTrue: [^ self].
+ pen := state at: PenIndex.
- pen _ state at: PenIndex.
pen drawFrom: lastP - bounds origin to: p - bounds origin.
self invalidRect: (
((lastP min: p) - pen sourceForm extent) corner:
((lastP max: p) + pen sourceForm extent)).
state at: LastMouseIndex put: p.
!
Item was changed:
----- Method: MultiuserTinyPaint>>penSize:hand: (in category 'menu') -----
penSize: anInteger hand: hand
| state |
(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
+ state := drawState at: hand.
- state _ drawState at: hand.
state at: PenSizeIndex put: anInteger.
(state at: PenIndex) roundNib: anInteger.
!
Item was changed:
----- Method: MultiuserTinyPaint>>setPenColor: (in category 'menu') -----
setPenColor: evt
| state |
(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
+ state := drawState at: evt hand.
- state _ drawState at: evt hand.
self changeColorTarget: self selector: #brushColor:hand: originalColor: (state at: PenColorIndex) hand: evt hand!
Item was changed:
----- Method: MultiuserTinyPaint>>setPenSize: (in category 'menu') -----
setPenSize: evt
| menu sizes |
+ menu := MenuMorph new.
+ sizes := (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
- menu _ MenuMorph new.
- sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
sizes do: [:w |
menu add: w printString
target: self
selector: #penSize:hand:
argumentList: (Array with: w with: evt hand)].
menu popUpEvent: evt in: self world!
Item was changed:
----- Method: NewWorldWindow>>addMorph:frame: (in category 'panes') -----
addMorph: aMorph frame: relFrame
| cc |
+ cc := aMorph color.
- cc _ aMorph color.
super addMorph: aMorph frame: relFrame.
aMorph color: cc.!
Item was changed:
----- Method: NewWorldWindow>>openInWorld: (in category 'initialization') -----
openInWorld: aWorld
| xxx |
"This msg and its callees result in the window being activeOnlyOnTop"
+ xxx := RealEstateAgent initialFrameFor: self world: aWorld.
- xxx _ RealEstateAgent initialFrameFor: self world: aWorld.
"Bob say: 'opening in ',xxx printString,' out of ',aWorld bounds printString.
6 timesRepeat: [Display flash: xxx andWait: 300]."
self bounds: xxx.
^self openAsIsIn: aWorld.!
Item was changed:
----- Method: NewWorldWindow>>setStripeColorsFrom: (in category 'label') -----
setStripeColorsFrom: paneColor
"Since our world may be *any* color, try to avoid really dark colors so title will show"
| revisedColor |
stripes ifNil: [^ self].
+ revisedColor := paneColor atLeastAsLuminentAs: 0.1 .
- revisedColor _ paneColor atLeastAsLuminentAs: 0.1 .
self isActive ifTrue:
[stripes second
color: revisedColor;
borderColor: stripes second color darker.
stripes first
color: stripes second borderColor darker;
borderColor: stripes first color darker.
^ self].
"This could be much faster"
stripes second
color: revisedColor;
borderColor: revisedColor.
stripes first
color: revisedColor;
borderColor: revisedColor!
Item was changed:
----- Method: NewWorldWindow>>setWindowColor: (in category 'color') -----
setWindowColor: incomingColor
| existingColor aColor |
incomingColor ifNil: [^ self]. "it happens"
+ aColor := incomingColor asNontranslucentColor.
- aColor _ incomingColor asNontranslucentColor.
(aColor = ColorPickerMorph perniciousBorderColor
or: [aColor = Color black]) ifTrue: [^ self].
+ existingColor := self paneColorToUse.
- existingColor _ self paneColorToUse.
existingColor ifNil: [^ Beeper beep].
self setStripeColorsFrom: aColor
!
Item was changed:
----- Method: NewWorldWindow>>spawnReframeHandle: (in category 'resize/collapse') -----
spawnReframeHandle: event
"The mouse has crossed a pane border. Spawn a reframe handle."
| resizer localPt pt ptName newBounds |
allowReframeHandles ifFalse: [^ self].
owner ifNil: [^ self "Spurious mouseLeave due to delete"].
(self isActive not or: [self isCollapsed]) ifTrue: [^ self].
((self world ifNil: [^ self]) firstSubmorph isKindOf: NewHandleMorph) ifTrue:
[^ self "Prevent multiple handles"].
"Transcript show: event hand printString,' ',event hand world printString,
' ',self world printString,' ',self outermostWorldMorph printString; cr; cr."
+ pt := event cursorPoint.
- pt _ event cursorPoint.
self bounds forPoint: pt closestSideDistLen:
[:side :dist :len | "Check for window side adjust"
+ dist <= 2 ifTrue: [ptName := side]].
- dist <= 2 ifTrue: [ptName _ side]].
ptName ifNil:
["Check for pane border adjust"
^ self spawnPaneFrameHandle: event].
#(topLeft bottomRight bottomLeft topRight) do:
[:corner | "Check for window corner adjust"
+ (pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName := corner]].
- (pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName _ corner]].
+ resizer := NewHandleMorph new
- resizer _ NewHandleMorph new
followHand: event hand
forEachPointDo:
+ [:p | localPt := self pointFromWorld: p.
+ newBounds := self bounds
- [:p | localPt _ self pointFromWorld: p.
- newBounds _ self bounds
withSideOrCorner: ptName
setToPoint: localPt
minExtent: self minimumExtent.
self fastFramingOn
ifTrue:
[self doFastWindowReframe: ptName]
ifFalse:
[self bounds: newBounds.
(Preferences roundedWindowCorners
and: [#(bottom right bottomRight) includes: ptName])
ifTrue:
["Complete kluge: causes rounded corners to get painted correctly,
in spite of not working with top-down displayWorld."
ptName = #bottom ifFalse:
[self invalidRect: (self bounds topRight - (6 at 0) extent: 7 at 7)].
ptName = #right ifFalse:
[self invalidRect: (self bounds bottomLeft - (0 at 6) extent: 7 at 7)].
self invalidRect: (self bounds bottomRight - (6 at 6) extent: 7 at 7)]]]
lastPointDo:
[:p | ].
self world addMorph: resizer.
resizer startStepping.
!
Item was changed:
----- Method: NoHaloMorph class>>inARow: (in category 'instance creation') -----
inARow: aCollectionOfMorphs
"Answer an instance of the receiver, a row morph, with the given collection as its submorphs, and transparent in color. Interpret the symbol #spacer in the incoming list as a request for a variable transparent spacer."
| row |
+ row := self new.
- row _ self new.
row layoutPolicy: TableLayout new.
row
listDirection: #leftToRight;
vResizing: #shrinkWrap;
hResizing: #spaceFill;
layoutInset: 0;
cellPositioning: #center;
borderWidth: 0;
color: Color transparent.
aCollectionOfMorphs do:
[ :each | | toAdd |
toAdd := each == #spacer
ifTrue:
[AlignmentMorph newVariableTransparentSpacer]
ifFalse:
[each].
row addMorphBack: toAdd].
^ row
!
Item was changed:
----- Method: Number class>>readEToyNumberFrom: (in category '*Etoys-Squeakland-instance creation') -----
readEToyNumberFrom: aString
"Answer a number as described in the string"
| value aStream sign |
aStream := ReadStream on: (aString copyWithout: $ ).
(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
+ sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
- sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
(aStream peekFor: $.) ifTrue: "Don't gag on leading decimal point without whole-number part"
[sign = 1
ifTrue: "leading decimal point"
[^ self readEToyNumberFrom: '0', aString]
ifFalse: "minus-sign followed by a decimal point"
[^ self readEToyNumberFrom: '-0', aString allButFirst]].
(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
+ value := [Integer readFrom: aStream base: 10] ifError:
- value _ [Integer readFrom: aStream base: 10] ifError:
[self inform: aString, ' is not a number;
please correct and try again' translated.
^ nil].
^ self readRemainderOf: value from: aStream base: 10 withSign: sign!
Item was changed:
----- Method: OLPCVirtualScreen class>>virtualScreenExtent: (in category 'installing') -----
virtualScreenExtent: aPoint
+ VirtualScreenExtent := aPoint
- VirtualScreenExtent _ aPoint
!
Item was changed:
----- Method: OLPCVirtualScreen>>copy: (in category 'copying') -----
copy: aRect
"Return a new form which derives from the portion of the original form delineated by aRect."
| newForm |
+ newForm := DisplayScreen extent: aRect extent depth: depth.
- newForm _ DisplayScreen extent: aRect extent depth: depth.
^ newForm copyBits: aRect from: self at: 0 at 0
clippingBox: newForm boundingBox rule: Form over fillColor: nil!
Item was changed:
----- Method: OLPCVirtualScreen>>zoomOut: (in category 'display') -----
zoomOut: aBoolean
"When the physical display is bigger than the virtual display size, we have two options. One is to zoom in and maximize the visible area and another is to map a pixel to a pixel and show it in smaller area (at the center of screen). This flag governs them."
self canZoomOut ifFalse: [^ self].
+ zoomOut := aBoolean.
- zoomOut _ aBoolean.
display fillColor: (Color gray: 0.2).
self setupWarp; forceToScreen.
display forceToScreen. "to capture the borders"
World restoreMorphicDisplay.
World repositionFlapsAfterScreenSizeChange.
!
Item was changed:
----- Method: Object>>categoriesForViewer: (in category '*Etoys-viewer') -----
categoriesForViewer: aViewer
"Answer a list of categories to offer in the given viewer"
| aList instItem |
+ aList := aViewer currentVocabulary categoryListForInstance: self ofClass: self class limitClass: aViewer limitClass.
- aList _ aViewer currentVocabulary categoryListForInstance: self ofClass: self class limitClass: aViewer limitClass.
self isPlayerLike ifTrue:
[self costume isWorldMorph ifFalse:
[aList removeAllFoundIn: #(preferences display)].
^ aList].
+ instItem := ScriptingSystem nameForInstanceVariablesCategory.
- instItem _ ScriptingSystem nameForInstanceVariablesCategory.
^ (aList includes: instItem)
ifTrue:
[aList]
ifFalse:
[ {instItem }, aList]!
Item was changed:
----- Method: Object>>launchPartOffsetVia:label: (in category '*Etoys-Squeakland-user interface') -----
launchPartOffsetVia: aSelector label: aString
"Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins. This variant makes the morph offset from the hand position by an amount suitable for tile-scripting in some circumstances."
| aMorph |
+ aMorph := self perform: aSelector.
- aMorph _ self perform: aSelector.
aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString).
aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
aMorph setProperty: #offsetForAttachingToHand toValue: 10@ -10.
aMorph fullBounds.
aMorph openInHand!
Item was changed:
----- Method: ObjectPropertiesMorph>>doEnables (in category 'enabling') -----
doEnables
"Carry out appropriate enablings within the receiver's interior."
| itsName fs |
+ fs := myTarget fillStyle.
- fs _ myTarget fillStyle.
self allMorphsDo: [ :each |
+ itsName := each knownName.
- itsName _ each knownName.
itsName == #pickerForColor ifTrue: [
self enable: each when: (myTarget doesColorAndBorder and: [ fs isSolidFill | fs isGradientFill])].
itsName == #pickerForBorderColor ifTrue: [
self enable: each when: (myTarget doesColorAndBorder and: [myTarget respondsTo: #borderColor:])
].
itsName == #pickerForShadowColor ifTrue: [
self enable: each when: myTarget hasDropShadow
].
itsName == #pickerFor2ndGradientColor ifTrue: [
self enable: each when: (myTarget doesColorAndBorder and: [myTarget doesColorAndBorder and: [fs isGradientFill]])
].
].
!
Item was changed:
----- Method: ObjectsTool>>doAlphabeticButtonAction: (in category '*Etoys-Squeakland-alphabetic') -----
doAlphabeticButtonAction: aCategoryName
| button |
+ button := self findButtonForCategory: aCategoryName.
- button _ self findButtonForCategory: aCategoryName.
button ifNotNil: [
self showAlphabeticCategory: aCategoryName fromButton: button
].!
Item was changed:
----- Method: ObjectsTool>>doCategoryButtonAction: (in category '*Etoys-Squeakland-categories') -----
doCategoryButtonAction: aCategoryName
| button |
+ button := self findButtonForCategory: aCategoryName.
- button _ self findButtonForCategory: aCategoryName.
button ifNotNil: [
self showCategory: aCategoryName fromButton: button
].!
Item was changed:
----- Method: OrderedCollection>>grow (in category '*Etoys-Squeakland-adding') -----
grow
"Become larger. Typically, a subclass has to override this if the subclass
adds instance variables."
| newArray |
+ newArray := Array new: self size + self growSize.
- newArray _ Array new: self size + self growSize.
newArray replaceFrom: 1 to: array size with: array startingAt: 1.
+ array := newArray!
- array _ newArray!
Item was changed:
----- Method: PDA>>addEvent (in category 'schedule') -----
addEvent
| newEvent |
+ newEvent := PDAEvent new key: self categorySelected; date: date;
- newEvent _ PDAEvent new key: self categorySelected; date: date;
time: (Time readFromString: '7 am');
description: 'new event'.
+ allEvents := allEvents copyWith: newEvent.
- allEvents _ allEvents copyWith: newEvent.
self currentItem: newEvent.
self updateScheduleList!
Item was changed:
----- Method: PDA>>addNote (in category 'notes') -----
addNote
| newNote |
+ newNote := PDARecord new key: self categorySelected; description: 'new note'.
+ allNotes := allNotes copyWith: newNote.
- newNote _ PDARecord new key: self categorySelected; description: 'new note'.
- allNotes _ allNotes copyWith: newNote.
self currentItem: newNote.
self updateNotesList!
Item was changed:
----- Method: PDA>>addPerson (in category 'people') -----
addPerson
| newPerson |
+ newPerson := PDAPerson new key: self categorySelected; name: 'Last, First'.
+ allPeople := allPeople copyWith: newPerson.
- newPerson _ PDAPerson new key: self categorySelected; name: 'Last, First'.
- allPeople _ allPeople copyWith: newPerson.
self currentItem: newPerson.
self updatePeopleList!
Item was changed:
----- Method: PDA>>addRecurringEvent (in category 'schedule') -----
addRecurringEvent
| newEvent |
+ newEvent := PDARecurringEvent new key: self categorySelected;
- newEvent _ PDARecurringEvent new key: self categorySelected;
firstDate: date; recurrence: PDARecurringEvent chooseRecurrence;
description: 'recurring event'.
newEvent key = 'recurring' ifTrue: [newEvent key: 'all'].
newEvent recurrence == #eachDay ifTrue: [newEvent lastDate: (date addDays: 1)].
+ recurringEvents := recurringEvents copyWith: newEvent.
- recurringEvents _ recurringEvents copyWith: newEvent.
self currentItem: newEvent.
self updateScheduleList!
Item was changed:
----- Method: PDA>>addToDoItem (in category 'to do') -----
addToDoItem
| newToDoItem |
+ newToDoItem := PDAToDoItem new key: self categorySelected; description: 'new item to do';
- newToDoItem _ PDAToDoItem new key: self categorySelected; description: 'new item to do';
dayPosted: Date today; priority: 1.
+ allToDoItems := allToDoItems copyWith: newToDoItem.
- allToDoItems _ allToDoItems copyWith: newToDoItem.
self currentItem: newToDoItem.
self updateToDoList!
Item was changed:
----- Method: PDA>>categoryChoices (in category 'category') -----
categoryChoices
"Return a list for the popup chooser"
| special |
+ special := {'all'. 'recurring'. nil}.
- special _ {'all'. 'recurring'. nil}.
(special includes: category) ifTrue:
[^ special , userCategories , {nil. 'add new key'}].
^ special , userCategories , {nil. 'remove ' , self categorySelected. 'rename ' , self categorySelected. nil. 'add new key'}!
Item was changed:
----- Method: PDA>>chooseFrom:categoryItem: (in category 'category') -----
chooseFrom: chooserMorph categoryItem: item
| newKey menu |
+ newKey := item.
- newKey _ item.
self okToChange ifFalse: [^ self].
(item = 'add new key') ifTrue:
+ [newKey := FillInTheBlank request: 'New key to use'
- [newKey _ FillInTheBlank request: 'New key to use'
initialAnswer: self categorySelected.
newKey isEmpty ifTrue: [^ self].
(userCategories includes: newKey) ifTrue: [^ self].
+ userCategories := (userCategories copyWith: newKey) sort].
- userCategories _ (userCategories copyWith: newKey) sort].
(item beginsWith: 'remove ') ifTrue:
[(self confirm: 'Removal of this category will cause all items formerly
categorized as ''' , self categorySelected , ''' to be reclassified as ''all''.
Is this really what you want to do?
[unless there are very few, choose ''no'']')
ifFalse: [^ self].
self rekeyAllRecordsFrom: self categorySelected to: 'all'.
+ userCategories := userCategories copyWithout: self categorySelected.
+ newKey := 'all'].
- userCategories _ userCategories copyWithout: self categorySelected.
- newKey _ 'all'].
(item beginsWith: 'rename ') ifTrue:
+ [menu := CustomMenu new.
- [menu _ CustomMenu new.
userCategories do: [:key | menu add: key action: key].
+ newKey := menu startUpWithCaption: 'Please select the new key for
- newKey _ menu startUpWithCaption: 'Please select the new key for
items now categorized as ''' , self categorySelected , '''.'.
newKey ifNil: [^ self].
(self confirm: 'Renaming this category will cause all items formerly
categorized as ''' , self categorySelected , ''' to be reclassified as ''' , newKey , '''.
Is this really what you want to do?')
ifFalse: [^ self].
self rekeyAllRecordsFrom: self categorySelected to: newKey.
+ userCategories := userCategories copyWithout: self categorySelected].
- userCategories _ userCategories copyWithout: self categorySelected].
self selectCategory: newKey.
chooserMorph contentsClipped: newKey!
Item was changed:
----- Method: PDA>>currentItem: (in category 'currentItem') -----
currentItem: newValue
"Assign newValue to currentItem."
currentItem class == newValue class ifFalse:
["get rid of this hideous hack"
(currentItem isMemberOf: PDAEvent) ifTrue: [self scheduleListIndex: 0].
(currentItem isMemberOf: PDAToDoItem) ifTrue: [self toDoListIndex: 0].
(currentItem isMemberOf: PDAPerson) ifTrue: [self peopleListIndex: 0].
(currentItem isMemberOf: PDARecord) ifTrue: [self notesListIndex: 0]].
+ currentItem := newValue.
- currentItem _ newValue.
self changed: #currentItemText!
Item was changed:
----- Method: PDA>>currentItemMenu: (in category 'currentItem') -----
currentItemMenu: aMenu
| donorMenu labels |
viewDescriptionOnly
ifTrue: [aMenu add: 'view entire records' target: self selector: #toggleDescriptionMode]
ifFalse: [aMenu add: 'view descriptions only' target: self selector: #toggleDescriptionMode].
aMenu addLine.
aMenu add: 'save database' target: self selector: #saveDatabase.
aMenu add: 'load database from file...' target: self selector: #loadDatabase.
aMenu add: 'spawn entire month' target: self selector: #openMonthView.
aMenu addLine.
aMenu add: 'accept (s)' target: self selector: #accept.
aMenu add: 'cancel (l)' target: self selector: #cancel.
aMenu addLine.
+ donorMenu := ParagraphEditor yellowButtonMenu.
+ labels := donorMenu labelString findTokens: String cr.
- donorMenu _ ParagraphEditor yellowButtonMenu.
- labels _ donorMenu labelString findTokens: String cr.
aMenu labels: (labels allButLast: 4) lines: donorMenu lineArray selections: donorMenu selections.
^ aMenu!
Item was changed:
----- Method: PDA>>currentItemSelection: (in category 'currentItem') -----
currentItemSelection: newValue
"Assign newValue to currentItemSelection."
+ currentItemSelection := newValue.!
- currentItemSelection _ newValue.!
Item was changed:
----- Method: PDA>>initialize (in category 'initialization') -----
initialize
+ viewDescriptionOnly := false.
- viewDescriptionOnly _ false.
self userCategories: self sampleCategoryList
allPeople: self samplePeopleList
allEvents: self sampleScheduleList
recurringEvents: self sampleRecurringEventsList
allToDoItems: self sampleToDoList
allNotes: self sampleNotes
dateSelected: Date today
!
Item was changed:
----- Method: PDA>>labelString (in category 'initialization') -----
labelString
| today |
+ today := Date today.
- today _ Date today.
^ String streamContents:
[:s | s nextPutAll: today weekday; space.
Time now print24: false showSeconds: false on: s.
s nextPutAll: ' -- '.
s nextPutAll: today monthName; space; print: today dayOfMonth;
nextPutAll: ', '; print: today year]!
Item was changed:
----- Method: PDA>>loadDatabase (in category 'initialization') -----
loadDatabase
| aName aFileStream list |
+ aName := Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
- aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
aName
ifNil: [^ self].
"User made no choice"
aName == #none
ifTrue: [^ self inform: 'Sorry, no suitable files found
(names should end with .data or .data.gz)'].
+ aFileStream := FileStream oldFileNamed: aName.
+ list := aFileStream fileInObjectAndCode.
+ userCategories := list first.
+ allPeople := list second.
+ allEvents := list third.
+ recurringEvents := list fourth.
+ allToDoItems := list fifth.
+ allNotes := list sixth.
+ date := Date today.
- aFileStream _ FileStream oldFileNamed: aName.
- list _ aFileStream fileInObjectAndCode.
- userCategories _ list first.
- allPeople _ list second.
- allEvents _ list third.
- recurringEvents _ list fourth.
- allToDoItems _ list fifth.
- allNotes _ list sixth.
- date _ Date today.
self selectCategory: 'all'!
Item was changed:
----- Method: PDA>>mergeDatabase (in category 'initialization') -----
mergeDatabase
| aName aFileStream list |
+ aName := Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
- aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'.
aName
ifNil: [^ self].
"User made no choice"
aName == #none
ifTrue: [^ self inform: 'Sorry, no suitable files found
(names should end with .data or .data.gz)'].
+ aFileStream := FileStream oldFileNamed: aName.
+ list := aFileStream fileInObjectAndCode.
+ userCategories := (list first , userCategories) asSet asArray sort.
+ allPeople := (list second , allPeople) asSet asArray sort.
+ allEvents := (list third , allEvents) asSet asArray sort.
+ recurringEvents := (list fourth , recurringEvents) asSet asArray sort.
+ allToDoItems := (list fifth , allToDoItems) asSet asArray sort.
+ allNotes := ((list sixth)
- aFileStream _ FileStream oldFileNamed: aName.
- list _ aFileStream fileInObjectAndCode.
- userCategories _ (list first , userCategories) asSet asArray sort.
- allPeople _ (list second , allPeople) asSet asArray sort.
- allEvents _ (list third , allEvents) asSet asArray sort.
- recurringEvents _ (list fourth , recurringEvents) asSet asArray sort.
- allToDoItems _ (list fifth , allToDoItems) asSet asArray sort.
- allNotes _ ((list sixth)
, allNotes) asSet asArray sort.
+ date := Date today.
- date _ Date today.
self selectCategory: 'all'!
Item was changed:
----- Method: PDA>>notesListIndex: (in category 'notes') -----
notesListIndex: newValue
"Assign newValue to notesListIndex."
notesListIndex = newValue ifTrue: [^ self].
self okToChange ifFalse: [^ self].
+ notesListIndex := newValue.
- notesListIndex _ newValue.
self currentItem: (notesListIndex ~= 0
ifTrue: [notesList at: notesListIndex]
ifFalse: [nil]).
self changed: #notesListIndex.!
Item was changed:
----- Method: PDA>>openAsMorphIn: (in category 'initialization') -----
openAsMorphIn: window "PDA new openAsMorph openInWorld"
"Create a pluggable version of all the morphs for a Browser in Morphic"
| dragNDropFlag paneColor chooser |
window color: Color black.
+ paneColor := (Color r: 0.6 g: 1.0 b: 0.0).
- paneColor _ (Color r: 0.6 g: 1.0 b: 0.0).
window model: self.
Preferences alternativeWindowLook ifTrue:[
window color: Color white.
window paneColor: paneColor].
+ dragNDropFlag := Preferences browseWithDragNDrop.
- dragNDropFlag _ Preferences browseWithDragNDrop.
window addMorph: ((PluggableListMorph on: self list: #peopleListItems
selected: #peopleListIndex changeSelected: #peopleListIndex:
menu: #peopleMenu: keystroke: #peopleListKey:from:) enableDragNDrop: dragNDropFlag)
frame: (0 at 0 corner: 0.3 at 0.25).
+ window addMorph: ((chooser := PDAChoiceMorph new color: paneColor) contentsClipped: 'all';
- window addMorph: ((chooser _ PDAChoiceMorph new color: paneColor) contentsClipped: 'all';
target: self; actionSelector: #chooseFrom:categoryItem:; arguments: {chooser};
getItemsSelector: #categoryChoices)
frame: (0 at 0.25 corner: 0.3 at 0.3).
window addMorph: ((MonthMorph newWithModel: self) color: paneColor; extent: 148 at 109)
frame: (0.3 at 0 corner: 0.7 at 0.3).
window addMorph: (PDAClockMorph new color: paneColor;
faceColor: (Color r: 0.4 g: 0.8 b: 0.6)) "To match monthMorph"
frame: (0.7 at 0 corner: 1.0 at 0.3).
window addMorph: ((PluggableListMorph on: self list: #toDoListItems
selected: #toDoListIndex changeSelected: #toDoListIndex:
menu: #toDoMenu: keystroke: #toDoListKey:from:) enableDragNDrop: dragNDropFlag)
frame: (0 at 0.3 corner: 0.3 at 0.7).
window addMorph: ((PluggableListMorph on: self list: #scheduleListItems
selected: #scheduleListIndex changeSelected: #scheduleListIndex:
menu: #scheduleMenu: keystroke: #scheduleListKey:from:) enableDragNDrop: dragNDropFlag)
frame: (0.3 at 0.3 corner: 0.7 at 0.7).
window addMorph: ((PluggableListMorph on: self list: #notesListItems
selected: #notesListIndex changeSelected: #notesListIndex:
menu: #notesMenu: keystroke: #notesListKey:from:) enableDragNDrop: dragNDropFlag)
frame: (0.7 at 0.3 corner: 1 at 0.7).
window addMorph: (PluggableTextMorph on: self
text: #currentItemText accept: #acceptCurrentItemText:
readSelection: #currentItemSelection menu: #currentItemMenu:)
frame: (0 at 0.7 corner: 1 at 1).
Preferences alternativeWindowLook ifFalse:[
window firstSubmorph color: paneColor.
].
window updatePaneColors.
window step.
^ window!
Item was changed:
----- Method: PDA>>openMonthView (in category 'initialization') -----
openMonthView
| row month col paneExtent window paneColor nRows |
+ month := date notNil
- month _ date notNil
ifTrue: [date month]
ifFalse: ["But... it's here somewhere..."
((self dependents detect: [:m | m isKindOf: PDAMorph])
findA: MonthMorph) month].
+ window := SystemWindow labelled: month printString.
+ paneColor := Color transparent.
- window _ SystemWindow labelled: month printString.
- paneColor _ Color transparent.
window color: (Color r: 0.968 g: 1.0 b: 0.355).
+ nRows := 0. month eachWeekDo: [:w | nRows := nRows + 1].
+ paneExtent := ((1.0/7) @ (1.0/nRows)).
+ row := 0.
- nRows _ 0. month eachWeekDo: [:w | nRows _ nRows + 1].
- paneExtent _ ((1.0/7) @ (1.0/nRows)).
- row _ 0.
month eachWeekDo:
+ [:week | col := 0.
- [:week | col _ 0.
week do:
[:day | day month = month ifTrue:
[window addMorph: ((PluggableListMorph on: self list: nil
selected: nil changeSelected: nil menu: nil keystroke: nil)
list: {(day dayOfMonth printString , ' ' , day weekday) asText allBold}
, (self scheduleListForDay: day))
frame: (paneExtent * (col at row) extent: paneExtent)].
+ col := col + 1].
+ row := row + 1].
- col _ col + 1].
- row _ row + 1].
window firstSubmorph color: paneColor.
window updatePaneColors.
window openInWorld!
Item was changed:
----- Method: PDA>>peopleListIndex: (in category 'people') -----
peopleListIndex: newValue
"Assign newValue to peopleListIndex."
peopleListIndex = newValue ifTrue: [^ self].
self okToChange ifFalse: [^ self].
+ peopleListIndex := newValue.
- peopleListIndex _ newValue.
self currentItem: (peopleListIndex ~= 0
ifTrue: [peopleList at: peopleListIndex]
ifFalse: [nil]).
self changed: #peopleListIndex.!
Item was changed:
----- Method: PDA>>removeEvent (in category 'schedule') -----
removeEvent
(currentItem isKindOf: PDARecurringEvent)
ifTrue: [(self confirm:
'Rather than remove a recurring event, it is
better to declare its last day to keep the record.
Do you still wish to remove it?')
ifFalse: [^ self].
+ recurringEvents := recurringEvents copyWithout: currentItem]
+ ifFalse: [allEvents := allEvents copyWithout: currentItem].
- recurringEvents _ recurringEvents copyWithout: currentItem]
- ifFalse: [allEvents _ allEvents copyWithout: currentItem].
self currentItem: nil.
self updateScheduleList.
!
Item was changed:
----- Method: PDA>>removeNote (in category 'notes') -----
removeNote
+ allNotes := allNotes copyWithout: currentItem.
- allNotes _ allNotes copyWithout: currentItem.
self currentItem: nil.
self updateNotesList.
!
Item was changed:
----- Method: PDA>>removePerson (in category 'people') -----
removePerson
+ allPeople := allPeople copyWithout: currentItem.
- allPeople _ allPeople copyWithout: currentItem.
self currentItem: nil.
self updatePeopleList.
!
Item was changed:
----- Method: PDA>>removeToDoItem (in category 'to do') -----
removeToDoItem
(self confirm: 'Rather than remove an item, it is
better to declare it done with a reason such as
''gave up'', or ''not worth it'', to keep the record.
Do you still wish to remove it?')
ifFalse: [^ self].
+ allToDoItems := allToDoItems copyWithout: currentItem.
- allToDoItems _ allToDoItems copyWithout: currentItem.
self currentItem: nil.
self updateToDoList.
!
Item was changed:
----- Method: PDA>>scheduleListForDay: (in category 'schedule') -----
scheduleListForDay: aDate
| dayList |
+ dayList := ((allEvents select: [:c | c matchesKey: 'all' andMatchesDate: aDate])
- dayList _ ((allEvents select: [:c | c matchesKey: 'all' andMatchesDate: aDate])
, ((recurringEvents select: [:c | c matchesKey: 'all' andMatchesDate: aDate])
collect: [:re | (re as: PDAEvent) date: aDate])) sort.
^ dayList collect: [:evt | evt asListItem]!
Item was changed:
----- Method: PDA>>scheduleListIndex: (in category 'schedule') -----
scheduleListIndex: newValue
"Assign newValue to scheduleListIndex."
scheduleListIndex = newValue ifTrue: [^ self].
self okToChange ifFalse: [^ self].
+ scheduleListIndex := newValue.
- scheduleListIndex _ newValue.
self currentItem: (scheduleListIndex ~= 0
ifTrue: [scheduleList at: scheduleListIndex]
ifFalse: [nil]).
self changed: #scheduleListIndex.!
Item was changed:
----- Method: PDA>>selectCategory: (in category 'category') -----
selectCategory: cat
+ category := cat.
- category _ cat.
self updateScheduleList.
self updateToDoList.
self updatePeopleList.
self updateNotesList.
currentItem ifNil: [^ self].
(scheduleListIndex + toDoListIndex + peopleListIndex + notesListIndex) = 0 ifTrue:
["Old current item is no longer current (not in any list)"
+ currentItem := nil.
- currentItem _ nil.
self changed: #currentItemText]!
Item was changed:
----- Method: PDA>>selectDate: (in category 'date') -----
selectDate: aDate
+ date := aDate.
- date _ aDate.
self updateScheduleList.
self updateToDoList.
self updateCurrentItem.!
Item was changed:
----- Method: PDA>>toDoListIndex: (in category 'to do') -----
toDoListIndex: newValue
"Assign newValue to toDoListIndex."
toDoListIndex = newValue ifTrue: [^ self].
self okToChange ifFalse: [^ self].
+ toDoListIndex := newValue.
- toDoListIndex _ newValue.
self currentItem: (toDoListIndex ~= 0
ifTrue: [toDoList at: toDoListIndex]
ifFalse: [nil]).
self changed: #toDoListIndex.!
Item was changed:
----- Method: PDA>>toggleDescriptionMode (in category 'currentItem') -----
toggleDescriptionMode
self okToChange ifFalse: [^ self].
+ viewDescriptionOnly := viewDescriptionOnly not.
- viewDescriptionOnly _ viewDescriptionOnly not.
self changed: #currentItemText!
Item was changed:
----- Method: PDA>>updateNotesList (in category 'notes') -----
updateNotesList
+ notesList := (allNotes select: [:c | c matchesKey: self categorySelected]) sort.
- notesList _ (allNotes select: [:c | c matchesKey: self categorySelected]) sort.
self notesListIndex: (notesList indexOf: currentItem).
self changed: #notesListItems!
Item was changed:
----- Method: PDA>>updatePeopleList (in category 'people') -----
updatePeopleList
+ peopleList := (allPeople select: [:c | c matchesKey: category]) sort.
+ peopleListIndex := peopleList indexOf: currentItem.
- peopleList _ (allPeople select: [:c | c matchesKey: category]) sort.
- peopleListIndex _ peopleList indexOf: currentItem.
self changed: #peopleListItems!
Item was changed:
----- Method: PDA>>updateScheduleList (in category 'schedule') -----
updateScheduleList
(date isNil
and: [category ~= 'recurring'])
+ ifTrue: [scheduleList := Array new.
+ scheduleListIndex := 0.
- ifTrue: [scheduleList _ Array new.
- scheduleListIndex _ 0.
^ self changed: #scheduleListItems].
+ scheduleList := (category = 'recurring'
- scheduleList _ (category = 'recurring'
ifTrue: ["When 'recurring' is selected, edit actual masters"
(recurringEvents
select: [:c | c matchesKey: category andMatchesDate: date]) ]
ifFalse: ["Otherwise, recurring events just spawn copies."
((allEvents
select: [:c | c matchesKey: category andMatchesDate: date])
, ((recurringEvents
select: [:c | c matchesKey: category andMatchesDate: date])
collect: [:re | (re as: PDAEvent)
date: date])) ])sort.
+ scheduleListIndex := scheduleList indexOf: currentItem.
- scheduleListIndex _ scheduleList indexOf: currentItem.
self changed: #scheduleListItems!
Item was changed:
----- Method: PDA>>updateToDoList (in category 'to do') -----
updateToDoList
date ifNil:
+ [toDoList := Array new. toDoListIndex := 0.
- [toDoList _ Array new. toDoListIndex _ 0.
^ self changed: #toDoListItems].
+ toDoList := (allToDoItems select: [:c | c matchesKey: category andMatchesDate: date]) sort.
+ toDoListIndex := toDoList indexOf: currentItem.
- toDoList _ (allToDoItems select: [:c | c matchesKey: category andMatchesDate: date]) sort.
- toDoListIndex _ toDoList indexOf: currentItem.
self changed: #toDoListItems!
Item was changed:
----- Method: PDA>>userCategories:allPeople:allEvents:recurringEvents:allToDoItems:allNotes:dateSelected: (in category 'initialization') -----
userCategories: cats allPeople: ppl allEvents: evts recurringEvents: recEvts allToDoItems: todo allNotes: notes dateSelected: aDate
+ userCategories := cats.
+ allPeople := ppl.
+ allEvents := evts.
+ recurringEvents := recEvts.
+ allToDoItems := todo.
+ allNotes := notes.
- userCategories _ cats.
- allPeople _ ppl.
- allEvents _ evts.
- recurringEvents _ recEvts.
- allToDoItems _ todo.
- allNotes _ notes.
+ date := aDate. "Because updates ahead will need *both* date and category"
- date _ aDate. "Because updates ahead will need *both* date and category"
self selectCategory: 'all'.
self selectDate: aDate. "Superfluous, but might not be"!
Item was changed:
----- Method: PDAChoiceMorph>>color: (in category 'accessing') -----
color: aColor
+ backgroundColor := aColor.
- backgroundColor _ aColor.
self changed!
Item was changed:
----- Method: PDAChoiceMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| offset |
+ offset := 4@(bounds height - self fontToUse height // 2).
- offset _ 4@(bounds height - self fontToUse height // 2).
aCanvas frameAndFillRectangle: bounds fillColor: backgroundColor
borderWidth: 1 borderColor: Color black.
aCanvas drawString: contents
in: ((bounds translateBy: offset) intersect: bounds)
font: self fontToUse color: Color black.
!
Item was changed:
----- Method: PDAClockMorph>>color: (in category 'accessing') -----
color: aColor
+ backgroundColor := aColor.
- backgroundColor _ aColor.
self changed!
Item was changed:
----- Method: PDAEvent>>asListItem (in category 'as text') -----
asListItem
| timeString ampm |
time ifNil: [^ '-- ' , (description copyUpTo: Character cr) , ' --'].
+ timeString := time printString.
+ ampm := timeString last: 2.
- timeString _ time printString.
- ampm _ timeString last: 2.
^ (timeString allButLast: 3) , ampm , ' ' , (description copyUpTo: Character cr)!
Item was changed:
----- Method: PDAEvent>>date: (in category 'date') -----
date: newValue
"Assign newValue to date."
+ date := newValue.!
- date _ newValue.!
Item was changed:
----- Method: PDAEvent>>duration: (in category 'duration') -----
duration: newValue
"Assign newValue to duration."
+ duration := newValue.!
- duration _ newValue.!
Item was changed:
----- Method: PDAEvent>>time: (in category 'time') -----
time: newValue
"Assign newValue to time."
+ time := newValue!
- time _ newValue!
Item was changed:
----- Method: PDAPerson>>address: (in category 'public access') -----
address: newValue
"Assign newValue to address."
+ address := newValue.!
- address _ newValue.!
Item was changed:
----- Method: PDAPerson>>email: (in category 'public access') -----
email: newValue
"Assign newValue to email."
+ email := newValue.!
- email _ newValue.!
Item was changed:
----- Method: PDAPerson>>name: (in category 'public access') -----
name: newValue
"Assign newValue to name."
+ name := newValue.!
- name _ newValue.!
Item was changed:
----- Method: PDAPerson>>phone: (in category 'public access') -----
phone: newValue
"Assign newValue to phone."
+ phone := newValue.!
- phone _ newValue.!
Item was changed:
----- Method: PDARecord>>description: (in category 'description') -----
description: newValue
"Assign newValue to description."
+ description := newValue.!
- description _ newValue.!
Item was changed:
----- Method: PDARecord>>key: (in category 'key') -----
key: newValue
"Assign newValue to key."
+ key := newValue.!
- key _ newValue.!
Item was changed:
----- Method: PDARecord>>otherFields: (in category 'other fields') -----
otherFields: newValue
"Assign newValue to otherFields."
+ otherFields := newValue.!
- otherFields _ newValue.!
Item was changed:
----- Method: PDARecord>>readField:fromString:fields:base: (in category 'as text') -----
readField: fieldName fromString: aString fields: sharedFields base: instVarBase
"This message should be overridden in subclasses to recognize the types for the various fields. If a fieldName is not recognized below, super will invoke this method at the end."
(sharedFields includes: fieldName) ifTrue:
[^ self instVarAt: instVarBase + (sharedFields indexOf: fieldName)
put: (Compiler evaluate: aString)].
+ otherFields ifNil: [otherFields := Dictionary new].
- otherFields ifNil: [otherFields _ Dictionary new].
otherFields at: fieldName put: (Compiler evaluate: aString)
!
Item was changed:
----- Method: PDARecord>>readFrom: (in category 'as text') -----
readFrom: aText
| buffer tokenStream fieldName token |
+ tokenStream := ReadStream on: (Scanner new scanTokens: aText asString).
+ buffer := WriteStream on: (String new: 500).
+ fieldName := nil.
- tokenStream _ ReadStream on: (Scanner new scanTokens: aText asString).
- buffer _ WriteStream on: (String new: 500).
- fieldName _ nil.
self sharedFieldsWithBaseDo:
[:fields :instVarBase |
[tokenStream atEnd] whileFalse:
+ [token := tokenStream next.
- [token _ tokenStream next.
((token isSymbol) and: [token endsWith: ':'])
ifTrue: [fieldName ifNotNil:
[self readField: fieldName fromString: buffer contents
fields: fields base: instVarBase].
+ buffer reset. fieldName := token allButLast]
- buffer reset. fieldName _ token allButLast]
ifFalse: [(token isSymbol)
ifTrue: [buffer nextPutAll: token; space]
ifFalse: [buffer print: token; space]]].
self readField: fieldName fromString: buffer contents
fields: fields base: instVarBase]!
Item was changed:
----- Method: PDARecord>>rekey:to: (in category 'key') -----
rekey: oldKey to: newKey
+ key = oldKey ifTrue: [key := newKey]!
- key = oldKey ifTrue: [key _ newKey]!
Item was changed:
----- Method: PDARecord>>sharedFieldsWithBaseDo: (in category 'as text') -----
sharedFieldsWithBaseDo: fieldsAndBaseBlock
| fields base |
+ fields := self class allInstVarNames allButFirst: (base := PDARecord superclass instSize).
- fields _ self class allInstVarNames allButFirst: (base _ PDARecord superclass instSize).
fieldsAndBaseBlock value: fields value: base!
Item was changed:
----- Method: PDARecurringEvent>>firstDate: (in category 'as yet unclassified') -----
firstDate: aDate
+ firstDate := aDate
- firstDate _ aDate
!
Item was changed:
----- Method: PDARecurringEvent>>lastDate: (in category 'as yet unclassified') -----
lastDate: aDate
+ lastDate := aDate
- lastDate _ aDate
!
Item was changed:
----- Method: PDARecurringEvent>>recurrence: (in category 'as yet unclassified') -----
recurrence: rSymbol
(self validRecurrenceSymbols includes: rSymbol)
ifFalse: [^ self error: 'unrecognized recurrence symbol: , rSymbol'].
+ recurrence := rSymbol!
- recurrence _ rSymbol!
Item was changed:
----- Method: PDAToDoItem>>dayDone: (in category 'day done') -----
dayDone: newValue
"Assign newValue to dayDone."
+ dayDone := newValue.!
- dayDone _ newValue.!
Item was changed:
----- Method: PDAToDoItem>>dayPosted: (in category 'day posted') -----
dayPosted: newValue
"Assign newValue to dayPosted."
+ dayPosted := newValue.!
- dayPosted _ newValue.!
Item was changed:
----- Method: PDAToDoItem>>deadline: (in category 'deadline') -----
deadline: newValue
"Assign newValue to deadline."
+ deadline := newValue.!
- deadline _ newValue.!
Item was changed:
----- Method: PDAToDoItem>>priority: (in category 'priority') -----
priority: newValue
"Assign newValue to priority."
+ priority := newValue.!
- priority _ newValue.!
Item was changed:
----- Method: PDAToDoItem>>result: (in category 'result') -----
result: newValue
"Assign newValue to result."
+ result := newValue.!
- result _ newValue.!
Item was changed:
----- Method: PaintBoxMorph>>replace4ButtonsWith: (in category '*Etoys-Squeakland-replace artwork') -----
replace4ButtonsWith: formDict
| pos m |
#('undo' 'keep' 'clear' 'toss') do: [:b |
+ pos := (m := submorphs detect: [:n | n externalName beginsWith: b]) position - self position.
- pos _ (m _ submorphs detect: [:n | n externalName beginsWith: b]) position - self position.
(formDict at: (b, 'On.png')) displayOn: image at: pos.
m pressedImage: (formDict at: (b, 'Pressed.png')).
].
!
Item was changed:
----- Method: PaintBoxMorph>>replace6ButtonsWith: (in category '*Etoys-Squeakland-replace artwork') -----
replace6ButtonsWith: formDict
| m |
1 to: 6 do: [:b |
+ m := submorphs detect: [:n | n externalName beginsWith: 'brush', b printString].
- m _ submorphs detect: [:n | n externalName beginsWith: 'brush', b printString].
m onImage: (formDict at: ('brush', b printString, 'On.png')).
m offImage: (formDict at: ('brush', b printString, 'Off.png')).
m pressedImage: (formDict at: ('brush', b printString, 'On.png')).
(formDict at: ('brush', b printString, 'Off.png')) displayOn: image at: (m position - self position).
].
+ brushes := OrderedCollection new.
- brushes _ OrderedCollection new.
#(#brush1: #brush2: #brush3: #brush4: #brush5: #brush6:)
do: [:sel | brushes addLast: (self submorphNamed: sel)].
!
Item was changed:
----- Method: ParagraphEditor>>indent:fromStream:toStream: (in category '*Etoys-Squeakland-private') -----
indent: delta fromStream: inStream toStream: outStream
"Append the contents of inStream to outStream, adding or deleting delta or -delta
tabs at the beginning, and after every CR except a final CR. Do not add tabs
to totally empty lines, and be sure nothing but tabs are removed from lines."
| ch skip cr tab prev atEnd |
+ cr := Character cr.
+ tab := Character tab.
- cr _ Character cr.
- tab _ Character tab.
delta > 0
ifTrue: "shift right"
+ [prev := cr.
+ [ch := (atEnd := inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
- [prev _ cr.
- [ch _ (atEnd _ inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
(prev == cr and: [ch ~~ cr]) ifTrue:
[delta timesRepeat: [outStream nextPut: tab]].
atEnd]
whileFalse:
[outStream nextPut: ch.
+ prev := ch]]
- prev _ ch]]
ifFalse: "shift left"
+ [skip := delta. "a negative number"
- [skip _ delta. "a negative number"
[inStream atEnd] whileFalse:
+ [((ch := inStream next) == tab and: [skip < 0]) ifFalse:
- [((ch _ inStream next) == tab and: [skip < 0]) ifFalse:
[outStream nextPut: ch].
+ skip := ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]!
- skip _ ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]!
Item was changed:
----- Method: ParagraphEditor>>recognizeCharactersWhileMouseIn: (in category '*Etoys-Squeakland-typing support') -----
recognizeCharactersWhileMouseIn: box
"Recognize hand-written characters and put them into the receiving pane. Invokes Alan's character recognizer. 2/5/96 sw"
| aRecognizer |
Cursor marker showWhile:
+ [aRecognizer := CharRecog new.
- [aRecognizer _ CharRecog new.
aRecognizer recognizeAndDispatch:
[:char | char == BS
ifTrue:
[self simulatedBackspace]
ifFalse:
[self simulatedKeystroke: char]]
until:
[(box containsPoint: sensor cursorPoint) not]].
view display!
Item was changed:
----- Method: ParagraphEditor>>shiftEnclose: (in category '*Etoys-Squeakland-editing keys') -----
shiftEnclose: characterStream
"Insert or remove bracket characters around the current selection.
Flushes typeahead."
| char left right startIndex stopIndex oldSelection which text |
+ char := sensor keyboard.
+ char = $9 ifTrue: [ char := $( ].
+ char = $, ifTrue: "[ char := $< ]"
- char _ sensor keyboard.
- char = $9 ifTrue: [ char _ $( ].
- char = $, ifTrue: "[ char _ $< ]"
[self closeTypeIn.
ActiveWorld showSourceKeyHit.
^ true].
+ char = $[ ifTrue: [ char := ${ ].
+ char = $' ifTrue: [ char := $" ].
+ char asciiValue = 27 ifTrue: [ char := ${ ]. "ctrl-["
- char = $[ ifTrue: [ char _ ${ ].
- char = $' ifTrue: [ char _ $" ].
- char asciiValue = 27 ifTrue: [ char _ ${ ]. "ctrl-["
self closeTypeIn.
+ startIndex := self startIndex.
+ stopIndex := self stopIndex.
+ oldSelection := self selection.
+ which := '([<{"''' indexOf: char ifAbsent: [1].
+ left := '([<{"''' at: which.
+ right := ')]>}"''' at: which.
+ text := paragraph text.
- startIndex _ self startIndex.
- stopIndex _ self stopIndex.
- oldSelection _ self selection.
- which _ '([<{"''' indexOf: char ifAbsent: [1].
- left _ '([<{"''' at: which.
- right _ ')]>}"''' at: which.
- text _ paragraph text.
((startIndex > 1 and: [stopIndex <= text size])
and:
[(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
ifTrue:
["already enclosed; strip off brackets"
self selectFrom: startIndex-1 to: stopIndex.
self replaceSelectionWith: oldSelection]
ifFalse:
["not enclosed; enclose by matching brackets"
self replaceSelectionWith:
(Text string: (String with: left), oldSelection string ,(String with: right)
emphasis: emphasisHere).
self selectFrom: startIndex+1 to: stopIndex].
^true!
Item was changed:
----- Method: ParameterTile>>scriptEditor: (in category '*Etoys-Squeakland-accessing') -----
scriptEditor: anEditor
+ scriptEditor := anEditor.
- scriptEditor _ anEditor.
!
Item was changed:
----- Method: ParseNode>>emitLong:code:on: (in category '*Etoys-Squeakland-code generation') -----
emitLong: dist code: longCode on: aStream
"Force a two-byte jump."
| code distance |
+ code := longCode.
+ distance := dist.
- code _ longCode.
- distance _ dist.
distance < 0
ifTrue:
+ [distance := distance + 1024.
+ code := code - 4]
- [distance _ distance + 1024.
- code _ code - 4]
ifFalse:
+ [distance > 1023 ifTrue: [distance := -1]].
- [distance > 1023 ifTrue: [distance _ -1]].
distance < 0
ifTrue:
[self error: 'A block compiles more than 1K bytes of code']
ifFalse:
[aStream nextPut: distance // 256 + code.
aStream nextPut: distance \\ 256]!
Item was changed:
----- Method: ParseNodeAttribute>>addRule: (in category 'all') -----
addRule: aSemanticRule
| newRules |
+ newRules := Array new: rules size + 1.
- newRules _ Array new: rules size + 1.
newRules at: 1 put: aSemanticRule.
newRules replaceFrom: 2 to: newRules size with: rules startingAt: 1.
+ rules := newRules.
- rules _ newRules.
!
Item was changed:
----- Method: ParseNodeAttribute>>addRules: (in category 'all') -----
addRules: semanticRules
+ rules := rules, semanticRules.
- rules _ rules, semanticRules.
!
Item was changed:
----- Method: ParseNodeAttribute>>attributeName: (in category 'all') -----
attributeName: aSymbol
+ attributeName := aSymbol.
+ setter := (attributeName, ':') asSymbol.
+ rawGetter := ('raw', attributeName) asSymbol.
+ "rawGetter := attributeName asSymbol."
- attributeName _ aSymbol.
- setter _ (attributeName, ':') asSymbol.
- rawGetter _ ('raw', attributeName) asSymbol.
- "rawGetter _ attributeName asSymbol."
!
Item was changed:
----- Method: ParseNodeAttribute>>grammarClass: (in category 'all') -----
grammarClass: aClass
+ grammarClass := aClass.
- grammarClass _ aClass.
!
Item was changed:
----- Method: ParseNodeAttribute>>initialize (in category 'all') -----
initialize
+ rules := Array new.
- rules _ Array new.
!
Item was changed:
----- Method: ParseNodeAttribute>>type: (in category 'all') -----
type: aSymbol
+ type := aSymbol.
- type _ aSymbol.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>attributeName: (in category 'all') -----
attributeName: aSymbol
+ attributeName := aSymbol.
- attributeName _ aSymbol.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>inTime: (in category 'all') -----
inTime: aValue
+ sortInTime := aValue.
- sortInTime _ aValue.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>initialize (in category 'all') -----
initialize
super initialize.
+ dependencies := WriteStream on: (Array new: 8).
+ sortInTime := -1.
+ sortOutTime := -1.
- dependencies _ WriteStream on: (Array new: 8).
- sortInTime _ -1.
- sortOutTime _ -1.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>node: (in category 'all') -----
node: aParseNode
+ node := aParseNode.
- node _ aParseNode.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>outTime: (in category 'all') -----
outTime: aValue
+ sortOutTime := aValue.!
- sortOutTime _ aValue.!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>rawGetter: (in category 'all') -----
rawGetter: aSymbol
+ rawGetter := aSymbol.
- rawGetter _ aSymbol.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>selectedRule: (in category 'all') -----
selectedRule: aSemanticRule
+ selectedRule := aSemanticRule.
+ inputSizes := Array new: aSemanticRule inputSpecs size.
- selectedRule _ aSemanticRule.
- inputSizes _ Array new: aSemanticRule inputSpecs size.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>setter: (in category 'all') -----
setter: aSymbol
+ setter := aSymbol.
- setter _ aSymbol.
!
Item was changed:
----- Method: ParseNodeAttributeOccurence>>value: (in category 'all') -----
value: anObject
+ value := anObject.
- value _ anObject.
!
Item was changed:
----- Method: ParseNodeBuilder>>assign: (in category 'all') -----
assign: sexp
| varNode valueNode |
+ varNode := self parse: sexp elements first.
+ valueNode := self parse: sexp elements second.
- varNode _ self parse: sexp elements first.
- valueNode _ self parse: sexp elements second.
^ AssignmentNode new
variable: varNode
value: valueNode
from: encoder
sourceRange: nil.!
Item was changed:
----- Method: ParseNodeBuilder>>condition: (in category 'all') -----
condition: sexp
| selector rec y n |
+ selector := #ifTrue:ifFalse:.
+ rec := self parse: sexp elements first.
+ y := self parse: sexp elements second.
+ n := self parse: sexp elements third.
- selector _ #ifTrue:ifFalse:.
- rec _ self parse: sexp elements first.
- y _ self parse: sexp elements second.
- n _ self parse: sexp elements third.
^ MessageNode new
receiver: rec
selector: selector
arguments: (Array with: y with: n)
precedence: (selector precedence)
from: encoder
sourceRange: nil.!
Item was changed:
----- Method: ParseNodeBuilder>>literal: (in category 'all') -----
literal: sexp
| type value |
+ type := Smalltalk at: (sexp attributeAt: #type ifAbsent: []) asSymbol.
+ value := sexp attributeAt: #value ifAbsent: [].
- type _ Smalltalk at: (sexp attributeAt: #type ifAbsent: []) asSymbol.
- value _ sexp attributeAt: #value ifAbsent: [].
(type inheritsFrom: Symbol) ifTrue: [
+ value := '#', value.
- value _ '#', value.
] ifFalse: [
(type inheritsFrom: String) ifTrue: [
^ encoder encodeLiteral: value.
] ifFalse: [
((type = Character) and: [value isString and: [value size = 1]]) ifTrue: [
^ encoder encodeLiteral: value first
]
]
].
^ encoder encodeLiteral: (type readFromString: value).!
Item was changed:
----- Method: ParseNodeBuilder>>return: (in category 'all') -----
return: sexp
| val |
+ val := self parse: sexp elements first.
- val _ self parse: sexp elements first.
^ ReturnNode new expr: val.!
Item was changed:
----- Method: ParseNodeBuilder>>script:with:in: (in category 'all') -----
script: sexp with: aDictionary in: aWorld
| playerClassId playerClass selector n selOrFalse argSexp arguments block tmps |
+ context := aDictionary.
+ playerClassId := sexp attributeAt: #playerClass.
+ playerClass := aDictionary at: playerClassId asSymbol ifAbsent: [self error: ''].
+ encoder := ScriptEncoder new init: playerClass context: nil notifying: nil; referenceObject: aWorld.
+ selector := (sexp attributeAt: #scriptName) asSymbol.
+ n := MethodNode new.
+ selOrFalse := encoder encodeSelector: selector.
- context _ aDictionary.
- playerClassId _ sexp attributeAt: #playerClass.
- playerClass _ aDictionary at: playerClassId asSymbol ifAbsent: [self error: ''].
- encoder _ ScriptEncoder new init: playerClass context: nil notifying: nil; referenceObject: aWorld.
- selector _ (sexp attributeAt: #scriptName) asSymbol.
- n _ MethodNode new.
- selOrFalse _ encoder encodeSelector: selector.
+ tmps := sexp elements detect: [:e | e keyword = #temporary] ifNone: [nil].
- tmps _ sexp elements detect: [:e | e keyword = #temporary] ifNone: [nil].
tmps ifNotNil: [
tmps elements do: [:t |
self temporary: t.
].
].
+ argSexp := (sexp elements select: [:e | e keyword == #parameter]) asSortedCollection: [:a :b | (a attributeAt: #position) asNumber < (b attributeAt: #position) asNumber].
+ arguments := argSexp collect: [:e | self parse: e].
+ block := self parse: (sexp elements detect: [:e | e keyword == #sequence]).
- argSexp _ (sexp elements select: [:e | e keyword == #parameter]) asSortedCollection: [:a :b | (a attributeAt: #position) asNumber < (b attributeAt: #position) asNumber].
- arguments _ argSexp collect: [:e | self parse: e].
- block _ self parse: (sexp elements detect: [:e | e keyword == #sequence]).
^ n
selector: selOrFalse
arguments: arguments
precedence: selector precedence
temporaries: #()
block: block
encoder: encoder
primitive: 0.!
Item was changed:
----- Method: ParseNodeBuilder>>selector: (in category 'all') -----
selector: sexp
| value |
+ value := sexp attributeAt: #selector ifAbsent: [].
- value _ sexp attributeAt: #selector ifAbsent: [].
^ encoder encodeSelector: value.!
Item was changed:
----- Method: ParseNodeBuilder>>send: (in category 'all') -----
send: sexp
| selector rec args |
+ selector := sexp elements first attributeAt: #selector.
+ rec := self parse: sexp elements second.
+ args := (sexp elements copyFrom: 3 to: sexp elements size) collect: [:e |
- selector _ sexp elements first attributeAt: #selector.
- rec _ self parse: sexp elements second.
- args _ (sexp elements copyFrom: 3 to: sexp elements size) collect: [:e |
self parse: e.
].
^ MessageNode new
receiver: rec
selector: selector asSymbol
arguments: args
precedence: (selector asSymbol precedence)
from: encoder
sourceRange: nil.!
Item was changed:
----- Method: ParseNodeBuilder>>sequence: (in category 'all') -----
sequence: sexp
| statements ret args |
+ args := sexp elements select: [:e | e keyword == #parameter].
+ statements := sexp elements reject: [:e | e keyword == #parameter].
+ args := args collect: [:e | self blockParameter: e].
+ statements := statements collect: [:e | self parse: e].
+ ret := (statements size > 0 and: [statements last isMemberOf: ReturnNode]).
- args _ sexp elements select: [:e | e keyword == #parameter].
- statements _ sexp elements reject: [:e | e keyword == #parameter].
- args _ args collect: [:e | self blockParameter: e].
- statements _ statements collect: [:e | self parse: e].
- ret _ (statements size > 0 and: [statements last isMemberOf: ReturnNode]).
args do: [:variable | variable scope: -1].
^ BlockNode new arguments: args statements: statements returns: ret from: encoder.!
Item was changed:
----- Method: ParseNodeBuilder>>temporary: (in category 'all') -----
temporary: sexp
| value |
+ value := sexp attributeAt: #value ifAbsent: [].
- value _ sexp attributeAt: #value ifAbsent: [].
^ encoder bindTemp: value asSymbol!
Item was changed:
----- Method: ParseNodeBuilder>>variable: (in category 'all') -----
variable: sexp
| value type |
+ value := sexp attributeAt: #value ifAbsent: [].
+ type := sexp attributeAt: #type ifAbsent: [].
- value _ sexp attributeAt: #value ifAbsent: [].
- type _ sexp attributeAt: #type ifAbsent: [].
type = 'Player' ifTrue: [
value = 'self' ifFalse: [
+ value := sexp attributeAt: #idref
- value _ sexp attributeAt: #idref
].
].
value first canBeGlobalVarInitial ifTrue: [
^ encoder encodeVariable: value
] ifFalse: [
value first isDigit ifTrue: [
^ encoder encodeVariable: (context at: value asSymbol) uniqueNameForReference.
]
].
^ encoder encodeVariable: value.!
Item was changed:
----- Method: Parser>>init:notifying:failBlock: (in category '*Etoys-Squeakland-private') -----
init: sourceStream notifying: req failBlock: aBlock
+ failBlock := aBlock.
- failBlock _ aBlock.
super scan: sourceStream.
+ prevMark := hereMark := mark.
+ requestorOffset := 0.
- prevMark _ hereMark _ mark.
- requestorOffset _ 0.
self advance!
Item was changed:
----- Method: Parser>>parseArgsAndTemps:notifying: (in category '*Etoys-Squeakland-public access') -----
parseArgsAndTemps: aString notifying: req
"Parse the argument, aString, notifying req if an error occurs. Otherwise,
answer a two-element Array containing Arrays of strings (the argument
names and temporary variable names)."
(req notNil and: [RequestAlternateSyntaxSetting signal]) ifTrue:
[^ (self as: DialectParser) parseArgsAndTemps: aString notifying: req].
aString == nil ifTrue: [^#()].
+ doitFlag := false. "Don't really know if a doit or not!!"
- doitFlag _ false. "Don't really know if a doit or not!!"
^self initPattern: aString
notifying: req
return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]!
Item was changed:
----- Method: Parser>>primitive (in category '*Etoys-Squeakland-primitives') -----
primitive
| n |
(self matchToken: #<) ifFalse: [^ 0].
+ n := self primitiveDeclarations.
- n _ self primitiveDeclarations.
(self matchToken: #>) ifFalse: [^ self expected: '>'].
^ n!
Item was changed:
----- Method: PartsBin class>>rebuildIconsWithProgress (in category '*Etoys-Squeakland-thumbnail cache') -----
rebuildIconsWithProgress
"Put up an eye-catching progress morph while doing a complete rebuild of all the parts icons in the system."
| fixBlock |
+ fixBlock := Project current displayProgressWithJump: 'Building icons' translated.
- fixBlock _ Project current displayProgressWithJump: 'Building icons' translated.
self clearThumbnailCache.
self cacheAllThumbnails.
fixBlock value.
ActiveWorld ifNotNil: [ActiveWorld fullRepaintNeeded]!
Item was changed:
----- Method: PartsBin>>listDirection:quadList:withPreviousEntries: (in category '*Etoys-Squeakland-initialization') -----
listDirection: aListDirection quadList: quadList withPreviousEntries: aCollection
"Initialize the receiver to run horizontally or vertically, obtaining its elements from the list of tuples of the form:
(<receiver> <selector> <label> <balloonHelp>)"
| aButton aClass oldDict |
self layoutPolicy: TableLayout new.
self listDirection: aListDirection.
self wrapCentering: #topLeft.
self layoutInset: 2.
self cellPositioning: #bottomCenter.
+ oldDict := Dictionary new.
- oldDict _ Dictionary new.
aCollection ifNotNil: [
aCollection do: [:e | oldDict at: e target put: e]
].
aListDirection == #leftToRight
ifTrue:
[self vResizing: #rigid.
self hResizing: #spaceFill.
self wrapDirection: #topToBottom]
ifFalse:
[self hResizing: #rigid.
self vResizing: #spaceFill.
self wrapDirection: #leftToRight].
quadList do:
[:tuple |
+ aClass := Smalltalk at: tuple first.
+ aButton := oldDict at: aClass ifAbsent: [].
- aClass _ Smalltalk at: tuple first.
- aButton _ oldDict at: aClass ifAbsent: [].
(aButton isNil or: [#(TextMorph ScriptableButton) includes: aClass name]) ifTrue: [
+ aButton := IconicButtonWithLabel new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass.
- aButton _ IconicButtonWithLabel new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass.
(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
[aButton setBalloonText: tuple fourth].
] ifFalse: [
aButton labelString: tuple third.
aButton arguments: {aButton arguments first. tuple third}.
(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
[aButton setBalloonText: tuple fourth].
].
self addMorphBack: aButton]!
Item was changed:
----- Method: PartsBin>>restoreUserDefinedObjectsFrom: (in category '*Etoys-Squeakland-saving/loading') -----
restoreUserDefinedObjectsFrom: anArray
| aButton m |
anArray do: [:pair |
+ aButton := IconicButton new.
+ m := pair second sissReadObjects.
- aButton _ IconicButton new.
- m _ pair second sissReadObjects.
aButton color: self color;
initializeToShow: m withLabel: pair first andSend: #veryDeepCopy to: m.
self addMorphBack: aButton
].
!
Item was changed:
----- Method: PartsWindow>>adjustBookControls (in category 'as yet unclassified') -----
adjustBookControls
| inner |
prevButton ifNil: [^ self].
+ prevButton align: prevButton topLeft with: (inner := self innerBounds) topLeft + (32 @ -1).
- prevButton align: prevButton topLeft with: (inner _ self innerBounds) topLeft + (32 @ -1).
nextButton align: nextButton topRight with: inner topRight - (18 @ 1).
menuButton align: menuButton topLeft with: inner topRight + (-42 @ 5).!
Item was changed:
----- Method: PartsWindow>>book: (in category 'as yet unclassified') -----
book: aBook
+ book := aBook.
- book _ aBook.
self addMorph: aBook frame: (0 at 0 extent: 1 at 1).
book beSticky.
self extent: aBook extent + (0 at self labelHeight).
nextButton target: aBook.
prevButton target: aBook!
Item was changed:
----- Method: PartsWindow>>closeEditing (in category 'as yet unclassified') -----
closeEditing
+ openForEditing := false.
- openForEditing _ false.
self color: Color white.
book pages do:
[:aPage | aPage setPartsBinStatusTo: true]!
Item was changed:
----- Method: PartsWindow>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| aFont aForm |
super initialize.
""
+ openForEditing := false.
+ aFont := Preferences standardButtonFont.
+ self addMorph: (prevButton := SimpleButtonMorph new borderWidth: 0;
- openForEditing _ false.
- aFont _ Preferences standardButtonFont.
- self addMorph: (prevButton _ SimpleButtonMorph new borderWidth: 0;
label: '<' font: aFont;
color: Color transparent;
setBalloonText: 'previous page';
actionSelector: #previousPage;
target: self;
extent: 16 @ 16).
+ self addMorph: (nextButton := SimpleButtonMorph new borderWidth: 0;
- self addMorph: (nextButton _ SimpleButtonMorph new borderWidth: 0;
label: '>' font: aFont;
color: Color transparent;
setBalloonText: 'next page';
actionSelector: #nextPage;
target: self;
extent: 16 @ 16).
+ menuButton := ThreePhaseButtonMorph new onImage: (aForm := ScriptingSystem formAtKey: 'OfferToUnlock');
- menuButton _ ThreePhaseButtonMorph new onImage: (aForm _ ScriptingSystem formAtKey: 'OfferToUnlock');
offImage: (ScriptingSystem formAtKey: 'OfferToLock');
pressedImage: (ScriptingSystem formAtKey: 'OfferToLock');
extent: aForm extent;
state: #on.
menuButton target: self;
actionSelector: #toggleStatus;
actWhen: #buttonUp.
menuButton setBalloonText: 'open for editing'.
self addMorph: menuButton.
"
+ self addMorph: (menuButton := SimpleButtonMorph new
- self addMorph: (menuButton _ SimpleButtonMorph new
borderWidth: 0;
label: '·' font: aFont; color: Color transparent;
actWhen: #buttonDown;
actionSelector: #invokePartsWindowMenu; target: self; extent:
16 at 16)."
self adjustBookControls!
Item was changed:
----- Method: PartsWindow>>invokePartsWindowMenu (in category 'as yet unclassified') -----
invokePartsWindowMenu
"Put up a menu offering parts-bin controls"
| aMenu sel |
+ aMenu := MVCMenuMorph new.
- aMenu _ MVCMenuMorph new.
aMenu defaultTarget: aMenu.
openForEditing
ifTrue:
[aMenu add: 'resume being a parts bin' selector: #selectMVCItem: argument: #toggleStatus]
ifFalse:
[aMenu add: 'open for editing' selector: #selectMVCItem: argument:#toggleStatus].
aMenu add: 'sort pages' selector: #selectMVCItem: argument: #sortPages.
aMenu add: 'save as Custom Parts Bin' selector: #selectMVCItem: argument: #saveAsCustomPartsBin.
+ sel := aMenu invokeAt: self primaryHand position in: self world.
- sel _ aMenu invokeAt: self primaryHand position in: self world.
sel ifNotNil: [self perform: sel].
!
Item was changed:
----- Method: PartsWindow>>openEditing (in category 'as yet unclassified') -----
openEditing
+ openForEditing := true.
- openForEditing _ true.
self color: Color green.
book pages do:
[:aPage | aPage setPartsBinStatusTo: false]!
Item was changed:
----- Method: PartsWindow>>setLabelWidgetAllowance (in category 'label') -----
setLabelWidgetAllowance
+ ^ labelWidgetAllowance := 115!
- ^ labelWidgetAllowance _ 115!
Item was changed:
----- Method: PartsWindow>>toggleStatus (in category 'as yet unclassified') -----
toggleStatus
+ openForEditing := openForEditing not.
- openForEditing _ openForEditing not.
openForEditing
ifTrue:
[self openEditing.
menuButton state: #off.
menuButton setBalloonText: 'resume being a parts bin']
ifFalse:
[self closeEditing.
menuButton state: #on.
menuButton setBalloonText: 'open for editing']!
Item was changed:
----- Method: PasteUpMorph>>actionButtonsDo: (in category '*Etoys-Squeakland-e-toy support') -----
actionButtonsDo: aBlock
"Find all morphs with an action that fires a script. Run the block on each one. Cases:
ScriptActivationButton fires a script (SimpleButtonMorph).
A torn off or pinned MenuItemMorph.
Player wearing a costume with event handler (mouseUp,mouseDown).
Inc/dec arrows on tiles.
An Open scriptor with execute (!!) button.
Start/Stop controls.
Page turn controls.
ProjectLink Buttons.
"
| got |
self allMorphsDo: [:mm |
+ got := false.
- got _ false.
((mm isKindOf: SimpleButtonMorph) and: [mm actionSelector ~~ nil]) ifTrue: [
+ aBlock value: mm. got := true].
- aBlock value: mm. got _ true].
(got not and: [mm isKindOf: MenuItemMorph]) ifTrue: [
+ aBlock value: mm. got := true].
- aBlock value: mm. got _ true].
(got not and: [mm isKindOf: ThreePhaseButtonMorph]) ifTrue: [
+ aBlock value: mm. got := true].
- aBlock value: mm. got _ true].
(got not and: [mm isKindOf: TileMorph]) ifTrue: ["do not set got"
mm upArrow notNil ifTrue: [aBlock value: mm upArrow].
mm downArrow notNil ifTrue: [aBlock value: mm downArrow].
mm suffixArrow notNil ifTrue: [aBlock value: mm suffixArrow].
mm retractArrow notNil ifTrue: [aBlock value: mm retractArrow]].
(got not and: [mm isKindOf: ProjectViewMorph]) ifTrue: [
+ aBlock value: mm. got := true].
- aBlock value: mm. got _ true].
(got not and: [mm eventHandler ~~ nil]) ifTrue: [
+ aBlock value: mm. got := true].
- aBlock value: mm. got _ true].
].!
Item was changed:
----- Method: PasteUpMorph>>attemptCleanupReporting: (in category '*Etoys-world menu') -----
attemptCleanupReporting: whetherToReport
"Try to fix up some bad things that are known to occur in some etoy projects we've seen. If the whetherToReport parameter is true, an informer is presented after the cleanups"
| fixes faultyStatusControls |
+ fixes := 0.
- fixes _ 0.
ActiveWorld ifNotNil:
[(ActiveWorld submorphs select:
[:m | (m isKindOf: ScriptEditorMorph) and: [m submorphs isEmpty]]) do:
+ [:m | m delete. fixes := fixes + 1]].
- [:m | m delete. fixes _ fixes + 1]].
TransformationMorph allSubInstancesDo:
[:m | (m player notNil and: [m renderedMorph ~~ m])
ifTrue:
[m renderedMorph visible ifFalse:
+ [m renderedMorph visible: true. fixes := fixes + 1]]].
- [m renderedMorph visible: true. fixes _ fixes + 1]]].
(Player class allSubInstances select: [:cl | cl isUniClass and: [cl instanceCount > 0]]) do:
[:aUniclass |
+ fixes := fixes + aUniclass cleanseScripts].
- fixes _ fixes + aUniclass cleanseScripts].
self presenter flushPlayerListCache; allExtantPlayers.
faultyStatusControls := ScriptStatusControl allInstances select: [:m |m fixUpScriptInstantiation].
fixes := fixes + faultyStatusControls size.
ScriptNameTile allInstancesDo:
[:aTile | aTile submorphs isEmpty ifTrue:
[aTile setLiteral: aTile literal.
fixes := fixes + 1]].
whetherToReport
ifTrue:
[self inform: ('{1} [or more] repair(s) made' translated format: {fixes printString})]
ifFalse:
[fixes > 0 ifTrue: [Transcript cr; show: fixes printString, ' repairs made to existing content.']]
"
ActiveWorld attemptCleanupReporting: true.
ActiveWorld attemptCleanupReporting: false.
"!
Item was changed:
----- Method: PasteUpMorph>>buildShowClickableButton (in category '*Etoys-Squeakland-e-toy support') -----
buildShowClickableButton
"Return a button that momentarily highlights all clickable objects on the screen. Showing the highlights takes a second or two, so press and be patient.
ActiveHand attachMorph: World buildShowClickableButton.
"
| bb |
+ bb := BasicButton new label: 'Show Clickable Areas'.
- bb _ BasicButton new label: 'Show Clickable Areas'.
bb on: #mouseDown send: #highlightActionButtonsOn to: self.
bb on: #mouseUp send: #highlightActionButtonsOff to: self.
^ bb!
Item was changed:
----- Method: PasteUpMorph>>buildWorldHaloMenuForHand: (in category '*Etoys-Squeakland-menu & halo') -----
buildWorldHaloMenuForHand: aHand
"Build and answer a menu that will serve as the world's halo menu."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
self addWorldHaloMenuItemsTo: aMenu hand: aHand.
^ aMenu
!
Item was changed:
----- Method: PasteUpMorph>>deleteBackgroundPainting (in category '*Etoys-playfield') -----
deleteBackgroundPainting
backgroundMorph
ifNotNil:
[backgroundMorph delete.
+ backgroundMorph := nil]
- backgroundMorph _ nil]
ifNil:
[self inform: 'There is presently no
background painting
to delete.' translated]!
Item was changed:
----- Method: PasteUpMorph>>extantGlobalFlapTabs (in category '*Etoys-Squeakland-flaps') -----
extantGlobalFlapTabs
"Answer a list of global flap tabs in the receiver."
| globalList |
+ globalList := Flaps globalFlapTabsIfAny.
- globalList _ Flaps globalFlapTabsIfAny.
^ submorphs select: [:m | (m isKindOf: FlapTab) and: [globalList includes: m]]
"
ActiveWorld extantGlobalFlapTabs
"!
Item was changed:
----- Method: PasteUpMorph>>hideAllPlayers (in category '*Etoys-world menu') -----
hideAllPlayers
"Remove all Viewers belonging to scripted players associated with the receiver or any of its subjects from the screen."
| a |
+ a := OrderedCollection new.
- a _ OrderedCollection new.
self allMorphsDo: [ :x |
(ActiveWorld presenter currentlyViewing: x player) ifTrue:
[a add: x player viewerFlapTab]].
a do: [ :each | each dismissViaHalo].
!
Item was changed:
----- Method: PasteUpMorph>>makeReference:to: (in category '*Etoys-support') -----
makeReference: aName to: anObject
| oldKey oldAssoc |
self referencePool at: aName put: anObject.
+ oldKey := References keyAtValue: anObject ifAbsent: [].
- oldKey _ References keyAtValue: anObject ifAbsent: [].
oldKey ifNotNil: [
+ oldAssoc := References associationAt: oldKey.
- oldAssoc _ References associationAt: oldKey.
References removeKey: oldKey.
oldAssoc becomeForward: (self referencePool associationAt: aName).
].
!
Item was changed:
----- Method: PasteUpMorph>>playfieldOptionsMenu (in category '*Etoys-playfield') -----
playfieldOptionsMenu
"Answer an auxiliary menu with options specific to playfields -- too many to be housed in the main menu"
| aMenu isWorld |
+ isWorld := self isWorldMorph.
+ aMenu := MenuMorph new defaultTarget: self.
- isWorld _ self isWorldMorph.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
#(
(autoLineLayoutString toggleAutoLineLayout
'whether submorphs should automatically be laid out in lines')
(autoExpansionString toggleAutomaticPhraseExpansion
'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
(autoViewingString toggleAutomaticViewing
'governs whether, when an object is touched inside me, a viewer should automatically be launched for it')
(behaveLikeAHolderString toggleBehaveLikeAHolder
'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.')
(fenceEnabledString toggleFenceEnabled
'whether moving objects should stop at the edge of their container')
(gridVisibleString gridVisibleOnOff
'whether the grid should be shown when gridding is on')
(indicateCursorString toggleIndicateCursor
'whether the "current" submorph should be indicated with a dark black border')
(mouseOverHalosString toggleMouseOverHalos
'whether objects should put up halos when the mouse is over them')
(originAtCenterString toggleOriginAtCenter
'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
(isPartsBinString toggleIsPartsBin
'whether dragging an object from the interior should produce a COPY of the object')
(resizeToFitString toggleResizeToFit
'whether I should automatically strive exactly to fit my contents')
(showThumbnailString toggleAlwaysShowThumbnail
'whether large objects should be represented by thumbnail miniatures of themselves')
(griddingString griddingOnOff
'whether gridding should be used in my interior')
) translatedNoop do:
[:triplet |
(isWorld and: [#(toggleAutoLineLayout toggleBehaveLikeAHolder toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail toggleResizeToFit ) includes: triplet second]) ifFalse:
[aMenu addUpdating: triplet first action: triplet second.
aMenu balloonTextForLastItem: triplet third translated]].
aMenu addLine.
aMenu add: 'round up strays' translated action: #roundUpStrays.
aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated.
isWorld ifFalse:
[aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs.
aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated].
aMenu add: 'set grid spacing...' translated action: #setGridSpec.
aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on' translated.
isWorld ifFalse:
[aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight.
aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated].
self backgroundSketch ifNotNil:
[aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting.
aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated].
presenter ifNil:
[aMenu add: 'make detachable' translated action: #makeDetachable.
aMenu balloonTextForLastItem: 'Allow this area to be separately governed by its own controls.' translated].
aMenu addLine.
aMenu add: 'use standard texture' translated action: #setStandardTexture.
aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated.
aMenu add: 'make graph paper...' translated action: #makeGraphPaper.
aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated.
aMenu addLine.
aMenu add: 'show viewers of all players' translated action: #showAllPlayers.
aMenu balloonTextForLastItem: 'Make viewers for all players which have user-written scripts in this playfield.' translated.
aMenu add: 'remove viewers of all players' translated action: #hideAllPlayers.
aMenu balloonTextForLastItem: 'Remove the viewers for all players in this playfield. This will save space before you publish this project' translated.
aMenu addTitle: 'playfield options' translated.
^ aMenu
!
Item was changed:
----- Method: PasteUpMorph>>presentDesktopColorMenu (in category '*Etoys-Squeakland-menus') -----
presentDesktopColorMenu
"Present the menu that governs the fill style of the squeak desktop."
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu title: 'desktop color' translated.
self fillStyle addFillStyleMenuItems: aMenu hand: ActiveHand from: self.
aMenu addLine.
aMenu add: 'solid fill' translated action: #useSolidFill.
aMenu add: 'gradient fill' translated action: #useGradientFill.
aMenu add: 'bitmap fill' translated action: #useBitmapFill.
aMenu add: 'default fill' translated action: #useDefaultFill.
aMenu popUpInWorld !
Item was changed:
----- Method: PasteUpMorph>>presentViewMenu (in category '*Etoys-viewing') -----
presentViewMenu
"Answer an auxiliary menu with options specific to viewing playfields -- this is put up from the provisional 'view' halo handle, on pasteup morphs only."
| aMenu isWorld |
+ isWorld := self isWorldMorph.
+ aMenu := MenuMorph new defaultTarget: self.
- isWorld _ self isWorldMorph.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
self addViewingItemsTo: aMenu.
#( "(autoLineLayoutString toggleAutoLineLayout
'whether submorphs should automatically be laid out in lines')"
(indicateCursorString toggleIndicateCursor
'whether the "current" submorph should be indicated with a dark black border')
(resizeToFitString toggleResizeToFit
'whether I should automatically strive exactly to fit my contents')
(behaveLikeAHolderString toggleBehaveLikeAHolder
'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.')
(isPartsBinString toggleIsPartsBin
'whether dragging an object from the interior should produce a COPY of the object')
(isOpenForDragNDropString toggleDragNDrop
'whether objects can be dropped into and dragged out of me')
(mouseOverHalosString toggleMouseOverHalos
'whether objects should put up halos when the mouse is over them')
(autoExpansionString toggleAutomaticPhraseExpansion
'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
(originAtCenterString toggleOriginAtCenter
'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
(showThumbnailString toggleAlwaysShowThumbnail
'whether large objects should be represented by thumbnail miniatures of themselves')
(fenceEnabledString toggleFenceEnabled
'whether moving objects should stop at the edge of their container')
(autoViewingString toggleAutomaticViewing
'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.')
(griddingString griddingOnOff
'whether gridding should be used in my interior')
(gridVisibleString gridVisibleOnOff
'whether the grid should be shown when gridding is on')
) do:
[:triplet |
(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail toggleAutomaticViewing ) includes: triplet second]) ifFalse:
[aMenu addUpdating: triplet first action: triplet second.
aMenu balloonTextForLastItem: triplet third translated]].
aMenu addLine.
aMenu add: 'round up strays' translated action: #roundUpStrays.
aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated.
aMenu add: 'gallery of players' translated target: self action: #galleryOfPlayers.
aMenu balloonTextForLastItem: 'A tool that lets you find out about all the players used in this project' translated.
aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs.
aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated.
aMenu add: 'set grid spacing...' translated action: #setGridSpec.
aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on' translated.
isWorld ifFalse:
[aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight.
aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated].
self backgroundSketch ifNotNil:
[aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting.
aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated].
aMenu addLine.
self addPenTrailsMenuItemsTo: aMenu.
aMenu addLine.
aMenu add: 'use standard texture' translated action: #setStandardTexture.
aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated.
aMenu add: 'make graph paper...' translated action: #makeGraphPaper.
aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated.
aMenu addTitle: ('viewing options for "{1}"' translated format: {self externalName}).
aMenu popUpForHand: self activeHand in: self world
!
Item was changed:
----- Method: PasteUpMorph>>putUpShowSourceMenu:title: (in category '*Etoys-Squeakland-world menu') -----
putUpShowSourceMenu: evt title: aTitle
"Put up a menu in response to the show-source button being hit"
| menu |
self bringTopmostsToFront.
"put up the show-source menu"
+ menu := (TheWorldMenu new adaptToWorld: ActiveWorld) buildShowSourceMenu.
- menu _ (TheWorldMenu new adaptToWorld: ActiveWorld) buildShowSourceMenu.
menu addTitle: aTitle.
menu popUpEvent: evt in: self.
^ menu!
Item was changed:
----- Method: PasteUpMorph>>removeHighlightFeedback (in category '*Etoys-Squeakland-highlighting') -----
removeHighlightFeedback
| prop |
+ prop := self valueOfProperty: #hilighted ifAbsent: [^ self].
- prop _ self valueOfProperty: #hilighted ifAbsent: [^ self].
prop delete.
self setProperty: #hilighted toValue: nil.
!
Item was changed:
----- Method: PasteUpMorph>>uniqueNameForReferenceFor: (in category '*Etoys-support') -----
uniqueNameForReferenceFor: aPlayer
| aName nameSym stem knownClassVars |
+ (aName := self uniqueNameForReferenceOrNilFor: aPlayer) ifNotNil: [^ aName].
+ (stem := aPlayer knownName) ifNil:
+ [stem := aPlayer defaultNameStemForInstances asString].
+ stem := stem select: [:ch | ch isLetter or: [ch isDigit]].
+ stem size == 0 ifTrue: [stem := 'A'].
- (aName _ self uniqueNameForReferenceOrNilFor: aPlayer) ifNotNil: [^ aName].
- (stem _ aPlayer knownName) ifNil:
- [stem _ aPlayer defaultNameStemForInstances asString].
- stem _ stem select: [:ch | ch isLetter or: [ch isDigit]].
- stem size == 0 ifTrue: [stem _ 'A'].
stem first isLetter ifFalse:
+ [stem := 'A', stem].
+ stem := stem capitalized.
+ knownClassVars := ScriptingSystem allKnownClassVariableNames.
+ aName := Utilities keyLike: stem satisfying:
- [stem _ 'A', stem].
- stem _ stem capitalized.
- knownClassVars _ ScriptingSystem allKnownClassVariableNames.
- aName _ Utilities keyLike: stem satisfying:
[:jinaLake |
+ nameSym := jinaLake asSymbol.
- nameSym _ jinaLake asSymbol.
((self referencePool includesKey: nameSym) not and:
[(Smalltalk includesKey: nameSym) not]) and:
[(knownClassVars includes: nameSym) not]].
self makeReference: aName asSymbol to: aPlayer.
^ aName!
Item was changed:
----- Method: PasteUpMorph>>updateSubmorphThumbnails (in category '*Etoys-viewing') -----
updateSubmorphThumbnails
| thumbsUp itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
+ thumbsUp := self alwaysShowThumbnail.
+ heightForThumbnails := self heightForThumbnails.
+ maxHeightToAvoidThumbnailing := self maxHeightToAvoidThumbnailing.
+ maxWidthForThumbnails := self maximumThumbnailWidth.
- thumbsUp _ self alwaysShowThumbnail.
- heightForThumbnails _ self heightForThumbnails.
- maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing.
- maxWidthForThumbnails _ self maximumThumbnailWidth.
self submorphs do:
[:aMorph | thumbsUp
ifTrue:
+ [itsThumbnail := aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
- [itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
(aMorph == itsThumbnail)
ifFalse:
[self replaceSubmorph: aMorph by: itsThumbnail]]
ifFalse:
[(aMorph isKindOf: MorphThumbnail)
ifTrue:
[self replaceSubmorph: aMorph by: aMorph morphRepresented]]].
self invalidRect: self bounds!
Item was changed:
----- Method: PasteUpMorph>>viewerFlapTabFor: (in category '*Etoys-playfield') -----
viewerFlapTabFor: anObject
"Open up a Viewer on aMorph in its own flap, creating it if necessary"
| bottomMost aPlayer aFlapTab tempFlapTab |
+ bottomMost := self top + 75.
+ aPlayer := anObject isMorph ifTrue: [anObject assuredPlayer] ifFalse: [anObject objectRepresented].
- bottomMost _ self top + 75.
- aPlayer _ anObject isMorph ifTrue: [anObject assuredPlayer] ifFalse: [anObject objectRepresented].
self flapTabs do:
[:aTab | ((aTab isKindOf: ViewerFlapTab) or: [aTab hasProperty: #paintingFlap])
ifTrue:
+ [bottomMost := aTab bottom max: bottomMost.
- [bottomMost _ aTab bottom max: bottomMost.
((aTab isKindOf: ViewerFlapTab) and: [aTab scriptedPlayer == aPlayer])
ifTrue:
[^ aTab]]].
"Not found; make a new one"
+ tempFlapTab := Flaps newFlapTitled: anObject nameForViewer onEdge: #right inPasteUp: self.
- tempFlapTab _ Flaps newFlapTitled: anObject nameForViewer onEdge: #right inPasteUp: self.
tempFlapTab arrangeToPopOutOnDragOver: false;
arrangeToPopOutOnMouseOver: false.
"For some reason those event handlers were causing trouble, as reported by ar 11/22/2001, after di's flapsOnBottom update."
+ aFlapTab := tempFlapTab as: ViewerFlapTab.
- aFlapTab _ tempFlapTab as: ViewerFlapTab.
aFlapTab initializeFor: aPlayer topAt: bottomMost + 2.
aFlapTab referent color: (Color green muchLighter alpha: 0.5).
aFlapTab referent borderWidth: 0.
aFlapTab referent setProperty: #automaticPhraseExpansion toValue: true.
Preferences compactViewerFlaps
ifTrue: [aFlapTab makeFlapCompact: true].
self addMorphFront: aFlapTab.
aFlapTab adaptToWorld: self.
aFlapTab setProperty: #isEToysFlap toValue: true.
^ aFlapTab!
Item was changed:
----- Method: PhraseTileForTest>>addCommandFeedback: (in category 'as yet unclassified') -----
addCommandFeedback: evt
"Add screen feedback showing what would be torn off in a drag"
| aMorph |
(self owner owner isMemberOf: PhraseTileMorph) ifTrue: [self owner owner addCommandFeedback: evt. ^ self].
+ aMorph := RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: (self bottomRight) + (2 at 1)).
- aMorph _ RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: (self bottomRight) + (2 at 1)).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem commandFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: self outmostScriptEditor!
Item was changed:
----- Method: PhraseTileForTest>>mouseDown: (in category 'mouse') -----
mouseDown: evt
"Handle a mouse-down on the receiver"
| guyToTake catViewer |
+ guyToTake := CompoundTileMorph new.
- guyToTake _ CompoundTileMorph new.
guyToTake setNamePropertyTo: 'TestTile' translated.
guyToTake position: evt position + (-25 at 8).
guyToTake formerPosition: ActiveHand position.
"self startSteppingSelector: #trackDropZones."
(catViewer := self ownerThatIsA: CategoryViewer) ifNotNil:
[guyToTake setProperty: #newPermanentPlayer toValue: catViewer scriptedPlayer.
guyToTake setProperty: #newPermanentScript toValue: true].
guyToTake justGrabbedFromViewer: true.
^ evt hand grabMorph: guyToTake
!
Item was changed:
----- Method: PhraseTileForTest>>setupCostume (in category 'as yet unclassified') -----
setupCostume
| stringMorph |
+ stringMorph := StringMorph new contents: 'Test' translated.
- stringMorph _ StringMorph new contents: 'Test' translated.
stringMorph name: 'Test' translated.
stringMorph font: Preferences standardEToysFont.
self addMorphBack: stringMorph.
self addMorphBack: (Morph new color: color;
extent: 15 @ 5).
+ stringMorph := StringMorph new contents: 'Yes' translated.
- stringMorph _ StringMorph new contents: 'Yes' translated.
stringMorph name: 'Yes' translated.
stringMorph font: Preferences standardEToysFont.
self addMorphBack: stringMorph.
self addMorphBack: (Morph new color: color;
extent: 15 @ 5).
+ stringMorph := StringMorph new contents: 'No' translated.
- stringMorph _ StringMorph new contents: 'No' translated.
stringMorph name: 'No' translated.
stringMorph font: Preferences standardEToysFont.
self addMorphBack: stringMorph.
self addMorphBack: (Morph new color: color;
extent: 15 @ 5).
!
Item was changed:
----- Method: PhraseTileForTimesRepeat>>addCommandFeedback: (in category 'hilighting') -----
addCommandFeedback: evt
"Add screen feedback showing what would be torn off in a drag"
| aMorph |
(self owner owner isMemberOf: PhraseTileMorph) ifTrue: [self owner owner addCommandFeedback: evt. ^ self].
+ aMorph := RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: (self bottomRight) + (2 at 1)).
- aMorph _ RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: (self bottomRight) + (2 at 1)).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem commandFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: self outmostScriptEditor!
Item was changed:
----- Method: PhraseTileForTimesRepeat>>mouseDown: (in category 'mouse') -----
mouseDown: evt
"Handle a mouse-down on the receiver"
| guyToTake catViewer |
+ guyToTake := TimesRepeatTile new.
- guyToTake _ TimesRepeatTile new.
guyToTake setNamePropertyTo: 'Repeat Tile' translated.
guyToTake position: evt position + (-25 at 8).
guyToTake formerPosition: ActiveHand position.
"self startSteppingSelector: #trackDropZones."
(catViewer := self ownerThatIsA: CategoryViewer) ifNotNil:
[guyToTake setProperty: #newPermanentPlayer toValue: catViewer scriptedPlayer.
guyToTake setProperty: #newPermanentScript toValue: true].
guyToTake justGrabbedFromViewer: true.
^ evt hand grabMorph: guyToTake
!
Item was changed:
----- Method: PhraseTileForTimesRepeat>>setupCostume (in category 'initialization') -----
setupCostume
"Set up the details that make up the receiver's appearance."
| stringMorph |
+ stringMorph := StringMorph new contents: 'Repeat' translated.
- stringMorph _ StringMorph new contents: 'Repeat' translated.
stringMorph name: 'Repeat' translated.
stringMorph font: Preferences standardEToysFont.
self addMorphBack: stringMorph.
self addMorphBack: (Morph new color: color;
extent: 15 @ 5).
+ stringMorph := StringMorph new contents: 'Times' translated.
- stringMorph _ StringMorph new contents: 'Times' translated.
stringMorph name: 'Times' translated.
stringMorph font: Preferences standardEToysFont.
self addMorphBack: stringMorph.
self addMorphBack: (Morph new color: color;
extent: 15 @ 5).
!
Item was changed:
----- Method: PhraseTileMorph>>addCommandFeedback: (in category '*Etoys-Squeakland-hilighting') -----
addCommandFeedback: evt
"Add screen feedback showing what would be torn off in a drag"
| aMorph |
(self owner owner isMemberOf: PhraseTileMorph)
ifTrue: [self owner owner addCommandFeedback: evt. ^ self].
+ aMorph := RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: ((submorphs at: (2 max: submorphs size)) bottomRight + (2 at 1))).
+ "inHotZone := evt ifNil: [true] ifNotNil: [rect containsPoint: evt cursorPoint]."
- aMorph _ RectangleMorph new bounds: ((self topLeft - (2 at 1)) corner: ((submorphs at: (2 max: submorphs size)) bottomRight + (2 at 1))).
- "inHotZone _ evt ifNil: [true] ifNotNil: [rect containsPoint: evt cursorPoint]."
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem commandFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: self outmostScriptEditor!
Item was changed:
----- Method: PhraseTileMorph>>assignmentNodeWith: (in category '*Etoys-Squeakland-code generation') -----
assignmentNodeWith: encoder
| suffix rec sel args left op right m |
+ rec := submorphs first parseNodeWith: encoder.
- rec _ submorphs first parseNodeWith: encoder.
+ suffix := submorphs second operatorForSexpAssignmentSuffix: submorphs second assignmentSuffix.
+ sel := submorphs second assignmentRootForParseNode.
- suffix _ submorphs second operatorForSexpAssignmentSuffix: submorphs second assignmentSuffix.
- sel _ submorphs second assignmentRootForParseNode.
+ args := WriteStream on: (Array new: 3).
- args _ WriteStream on: (Array new: 3).
(submorphs second isMemberOf: AssignmentTileMorph) ifFalse: [
args nextPut: (submorphs second parseNodeWith: encoder).
+ sel := (sel, 'to:') asSymbol.
- sel _ (sel, 'to:') asSymbol.
].
suffix isEmpty ifFalse: [
+ left := self updatingOperatorNodeWith: encoder.
+ op := (AssignmentTileMorph new operatorForAssignmentSuffix: suffix) asSymbol.
+ right := self convertPrecedenceInParseNode: (submorphs third parseNodeWith: encoder) with: encoder.
+ m := MessageNode new
- left _ self updatingOperatorNodeWith: encoder.
- op _ (AssignmentTileMorph new operatorForAssignmentSuffix: suffix) asSymbol.
- right _ self convertPrecedenceInParseNode: (submorphs third parseNodeWith: encoder) with: encoder.
- m _ MessageNode new
receiver: left
selector: op
arguments: (Array with: right)
precedence: (op precedence)
from: encoder
sourceRange: nil.
args nextPut: m.
] ifTrue: [
args nextPut: (self convertPrecedenceInParseNode: (submorphs third parseNodeWith: encoder) with: encoder).
].
^ MessageNode new
receiver: rec
selector: sel
arguments: args contents
precedence: (sel asSymbol precedence)
from: encoder
sourceRange: nil.!
Item was changed:
----- Method: PhraseTileMorph>>colorSeerNodeWith: (in category '*Etoys-Squeakland-code generation') -----
colorSeerNodeWith: encoder
| rec sel args |
+ rec := submorphs first parseNodeWith: encoder.
+ sel := #color:sees:.
+ args := OrderedCollection new: 2.
- rec _ submorphs first parseNodeWith: encoder.
- sel _ #color:sees:.
- args _ OrderedCollection new: 2.
args add: (self colorNodeFor: submorphs second colorSwatch color with: encoder).
args add: (submorphs third parseNodeWith: encoder).
^ MessageNode new
receiver: rec
selector: sel
arguments: args asArray
precedence: (sel precedence)
from: encoder
sourceRange: nil.
!
Item was changed:
----- Method: PhraseTileMorph>>convertPrecedenceInParseNode:with: (in category '*Etoys-Squeakland-code generation') -----
convertPrecedenceInParseNode: message with: encoder
| e w list |
+ w := WriteStream on: (Array new: 3).
- w _ WriteStream on: (Array new: 3).
message eToysExpFlattenOn: w.
+ list := w contents.
+ e := EToyExpressionTransformer2 new newNodeFromList: list encoder: encoder.
- list _ w contents.
- e _ EToyExpressionTransformer2 new newNodeFromList: list encoder: encoder.
^ e transform.
!
Item was changed:
----- Method: PhraseTileMorph>>convertPrecedenceOfArgsInParseNode:with: (in category '*Etoys-Squeakland-code generation') -----
convertPrecedenceOfArgsInParseNode: message with: encoder
| e r w list |
message arguments size > 0 ifTrue: [
+ w := WriteStream on: (Array new: 3).
- w _ WriteStream on: (Array new: 3).
message arguments first eToysExpFlattenOn: w.
+ list := w contents.
+ e := EToyExpressionTransformer2 new newNodeFromList: list encoder: encoder.
+ r := e transform.
- list _ w contents.
- e _ EToyExpressionTransformer2 new newNodeFromList: list encoder: encoder.
- r _ e transform.
message arguments at: 1 put: r.
^ message.
] ifFalse: [
^ message.
].
!
Item was changed:
----- Method: PhraseTileMorph>>forceScriptCreationAt: (in category '*Etoys-Squeakland-mouse') -----
forceScriptCreationAt: aPosition
"For performance testing."
| dup |
+ dup := self duplicate.
- dup _ self duplicate.
dup eventHandler: nil. "Remove viewer-related evt mouseover feedback"
dup formerPosition: ActiveHand position.
ActiveHand attachMorph: dup.
ActiveHand simulateMorphDropAt: aPosition!
Item was changed:
----- Method: PhraseTileMorph>>initialize (in category 'initialization') -----
initialize
"Initialize a nascent instance"
super initialize.
+ resultType := #unknown.
- resultType _ #unknown.
self wrapCentering: #center; cellPositioning: #leftCenter.
self hResizing: #shrinkWrap.
self vResizing: #spaceFill.
self borderWidth: 0.
self layoutInset: 0.
self extent: 5 at 5. "will grow to fit"
self minCellSize: 0 @ TileMorph defaultH.
self minHeight: TileMorph defaultH.
+ justGrabbedFromViewer := true. "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false"
- justGrabbedFromViewer _ true. "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false"
!
Item was changed:
----- Method: PhraseTileMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
"Phrase tiles only auto-expand if they originate from viewers. Any phrase tile, once dropped, loses its auto-phrase-expansion thing"
(justGrabbedFromViewer = true and: [newOwner isKindOf: Viewer]) ifTrue: [
self formerPosition ifNotNil: [
^ self vanishAfterSlidingTo: self formerPosition event: evt
].
].
+ justGrabbedFromViewer := false.
- justGrabbedFromViewer _ false.
super justDroppedInto: newOwner event: evt.
((owner isKindOf: TilePadMorph) and: [submorphs size = 3] and: [#(bearingTo: distanceToPlayer:) includes: submorphs second operatorOrExpression])
ifTrue:
[owner wrapInFunction.
owner owner operator: #grouped wording: '()' helpString: 'parenthesized' translated pad: owner.
owner scriptEdited]!
Item was changed:
----- Method: PhraseTileMorph>>morphToDropInPasteUp: (in category 'mouse') -----
morphToDropInPasteUp: aPasteUp
"Answer the morph to drop in aPasteUp, given that the receiver is the putative droppee"
| actualObject itsSelector aScriptor pos aWatcher op |
+ ((actualObject := self actualObject) isNil or: [actualObject isPlayerLike not] or: [actualObject costume isInWorld not]) ifTrue:
- ((actualObject _ self actualObject) isNil or: [actualObject isPlayerLike not] or: [actualObject costume isInWorld not]) ifTrue:
[^ ScriptingTileHolder around: self].
self isCommand ifFalse: "Can't expand to a scriptor, but maybe launch a watcher..."
[^ (Preferences dropProducesWatcher and: [(#(unknown command) includes: self resultType) not] and:
+ [(op := self operatorTile operatorOrExpression) notNil] and: [op numArgs = 0] and: [(Vocabulary gettersForbiddenFromWatchers includes: op) not])
- [(op _ self operatorTile operatorOrExpression) notNil] and: [op numArgs = 0] and: [(Vocabulary gettersForbiddenFromWatchers includes: op) not])
ifTrue:
+ [aWatcher := WatcherWrapper new fancyForPlayer: self associatedPlayer getter: op.
- [aWatcher _ WatcherWrapper new fancyForPlayer: self associatedPlayer getter: op.
aWatcher position: self position]
ifFalse:
[ScriptingTileHolder around: self]].
(aPasteUp automaticPhraseExpansion and: [self justGrabbedFromViewer]) ifFalse: [^ ScriptingTileHolder around: self].
actualObject assureUniClass.
+ itsSelector := self userScriptSelector.
+ pos := self position.
+ aScriptor := itsSelector isEmptyOrNil
- itsSelector _ self userScriptSelector.
- pos _ self position.
- aScriptor _ itsSelector isEmptyOrNil
ifFalse:
[actualObject scriptEditorFor: itsSelector]
ifTrue:
["It's a system-defined selector; construct an anonymous scriptor around it"
actualObject newScriptorAround: self].
aScriptor ifNil:[^ ScriptingTileHolder around: self].
(self hasOwner: aScriptor) ifTrue:[
aScriptor fullBounds. "force layout"
aScriptor position: pos - self position.
] ifFalse:[
aScriptor position: self position.
].
(aScriptor valueOfProperty: #needsLayoutFixed) ifNotNil: [
aScriptor removeProperty: #needsLayoutFixed.
aScriptor fixLayout
].
^ aScriptor!
Item was changed:
----- Method: PhraseTileMorph>>mouseDown: (in category 'mouse') -----
mouseDown: evt
"Handle a mouse-down on the receiver"
| ed guyToTake dup enclosingPhrase |
self removeHighlightFeedback.
self isPartsDonor ifTrue:
+ [dup := self duplicate.
- [dup _ self duplicate.
dup eventHandler: nil. "Remove viewer-related evt mouseover feedback"
evt hand attachMorph: dup.
dup position: evt position + (-25 at 8).
"So that the drag vs. click logic works"
dup formerPosition: evt position.
^ self].
submorphs isEmpty
ifTrue: [^ self].
+ guyToTake := self.
+ [(enclosingPhrase := guyToTake ownerThatIsA: PhraseTileMorph) notNil] whileTrue:
+ [guyToTake := enclosingPhrase]. "This logic always grabs the outermost phrase, for now anyway"
- guyToTake _ self.
- [(enclosingPhrase _ guyToTake ownerThatIsA: PhraseTileMorph) notNil] whileTrue:
- [guyToTake _ enclosingPhrase]. "This logic always grabs the outermost phrase, for now anyway"
"the below had comment: 'picking me out of another phrase'"
"owner class == TilePadMorph
ifTrue:
+ [(ss := submorphs first) class == TilePadMorph
+ ifTrue: [ss := ss submorphs first].
+ guyToTake := ss veryDeepCopy]."
- [(ss _ submorphs first) class == TilePadMorph
- ifTrue: [ss _ ss submorphs first].
- guyToTake _ ss veryDeepCopy]."
+ (ed := self enclosingEditor) ifNil: [^ evt hand grabMorph: guyToTake].
- (ed _ self enclosingEditor) ifNil: [^ evt hand grabMorph: guyToTake].
evt hand grabMorph: guyToTake.
ed startStepping.
ed mouseEnterDragging: evt.
ed setProperty: #justPickedUpPhrase toValue: true.
!
Item was changed:
----- Method: PhraseTileMorph>>operatorNodeWith: (in category '*Etoys-Squeakland-code generation') -----
operatorNodeWith: encoder
| sel rec args |
+ sel := submorphs second operatorOrExpression.
+ sel := (TileMorph classPool at: #EqualityOperators) at: sel ifAbsent: [sel].
+ rec := submorphs first parseNodeWith: encoder.
+ args := WriteStream on: (Array new: 3).
- sel _ submorphs second operatorOrExpression.
- sel _ (TileMorph classPool at: #EqualityOperators) at: sel ifAbsent: [sel].
- rec _ submorphs first parseNodeWith: encoder.
- args _ WriteStream on: (Array new: 3).
((submorphs second isMemberOf: TileCommandWithArgumentMorph) or: [
submorphs second isMemberOf: KedamaGetColorComponentTile]) ifTrue: [
args nextPut: (submorphs second parseNodeWith: encoder).
].
(3 to: submorphs size) do: [:e |
args nextPut: ((submorphs at: e) parseNodeWith: encoder).
].
^ MessageNode new
receiver: rec
selector: sel
arguments: args contents
precedence: (sel precedence)
from: encoder
sourceRange: nil.
!
Item was changed:
----- Method: PhraseTileMorph>>parseNodeWith:asStatement: (in category '*Etoys-Squeakland-code generation') -----
parseNodeWith: encoder asStatement: aBoolean
| ret |
submorphs size >= 2 ifTrue: [
self isAssignment ifTrue: [
^ self assignmentNodeWith: encoder.
].
self isColorSeer ifTrue: [
^ self colorSeerNodeWith: encoder.
].
(true) ifTrue: [
+ ret := self operatorNodeWith: encoder.
- ret _ self operatorNodeWith: encoder.
aBoolean ifTrue: [^ self convertPrecedenceOfArgsInParseNode: ret with: encoder].
^ ret.
].
].
+ ret := submorphs first parseNodeWith: encoder.
- ret _ submorphs first parseNodeWith: encoder.
aBoolean ifTrue: [^ self convertPrecedenceInParseNode: ret with: encoder].
^ ret.
!
Item was changed:
----- Method: PhraseTileMorph>>replacePlayerInReadoutWith: (in category 'kedama') -----
replacePlayerInReadoutWith: aPlayer
| tile |
+ tile := self firstMorphBearingKedamaPlayer.
- tile _ self firstMorphBearingKedamaPlayer.
tile ifNil: [^ self].
(tile isMemberOf: TileMorph) ifFalse: [^ self].
tile type = #objRef ifFalse: [^ self].
tile referToSimilarObject: aPlayer.
self allMorphsDo: [:e |
((e isMemberOf: UpdatingStringMorph) or: [e isMemberOf: UpdatingRectangleMorph]) ifTrue: [
e target isPlayerLike ifTrue: [
e target: aPlayer
].
].
(e isMemberOf: KedamaPatchTile) ifTrue: [
e usePatch: (aPlayer costume renderedMorph kedamaWorld defaultPatch player).
].
].!
Item was changed:
----- Method: PhraseTileMorph>>replacePlayerWith: (in category '*Etoys-Squeakland-kedama') -----
replacePlayerWith: aPlayer
"Kedama hook."
| tile patch |
aPlayer isPlayerLike ifFalse: [^ self].
aPlayer isPrototypeTurtlePlayer ifTrue: [
+ tile := self firstMorphBearingKedamaPlayer.
- tile _ self firstMorphBearingKedamaPlayer.
tile ifNil: [^ self].
(tile isMemberOf: TileMorph) ifFalse: [^ self].
tile type = #objRef ifFalse: [^ self].
tile referToSimilarObject: aPlayer.
+ patch := aPlayer costume renderedMorph kedamaWorld defaultPatch player.
- patch _ aPlayer costume renderedMorph kedamaWorld defaultPatch player.
] ifFalse: [
(aPlayer costume renderedMorph isMemberOf: KedamaPatchMorph) ifTrue: [
+ patch := aPlayer.
- patch _ aPlayer.
] ifFalse: [^ self].
].
self allMorphsDo: [:e |
((e isMemberOf: UpdatingStringMorph) or: [e isMemberOf: UpdatingRectangleMorph]) ifTrue: [
e target isPlayerLike ifTrue: [
e target costume renderedMorph class = aPlayer costume renderedMorph class ifTrue: [
e target: aPlayer
].
].
].
(e isMemberOf: KedamaPatchTile) ifTrue: [
e usePatch: patch.
].
].!
Item was changed:
----- Method: PhraseTileMorph>>setAngleToOperator:type:rcvrType:argType: (in category 'initialization') -----
setAngleToOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaAngleToTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaAngleToTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setBounceOnOperator:type:rcvrType:argType: (in category 'initialization') -----
setBounceOnOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaBounceOnTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaBounceOnTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setDistanceToOperator:type:rcvrType:argType: (in category 'initialization') -----
setDistanceToOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaDistanceToTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaDistanceToTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setGetColorComponentOperator:componentName:type:rcvrType:argType: (in category 'initialization') -----
setGetColorComponentOperator: opSymbol componentName: componentName type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := KedamaGetColorComponentTile new adoptVocabulary: self currentVocabulary.
- aTileMorph _ KedamaGetColorComponentTile new adoptVocabulary: self currentVocabulary.
aTileMorph componentName: componentName.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setGetPixelOperator:type:rcvrType:argType: (in category 'initialization') -----
setGetPixelOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaGetPatchValueTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaGetPatchValueTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setTurtleOfOperator:type:rcvrType:argType: (in category 'initialization') -----
setTurtleOfOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaGetTurtleOfTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaGetTurtleOfTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>setUpHillOperator:type:rcvrType:argType: (in category 'initialization') -----
setUpHillOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
"Set the operator, type, receiver type, and argument type for the phrase"
| aTileMorph |
+ resultType := opType.
- resultType _ opType.
opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
self removeAllMorphs.
self addMorph: (TilePadMorph new setType: rcvrType).
+ aTileMorph := TileCommandWithArgumentMorph newKedamaGetUpHillTile.
- aTileMorph _ TileCommandWithArgumentMorph newKedamaGetUpHillTile.
aTileMorph adoptVocabulary: self currentVocabulary.
self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
!
Item was changed:
----- Method: PhraseTileMorph>>updatingOperatorNodeWith: (in category '*Etoys-Squeakland-code generation') -----
updatingOperatorNodeWith: encoder
| sel rec args |
+ sel := Utilities getterSelectorFor: submorphs second assignmentRoot.
+ rec := submorphs first parseNodeWith: encoder.
+ args := WriteStream on: (Array new: 3).
- sel _ Utilities getterSelectorFor: submorphs second assignmentRoot.
- rec _ submorphs first parseNodeWith: encoder.
- args _ WriteStream on: (Array new: 3).
((submorphs second isMemberOf: TileCommandWithArgumentMorph)
or: [(submorphs second isMemberOf: KedamaSetColorComponentTile)
or: [submorphs second isMemberOf: KedamaSetPixelValueTile]]) ifTrue: [
args nextPut: (submorphs second parseNodeWith: encoder).
].
^ MessageNode new
receiver: rec
selector: sel
arguments: args contents
precedence: (sel precedence)
from: encoder
sourceRange: nil.
!
Item was changed:
----- Method: PianoKeyboardMorph>>stopSoundAt: (in category '*Etoys-Squeakland-private') -----
stopSoundAt: morphIndex
| sound noteMorph |
noteMorph := submorphs at: morphIndex.
self setProperty: #frequency toValue: 0.
noteMorph
color: ((#(1 2 3 4 5) includes: (morphIndex - 1) \\ 12)
ifTrue: [blackKeyColor]
ifFalse: [whiteKeyColor]).
+ sound := self soundPlayingListAt: morphIndex.
- sound _ self soundPlayingListAt: morphIndex.
sound notNil
ifTrue: [sound stopGracefully.
self soundPlayingListAt: morphIndex put: nil]!
Item was changed:
----- Method: PinMorph class>>initialize (in category 'class initialization') -----
initialize "PinMorph initialize"
+ OutputPinForm := Form extent: 8 at 8 depth: 1 fromArray:
- OutputPinForm _ Form extent: 8 at 8 depth: 1 fromArray:
#( 0 3221225472 4026531840 4227858432 4278190080 4227858432 4026531840 3221225472)
offset: 0 at 0.
+ IoPinForm := Form extent: 8 at 8 depth: 1 fromArray:
- IoPinForm _ Form extent: 8 at 8 depth: 1 fromArray:
#( 0 402653184 1006632960 2113929216 4278190080 2113929216 1006632960 402653184)
offset: 0 at 0.
+ InputPinForm := OutputPinForm flipBy: #horizontal centerAt: 0 at 0.
- InputPinForm _ OutputPinForm flipBy: #horizontal centerAt: 0 at 0.
!
Item was changed:
----- Method: PinMorph>>addModelVariable (in category 'variables') -----
addModelVariable
| accessors |
+ accessors := component model addVariableNamed: component knownName , pinSpec pinName.
- accessors _ component model addVariableNamed: component knownName , pinSpec pinName.
pinSpec modelReadSelector: accessors first modelWriteSelector: accessors second.
component initFromPinSpecs.
self connectedPins do: [:connectee | connectee shareVariableOf: self]!
Item was changed:
----- Method: PinMorph>>component:pinSpec: (in category 'initialization') -----
component: aComponent pinSpec: spec
+ component := aComponent.
+ pinSpec := spec.
+ pinSpec isInput ifTrue: [pinForm := InputPinForm].
+ pinSpec isOutput ifTrue: [pinForm := OutputPinForm].
+ pinSpec isInputOutput ifTrue: [pinForm := IoPinForm].
- component _ aComponent.
- pinSpec _ spec.
- pinSpec isInput ifTrue: [pinForm _ InputPinForm].
- pinSpec isOutput ifTrue: [pinForm _ OutputPinForm].
- pinSpec isInputOutput ifTrue: [pinForm _ IoPinForm].
self image: pinForm!
Item was changed:
----- Method: PinMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ wires := OrderedCollection new!
- wires _ OrderedCollection new!
Item was changed:
----- Method: PinMorph>>placeFromSpec (in category 'geometry') -----
placeFromSpec
| side corners c1 c2 |
+ side := pinSpec pinLoc asInteger. "1..4 ccw from left"
+ corners := owner bounds corners.
+ c1 := corners at: side.
+ c2 := corners atWrap: side+1.
- side _ pinSpec pinLoc asInteger. "1..4 ccw from left"
- corners _ owner bounds corners.
- c1 _ corners at: side.
- c2 _ corners atWrap: side+1.
self position: (c1 + (c2 - c1 * pinSpec pinLoc fractionPart)).
self updateImage.!
Item was changed:
----- Method: PinMorph>>wiringEndPoint (in category 'geometry') -----
wiringEndPoint
| side |
+ side := owner bounds sideNearestTo: bounds center.
- side _ owner bounds sideNearestTo: bounds center.
side = #left ifTrue: [^ self position + (0 at 4)].
side = #bottom ifTrue: [^ self position + (4 at 7)].
side = #right ifTrue: [^ self position + (7 at 4)].
side = #top ifTrue: [^ self position + (4 at 0)]!
Item was changed:
----- Method: PinSpec>>modelReadSelector:modelWriteSelector: (in category 'accessing') -----
modelReadSelector: a modelWriteSelector: b
+ modelReadSelector := a.
+ modelWriteSelector := b!
- modelReadSelector _ a.
- modelWriteSelector _ b!
Item was changed:
----- Method: PinSpec>>pinLoc: (in category 'accessing') -----
pinLoc: x
+ pinLoc := x!
- pinLoc _ x!
Item was changed:
----- Method: PinSpec>>pinName:direction:localReadSelector:localWriteSelector:modelReadSelector:modelWriteSelector:defaultValue:pinLoc: (in category 'initialization') -----
pinName: a direction: b localReadSelector: c localWriteSelector: d modelReadSelector: e modelWriteSelector: f defaultValue: g pinLoc: h
+ pinName := a.
+ direction := b.
+ localReadSelector := c.
+ localWriteSelector := d.
+ modelReadSelector := e.
+ modelWriteSelector := f.
+ defaultValue := g.
+ pinLoc := h!
- pinName _ a.
- direction _ b.
- localReadSelector _ c.
- localWriteSelector _ d.
- modelReadSelector _ e.
- modelWriteSelector _ f.
- defaultValue _ g.
- pinLoc _ h!
Item was changed:
----- Method: Player class>>freeUnreferencedSubclasses (in category 'housekeeping') -----
freeUnreferencedSubclasses
"Player classes may hold in their class instance variables references
to instances of themselves that are housekeepingwise unreachable. This
method allows such loops to be garbage collected. This is done in three
steps:
1. Remove user-created subclasses from the 'subclasses' set and from
Smalltalk. Only remove classes whose name begins with 'Player' and which
have no references.
2. Do a full garbage collection.
3. Enumerate all Metaclasses and find those whose soleInstance's
superclass is this class. Reset the subclasses set to this set of
classes, and add back to Smalltalk."
"Player freeUnreferencedSubclasses"
| oldFree candidatesForRemoval class |
+ oldFree := Smalltalk garbageCollect.
+ candidatesForRemoval := self subclasses asOrderedCollection select:
- oldFree _ Smalltalk garbageCollect.
- candidatesForRemoval _ self subclasses asOrderedCollection select:
[:aClass | (aClass name beginsWith: 'Player') and: [aClass name
endsWithDigit]].
"Break all system links and then perform garbage collection."
candidatesForRemoval do:
[:c | self removeSubclass: c. "Break downward subclass pointers."
Smalltalk removeKey: c name ifAbsent: []. "Break binding of global
name"].
+ candidatesForRemoval := nil.
- candidatesForRemoval _ nil.
Smalltalk garbageCollect. "Now this should reclaim all unused
subclasses"
"Now reconstruct system links to subclasses with valid references."
"First restore any global references via associations"
(Association allSubInstances select:
[:assn | (assn key isSymbol)
and: [(assn key beginsWith: 'Player')
and: [assn key endsWithDigit]]])
+ do: [:assn | class := assn value.
- do: [:assn | class _ assn value.
(class isKindOf: self class) ifTrue:
[self addSubclass: class.
Smalltalk add: assn]].
"Then restore any further direct references, creating new
associations."
(Metaclass allInstances select:
[:m | (m soleInstance name beginsWith: 'Player')
and: [m soleInstance name endsWithDigit]])
+ do: [:m | class := m soleInstance.
- do: [:m | class _ m soleInstance.
((class isKindOf: self class) and: [(Smalltalk includesKey: class
name) not]) ifTrue:
[self addSubclass: class.
Smalltalk at: class name put: class]].
SystemOrganization removeMissingClasses.
^ Smalltalk garbageCollect - oldFree
!
Item was changed:
----- Method: Player>>acceptScript:for: (in category 'scripts-kernel') -----
acceptScript: aScriptEditorMorph for: aSelector
"Accept the tile code in the script editor as the code for the given selector. This branch is only for the classic-tile system, 1997-2001"
| aUniclassScript node method |
aScriptEditorMorph generateParseNodeDirectly ifTrue: [
+ (node := aScriptEditorMorph methodNode) ifNotNil: [
- (node _ aScriptEditorMorph methodNode) ifNotNil: [
method := node generate: (CompiledMethodTrailer empty
sourceCode: (node sourceText);
yourself).
self class addSelectorSilently: aScriptEditorMorph scriptName withMethod: method.
SystemChangeNotifier uniqueInstance doSilently: [self class organization classify: aSelector under: 'scripts']
].
] ifFalse: [
self class compileSilently: aScriptEditorMorph methodString
classified: 'scripts' for: self.
].
+ aUniclassScript := self class assuredMethodInterfaceFor: aSelector asSymbol.
- aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol.
aUniclassScript currentScriptEditor: aScriptEditorMorph.
aScriptEditorMorph world ifNotNil: [aScriptEditorMorph world removeHighlightFeedback].
!
Item was changed:
----- Method: Player>>acceptableScriptNameFrom:forScriptCurrentlyNamed: (in category 'scripts-kernel') -----
acceptableScriptNameFrom: originalString forScriptCurrentlyNamed: currentName
"Produce an acceptable script name, derived from the current name, for the receiver. This method will always return a valid script name that will be suitable for use in the given situation, though you might not like its beauty sometimes."
| aString stemAndSuffix proscribed stem suffix withoutColon currentNumArgs withColon |
+ withoutColon := originalString withFirstCharacterDownshifted copyWithoutAll: {$:. $ }.
- withoutColon _ originalString withFirstCharacterDownshifted copyWithoutAll: {$:. $ }.
(currentName notNil and: [(currentName copyWithout: $:) = withoutColon])
ifTrue:
[^ currentName]. "viz. no change; otherwise, the #respondsTo: check gets in the way"
+ currentNumArgs := currentName ifNil: [0] ifNotNil: [currentName numArgs].
+ aString := withoutColon asIdentifier: false. "get an identifier starting with a lowercase letter"
+ stemAndSuffix := aString stemAndNumericSuffix.
+ proscribed := #(self super thisContext costume costumes dependents #true #false size).
- currentNumArgs _ currentName ifNil: [0] ifNotNil: [currentName numArgs].
- aString _ withoutColon asIdentifier: false. "get an identifier starting with a lowercase letter"
- stemAndSuffix _ aString stemAndNumericSuffix.
- proscribed _ #(self super thisContext costume costumes dependents #true #false size).
+ stem := stemAndSuffix first.
+ suffix := stemAndSuffix last.
+ withoutColon := aString asSymbol.
+ withColon := (withoutColon, ':') asSymbol.
- stem _ stemAndSuffix first.
- suffix _ stemAndSuffix last.
- withoutColon _ aString asSymbol.
- withColon _ (withoutColon, ':') asSymbol.
[(proscribed includes: withoutColon)
or: [self respondsTo: withoutColon]
or: [self respondsTo: withColon]
or: [Smalltalk includesKey: withoutColon]
or: [Smalltalk includesKey: withColon]]
whileTrue:
+ [suffix := suffix + 1.
+ withoutColon := (stem, suffix printString) asSymbol.
+ withColon := (withoutColon, ':') asSymbol].
- [suffix _ suffix + 1.
- withoutColon _ (stem, suffix printString) asSymbol.
- withColon _ (withoutColon, ':') asSymbol].
^ currentNumArgs = 0
ifTrue:
[withoutColon]
ifFalse:
[withColon]!
Item was changed:
----- Method: Player>>adoptScriptsFrom (in category 'misc') -----
adoptScriptsFrom
"Let the user click on another object form which the receiver should obtain scripts and code"
| aMorph |
Sensor waitNoButton.
+ aMorph := ActiveWorld chooseClickTarget.
- aMorph _ ActiveWorld chooseClickTarget.
aMorph ifNil: [^ Beeper beep].
(((aMorph renderedMorph isSketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not])
ifTrue:
[costume acquirePlayerSimilarTo: aMorph player]
ifFalse:
[Beeper beep]!
Item was changed:
----- Method: Player>>basicBeNotZero: (in category '*Etoys-Squeakland-misc') -----
basicBeNotZero: aNumber
"This is a runtime check if the arg to divide in a script is zero. If it is, put up a warning message. Return 0.001 instead of 0. Note the time. If fails again within 1 min., don't tell the user again."
aNumber = 0 ifFalse: [^ aNumber]. "normal case"
"We have a problem"
TimeOfError
+ ifNil: [TimeOfError := Time totalSeconds]
- ifNil: [TimeOfError _ Time totalSeconds]
ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [
+ TimeOfError := Time totalSeconds. "in case user interrupt and reenter"
- TimeOfError _ Time totalSeconds. "in case user interrupt and reenter"
self inform:
'Dividing by zero makes a number too
large for even a Sorcerer to handle.
Please change your script.' translated.
+ TimeOfError := Time totalSeconds]].
- TimeOfError _ Time totalSeconds]].
^ 0.001!
Item was changed:
----- Method: Player>>beNotZero: (in category 'misc') -----
beNotZero: value
"This is a runtime check if the arg to divide in a script is zero. If it is, put up a warning message. Return 0.001 instead of 0. Note the time. If fails again within 1 min., don't tell the user again."
| ret v result |
value isNumber ifTrue: [^ self basicBeNotZero: value].
+ ret := KedamaFloatArray new: value size.
- ret _ KedamaFloatArray new: value size.
1 to: value size do: [:i |
+ v := value at: i.
+ v = 0 ifFalse: [result := v].
- v _ value at: i.
- v = 0 ifFalse: [result _ v].
"We have a problem"
TimeOfError
+ ifNil: [TimeOfError := Time totalSeconds]
- ifNil: [TimeOfError _ Time totalSeconds]
ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [
+ TimeOfError := Time totalSeconds. "in case user interrupt and reenter"
- TimeOfError _ Time totalSeconds. "in case user interrupt and reenter"
self inform:
'Dividing by zero makes a number too
large for even a Sorcerer to handle.
Please change your script.' translated.
+ TimeOfError := Time totalSeconds]].
+ result := 0.001.
- TimeOfError _ Time totalSeconds]].
- result _ 0.001.
ret at: i put: result.
].
^ ret.
!
Item was changed:
----- Method: Player>>categoriesForVocabulary: (in category 'slots-kernel') -----
categoriesForVocabulary: aVocabulary
"Answer a list of categories appropriate to the receiver and its costumes, in the given Vocabulary"
| aList scriptsName |
self hasCostumeThatIsAWorld
ifTrue:
+ [aList := self categoriesForWorld]
- [aList _ self categoriesForWorld]
ifFalse:
+ [aList := OrderedCollection new.
- [aList _ OrderedCollection new.
self slotNames ifNotEmpty:
[aList add: ScriptingSystem nameForInstanceVariablesCategory].
aList addAll: costume categoriesForViewer].
aVocabulary addCustomCategoriesTo: aList.
aList remove: ScriptingSystem nameForScriptsCategory ifAbsent: [].
+ scriptsName := ScriptingSystem nameForScriptsCategory.
- scriptsName _ ScriptingSystem nameForScriptsCategory.
aList size > 2 ifTrue: [
aList add: scriptsName after: aList first.
] ifFalse: [
aList addLast: scriptsName.
].
^ aList!
Item was changed:
----- Method: Player>>categoriesForWorld (in category 'slots-kernel') -----
categoriesForWorld
"Answer the list of categories given that the receiver is the Player representing a World"
| aList |
+ aList := #(color #'fill & border' scripting #'pen trails' #'world geometry' playfield collections sound) asOrderedCollection.
- aList _ #(color #'fill & border' scripting #'pen trails' #'world geometry' playfield collections sound) asOrderedCollection.
aList add: #input.
Preferences eToyFriendly ifFalse:
[aList addAll: #(preferences #'as object'
display) ].
aList addAll: {ScriptingSystem nameForInstanceVariablesCategory. ScriptingSystem nameForScriptsCategory}.
^ aList!
Item was changed:
----- Method: Player>>changeParameterTypeFor: (in category 'costume') -----
changeParameterTypeFor: aSelector
"Change the parameter type for the given selector. Not currently sent, since types are now set by direct manipulation in the Scriptor header. If this were reinstated someday, there would probably be an issue about getting correct-looking Parameter tile(s) into the Scriptor header(s)"
| current typeChoices typeChosen |
+ current := self typeforParameterFor: aSelector.
+ typeChoices := Vocabulary typeChoicesForUserVariables.
+ typeChosen := (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption:
- current _ self typeforParameterFor: aSelector.
- typeChoices _ Vocabulary typeChoicesForUserVariables.
- typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption:
('Choose the TYPE
for the parameter (currently {1})' translated format: {current}).
self setParameterFor: aSelector toType: typeChosen
!
Item was changed:
----- Method: Player>>chooseUserSlot (in category 'slots-user') -----
chooseUserSlot
| names aMenu result |
+ (names := self slotNames) size == 1
- (names _ self slotNames) size == 1
ifTrue: [^ names first].
+ aMenu := SelectionMenu selections: names.
+ result := aMenu startUpWithCaption: 'Please choose a variable' translated.
- aMenu _ SelectionMenu selections: names.
- result _ aMenu startUpWithCaption: 'Please choose a variable' translated.
result isEmptyOrNil ifTrue: [^ nil].
^ result!
Item was changed:
----- Method: Player>>getGraphic (in category 'slot getters/setters') -----
getGraphic
"Answer a form representing the receiver's primary graphic"
| aMorph |
+ ^ ((aMorph := costume renderedMorph) isSketchMorph)
- ^ ((aMorph _ costume renderedMorph) isSketchMorph)
ifTrue:
[aMorph topRendererOrSelf imageForm]
ifFalse:
[aMorph isPlayfieldLike
ifTrue:
[aMorph backgroundForm]
ifFalse:
[aMorph imageForm]]!
Item was changed:
----- Method: Player>>getGraphicAtCursor (in category 'slot getters/setters') -----
getGraphicAtCursor
"Answer a form depicting the object at the current cursor"
| anObject aMorph |
+ anObject := self getValueFromCostume: #valueAtCursor.
- anObject _ self getValueFromCostume: #valueAtCursor.
^ (anObject isNil or: [anObject == 0 "weird return from GraphMorph"])
ifTrue:
[ScriptingSystem formAtKey: #Paint]
ifFalse:
+ [((aMorph := anObject renderedMorph) isSketchMorph)
- [((aMorph _ anObject renderedMorph) isSketchMorph)
ifTrue:
[aMorph form]
ifFalse:
[aMorph isPlayfieldLike
ifTrue:
[aMorph backgroundForm]
ifFalse:
[aMorph imageForm]]]!
Item was changed:
----- Method: Player>>getNewClone (in category 'slot getters/setters') -----
getNewClone
"Answer a new player of the same class as the receiver, with a costume much like mine"
| clone |
+ clone := costume usableSiblingInstance.
- clone _ costume usableSiblingInstance.
costume pasteUpMorph ifNotNilDo: [:parent | parent addMorph: clone].
^ clone player
!
Item was changed:
----- Method: Player>>getNumberAtCursor (in category 'slot getters/setters') -----
getNumberAtCursor
"Answer the number borne by the object at my costume's current cursor position"
| renderedMorph aCostume |
+ aCostume := self costume.
+ ((renderedMorph := aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor renderedMorph getNumericValue]!
- aCostume _ self costume.
- ((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor renderedMorph getNumericValue]!
Item was changed:
----- Method: Player>>getNumberOfPages (in category '*Etoys-Squeakland-slot getters/setters') -----
getNumberOfPages
"Answer how many pages the book currently has"
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pages size]
ifNil:
[0]!
Item was changed:
----- Method: Player>>getPageControlsAtTop (in category '*Etoys-Squeakland-slot getters/setters') -----
getPageControlsAtTop
"Answer whether the book is currently set to show page controls at top."
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pageControlsAtTop]
ifNil:
[false]!
Item was changed:
----- Method: Player>>getPageControlsShort (in category '*Etoys-Squeakland-slot getters/setters') -----
getPageControlsShort
"Answer whether the book is currentset to show short page controls"
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pageControlsShort]
ifNil:
[false]!
Item was changed:
----- Method: Player>>getPageControlsShowing (in category '*Etoys-Squeakland-slot getters/setters') -----
getPageControlsShowing
"Answer whether the book is current showing page-controls"
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pageControlsVisible]
ifNil:
[false]!
Item was changed:
----- Method: Player>>getPageCount (in category '*Etoys-Squeakland-playing commands') -----
getPageCount
| b |
+ b := Utilities scrapsBook renderedMorph.
- b _ Utilities scrapsBook renderedMorph.
^ b ifNotNil: [b pages size] ifNil: [1].
!
Item was changed:
----- Method: Player>>getPrecisionFor: (in category '*Etoys-Squeakland-slots-user') -----
getPrecisionFor: slotName
"get the precision for the given slot name"
| aGetter places precision |
+ precision := 1.
- precision _ 1.
(self slotInfo includesKey: slotName)
ifTrue:
["it's a user slot"
+ precision := (self slotInfoAt: slotName) floatPrecision]
- precision _ (self slotInfoAt: slotName) floatPrecision]
ifFalse:
["reference to system slots"
aGetter := Utilities getterSelectorFor: slotName.
self costume renderedMorph ifNotNilDo: [ :morph |
+ places := morph decimalPlacesForGetter: aGetter.
+ precision := Utilities floatPrecisionForDecimalPlaces: places ]].
- places _ morph decimalPlacesForGetter: aGetter.
- precision _ Utilities floatPrecisionForDecimalPlaces: places ]].
^precision!
Item was changed:
----- Method: Player>>getXOnGraph (in category '*Etoys-Squeakland-morphicExtras-Charts') -----
getXOnGraph
"Answer the x-coordinate with respect to a corresponding horizontal axis, if any; if none, answer the cartesian x"
| aCostume |
+ (aCostume := self costume) isInWorld ifFalse: [^ self getX].
- (aCostume _ self costume) isInWorld ifFalse: [^ self getX].
(aCostume referencePlayfield findA: HorizontalNumberLineMorph) ifNotNilDo:
[:aNumberLine |
^ aNumberLine horizontalCoordinateOf: aCostume].
^ self getX!
Item was changed:
----- Method: Player>>headDown (in category 'heading') -----
headDown
| radians |
+ radians := (self getHeadingUnrounded - 90.0) degreesToRadians.
- radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
self setHeading:
(radians cos @ radians sin abs) theta radiansToDegrees + 90.0.
!
Item was changed:
----- Method: Player>>headLeft (in category 'heading') -----
headLeft
| radians |
+ radians := (self getHeadingUnrounded - 90.0) degreesToRadians.
- radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
self setHeading: (radians cos abs negated @ radians sin) theta radiansToDegrees + 90.0.
!
Item was changed:
----- Method: Player>>headRight (in category 'heading') -----
headRight
| radians |
+ radians := (self getHeadingUnrounded - 90.0) degreesToRadians.
- radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
self setHeading: (radians cos abs @ radians sin) theta radiansToDegrees + 90.0.
!
Item was changed:
----- Method: Player>>headUp (in category 'heading') -----
headUp
| radians |
+ radians := (self getHeadingUnrounded - 90.0) degreesToRadians.
- radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
self setHeading: (radians cos @ radians sin abs negated) theta radiansToDegrees + 90.0.
!
Item was changed:
----- Method: Player>>moveToward: (in category 'scripts-standard') -----
moveToward: aPlayer
"Move a standard amount in the direction of the given player. If the object has an instance variable named 'speed', the speed of the motion will be governed by that value"
| myPosition itsPosition dist delta |
((aPlayer ~~ self) and: [(self overlaps: aPlayer) not]) ifTrue:
+ [((myPosition := self costume referencePosition) = (itsPosition := aPlayer costume referencePosition))
- [((myPosition _ self costume referencePosition) = (itsPosition _ aPlayer costume referencePosition))
ifFalse:
[self setHeading: (myPosition bearingToPoint: itsPosition).
+ delta := myPosition - itsPosition.
+ dist := (delta x * delta x + (delta y * delta y)) sqrt.
- delta _ myPosition - itsPosition.
- dist _ (delta x * delta x + (delta y * delta y)) sqrt.
self forward: (self getSpeed min: dist)]]!
Item was changed:
----- Method: Player>>newCostume (in category 'costume') -----
newCostume
| aMenu reply |
+ aMenu := SelectionMenu selections: self availableCostumeNames.
+ (reply := aMenu startUpWithCaption: 'choose a costume' translated) ifNil: [^ self].
- aMenu _ SelectionMenu selections: self availableCostumeNames.
- (reply _ aMenu startUpWithCaption: 'choose a costume' translated) ifNil: [^ self].
self wearCostumeOfName: reply.
self updateAllViewers!
Item was changed:
----- Method: Player>>newPatch (in category 'slot-kedama') -----
newPatch
| f usedNames newName |
+ f := KedamaPatchMorph newExtent: self costume renderedMorph dimensions.
- f _ KedamaPatchMorph newExtent: self costume renderedMorph dimensions.
f assuredPlayer assureUniClass.
f kedamaWorld: self costume renderedMorph.
+ usedNames := ActiveWorld allKnownNames, self class instVarNames.
+ newName := Utilities keyLike: f innocuousName satisfying:
- usedNames _ ActiveWorld allKnownNames, self class instVarNames.
- newName _ Utilities keyLike: f innocuousName satisfying:
[:aName | (usedNames includes: aName) not].
f setNameTo: newName.
self createSlotForPatch: f.
self addToPatchDisplayList: f assuredPlayer.
self costume world primaryHand attachMorph: f.
^ f.
!
Item was changed:
----- Method: Player>>newPatchForSet (in category '*Etoys-Squeakland-slot-kedama') -----
newPatchForSet
| f |
+ f := KedamaPatchMorph newExtent: self costume renderedMorph dimensions.
- f _ KedamaPatchMorph newExtent: self costume renderedMorph dimensions.
f assuredPlayer assureUniClass.
f setNameTo: (ActiveWorld unusedMorphNameLike: f innocuousName).
f kedamaWorld: self costume renderedMorph.
self createSlotForPatch: f.
^ f.
!
Item was changed:
----- Method: Player>>newScriptorAround: (in category 'viewer') -----
newScriptorAround: aPhrase
"Sprout a scriptor around aPhrase, thus making a new script. aPhrase may either be a PhraseTileMorph (classic tiles 1997-2001) or a SyntaxMorph (2001 onward)"
| aScriptEditor aUniclassScript tw blk |
Cursor wait showWhile: [
+ aUniclassScript := self class permanentUserScriptFor: self unusedScriptName player: self.
+ aScriptEditor := aUniclassScript instantiatedScriptEditorForPlayer: self.
- aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self.
- aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self.
Preferences universalTiles ifTrue: [
aScriptEditor install.
"aScriptEditor hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
cellPositioning: #topLeft;
setProperty: #autoFitContents toValue: true."
aScriptEditor insertUniversalTiles. "Gets an empty SyntaxMorph for a MethodNode"
+ tw := aScriptEditor findA: TwoWayScrollPane.
- tw _ aScriptEditor findA: TwoWayScrollPane.
aPhrase ifNotNil:
+ [blk := (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode.
- [blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode.
blk addMorphFront: aPhrase.
aPhrase accept.
].
SyntaxMorph setSize: nil andMakeResizable: aScriptEditor.
] ifFalse: [
aPhrase
ifNotNil: [aScriptEditor phrase: aPhrase] "does an install"
ifNil: [aScriptEditor install]
].
self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector].
"The above assures the presence of a ScriptInstantiation for the new selector in all siblings"
self updateScriptsCategoryOfViewers.
].
^ aScriptEditor!
Item was changed:
----- Method: Player>>newTurtle (in category 'slot-kedama') -----
newTurtle
| m |
+ m := KedamaTurtleMorph new openInWorld.
- m _ KedamaTurtleMorph new openInWorld.
self costume renderedMorph hasNoTurtleBreed ifTrue: [m color: Color red].
self useTurtle: m player.
m setNameTo: (ActiveWorld unusedMorphNameLike: m innocuousName).
self costume world primaryHand attachMorph: m.
^ m.
!
Item was changed:
----- Method: Player>>newTurtleForSet (in category '*Etoys-Squeakland-slot-kedama') -----
newTurtleForSet
| m |
+ m := KedamaTurtleMorph new openInWorld.
- m _ KedamaTurtleMorph new openInWorld.
self costume renderedMorph hasNoTurtleBreed ifTrue: [m color: Color red].
self useTurtle: m player.
m setNameTo: (ActiveWorld unusedMorphNameLike: m innocuousName).
^ m.
!
Item was changed:
----- Method: Player>>offerAlternateViewerMenuFor:event: (in category 'misc') -----
offerAlternateViewerMenuFor: aViewer event: evt
"Put up an alternate Viewer menu on behalf of the receiver."
| aMenu aWorld |
+ aWorld := aViewer world.
+ aMenu := MenuMorph new defaultTarget: self.
- aWorld _ aViewer world.
- aMenu _ MenuMorph new defaultTarget: self.
costumes ifNotNil:
[(costumes size > 1 or: [costumes size == 1 and: [costumes first ~~ costume renderedMorph]])
ifTrue:
[aMenu add: 'forget other costumes' translated target: self selector: #forgetOtherCostumes]].
aMenu add: 'expunge empty scripts' translated target: self action: #expungeEmptyScripts.
aMenu addLine.
aMenu add: 'choose vocabulary...' translated target: aViewer action: #chooseVocabulary.
aMenu balloonTextForLastItem: 'Choose a different vocabulary for this Viewer.' translated.
aMenu add: 'choose limit class...' translated target: aViewer action: #chooseLimitClass.
aMenu balloonTextForLastItem: 'Specify what the limitClass should be for this Viewer -- i.e., the most generic class whose methods and categories should be considered here.' translated.
aMenu add: 'open standard lexicon' translated target: aViewer action: #openLexicon.
aMenu balloonTextForLastItem: 'open a window that shows the code for this object in traditional programmer format' translated.
aMenu add: 'open lexicon with search pane' translated target: aViewer action: #openSearchingProtocolBrowser.
aMenu balloonTextForLastItem: 'open a lexicon that has a type-in pane for search (not recommended!!)' translated.
aMenu addLine.
aMenu add: 'inspect morph' translated target: costume selector: #inspect.
aMenu add: 'inspect player' translated target: self selector: #inspect.
self belongsToUniClass ifTrue:
[aMenu add: 'browse class' translated target: self action: #browsePlayerClass.
aMenu add: 'inspect class' translated target: self class action: #inspect].
aMenu add: 'inspect this Viewer' translated target: aViewer selector: #inspect.
aMenu add: 'inspect this Vocabulary' translated target: aViewer currentVocabulary selector: #inspect.
aMenu addLine.
aMenu add: 'relaunch this Viewer' translated target: aViewer action: #relaunchViewer.
aMenu add: 'attempt repairs' translated target: ActiveWorld action: #attemptCleanup.
aMenu add: 'destroy all this object''s scripts' translated target: self action: #destroyAllScripts.
aMenu add: 'view morph directly' translated target: aViewer action: #viewMorphDirectly.
aMenu balloonTextForLastItem: 'opens a Viewer directly on the rendered morph.' translated.
(costume renderedMorph isSketchMorph) ifTrue:
[aMenu addLine.
aMenu add: 'impart scripts to...' translated target: self action: #impartSketchScripts].
aMenu popUpEvent: evt in: aWorld!
Item was changed:
----- Method: Player>>offerViewerMenuFor:event: (in category 'misc') -----
offerViewerMenuFor: aViewer event: evt
"Put up the Viewer menu on behalf of the receiver. If the shift key is held down, put up the alternate menu. The menu omits the 'add a new variable' item when in eToyFriendly mode, as per request from teachers using Squeakland in 2003 once the button for adding a new variable was added to the viewer"
| aMenu aWorld |
(evt notNil and: [evt shiftPressed and: [Preferences eToyFriendly not]]) ifTrue:
[^ self offerAlternateViewerMenuFor: aViewer event: evt].
+ aWorld := aViewer world.
+ aMenu := MenuMorph new defaultTarget: self.
- aWorld _ aViewer world.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu title: self externalName.
aMenu addStayUpItem.
self costume renderedMorph offerCostumeViewerMenu: aMenu.
Preferences eToyFriendly ifFalse: "exclude this from squeakland-like UI "
[aMenu add: 'add a new variable' translated target: self action: #addInstanceVariable.
aMenu balloonTextForLastItem: 'Add a new variable to this object and all of its siblings. You will be asked to supply a name for it.' translated].
aMenu add: 'add a new script' translated target: aViewer action: #newPermanentScript.
aMenu balloonTextForLastItem: 'Add a new script that will work for this object and all of its siblings' translated.
aMenu addLine.
aMenu add: 'grab this object' translated target: self selector: #grabPlayerIn: argument: aWorld.
aMenu balloonTextForLastItem: 'This will actually pick up the object this Viewer is looking at, and hand it to you. Click the (left) button to drop it' translated.
aMenu add: 'reveal this object' translated target: self selector: #revealPlayerIn: argument: aWorld.
aMenu balloonTextForLastItem: 'If you have misplaced the object that this Viewer is looking at, use this item to (try to) make it visible' translated.
aMenu add: 'tile representing this object' translated action: #tearOffTileForSelf.
aMenu balloonTextForLastItem: 'choose this to obtain a tile which represents the object associated with this script' translated.
aMenu addLine.
aMenu add: 'add a search pane' translated target: aViewer action: #addSearchPane.
Preferences eToyFriendly ifFalse: [
aMenu addLine.
aMenu add: 'more...' translated target: self selector: #offerAlternateViewerMenuFor:event: argumentList: {aViewer. evt}].
aMenu popUpEvent: evt in: aWorld
!
Item was changed:
----- Method: Player>>removeWatchersOfSlotNamed: (in category '*Etoys-Squeakland-translation') -----
removeWatchersOfSlotNamed: aName
"A variable has been removed. Deal with possible watchers."
| aGetter |
+ aGetter := Utilities getterSelectorFor: aName.
- aGetter _ Utilities getterSelectorFor: aName.
self allPossibleWatchersFromWorld do: [:aWatcher |
(aWatcher getSelector = aGetter) ifTrue:
[aWatcher stopStepping.
(aWatcher ownerThatIsA: WatcherWrapper) ifNotNilDo:
[:aWrapper | aWrapper delete]]]!
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 aDict |
oldSelector = newSelector ifTrue: [^ self].
oldSelector numArgs == 0
ifTrue:
[self class allInstancesDo:
[:aPlayer | | itsCostume |
+ anInstantiation := aPlayer scriptInstantiationForSelector: oldSelector.
- anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector.
anInstantiation ifNotNil: [
newSelector numArgs == 0
ifTrue:
[anInstantiation changeSelectorTo: newSelector].
+ aDict := aPlayer costume actorState instantiatedUserScriptsDictionary.
+ itsCostume := aPlayer costume renderedMorph.
- 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 allInstancesDo:
[:aPlayer |
+ anInstantiation := aPlayer scriptInstantiationForSelector: newSelector.
- anInstantiation _ aPlayer scriptInstantiationForSelector: newSelector.
anInstantiation ifNotNil: [anInstantiation assureEventHandlerRepresentsStatus]]]].
+ aUserScript := self class userScriptForPlayer: self selector: oldSelector.
- 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 removeScriptNamed: oldSelector.
((self existingScriptInstantiationForSelector: newSelector) notNil and:
[newSelector numArgs > 0]) ifTrue: [self error: 'ouch'].
self updateScriptsCategoryOfViewers.
(self scriptEditorFor: newSelector) ifNotNilDo:
[:e | e updateHeader]!
Item was changed:
----- Method: Player>>revealPlayerIn: (in category 'misc') -----
revealPlayerIn: aWorld
"Reveal the receiver if at all possible in the world; once it's visible, flash its image for a bit, and leave it with its halo showing"
| aMorph |
+ (aMorph := self costume) isInWorld ifTrue:
- (aMorph _ self costume) isInWorld ifTrue:
[aMorph goHome.
self indicateLocationOnScreen.
aMorph owner ifNotNilDo: [:ownr | ownr layoutPolicy ifNil:
[aMorph comeToFront]].
aMorph addHalo.
^ self].
"It's hidden somewhere; search for it"
aWorld submorphs do:
[:m | (m succeededInRevealing: self) ifTrue: "will have obtained halo already"
[aWorld doOneCycle.
self indicateLocationOnScreen.
^ self]].
"The morph is truly unreachable in this world at present. So extract it from hyperspace, and place it at center of screen, wearing a halo."
aMorph isWorldMorph ifFalse:
[aWorld addMorphFront: aMorph.
aMorph position: aWorld bounds center.
aMorph addHalo]!
Item was changed:
----- Method: Player>>scriptEditorForNoCng: (in category '*Etoys-Squeakland-scripts-kernel') -----
scriptEditorForNoCng: aSelector
"Answer the receiver's script editor for aSelector. The script editor may be targeted to a sibiling of me. Do not change the script editor's receiver."
| aScriptEditor |
+ aScriptEditor := (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditorForPlayer: self. "creates an editor if none exists"
- aScriptEditor _ (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditorForPlayer: self. "creates an editor if none exists"
aScriptEditor bringUpToDate.
^ aScriptEditor!
Item was changed:
----- Method: Player>>setCharacterAtCursor: (in category 'slot getters/setters') -----
setCharacterAtCursor: aCharOrString
"Insert the given character at my cursor position"
| aLoc aTextMorph aString charToUse newText |
+ aLoc := (aTextMorph := self costume renderedMorph) cursor.
+ charToUse := (aString := aCharOrString asString) size > 0
- aLoc _ (aTextMorph _ self costume renderedMorph) cursor.
- charToUse _ (aString _ aCharOrString asString) size > 0
ifTrue: [aString first]
ifFalse: ['·'].
+ newText := charToUse asString asText.
- newText _ charToUse asString asText.
(aTextMorph text attributesAt: aLoc) do: [:att | newText addAttribute: att].
aTextMorph paragraph replaceFrom: aLoc to: aLoc with: newText displaying: true.
aTextMorph updateFromParagraph. !
Item was changed:
----- Method: Player>>setGraphic:rotationCenter: (in category '*Etoys-Squeakland-slot getters/setters') -----
setGraphic: aForm rotationCenter: aPoint
"Set the receiver's graphic as indicated"
| aMorph |
+ ^ ((aMorph := costume renderedMorph) isSketchMorph)
- ^ ((aMorph _ costume renderedMorph) isSketchMorph)
ifTrue:
[aMorph form: aForm rotationCenter: aPoint]
ifFalse:
[aMorph isPlayfieldLike
ifTrue:
[aMorph backgroundForm: aForm]
ifFalse:
["what to do?"]]!
Item was changed:
----- Method: Player>>setHeading: (in category 'slot getters/setters') -----
setHeading: newHeading
"Set the heading as indicated"
| aCostume |
+ aCostume := self costume.
- aCostume _ self costume.
aCostume isWorldMorph ifTrue: [^ self].
aCostume heading: newHeading.
+ aCostume := self costume. "in case we just got flexed for no apparent reason"
- aCostume _ self costume. "in case we just got flexed for no apparent reason"
(aCostume isFlexMorph and:[aCostume hasNoScaleOrRotation])
ifTrue: [aCostume removeFlexShell]!
Item was changed:
----- Method: Player>>setLength: (in category 'slot getters/setters') -----
setLength: aLength
"Set the length of the receiver."
| cost lengthToUse |
+ cost := self costume.
- cost _ self costume.
cost isWorldMorph ifTrue: [^self].
cost isLineMorph
ifTrue:
[^ cost unrotatedLength: aLength].
+ lengthToUse := cost isRenderer
- lengthToUse _ cost isRenderer
ifTrue:
[aLength / cost scaleFactor]
ifFalse:
[aLength].
cost renderedMorph height: lengthToUse!
Item was changed:
----- Method: Player>>setLocation: (in category '*Etoys-Squeakland-points') -----
setLocation: val
"Set the receiver's location; expected to be called with a point argument"
| aCostume |
(val isKindOf: Point) ifFalse: [^ ScriptingSystem reportToUser: 'Expected a Point but instead got ' translated, val printString].
+ (aCostume := self costume) isInWorld ifFalse: [^ self].
- (aCostume _ self costume) isInWorld ifFalse: [^ self].
aCostume isWorldOrHandMorph ifTrue: [^ self].
aCostume owner isHandMorph ifTrue: [^ self].
^ aCostume x: val x y: val y!
Item was changed:
----- Method: Player>>setNumberAtCursor: (in category 'slot getters/setters') -----
setNumberAtCursor: aNumber
"Place the given number into the morph residing at my costume's current cursor position"
| renderedMorph aCostume |
+ aCostume := self costume.
+ ((renderedMorph := aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor renderedMorph setNumericValue: aNumber]!
- aCostume _ self costume.
- ((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor renderedMorph setNumericValue: aNumber]!
Item was changed:
----- Method: Player>>setPageControlsAtTop: (in category '*Etoys-Squeakland-slot getters/setters') -----
setPageControlsAtTop: aBoolean
"Set whether the book should show page controls at top."
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pageControlsAtTop: aBoolean]!
Item was changed:
----- Method: Player>>setPageControlsShort: (in category '*Etoys-Squeakland-slot getters/setters') -----
setPageControlsShort: aBoolean
"Set whether the book is set for short page controls currently"
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBook pageControlsShort: aBoolean]!
Item was changed:
----- Method: Player>>setPageControlsShowing: (in category '*Etoys-Squeakland-slot getters/setters') -----
setPageControlsShowing: aBoolean
"Answer whether the book is current showing page-controls"
| aBook |
+ ^ (aBook := self bookEmbodied)
- ^ (aBook _ self bookEmbodied)
ifNotNil:
[aBoolean
ifTrue:
[aBook showPageControls]
ifFalse:
[aBook hidePageControls]]!
Item was changed:
----- Method: Player>>setPenDown: (in category 'pen') -----
setPenDown: penDown
"Set the penDown state as indicated, to true or false"
| morph trailMorph tfm |
self actorState setPenDown: penDown.
+ ((morph := self costume) notNil and: [(trailMorph := morph trailMorph) notNil and: [morph isWorldMorph not]])
- ((morph _ self costume) notNil and: [(trailMorph _ morph trailMorph) notNil and: [morph isWorldMorph not]])
ifTrue:
+ [tfm := morph owner transformFrom: trailMorph.
- [tfm _ morph owner transformFrom: trailMorph.
trailMorph notePenDown: penDown forPlayer: self
at: (tfm localPointToGlobal: morph referencePosition)]
!
Item was changed:
----- Method: Player>>setSecondColor: (in category 'slot getters/setters') -----
setSecondColor: aColor
"Setter for costume's second color, if it's using gradient fill; if not, does nothing"
| aFillStyle aMorph toUse |
+ ^ (aFillStyle := (aMorph := costume renderedMorph) fillStyle) isGradientFill
- ^ (aFillStyle _ (aMorph _ costume renderedMorph) fillStyle) isGradientFill
ifTrue:
[toUse := (costume isWorldMorph and: [aColor isColor])
ifTrue:
[aColor alpha: 1.0] "reject any translucency"
ifFalse:
[aColor].
aFillStyle lastColor: toUse forMorph: aMorph hand: ActiveHand]!
Item was changed:
----- Method: Player>>setWidth: (in category 'slot getters/setters') -----
setWidth: aWidth
"Set the width"
| cost widthToUse |
+ cost := self costume.
- cost _ self costume.
cost isWorldMorph ifTrue: [^ self].
cost isLineMorph
ifTrue:
[^ cost unrotatedWidth: aWidth].
+ widthToUse := cost isRenderer
- widthToUse _ cost isRenderer
ifTrue:
[aWidth / cost scaleFactor]
ifFalse:
[aWidth].
cost renderedMorph width: widthToUse!
Item was changed:
----- Method: Player>>setXOnGraph: (in category '*Etoys-Squeakland-morphicExtras-Charts') -----
setXOnGraph: aNumber
"Set the x-on-graph coordinate as indicated. If there is Horizontal Number Line in the same playfield, this is interpreted with reference to the position and scale of that number line; if not, this is no different from setX:"
| aCostume |
+ (aCostume := self costume) isInWorld ifFalse: [^ self setX: aNumber].
- (aCostume _ self costume) isInWorld ifFalse: [^ self setX: aNumber].
(aCostume referencePlayfield findA: HorizontalNumberLineMorph) ifNotNilDo:
[:aNumberLine |
^ aNumberLine setXOnGraphFor: aCostume to: aNumber].
^ self getX!
Item was changed:
----- Method: Player>>tileReferringToSelf (in category 'misc') -----
tileReferringToSelf
| aTile |
+ aTile := TileMorph new setToReferTo: self.
- aTile _ TileMorph new setToReferTo: self.
aTile updateWordingToMatchVocabulary.
^ aTile!
Item was changed:
----- Method: PlayerSurrogate>>rebuildRow (in category 'accessing') -----
rebuildRow
"Rebuild the row"
| aThumbnail aTileButton aViewerButton aMenuButton |
self removeAllMorphs.
self layoutInset: 2; cellInset: 3.
self beTransparent.
+ aThumbnail := ThumbnailForAllPlayersTool new objectToView: playerRepresented viewSelector: #graphicForViewerTab.
- aThumbnail _ ThumbnailForAllPlayersTool new objectToView: playerRepresented viewSelector: #graphicForViewerTab.
+ aMenuButton := IconicButton new labelGraphic: (ScriptingSystem formAtKey: #MenuIcon).
- aMenuButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #MenuIcon).
aMenuButton target: self;
actionSelector: #playerButtonHit;
color: Color transparent;
borderWidth: 0;
shedSelvedge;
actWhen: #buttonDown.
aMenuButton setBalloonText: 'Press here to get a menu' translated.
self addMorphBack: aMenuButton.
aThumbnail setBalloonText: 'Click here to reveal this object' translated.
self addMorphBack: aThumbnail.
aThumbnail on: #mouseUp send: #beRevealedInActiveWorld to: playerRepresented.
+ aViewerButton := IconicButton new labelGraphic: (ScriptingSystem formAtKey: #'LargeHalo-View').
- aViewerButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #'LargeHalo-View').
aViewerButton color: Color transparent;
actWhen: #buttonUp;
actionSelector: #beViewed; target: playerRepresented;
setBalloonText: 'click here to obtain this object''s Viewer' translated;
color: Color transparent;
borderWidth: 0;
shedSelvedge.
self addMorphBack: aViewerButton.
+ aTileButton := IconicButton new borderWidth: 0.
- aTileButton _ IconicButton new borderWidth: 0.
aTileButton labelGraphic: (TileMorph new setToReferTo: playerRepresented) imageForm.
aTileButton color: Color transparent;
actWhen: #buttonDown;
actionSelector: #tearOffTileForSelf; target: playerRepresented;
setBalloonText: 'click here to obtain a tile that refers to this player.' translated.
self addMorphBack: aTileButton.
+ " aNameMorph := UpdatingStringMorph new
- " aNameMorph _ UpdatingStringMorph new
useStringFormat;
target: playerRepresented;
getSelector: #nameForViewer;
setNameTo: 'name';
font: ScriptingSystem fontForNameEditingInScriptor.
aNameMorph putSelector: #setName:.
aNameMorph setProperty: #okToTextEdit toValue: true.
aNameMorph step.
self addMorphBack: aNameMorph.
aNameMorph setBalloonText: 'Click here to edit the player''s name.'. "
!
Item was changed:
----- Method: PlayingCard>>blankCard (in category 'all') -----
blankCard
CachedDepth = Display depth ifFalse:
+ [CachedDepth := Display depth.
+ CachedBlank := Form extent: CardSize depth: CachedDepth.
- [CachedDepth _ Display depth.
- CachedBlank _ Form extent: CardSize depth: CachedDepth.
CachedBlank fillWhite; border: CachedBlank boundingBox width: 1.
CachedBlank fill: (0 at 0 extent: 2 at 2) fillColor: Color transparent. "Round the top corners"
CachedBlank fill: (1 at 1 extent: 1 at 1) fillColor: Color black.
CachedBlank fill: (CachedBlank width-2 at 0 extent: 2 at 2) fillColor: Color transparent.
CachedBlank fill: (CachedBlank width-2 at 1 extent: 1 at 1) fillColor: Color black].
^ CachedBlank!
Item was changed:
----- Method: PlayingCard>>buildImage (in category 'all') -----
buildImage "(PlayingCard the: 12 of: #hearts) cardForm display"
"World addMorph: (ImageMorph new image: (PlayingCard the: 12 of: #hearts) cardForm)"
"PlayingCard test"
| blt numForm suitForm spot face ace sloc colorMap fillColor |
"Set up blt to copy in color for 1-bit forms"
+ blt := BitBlt current toForm: cardForm.
+ fillColor := self color.
+ colorMap := (((Array with: Color white with: fillColor)
- blt _ BitBlt current toForm: cardForm.
- fillColor _ self color.
- colorMap _ (((Array with: Color white with: fillColor)
collect: [:c | cardForm pixelWordFor: c])
as: Bitmap).
blt copy: cardForm boundingBox from: 0 at 0 in: self blankCard. "Start with a blank card image"
+ numForm := NumberForms at: cardNo. "Put number in topLeft"
- numForm _ NumberForms at: cardNo. "Put number in topLeft"
blt copyForm: numForm to: NumberLoc rule: Form over colorMap: colorMap.
+ suitForm := SuitForms at: suitNo*3-2. "Put small suit just below number"
+ sloc := SuitLoc.
- suitForm _ SuitForms at: suitNo*3-2. "Put small suit just below number"
- sloc _ SuitLoc.
cardNo > 10 ifTrue:
+ [suitForm := SuitForms at: suitNo*3-1. "Smaller for face cards"
+ sloc := SuitLoc - (1 at 0)].
- [suitForm _ SuitForms at: suitNo*3-1. "Smaller for face cards"
- sloc _ SuitLoc - (1 at 0)].
blt copyForm: suitForm to: sloc rule: Form over colorMap: colorMap.
cardNo <= 10
ifTrue:
["Copy top-half spots to the number cards"
+ spot := SuitForms at: suitNo*3. "Large suit spots"
- spot _ SuitForms at: suitNo*3. "Large suit spots"
(TopSpotLocs at: cardNo) do:
[:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]]
ifFalse:
["Copy top half of face cards"
+ face := FaceForms at: suitNo-1*3 + 14-cardNo.
- face _ FaceForms at: suitNo-1*3 + 14-cardNo.
blt colorMap: self faceColorMap;
copy: (FaceLoc extent: face extent) from: 0 at 0 in: face].
"Now copy top half to bottom"
self copyTopToBottomHalf.
cardNo <= 10 ifTrue:
["Copy middle spots to the number cards"
(MidSpotLocs at: cardNo) do:
[:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]].
(cardNo = 1 and: [suitNo = 4]) ifTrue:
["Special treatment for the ace of spades"
+ ace := FaceForms at: 13.
- ace _ FaceForms at: 13.
blt colorMap: self faceColorMap;
copy: (ASpadesLoc extent: ace extent) from: 0 at 0 in: ace]
!
Item was changed:
----- Method: PlayingCard>>copyTopToBottomHalf (in category 'all') -----
copyTopToBottomHalf
"The bottom half is a 180-degree rotation of the top half (except for 7)"
| topHalf corners |
+ topHalf := 0 at 0 corner: cardForm width@(cardForm height+1//2).
+ corners := topHalf corners.
- topHalf _ 0 at 0 corner: cardForm width@(cardForm height+1//2).
- corners _ topHalf corners.
(WarpBlt current toForm: cardForm)
sourceForm: cardForm;
combinationRule: 3;
copyQuad: ((3 to: 6) collect: [:i | corners atWrap: i])
toRect: (CardSize - topHalf extent corner: CardSize).
!
Item was changed:
----- Method: PlayingCard>>faceColorMap (in category 'all') -----
faceColorMap
| map |
+ map := Color colorMapIfNeededFrom: 4 to: Display depth.
- map _ Color colorMapIfNeededFrom: 4 to: Display depth.
^ map!
Item was changed:
----- Method: PlayingCard>>setCardNo:suitNo:cardForm: (in category 'all') -----
setCardNo: c suitNo: s cardForm: f
+ cardNo := c.
+ suitNo := s.
+ cardForm := f.
- cardNo _ c.
- suitNo _ s.
- cardForm _ f.
self buildImage!
Item was changed:
----- Method: PlayingCardDeck>>acceptCardSelector: (in category 'accessing') -----
acceptCardSelector: aSymbolOrString
+ acceptCardSelector := self nilOrSymbol: aSymbolOrString.!
- acceptCardSelector _ self nilOrSymbol: aSymbolOrString.!
Item was changed:
----- Method: PlayingCardDeck>>cardDoubleClickSelector: (in category 'accessing') -----
cardDoubleClickSelector: aSymbolOrString
+ cardDoubleClickSelector := self nilOrSymbol: aSymbolOrString.!
- cardDoubleClickSelector _ self nilOrSymbol: aSymbolOrString.!
Item was changed:
----- Method: PlayingCardDeck>>cardDraggedSelector: (in category 'accessing') -----
cardDraggedSelector: aSymbolOrString
+ cardDraggedSelector := self nilOrSymbol: aSymbolOrString.!
- cardDraggedSelector _ self nilOrSymbol: aSymbolOrString.!
Item was changed:
----- Method: PlayingCardDeck>>cardDroppedSelector: (in category 'accessing') -----
cardDroppedSelector: aSymbolOrString
+ cardDroppedSelector := self nilOrSymbol: aSymbolOrString.!
- cardDroppedSelector _ self nilOrSymbol: aSymbolOrString.!
Item was changed:
----- Method: PlayingCardDeck>>emptyDropPolicy: (in category 'accessing') -----
emptyDropPolicy: aSymbol
"#any #inOrder #anyClub #anyDiamond #anyHeart #anySpade"
+ emptyDropPolicy := aSymbol!
- emptyDropPolicy _ aSymbol!
Item was changed:
----- Method: PlayingCardDeck>>inStackingOrder:onTopOf: (in category 'dropping/grabbing') -----
inStackingOrder: aCard onTopOf: cardBelow
| diff |
(stackingPolicy = #altStraight and: [aCard suitColor = cardBelow suitColor]) ifTrue: [^ false].
(stackingPolicy = #straight and: [aCard suit ~= cardBelow suit]) ifTrue: [^ false].
+ diff := aCard cardNumber - cardBelow cardNumber.
- diff _ aCard cardNumber - cardBelow cardNumber.
stackingOrder = #ascending ifTrue: [^ diff = 1].
stackingOrder = #descending ifTrue: [^ diff = -1].
^ false.!
Item was changed:
----- Method: PlayingCardDeck>>initialize (in category 'initialization') -----
initialize
super initialize.
self cellPositioning: #topLeft.
self reverseTableCells: true.
self layout: #grid.
self hResizing: #shrinkWrap.
self vResizing: #shrinkWrap.
+ borderWidth := 0.
- borderWidth _ 0.
self layoutInset: 0.
+ stackingPolicy := #stagger.
+ stackingOrder := #ascending.
+ emptyDropPolicy := #any.
- stackingPolicy _ #stagger.
- stackingOrder _ #ascending.
- emptyDropPolicy _ #any.
self newSeed.
^self!
Item was changed:
----- Method: PlayingCardDeck>>layout: (in category 'accessing') -----
layout: aSymbol
" #grid #pile #stagger"
+ layout := aSymbol.
- layout _ aSymbol.
layout == #grid
ifTrue:[self maxCellSize: SmallInteger maxVal].
layout == #pile
ifTrue:[self maxCellSize: 0].
layout == #stagger
ifTrue:[self maxCellSize: self staggerOffset].!
Item was changed:
----- Method: PlayingCardDeck>>newSeed (in category 'accessing') -----
newSeed
+ seed := (1 to: 32000) atRandom!
- seed _ (1 to: 32000) atRandom!
Item was changed:
----- Method: PlayingCardDeck>>reverse (in category 'shuffling/dealing') -----
reverse
self invalidRect: self fullBounds.
+ submorphs := submorphs reversed.
- submorphs _ submorphs reversed.
self layoutChanged.!
Item was changed:
----- Method: PlayingCardDeck>>seed: (in category 'accessing') -----
seed: anInteger
+ seed := anInteger!
- seed _ anInteger!
Item was changed:
----- Method: PlayingCardDeck>>shuffle (in category 'shuffling/dealing') -----
shuffle
self invalidRect: self fullBounds.
+ submorphs := submorphs shuffledBy: (Random new seed: seed).
- submorphs _ submorphs shuffledBy: (Random new seed: seed).
self layoutChanged.!
Item was changed:
----- Method: PlayingCardDeck>>stackingOrder: (in category 'accessing') -----
stackingOrder: aSymbol
"#ascending #descending"
+ stackingOrder := aSymbol!
- stackingOrder _ aSymbol!
Item was changed:
----- Method: PlayingCardDeck>>stackingPolicy: (in category 'accessing') -----
stackingPolicy: aSymbol
"#straight #altStraight #single #none"
+ stackingPolicy := aSymbol!
- stackingPolicy _ aSymbol!
Item was changed:
----- Method: PlayingCardDeck>>subDeckStartingAt: (in category 'accessing') -----
subDeckStartingAt: aCard
| i subDeck |
+ i := submorphs indexOf: aCard ifAbsent: [^ aCard].
- i _ submorphs indexOf: aCard ifAbsent: [^ aCard].
i = 1 ifTrue: [^aCard].
+ subDeck := PlayingCardDeck new.
- subDeck _ PlayingCardDeck new.
(submorphs copyFrom: 1 to: i-1) do:
[:m | m class = aCard class ifTrue: [subDeck addMorphBack: m]].
^subDeck.
!
Item was changed:
----- Method: PlayingCardDeck>>target: (in category 'accessing') -----
target: anObject
+ target := anObject!
- target _ anObject!
Item was changed:
----- Method: PlayingCardMorph class>>test (in category 'testing') -----
test "Display all cards in the deck"
"MessageTally spyOn: [20 timesRepeat: [PlayingCardMorph test]]"
| table row |
+ table := AlignmentMorph newColumn.
- table _ AlignmentMorph newColumn.
self suits do: [:suit |
+ row := AlignmentMorph newRow.
- row _ AlignmentMorph newRow.
table addMorph: row.
1 to: 13 do: [:cn |
row addMorph:
(PlayingCardMorph the: cn of: suit)]].
table openInWorld.!
Item was changed:
----- Method: PlayingCardMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
aboutToBeGrabbedBy: aHand
"I'm about to be grabbed by the hand. If other cards are above me in a deck,
then move them from the deck to being submorphs of me"
| i |
super aboutToBeGrabbedBy: aHand.
self removeProperty: #undoGrabCommand. "So it won't interfere with overall move"
self board captureStateBeforeGrab.
+ i := owner submorphs indexOf: self ifAbsent: [^ self].
- i _ owner submorphs indexOf: self ifAbsent: [^ self].
i = 1 ifTrue: [^ self].
(owner submorphs copyFrom: 1 to: i-1) do:
[:m | m class = self class ifTrue: [self addMorphBack: m]].
!
Item was changed:
----- Method: PlayingCardMorph>>cardNumber:suitNumber: (in category 'access') -----
cardNumber: c suitNumber: s
+ cardNumber := c.
+ suitNumber := s.!
- cardNumber _ c.
- suitNumber _ s.!
Item was changed:
----- Method: PluggableTabBarMorph>>activeTab (in category 'private - access') -----
activeTab
activeTab ifNil: [
self tabs size > 0 ifTrue: [
+ activeTab := self tabs first key.
- activeTab _ self tabs first key.
activeTab active: true]].
^ activeTab !
Item was changed:
----- Method: PluggableTabBarMorph>>activeTab: (in category 'private - access') -----
activeTab: aTabMorph
self activeTab ifNotNil: [self activeTab toggle].
+ activeTab := aTabMorph.
- activeTab _ aTabMorph.
self activeTab toggle.
aTabMorph delete.
self addMorphFront: aTabMorph.
self performActiveTabAction.
self changed.
!
Item was changed:
----- Method: PluggableTabBarMorph>>addTab:withAction: (in category 'access') -----
addTab: aStringOrTextOrMorph withAction: aSymbolOrBlock
"Add a new tab. The tab will be added onto the end of the list and displayed on the far right of previously added tabs. The first argument can be a simple String, a Text, or any Morph. The second argument is the action to be performed when the tab is selected. It can either be a symbol for a unary method on the target object or a block. Each tab is stored as an Association with the created tab as the key and the selector as the value."
| tabMorph |
+ tabMorph := PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph].
- tabMorph _ PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph].
tabMorph color: self color.
self addMorphBack: tabMorph.
self tabs ifEmpty: [ self activeTab: tabMorph ].
self tabs add: (Association key: tabMorph value: aSymbolOrBlock).
self layoutChanged.
self changed.!
Item was changed:
----- Method: PluggableTabBarMorph>>color: (in category 'access') -----
color: aFillStyle
+ color := aFillStyle.
- color _ aFillStyle.
self tabs do: [ :anAssociation |
anAssociation key color: aFillStyle ]
!
Item was changed:
----- Method: PluggableTabBarMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
self tabs size > 0 ifFalse: [^ self ].
self tabs do: [ :anAssociation | | tab |
+ tab := anAssociation key.
- tab _ anAssociation key.
tab drawOn: aCanvas]!
Item was changed:
----- Method: PluggableTabBarMorph>>layoutChanged (in category 'actions') -----
layoutChanged
"Fix up our tabs bounds"
| tabsCount |
super layoutChanged.
+ tabsCount := self tabs size.
- tabsCount _ self tabs size.
tabsCount isZero ifFalse: [ | tabInnerExtent count |
+ tabInnerExtent := ((self width -
- tabInnerExtent _ ((self width -
((self tabs first key outerGap + self tabs last key outerGap) // 2)
- tabsCount)
// tabsCount)
@ (self height).
+ count := 1.
- count _ 1.
self tabs do: [ :anAssociation | | tab |
+ tab := anAssociation key.
- tab _ anAssociation key.
tab innerExtent: tabInnerExtent.
count = 1
ifTrue: [tab position: self position]
ifFalse: [
tab position:
(self position translateBy:
((tabInnerExtent x + 1) * (count - 1))@0)].
+ count := count + 1 ] ].
- count _ count + 1 ] ].
self changed.!
Item was changed:
----- Method: PluggableTabBarMorph>>mouseDown: (in category 'actions') -----
mouseDown: anEvent
| xPosition newTab |
+ xPosition := anEvent cursorPoint x.
- xPosition _ anEvent cursorPoint x.
newTab _
((self tabs detect: [ :anAssociation | | tabBounds |
+ tabBounds := anAssociation key bounds.
- tabBounds _ anAssociation key bounds.
(tabBounds left <= xPosition) and: [ tabBounds right >= xPosition]]
ifNone: [nil])
key).
newTab ifNil: [^ self].
newTab = activeTab ifFalse: [ self activeTab: newTab ]
!
Item was changed:
----- Method: PluggableTabBarMorph>>performActiveTabAction (in category 'actions') -----
performActiveTabAction
"Look up the Symbol or Block associated with the currently active tab, and perform it."
| tabActionAssoc aSymbolOrBlock |
+ tabActionAssoc := self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ].
+ aSymbolOrBlock := tabActionAssoc value.
- tabActionAssoc _ self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ].
- aSymbolOrBlock _ tabActionAssoc value.
aSymbolOrBlock ifNil: [ ^ false ].
^ aSymbolOrBlock isSymbol
ifTrue: [ self target perform: aSymbolOrBlock ]
ifFalse: [ aSymbolOrBlock value ].
!
Item was changed:
----- Method: PluggableTabBarMorph>>tabs (in category 'private - access') -----
tabs
+ tabs ifNil: [ tabs := OrderedCollection new ].
- tabs ifNil: [ tabs _ OrderedCollection new ].
^ tabs!
Item was changed:
----- Method: PluggableTabBarMorph>>target: (in category 'access') -----
target: anObject
+ target := anObject!
- target _ anObject!
Item was changed:
----- Method: PolygonMorph class>>curvePrototype (in category '*Etoys-Squeakland-instance creation') -----
curvePrototype
"Answer an instance of the receiver that will serve as a prototypical curve"
| aa |
+ aa := self new.
- aa _ self new.
aa vertices: (Array with: 0 at 80 with: 70 at 90 with: 60 at 0)
color: Color orange lighter
borderWidth: 4
borderColor: Color black.
aa beSmoothCurve.
aa setNameTo: 'Curve'.
aa makeForwardArrow. "is already open"
aa computeBounds.
^ aa
"
PolygonMorph curvePrototype openInHand
"!
Item was changed:
----- Method: PolygonMorph class>>trianglePrototype (in category '*Etoys-Squeakland-instance creation') -----
trianglePrototype
"Answer an instance of the receiver that will serve as a prototypical triangle"
| aa |
+ aa := self new.
- aa _ self new.
aa vertices: {0.0 at 0.0. 138.0 at 0.0. -37.0@ -74.0}
color: (TranslucentColor r: 0.387 g: 1.0 b: 0.548 alpha: 0.463)
borderWidth: 3
borderColor: Color black.
aa setProperty: #noNewVertices toValue: true.
aa setNameTo: 'Triangle'.
aa makeForwardArrow. "is already open"
aa computeBounds.
aa addHandles.
^ aa
"
PolygonMorph trianglePrototype openInHand
"!
Item was changed:
----- Method: PopUpMenu>>startUpWithCaption:at:allowKeyboard:centered: (in category '*Etoys-Squeakland-basic control sequence') -----
startUpWithCaption: captionOrNil at: location allowKeyboard: allowKeyboard centered: centered
"Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard
If centered is true, the menu items are displayed centered.."
| maxHeight aMenu |
(ProvideAnswerNotification signal: captionOrNil) ifNotNilDo:
+ [:answer | ^ selection := answer ifTrue: [1] ifFalse: [2]].
- [:answer | ^ selection _ answer ifTrue: [1] ifFalse: [2]].
+ maxHeight := Display height*3//4.
- maxHeight _ Display height*3//4.
self frameHeight > maxHeight ifTrue:
[^ self
startUpSegmented: maxHeight
withCaption: captionOrNil
at: location
allowKeyboard: allowKeyboard].
Smalltalk isMorphic
ifTrue:[
+ selection := Cursor normal showWhile:
- selection _ Cursor normal showWhile:
[aMenu := MVCMenuMorph from: self title: captionOrNil.
centered ifTrue:
[aMenu submorphs allButFirst do:
[:m | m setProperty: #centered toValue: true]].
aMenu
invokeAt: location
in: ActiveWorld
allowKeyboard: allowKeyboard].
^ selection].
frame ifNil: [self computeForm].
Cursor normal showWhile:
[self
displayAt: location
withCaption: captionOrNil
during: [self controlActivity]].
^ selection!
Item was changed:
----- Method: PortugueseLexiconServer class>>decodeAccents: (in category 'as yet unclassified') -----
decodeAccents: appleLikeString
"change characters like í, to the form used in Portuguese"
| encodedStream rem |
+ encodedStream := WriteStream on: (String new).
- encodedStream _ WriteStream on: (String new).
appleLikeString do: [ :c |
+ rem := encodedStream position.
- rem _ encodedStream position.
c == $í ifTrue: [encodedStream nextPut: (Character value: 237)].
c == $á ifTrue: [encodedStream nextPut: (Character value: 225)].
c == $é ifTrue: [encodedStream nextPut: (Character value: 233)].
c == $ç ifTrue: [encodedStream nextPut: (Character value: 231)].
c == $ã ifTrue: [encodedStream nextPut: (Character value: 227)].
c == $ó ifTrue: [encodedStream nextPut: (Character value: 243)].
c == $ê ifTrue: [encodedStream nextPut: (Character value: 234)].
"and more, such as e with a backwards accent"
rem = encodedStream position ifTrue: [
encodedStream nextPut: c].
].
^encodedStream contents. !
Item was changed:
----- Method: PortugueseLexiconServer class>>openScamperOn: (in category 'as yet unclassified') -----
openScamperOn: aWord
| aUrl scamperWindow |
"Open a Scamper web browser on the web dictionary entry for this word. If Scamper is already pointing at it, use the same browser. Special code for this server."
+ aUrl := 'http://www.priberam.pt/scripts/dlpouniv.dll',
- aUrl _ 'http://www.priberam.pt/scripts/dlpouniv.dll',
'?search_value=', (self decodeAccents: aWord).
+ scamperWindow := (WebBrowser default ifNil: [^self]) newOrExistingOn: aUrl.
- scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: aUrl.
scamperWindow model jumpToUrl: aUrl asUrl.
scamperWindow activate.
!
Item was changed:
----- Method: PortugueseLexiconServer>>definition: (in category 'as yet unclassified') -----
definition: theWord
"look this word up in the basic way. Return nil if there is trouble accessing the web site."
| doc |
+ word := theWord.
+ doc := HTTPSocket
- word _ theWord.
- doc _ HTTPSocket
httpGetDocument: 'http://www.priberam.pt/scripts/dlpouniv.dll'
args: 'search_value=', (self class decodeAccents: word).
+ replyHTML := (doc isKindOf: MIMEDocument)
- replyHTML _ (doc isKindOf: MIMEDocument)
ifTrue: [doc content]
ifFalse: [nil].
"self parseReply."
^ replyHTML!
Item was changed:
----- Method: PortugueseLexiconServer>>parts (in category 'as yet unclassified') -----
parts
| divider |
"return the parts of speech this word can be. Keep the streams for each"
+ parts := OrderedCollection new.
+ partStreams := OrderedCollection new.
- parts _ OrderedCollection new.
- partStreams _ OrderedCollection new.
rwStream ifNil: [self stream].
rwStream reset.
rwStream match: 'Palavra desconhecida pelo Dicionário.'.
rwStream atEnd ifFalse: [^ #()]. "not in dictionary"
rwStream reset.
+ rwStream match: (divider := '<li>'). "stemming a complex word"
- rwStream match: (divider _ '<li>'). "stemming a complex word"
rwStream atEnd ifTrue: [rwStream reset.
+ rwStream match: (divider := '<dd>')]. "base word in dict"
- rwStream match: (divider _ '<dd>')]. "base word in dict"
[rwStream atEnd] whileFalse: [
partStreams add: (ReadStream on: (rwStream upToAll: divider))].
partStreams do: [:pp |
parts add: (pp upToAll: '</b>')].
parts size = 0 ifTrue: [^ parts].
parts last = '' ifTrue: [parts removeLast. partStreams removeLast].
"May want to remove all after </dl>"
^ parts !
Item was changed:
----- Method: PreDebugWindow>>adjustBookControls (in category 'as yet unclassified') -----
adjustBookControls
| inner |
proceedButton ifNil: [^ self].
+ proceedButton align: proceedButton topLeft with: (inner := self innerBounds) topLeft + (35@ -4).
- proceedButton align: proceedButton topLeft with: (inner _ self innerBounds) topLeft + (35@ -4).
debugButton align: debugButton topRight with: inner topRight - (16 at 4).!
Item was changed:
----- Method: PreDebugWindow>>setLabelWidgetAllowance (in category 'label') -----
setLabelWidgetAllowance
+ ^ labelWidgetAllowance := (Smalltalk isMorphic | Preferences optionalButtons)
- ^ labelWidgetAllowance _ (Smalltalk isMorphic | Preferences optionalButtons)
ifTrue:
[super setLabelWidgetAllowance]
ifFalse:
[180]!
Item was changed:
----- Method: PredicatedArray class>>new: (in category 'instance creation') -----
new: size
| inst elems |
+ inst := self basicNew.
+ elems := ByteArray new: size withAll: 1.
- inst _ self basicNew.
- elems _ ByteArray new: size withAll: 1.
inst predicates: elems values: elems.
^ inst.
!
Item was changed:
----- Method: PredicatedArray class>>newFor: (in category 'instance creation') -----
newFor: anArrayedCollection
| inst predicates |
+ inst := self basicNew.
+ predicates := ByteArray new: anArrayedCollection size.
- inst _ self basicNew.
- predicates _ ByteArray new: anArrayedCollection size.
inst predicates: predicates values: anArrayedCollection.
^ inst.
!
Item was changed:
----- Method: PredicatedArray>>asPredicate (in category 'converting') -----
asPredicate
+ predicates := values.
- predicates _ values.
!
Item was changed:
----- Method: PredicatedArray>>predicates: (in category 'accessing') -----
predicates: anArray
+ predicates := anArray.
- predicates _ anArray.
!
Item was changed:
----- Method: PredicatedArray>>predicates:values: (in category 'initialization') -----
predicates: anObject values: anotherObject
+ predicates := anObject.
+ values := anotherObject.
- predicates _ anObject.
- values _ anotherObject.
!
Item was changed:
----- Method: PredicatedArray>>predicates:values:type: (in category 'initialization') -----
predicates: anObject values: anotherObject type: typeSymbol
+ predicates := anObject.
+ values := anotherObject.
+ type := typeSymbol.
- predicates _ anObject.
- values _ anotherObject.
- type _ typeSymbol.
!
Item was changed:
----- Method: PredicatedArray>>primAtAllPutBoolean: (in category 'primitives') -----
primAtAllPutBoolean: val
| b |
<primitive: 'primitivePredicateAtAllPutBoolean' module:'KedamaPlugin2'>
"^ KedamaPlugin2 doPrimitive: #primitivePredicateAtAllPutBoolean."
+ b := (val == true or: [val == false]) ifTrue: [
- b _ (val == true or: [val == false]) ifTrue: [
val ifTrue: [1] ifFalse: [0].
] ifFalse: [val].
1 to: (values size min: predicates size) do: [:index |
(predicates at: index) = 1 ifTrue: [
values at: index put: b.
].
].
!
Item was changed:
----- Method: PredicatedArray>>primAtAllPutColor: (in category 'primitives') -----
primAtAllPutColor: val
| p |
<primitive: 'primitivePredicateAtAllPutColor' module:'KedamaPlugin2'>
"^ KedamaPlugin2 doPrimitive: #primitivePredicateAtAllPutColor."
+ p := val bitOr: 16rFF000000.
- p _ val bitOr: 16rFF000000.
1 to: (values size min: predicates size) do: [:index |
(predicates at: index) = 1 ifTrue: [
values at: index put: p.
].
].
!
Item was changed:
----- Method: PredicatedArray>>primReplaceWordsFrom:to:with:startingAt: (in category 'primitives') -----
primReplaceWordsFrom: start to: stop with: replacement startingAt: repStart
| v |
<primitive: 'primitivePredicateReplaceWords' module: 'KedamaPlugin2'>
"^ KedamaPlugin2 doPrimitive: #primitivePredicateReplaceWords."
self indexDo: [:index |
(index between: start and: stop) ifTrue: [
+ v := replacement at: repStart + index - start.
- v _ replacement at: repStart + index - start.
self at: index put: v.
].
].
!
Item was changed:
----- Method: PredicatedArray>>type: (in category 'accessing') -----
type: aSymbol
+ type := aSymbol.
- type _ aSymbol.
!
Item was changed:
----- Method: PredicatedArray>>values: (in category 'accessing') -----
values: anArray
+ values := anArray.
- values _ anArray.
!
Item was changed:
----- Method: Preferences class>>initializePreferencePanel:in: (in category '*Etoys-Squeakland-preferences panel') -----
initializePreferencePanel: aPanel in: aPasteUpMorph
"Initialize the given Preferences panel. in the given pasteup, which is the top-level panel installed in the container window. Also used to reset it after some change requires reformulation"
| tabbedPalette controlPage aColor aFont maxEntriesPerCategory tabsMorph anExtent prefObjects cc |
aPasteUpMorph removeAllMorphs.
aFont := Preferences standardListFont.
aColor := aPanel defaultBackgroundColor.
tabbedPalette := TabbedPalette newSticky.
tabbedPalette dropEnabled: false.
(tabsMorph := tabbedPalette tabsMorph) color: aColor darker;
highlightColor: Color red regularColor: Color brown darker darker.
tabbedPalette on: #mouseDown send: #yourself to: #().
maxEntriesPerCategory := 0.
self listOfCategories do:
[:aCat |
controlPage := AlignmentMorph newColumn beSticky color: aColor.
controlPage on: #mouseDown send: #yourself to: #().
controlPage dropEnabled: false.
Preferences alternativeWindowLook ifTrue:
[cc := Color transparent.
controlPage color: cc].
controlPage borderColor: aColor;
layoutInset: 4.
(prefObjects := self preferenceObjectsInCategory: aCat) do:
[:aPreference | | button |
+ button := aPreference representativeButtonWithColor: cc inPanel: aPanel.
- button _ aPreference representativeButtonWithColor: cc inPanel: aPanel.
button ifNotNil: [controlPage addMorphBack: button]].
controlPage setNameTo: aCat asString.
aCat = #?
ifTrue: [aPanel addHelpItemsTo: controlPage].
tabbedPalette addTabFor: controlPage font: aFont.
aCat = 'search results' ifTrue:
[(tabbedPalette tabNamed: aCat) setBalloonText:
'Use the ? category to find preferences by keyword; the results of your search will show up here' translated].
maxEntriesPerCategory := maxEntriesPerCategory max: prefObjects size].
tabbedPalette selectTabNamed: '?'.
tabsMorph rowsNoWiderThan: aPasteUpMorph width.
aPasteUpMorph on: #mouseDown send: #yourself to: #().
anExtent := aPasteUpMorph width @ (490 max: (25 + tabsMorph height + (24 * maxEntriesPerCategory))).
aPasteUpMorph extent: anExtent.
aPasteUpMorph color: aColor.
aPasteUpMorph addMorphBack: tabbedPalette.!
Item was changed:
----- Method: Preferences class>>preferencesControlPanel (in category '*Etoys-Squeakland-preferences panel') -----
preferencesControlPanel
"Answer a Preferences control panel window"
"Preferences preferencesControlPanel openInHand"
| window playfield aPanel |
+ aPanel := PreferencesPanel new.
+ playfield := PasteUpMorph new width: 450.
- aPanel _ PreferencesPanel new.
- playfield _ PasteUpMorph new width: 450.
playfield dropEnabled: false.
+ window := (SystemWindow labelled: 'Preferences' translated) model: aPanel.
- window _ (SystemWindow labelled: 'Preferences' translated) model: aPanel.
self initializePreferencePanel: aPanel in: playfield.
window on: #keyStroke send: #keyStroke: to: aPanel.
window bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
window addMorph: playfield frame: (0 @ 0 extent: 1 @ 1).
window updatePaneColors.
window setProperty: #minimumExtent toValue: playfield extent + (12 at 15).
^ window!
Item was changed:
----- Method: Preferences class>>windowColorHelp (in category '*Etoys-Squeakland-window colors') -----
windowColorHelp
"Provide help for the window-color panel"
| helpString |
+ helpString :=
- helpString _
'The "Window Colors" panel lets you select colors for many kinds of standard Squeak windows.
You can change your color preference for any particular tool by clicking on the color swatch and then selecting the desired color from the resulting color-picker.
The three buttons entitled "Bright", "Pastel", and "White" let you revert to any of three different standard color schemes.
The choices you make in the Window Colors panel only affect the colors of new windows that you open.
You can make other tools have their colors governed by this panel by simply implementing #windowColorSpecification on the class side of the model -- consult implementors of that method to see examples of how to do this.'.
(StringHolder new contents: helpString)
openLabel: 'About Window Colors' translated
"Preferences windowColorHelp"!
Item was changed:
----- Method: Preferences class>>windowSpecificationPanel (in category '*Etoys-Squeakland-window colors') -----
windowSpecificationPanel
"Put up a panel for specifying window colors"
"Preferences windowSpecificationPanel"
| aPanel buttonRow aButton aRow aSwatch aColor aWindow aMiniWorld aStringMorph |
+ aPanel := AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap;
- aPanel _ AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap;
layoutInset: 0.
+ aPanel addMorph: (buttonRow := AlignmentMorph newRow color: (aColor := Color tan lighter)).
- aPanel addMorph: (buttonRow _ AlignmentMorph newRow color: (aColor _ Color tan lighter)).
buttonRow addTransparentSpacerOfSize: 2 at 0.
buttonRow addMorphBack: (SimpleButtonMorph new label: '?'; target: self; actionSelector: #windowColorHelp; setBalloonText: 'Click for an explanation of this panel' translated; color: Color veryVeryLightGray; yourself).
buttonRow addTransparentSpacerOfSize: 8 at 0.
#( ('Bright' installBrightWindowColors yellow
'Use standard bright colors for all windows.')
('Pastel' installPastelWindowColors paleMagenta
'Use standard pastel colors for all windows.')
('White' installUniformWindowColors white
'Use white backgrounds for all standard windows.')) translatedNoop do:
[:quad |
+ aButton := (SimpleButtonMorph new target: self)
- aButton _ (SimpleButtonMorph new target: self)
label: quad first translated;
actionSelector: quad second;
color: (Color colorFrom: quad third);
setBalloonText: quad fourth translated;
yourself.
buttonRow addMorphBack: aButton.
buttonRow addTransparentSpacerOfSize: 10 at 0].
self windowColorTable do:
[:colorSpec |
+ aRow := AlignmentMorph newRow color: aColor.
+ aSwatch := ColorSwatch new
- aRow _ AlignmentMorph newRow color: aColor.
- aSwatch _ ColorSwatch new
target: self;
getSelector: #windowColorFor:;
putSelector: #setWindowColorFor:to:;
argument: colorSpec classSymbol;
extent: (40 @ 20);
setBalloonText: ('Click here to change the standard color to be used for {1} windows.' format: {colorSpec wording translated});
yourself.
aRow addMorphFront: aSwatch.
aRow addTransparentSpacerOfSize: (12 @ 1).
+ aRow addMorphBack: (aStringMorph := StringMorph contents: colorSpec wording translated font: TextStyle defaultFont).
- aRow addMorphBack: (aStringMorph _ StringMorph contents: colorSpec wording translated font: TextStyle defaultFont).
aStringMorph setBalloonText: colorSpec helpMessage translated.
aPanel addMorphBack: aRow].
Smalltalk isMorphic
ifTrue:
+ [aWindow := aPanel wrappedInWindowWithTitle: 'Window Colors' translated.
- [aWindow _ aPanel wrappedInWindowWithTitle: 'Window Colors' translated.
" don't allow the window to be picked up by clicking inside "
aPanel on: #mouseDown send: #yourself to: aPanel.
self currentWorld addMorphCentered: aWindow.
aWindow activateAndForceLabelToShow ]
ifFalse:
+ [(aMiniWorld := MVCWiWPasteUpMorph newWorldForProject: nil)
- [(aMiniWorld _ MVCWiWPasteUpMorph newWorldForProject: nil)
addMorph: aPanel.
aMiniWorld startSteppingSubmorphsOf: aPanel.
MorphWorldView openOn: aMiniWorld
label: 'Window Colors' translated
extent: aMiniWorld fullBounds extent]!
Item was changed:
----- Method: PreferencesPanel class>>deleteAllPreferencesPanels (in category 'cleanup') -----
deleteAllPreferencesPanels
"Called manually to clobber all existing preferences panels"
"PreferencesPanel deleteAllPreferencesPanels"
| aWindow |
self allInstancesDo:
[:aPanel |
+ (aWindow := aPanel containingWindow) isMorph
- (aWindow _ aPanel containingWindow) isMorph
ifTrue:
[aWindow delete]].
self killExistingMVCViews.
UpdatingThreePhaseButtonMorph allInstancesDo: "clobber old stand-alone prefs buttons"
[:m | (m actionSelector == #togglePreference:) ifTrue:
[(m owner isAlignmentMorph) ifTrue:
[m owner delete]]]!
Item was changed:
----- Method: PreferencesPanel class>>isAPreferenceViewToKill: (in category 'cleanup') -----
isAPreferenceViewToKill: aSystemView
"Answer whether the given StandardSystemView is one affiliated with a PreferencesPanel"
| m target subView |
aSystemView subViews size = 1 ifFalse: [^ false].
+ subView := aSystemView subViews first.
- subView _ aSystemView subViews first.
(subView isKindOf: MorphWorldView) ifFalse: [^ false].
+ ((m := subView model) isKindOf: MVCWiWPasteUpMorph) ifFalse: [^ false].
- ((m _ subView model) isKindOf: MVCWiWPasteUpMorph) ifFalse: [^ false].
m submorphs size = 1 ifFalse: [^ false].
m firstSubmorph submorphs size = 1 ifFalse: [^ false].
+ target := m firstSubmorph firstSubmorph.
- target _ m firstSubmorph firstSubmorph.
(target isKindOf: TabbedPalette) ifFalse: [^ false].
^ #(browsing debug fileout general halos) allSatisfy: [:s |
(target tabNamed: s) notNil]!
Item was changed:
----- Method: PreferencesPanel class>>killExistingMVCViews (in category 'cleanup') -----
killExistingMVCViews
"Kill all existing preferences views in mvc"
"
PreferencesPanel killExistingMVCViews
"
| byebye |
ControlManager allInstances do: [ :cm |
+ byebye := cm controllersSatisfying: [ :eachC |
- byebye _ cm controllersSatisfying: [ :eachC |
self isAPreferenceViewToKill: eachC view].
byebye do: [ :each |
each status: #closed.
each view release.
cm unschedule: each]]!
Item was changed:
----- Method: PreferencesPanel>>addHelpItemsTo: (in category 'find') -----
addHelpItemsTo: panelPage
"Add the items appropriate the the ? page of the receiver"
| aButton aTextMorph aMorph firstTextMorph |
panelPage hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ firstTextMorph := TextMorph new contents: 'Search Preferences for:' translated.
- firstTextMorph _ TextMorph new contents: 'Search Preferences for:' translated.
"firstTextMorph beAllFont: ((TextStyle default fontOfSize: 13) emphasized: 1)."
panelPage addMorphBack: firstTextMorph lock.
panelPage addTransparentSpacerOfSize: 0 at 10.
+ aMorph := RectangleMorph new clipSubmorphs: true; beTransparent; borderWidth: 2; borderColor: Color black; extent: 250 @ 36.
- aMorph _ RectangleMorph new clipSubmorphs: true; beTransparent; borderWidth: 2; borderColor: Color black; extent: 250 @ 36.
aMorph vResizing: #rigid; hResizing: #rigid.
+ aTextMorph := PluggableTextMorph new
- aTextMorph _ PluggableTextMorph new
on: self
text: #searchString
accept: #setSearchStringTo:
readSelection: nil
menu: nil.
" aTextMorph hResizing: #rigid."
aTextMorph borderWidth: 0.
aTextMorph font: ((TextStyle default fontOfSize: 21) emphasized: 1); setTextColor: Color red.
aMorph addMorphBack: aTextMorph.
aTextMorph acceptOnCR: true.
aTextMorph position: (aTextMorph position + (6 at 5)).
aMorph clipLayoutCells: true.
aTextMorph extent: 240 @ 25.
panelPage addMorphBack: aMorph.
aTextMorph setBalloonText: 'Type what you want to search for here, then hit the "Search" button, or else hit RETURN or ENTER' translated.
aTextMorph setTextMorphToSelectAllOnMouseEnter.
aTextMorph hideScrollBarsIndefinitely.
panelPage addTransparentSpacerOfSize: 0 at 10.
+ aButton := SimpleButtonMorph new
- aButton _ SimpleButtonMorph new
target: self;
color: Color transparent;
actionSelector: #initiateSearch:;
arguments: {aTextMorph};
label: 'Search' translated.
panelPage addMorphBack: aButton.
aButton setBalloonText: 'Type what you want to search for in the box above, then click here (or hit RETURN or ENTER) to start the search; results will appear in the "search results" category.' translated.
panelPage addTransparentSpacerOfSize: 0 at 30.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Reset preferences on startup' translated;
target: Preferences;
actionSelector: #deletePersistedPreferences;
setBalloonText: 'Click here to delete all the preferences saved on file. On the next start, they will have their original value.' translated ; yourself).
panelPage addTransparentSpacerOfSize: 0 at 14.
Preferences eToyFriendly ifFalse: [
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Restore all Default Preference Settings' translated;
target: Preferences;
actionSelector: #chooseInitialSettings;
setBalloonText: 'Click here to reset all the preferences to their standard default values.' translated ; yourself).
panelPage addTransparentSpacerOfSize: 0 at 14.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Save Current Settings as my Personal Preferences' translated;
target: Preferences;
actionSelector: #savePersonalPreferences;
setBalloonText: 'Click here to save the current constellation of Preferences settings as your personal defaults; you can get them all reinstalled with a single gesture by clicking the "Restore my Personal Preferences".' translated; yourself).
panelPage addTransparentSpacerOfSize: 0 at 14.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Restore my Personal Preferences' translated;
target: Preferences;
actionSelector: #restorePersonalPreferences;
setBalloonText: 'Click here to reset all the preferences to their values in your Personal Preferences.' translated; yourself).
panelPage addTransparentSpacerOfSize: 0 at 30.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Save Current Settings to Disk' translated;
target: Preferences;
actionSelector: #storePreferencesToDisk;
setBalloonText: 'Click here to save the current constellation of Preferences settings to a file; you can get them all reinstalled with a single gesture by clicking "Restore Settings From Disk".' translated; yourself).
panelPage addTransparentSpacerOfSize: 0 at 14.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Restore Settings from Disk' translated;
target: Preferences;
actionSelector: #restorePreferencesFromDisk;
setBalloonText: 'Click here to load all the preferences from their saved values on disk.' translated; yourself).
panelPage addTransparentSpacerOfSize: 0 at 30.
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Inspect Parameters' translated;
target: Preferences;
actionSelector: #inspectParameters;
setBalloonText: 'Click here to view all the values stored in the system Parameters dictionary' translated; yourself).
panelPage addTransparentSpacerOfSize: 0 at 10.
panelPage addMorphBack: (Preferences themeChoiceButtonOfColor: Color transparent font: TextStyle defaultFont).
panelPage addTransparentSpacerOfSize: 0 at 10.
].
panelPage addMorphBack: (SimpleButtonMorph new
color: Color transparent;
label: 'Help!!' translated;
target: Preferences;
actionSelector: #giveHelpWithPreferences;
setBalloonText: 'Click here to get some hints on use of this Preferences Panel' translated; yourself).
panelPage wrapCentering: #center.
!
Item was changed:
----- Method: PreferencesPanel>>adjustProjectLocalEmphasisFor: (in category 'initialization') -----
adjustProjectLocalEmphasisFor: aSymbol
"Somewhere, the preference represented by aSymbol got changed from being one that is truly global to one that varies by project, or vice-versa. Get my panel right -- this involves changing the emphasis on the item"
| aWindow toFixUp allMorphs emphasis |
+ (aWindow := self containingWindow) ifNil: [^ self].
+ emphasis := (Preferences preferenceAt: aSymbol ifAbsent: [^ self]) localToProject
- (aWindow _ self containingWindow) ifNil: [^ self].
- emphasis _ (Preferences preferenceAt: aSymbol ifAbsent: [^ self]) localToProject
ifTrue: [1 "bold for local-to-project"]
ifFalse: [0 "plain for global"].
+ allMorphs := IdentitySet new.
- allMorphs _ IdentitySet new.
aWindow allMorphsAndBookPagesInto: allMorphs.
+ toFixUp := allMorphs select:
- toFixUp _ allMorphs select:
[:m | (m isKindOf: StringMorph) and: [m contents = aSymbol]].
toFixUp do:
[:aStringMorph | aStringMorph emphasis: emphasis]
!
Item was changed:
----- Method: PreferencesPanel>>findCategoryFromPreference: (in category 'find') -----
findCategoryFromPreference: prefSymbol
"Find all categories in which the preference occurs"
| aMenu|
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
(Preferences categoriesContainingPreference: prefSymbol) do:
[:aCategory | aMenu add: aCategory target: self selector: #switchToCategoryNamed:event: argumentList: {aCategory. MorphicEvent new}].
aMenu popUpInWorld!
Item was changed:
----- Method: PreferencesPanel>>findPreferencesMatching: (in category 'initialization') -----
findPreferencesMatching: incomingTextOrString
"find all preferences matching incomingTextOrString"
| result aList aPalette controlPage cc |
result := incomingTextOrString asString asLowercase.
result := result asLowercase withBlanksTrimmed.
result isEmptyOrNil ifTrue: [^ self].
aList := Preferences allPreferenceObjects select:
[:aPreference |
(aPreference name includesSubstring: result caseSensitive: false) or:
[aPreference helpString includesSubstring: result caseSensitive: false]].
aPalette := (self containingWindow ifNil: [^ self]) findDeeplyA: TabbedPalette.
aPalette ifNil: [^ self].
aPalette selectTabNamed: 'search results'.
aPalette currentPage ifNil: [^ self]. "bkwd compat"
controlPage := aPalette currentPage.
controlPage removeAllMorphs.
controlPage addMorph: (StringMorph contents: ('Preferences matching "', self searchString, '"') font: Preferences standardEToysButtonFont).
Preferences alternativeWindowLook ifTrue:[
cc := Color transparent.
controlPage color: cc].
aList := aList asSortedCollection:
[:a :b | a name < b name].
aList do:
[:aPreference | | button |
+ button := aPreference representativeButtonWithColor: cc inPanel: self.
- button _ aPreference representativeButtonWithColor: cc inPanel: self.
button ifNotNil: [controlPage addMorphBack: button]].
aPalette world startSteppingSubmorphsOf: aPalette!
Item was changed:
----- Method: PreferencesPanel>>initiateSearch: (in category 'find') -----
initiateSearch: morphHoldingSearchString
"Carry out the action of the Search button in the Preferences panel"
+ searchString := morphHoldingSearchString text.
- searchString _ morphHoldingSearchString text.
self setSearchStringTo: self searchString.
self findPreferencesMatchingSearchString!
Item was changed:
----- Method: PreferencesPanel>>searchString (in category 'find') -----
searchString
"Answer the current searchString, initializing it if need be"
| win aMorph |
searchString isEmptyOrNil ifTrue:
+ [searchString := 'Type here, hit Search' translated.
+ (win := self containingWindow) ifNotNil:
+ [aMorph := win findDeepSubmorphThat:
- [searchString _ 'Type here, hit Search' translated.
- (win _ self containingWindow) ifNotNil:
- [aMorph _ win findDeepSubmorphThat:
[:m | m isKindOf: PluggableTextMorph]
ifAbsent: [^ searchString].
aMorph setText: searchString.
aMorph setTextMorphToSelectAllOnMouseEnter.
aMorph selectAll]].
^ searchString!
Item was changed:
----- Method: PreferencesPanel>>setSearchStringTo: (in category 'find') -----
setSearchStringTo: aText
"The user submitted aText as the search string; now search for it"
+ searchString := aText asString.
- searchString _ aText asString.
self findPreferencesMatching: searchString.
^ true!
Item was changed:
----- Method: PreferencesPanel>>switchToCategoryNamed:event: (in category 'category switch') -----
switchToCategoryNamed: aName event: anEvent
"Switch the panel so that it looks at the category of the given name"
| aPalette |
+ aPalette := self containingWindow findDeeplyA: TabbedPalette.
- aPalette _ self containingWindow findDeeplyA: TabbedPalette.
aPalette ifNil: [^ self].
aPalette selectTabNamed: aName!
Item was changed:
----- Method: PrintComponent>>initPinSpecs (in category 'components') -----
initPinSpecs
+ pinSpecs := Array
- pinSpecs _ Array
with: (PinSpec new pinName: 'value' direction: #inputOutput
localReadSelector: nil localWriteSelector: nil
modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
defaultValue: nil pinLoc: 1.5)!
Item was changed:
----- Method: Process>>debug:title:full:contents: (in category '*Etoys-Squeakland-debugging') -----
debug: context title: title full: bool contents: contents
"Open debugger on self with context shown on top"
| topCtxt |
+ topCtxt := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
- topCtxt _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
(topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process'].
Debugger openOn: self context: context label: title contents: contents fullView: bool.
!
Item was changed:
----- Method: ProgressInitiationException>>defaultMorphicAction (in category '*Etoys-Squeakland-as yet unclassified') -----
defaultMorphicAction
| result progress |
+ progress := SystemProgressMorph label: progressTitle min: minVal max: maxVal.
+ [result := workBlock value: progress] ensure: [SystemProgressMorph close: progress].
- progress _ SystemProgressMorph label: progressTitle min: minVal max: maxVal.
- [result _ workBlock value: progress] ensure: [SystemProgressMorph close: progress].
self resume: result!
Item was changed:
----- Method: Project class>>fromExampleEtoys: (in category '*Etoys-Squeakland-squeaklet on server') -----
fromExampleEtoys: urlString
| pair projName proj triple serverDir projectFilename |
Project canWeLoadAProjectNow ifFalse: [^ self].
+ projectFilename := urlString.
+ triple := Project parseProjectFileName: projectFilename unescapePercents.
+ projName := triple first.
+ (proj := Project named: projName)
- projectFilename _ urlString.
- triple _ Project parseProjectFileName: projectFilename unescapePercents.
- projName _ triple first.
- (proj _ Project named: projName)
ifNotNil: ["it appeared" ^ ProjectEntryNotification signal: proj].
+ serverDir := FileDirectory on: (Smalltalk imagePath, FileDirectory slash, 'ExampleEtoys').
- serverDir _ FileDirectory on: (Smalltalk imagePath, FileDirectory slash, 'ExampleEtoys').
+ pair := self mostRecent: projectFilename onServer: serverDir.
- pair _ self mostRecent: projectFilename onServer: serverDir.
"Pair first is name exactly as it is on the server"
pair first ifNil: [^Project current openBlankProjectNamed: projName].
ProjectLoading
installRemoteNamed: pair first
from: serverDir
named: projName
in: CurrentProject.!
Item was changed:
----- Method: Project>>displayProgressWithJump: (in category '*Etoys-Squeakland-menu messages') -----
displayProgressWithJump: aMessage
"Answer a block to display progress while some time-consuming action is going on; the message provided is shown within a tableau of special chars. This is basically Andreas's code."
| done b guy guys c text idx |
done := false.
b := ScriptableButton new.
+ guy := TextMorph new.
- guy _ TextMorph new.
guy usePango: false.
+ guys := #('\o/
- guys _ #('\o/
_I_
' '_o_
I
/ \' 'o
/ I \
| |' '_o_
I
/ \').
b color: Color yellow.
b borderWidth: 1; borderColor: Color black.
[
+ idx := 0.
- idx _ 0.
[done] whileFalse:[
+ c := Display getCanvas.
- c _ Display getCanvas.
b label: aMessage font: (Preferences standardEToysFont emphasized: 1).
b extent: 200 at 100.
b center: Display center.
b fullDrawOn: Display getCanvas.
guy beAllFont: (Preferences standardEToysFont emphasized: 1).
+ text := (guys atWrap: (idx := idx + 1)) asText.
- text _ (guys atWrap: (idx := idx + 1)) asText.
text addAttribute: (TextAlignment centered) from: 1 to: text string size.
guy contents: text.
guy center: b position + (30 at 50); top: b top + 20.
guy fullDrawOn: c.
guy center: b position + (170 at 50); top: b top + 20.
guy fullDrawOn: c.
Display forceToScreen: b bounds.
(Delay forMilliseconds: 500) wait.
].
] forkAt: Processor userInterruptPriority.
^[done := true]!
Item was changed:
----- Method: Project>>helpGuideIfOpen (in category '*Etoys-Squeakland-flaps support') -----
helpGuideIfOpen
"Return the QuickGuideMorph of the help flap if it is open. Return nil if the Help flap is closed or if there is no help flap."
| ref ff |
+ ff := Flaps globalFlapTab: 'Help' translated.
- ff _ Flaps globalFlapTab: 'Help' translated.
ff ifNil: [^ nil].
ff isInWorld ifFalse: [^ nil].
ff flapShowing ifFalse: [^ nil].
+ ref := ff referent.
- ref _ ff referent.
ref ifNil: [^ nil].
^ ref findDeeplyA: QuickGuideMorph
!
Item was changed:
----- Method: Project>>okToChangeSilently (in category '*Etoys-Squeakland-release') -----
okToChangeSilently
"Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation"
| ok is list |
self subProjects size > 0 ifTrue:
[^ false].
+ ok := world isMorph not and: [world scheduledControllers size <= 1].
- ok _ world isMorph not and: [world scheduledControllers size <= 1].
ok ifFalse: [self isMorphic ifTrue:
[self parent == CurrentProject
ifFalse: [^ true]]]. "view from elsewhere. just delete it."
+ ok := true.
- ok _ true.
ok ifFalse: [^ false].
world isMorph ifTrue:
[Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass |
world submorphs do: "special release for wonderlands"
[:m | (m isKindOf: aClass)
and: [m getWonderland release]]].
"Remove Player classes and metaclasses owned by project"
+ is := ImageSegment new arrayOfRoots: (Array with: self).
+ (list := is rootsIncludingPlayers) ifNotNil:
- is _ ImageSegment new arrayOfRoots: (Array with: self).
- (list _ is rootsIncludingPlayers) ifNotNil:
[list do: [:playerCls |
(playerCls respondsTo: #isMeta) ifTrue:
[playerCls isMeta ifFalse:
[playerCls removeFromSystemUnlogged]]]]].
self removeChangeSetIfPossible.
"do this last since it will render project inaccessible to #allProjects and their ilk"
ProjectHistory forget: self.
Project deletingProject: self.
^ true
!
Item was changed:
----- Method: Project>>storeOnServerWithNoInteraction (in category '*Etoys-Squeakland-file in/out') -----
storeOnServerWithNoInteraction
"Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded."
| ret pp |
world setProperty: #optimumExtentFromAuthor toValue: world extent.
self isCurrentProject ifTrue: ["exit, then do the command"
Flaps globalFlapTabsIfAny do: [:each | Flaps removeFlapTab: each keepInList: true].
+ ret := self
- ret _ self
armsLengthCommand: #storeOnServerWithNoInteraction
withDescription: 'Publishing' translated.
^ ret
].
+ pp := self displaySavingProgress.
- pp _ self displaySavingProgress.
[self storeOnServerWithNoInteractionInnards] on: Error do: [:ex |
Smalltalk logError: ex description inContext: ex signalerContext to: 'SqueakDebug.log'.
pp value. ^ false].
pp value.
^ true.
!
Item was changed:
----- Method: Project>>storeOnServerWithNoInteractionInnards (in category '*Etoys-Squeakland-file in/out') -----
storeOnServerWithNoInteractionInnards
"Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded."
| newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber priorWorld myDepth |
self assureIntegerVersion.
"Find out what version"
+ primaryServerDirectory := self defaultFolderForAutoSaving ifNil: [^self].
- primaryServerDirectory _ self defaultFolderForAutoSaving ifNil: [^self].
+ localDirectory := self squeakletDirectory.
+ serverVersionPair := self class mostRecent: self name onServer: primaryServerDirectory.
+ localVersionPair := self class mostRecent: self name onServer: localDirectory.
+ maxNumber := myVersionNumber := self currentVersionNumber.
- localDirectory _ self squeakletDirectory.
- serverVersionPair _ self class mostRecent: self name onServer: primaryServerDirectory.
- localVersionPair _ self class mostRecent: self name onServer: localDirectory.
- maxNumber _ myVersionNumber _ self currentVersionNumber.
ProgressNotification signal: '2:versionsDetected'.
+ warning := ''.
- warning _ ''.
myVersionNumber < serverVersionPair second ifTrue: [
+ warning := warning,'\There are newer version(s) on the server' translated.
+ maxNumber := maxNumber max: serverVersionPair second.
- warning _ warning,'\There are newer version(s) on the server' translated.
- maxNumber _ maxNumber max: serverVersionPair second.
].
myVersionNumber < localVersionPair second ifTrue: [
+ warning := warning,'\There are newer version(s) in the local directory' translated.
+ maxNumber := maxNumber max: localVersionPair second.
- warning _ warning,'\There are newer version(s) in the local directory' translated.
- maxNumber _ maxNumber max: localVersionPair second.
].
+ version := self bumpVersion: maxNumber.
- version _ self bumpVersion: maxNumber.
"write locally - now zipped automatically"
Display isVirtualScreen ifTrue: [
+ myDepth := displayDepth.
+ displayDepth := OLPCVirtualScreen preferredScreenDepth..
- myDepth _ displayDepth.
- displayDepth _ OLPCVirtualScreen preferredScreenDepth..
].
+ newName := self versionedFileName.
+ lastSavedAtSeconds := Time totalSeconds.
+ priorWorld := ActiveWorld.
- newName _ self versionedFileName.
- lastSavedAtSeconds _ Time totalSeconds.
- priorWorld _ ActiveWorld.
self exportSegmentFileName: newName directory: localDirectory withoutInteraction: true.
+ ActiveWorld := priorWorld.
- ActiveWorld _ priorWorld.
(localDirectory readOnlyFileNamed: newName) setFileTypeToObject; close.
Display isVirtualScreen ifTrue: [
+ displayDepth := myDepth.
- displayDepth _ myDepth.
].
ProgressNotification signal: '4:localSaveComplete'. "3 is deep in export logic"
primaryServerDirectory ifNotNil: [
[
primaryServerDirectory
writeProject: self
inFileNamed: newName asFileName
fromDirectory: localDirectory.
] on: ProjectPasswordNotification do: [ :ex |
ex resume: ''
].
].
ProgressNotification signal: '9999 save complete'.
!
Item was changed:
----- Method: Project>>storeOnServerWithNoInteractionThenQuit (in category '*Etoys-Squeakland-file in/out') -----
storeOnServerWithNoInteractionThenQuit
"Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded. Then Quit"
| ret pp |
world setProperty: #optimumExtentFromAuthor toValue: world extent.
self isCurrentProject ifTrue: ["exit, then do the command"
Flaps globalFlapTabsIfAny do: [:each | Flaps removeFlapTab: each keepInList: true].
+ ret := self
- ret _ self
armsLengthCommand: #storeOnServerWithNoInteractionThenQuit
withDescription: 'Publishing' translated.
^ ret
].
+ pp := self displaySavingProgress.
- pp _ self displaySavingProgress.
[[self storeOnServerWithNoInteractionInnards]
on: Error do: [:ex |
Smalltalk logError: ex description
inContext: ex signalerContext
to: 'SqueakDebug.log']
] ensure: [pp value. Smalltalk quitPrimitive].
^ true.
!
Item was changed:
----- Method: Project>>storePngThumbnailIn: (in category '*Etoys-Squeakland-file in/out') -----
storePngThumbnailIn: aFileDirectory
"Make an icon representing the receiver, and store it in the given directory."
| file writer |
+ file := aFileDirectory forceNewFileNamed: ('thumbnail', FileDirectory dot, 'png').
- file _ aFileDirectory forceNewFileNamed: ('thumbnail', FileDirectory dot, 'png').
file ifNil: [^ self].
writer := PNGReadWriter on: file.
[writer nextPutImage: self thumbnail]
ensure: [writer close]!
Item was changed:
----- Method: Project>>updateLocaleDependentsGently (in category '*Etoys-Squeakland-language') -----
updateLocaleDependentsGently
| supplies prev |
+ prev := Locale previous ifNotNil: [Locale previous localeID] ifNil: [LocaleID isoString: 'en'].
+ supplies := Flaps globalFlapTabWithID: ('Supplies' translatedTo: prev).
+ supplies ifNotNil: [supplies := supplies referent submorphs].
- prev _ Locale previous ifNotNil: [Locale previous localeID] ifNil: [LocaleID isoString: 'en'].
- supplies _ Flaps globalFlapTabWithID: ('Supplies' translatedTo: prev).
- supplies ifNotNil: [supplies _ supplies referent submorphs].
^ self updateLocaleDependentsWithPreviousSupplies: supplies gently: true.
!
Item was changed:
----- Method: Project>>version: (in category '*Etoys-Squeakland-file in/out') -----
version: anInteger
+ version := anInteger.
- version _ anInteger.
!
Item was changed:
----- Method: Project>>writeForExportInSexp:withSources:inDirectory:changeSet: (in category '*Etoys-Squeakland-file in/out') -----
writeForExportInSexp: sexp withSources: actualName inDirectory: aDirectory changeSet:
aChangeSetOrNil
| fileStream tempFileName zipper |
+ tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'.
+ zipper := [
- tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
- zipper _ [
aDirectory rename: tempFileName toBe: actualName.
aDirectory deleteFileNamed: tempFileName ifAbsent: []
].
+ fileStream := aDirectory newFileNamed: tempFileName.
- fileStream _ aDirectory newFileNamed: tempFileName.
sexp printOn: fileStream.
fileStream close.
+ fileStream := aDirectory newFileNamed: 'changes.cs'.
- fileStream _ aDirectory newFileNamed: 'changes.cs'.
aChangeSetOrNil ifNotNil: [aChangeSetOrNil fileOutOn: fileStream].
fileStream close.
zipper value.!
Item was changed:
----- Method: ProjectLoading class>>loadSexpProjectDict:stream:fromDirectory:withProjectView: (in category '*etoys') -----
loadSexpProjectDict: dict stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView
| archive anObject newProj d member b s memberStream members newSet allNames realName oldSet |
(self checkStream: preStream) ifTrue: [^ nil].
ProgressNotification signal: '0.2'.
preStream reset.
+ archive := preStream isZipArchive
- archive _ preStream isZipArchive
ifTrue:[ZipArchive new readFrom: preStream]
ifFalse:[nil].
+ members := archive membersMatching: '*.cs'.
+ members do: [:e | newSet := ChangeSorter newChangesFromStream: e contentStream named: 'zzTemp', Time totalSeconds printString].
- members _ archive membersMatching: '*.cs'.
- members do: [:e | newSet _ ChangeSorter newChangesFromStream: e contentStream named: 'zzTemp', Time totalSeconds printString].
+ member := (archive membersMatching: '*.sexp') first.
+ memberStream := member contentStream.
- member _ (archive membersMatching: '*.sexp') first.
- memberStream _ member contentStream.
(self checkSecurity: member name preStream: preStream projStream: memberStream)
ifFalse: [^nil].
+ b := String new: member uncompressedSize.
- b _ String new: member uncompressedSize.
s := memberStream basicUpToEnd.
d := (Smalltalk at: #MSExpParser) parse: s with: #ksexp.
+ anObject := d sissReadObjectsAsEtoysProject.
- anObject _ d sissReadObjectsAsEtoysProject.
preStream close.
+ "anObject := (MSExpParser parse: (archive membersMatching: '*.sexp') first contents with: #ksexp) sissReadObjects."
- "anObject _ (MSExpParser parse: (archive membersMatching: '*.sexp') first contents with: #ksexp) sissReadObjects."
anObject ifNil: [^ nil].
(anObject isKindOf: PasteUpMorph) ifFalse: [^ World addMorph: anObject].
ProgressNotification signal: '0.7'.
+ newProj := MorphicProject new.
- newProj _ MorphicProject new.
newProj installPasteUpAsWorld: anObject.
+ newSet ifNotNil: [oldSet := newProj changeSet. newProj setChangeSet: newSet. ChangeSorter removeChangeSet: oldSet].
- newSet ifNotNil: [oldSet _ newProj changeSet. newProj setChangeSet: newSet. ChangeSorter removeChangeSet: oldSet].
dict at: 'projectname' ifPresent: [:n |
+ allNames := Project allNames.
+ realName := Utilities keyLike: n satisfying:
- allNames _ Project allNames.
- realName _ Utilities keyLike: n satisfying:
[:nn | (allNames includes: nn) not].
newProj renameTo: realName.
].
anObject valueOfProperty: #projectVersion ifPresentDo: [:v | newProj version: v].
newProj noteManifestDetailsIn: dict.
ProgressNotification signal: '0.8'.
^ newProj.!
Item was changed:
----- Method: ProjectNavigationMorph>>doStopButtonMenuEvent: (in category '*Etoys-Squeakland-the actions') -----
doStopButtonMenuEvent: evt
| menu selection |
+ menu := CustomMenu new.
- menu _ CustomMenu new.
menu
add: 'stop Etoys' translated action: [self stopSqueak];
add: 'quit without saving' translated action: [SmalltalkImage current snapshot: false andQuit: true].
+ selection := menu build startUpCenteredWithCaption: 'Stop options' translated.
- selection _ menu build startUpCenteredWithCaption: 'Stop options' translated.
selection ifNil: [^self].
selection value.
!
Item was changed:
----- Method: QuickGuideGenerator>>generate (in category 'all') -----
generate
| inDir outDir |
+ inDir := FileDirectory on: input.
- inDir _ FileDirectory on: input.
inDir fileNames ifEmpty: [
self inform: 'the input path doesn''t point to\the directory with projects' withCRs. ^ self].
+ outDir := FileDirectory on: output.
- outDir _ FileDirectory on: output.
outDir assureExistence.
outDir fileNames ifNotEmpty: [
"self halt. let me see what is in it!!"
self inform: 'output directory is not empty.\Please remove files in it first.' withCRs. ^ self].
QuickGuideMorph convertProjectsWithBooksToSISSIn: inDir to: outDir.
!
Item was changed:
----- Method: QuickGuideGenerator>>initialize (in category 'all') -----
initialize
super initialize.
+ input := ''.
+ output := (FileDirectory on: Smalltalk imagePath) fullPathFor: 'Newest'.
- input _ ''.
- output _ (FileDirectory on: Smalltalk imagePath) fullPathFor: 'Newest'.
self setup.
!
Item was changed:
----- Method: QuickGuideGenerator>>makeInputDirList (in category 'all') -----
makeInputDirList
| m |
+ fileList := FileList2 morphicView model.
- fileList _ FileList2 morphicView model.
fileList directory: (FileDirectory default).
+ m := (SimpleHierarchicalListMorph
- m _ (SimpleHierarchicalListMorph
on: self
list: #initialDirectoryList
selected: #currentDirectorySelected
changeSelected: #setSelectedDirectoryTo:
menu: nil
keystroke: nil)
autoDeselect: false;
enableDrag: false;
enableDrop: true;
yourself.
m extent: m extent + (200 at 200).
^ m.
!
Item was changed:
----- Method: QuickGuideGenerator>>setInput: (in category 'all') -----
setInput: aString
input := aString asString.
+ (input endsWith: FileDirectory slash) ifTrue: [input := input copyFrom: 1 to: input size - 1].
- (input endsWith: FileDirectory slash) ifTrue: [input _ input copyFrom: 1 to: input size - 1].
inputMorph hasUnacceptedEdits: false.
!
Item was changed:
----- Method: QuickGuideGenerator>>setOutput: (in category 'all') -----
setOutput: aString
output := aString asString.
+ (output endsWith: FileDirectory slash) ifTrue: [output := output copyFrom: 1 to: output size - 1].
- (output endsWith: FileDirectory slash) ifTrue: [output _ output copyFrom: 1 to: output size - 1].
outputMorph hasUnacceptedEdits: false.
!
Item was changed:
----- Method: QuickGuideGenerator>>setSelectedDirectoryTo: (in category 'all') -----
setSelectedDirectoryTo: dir
+ input := dir withoutListWrapper pathName.
- input _ dir withoutListWrapper pathName.
fileList setSelectedDirectoryTo: dir.
self changed: #fileList.
self changed: #contents.
self changed: #currentDirectorySelected.
self changed: #getInput.
!
Item was changed:
----- Method: QuickGuideGenerator>>setup (in category 'all') -----
setup
| button |
self color: Color lightBlue.
self extent: 650 at 360.
self addMorph: self makeInputDirList.
+ inputMorph := PluggableTextMorph on: self text: #getInput accept: #setInput:.
- inputMorph _ PluggableTextMorph on: self text: #getInput accept: #setInput:.
inputMorph acceptOnCR: true.
self addMorph: inputMorph.
inputMorph extent: 300 at 50.
inputMorph position: 355 at 0.
+ outputMorph := PluggableTextMorph on: self text: #getOutput accept: #setOutput:.
- outputMorph _ PluggableTextMorph on: self text: #getOutput accept: #setOutput:.
outputMorph acceptOnCR: true.
outputMorph extent: 300 at 50.
outputMorph position: 355 at 50.
self addMorph: outputMorph.
+ button := SimpleButtonMorph new.
- button _ SimpleButtonMorph new.
button
labelString: 'Generate' font: Preferences standardMenuFont;
actionSelector: #generate;
arguments: #();
target: self.
button position: 365 at 125.
self addMorph: button.
!
Item was changed:
----- Method: QuickGuideHolderMorph>>guideCategory: (in category 'accessing') -----
guideCategory: anObject
"Set the value of guideCategory"
+ guideCategory := anObject!
- guideCategory _ anObject!
Item was changed:
----- Method: QuickGuideHolderMorph>>guideName: (in category 'accessing') -----
guideName: aString
+ guideName := aString.
- guideName _ aString.
self setNamePropertyTo: aString.
!
Item was changed:
----- Method: QuickGuideHolderMorph>>guideNameInWords: (in category 'accessing') -----
guideNameInWords: anObject
"Set the value of guideNameInWords"
+ guideNameInWords := anObject!
- guideNameInWords _ anObject!
Item was changed:
----- Method: QuickGuideHolderMorph>>load (in category 'file in/file out') -----
load
"If 'guide.00x.pr' is present, take the one with the largest x. If only '.sexp.data.gz', then use it"
| dir m fileName f unzipped zipped ours proj tm |
self submorphs size > 0 ifTrue: [^ self].
+ dir := FileDirectory on: QuickGuideMorph guidePath.
- dir _ FileDirectory on: QuickGuideMorph guidePath.
"#('xxx.001.pr' 'xxx.035.pr' 'xxx.sexp.data.gz') asSortedCollection ('xxx.001.pr' 'xxx.035.pr' 'xxx.sexp.data.gz')"
+ ours := dir fileNames select: [:fName |
- ours _ dir fileNames select: [:fName |
(fName beginsWith: guideName) and: [(fName endsWith: '.pr') or: [fName endsWith: '.sexp.data.gz']]].
+ ours := ours asSortedCollection.
- ours _ ours asSortedCollection.
ours size = 0 ifTrue: [
submorphs size = 0 ifTrue: [
tm := TextMorph new contents: 'guide is missing' translated.
tm topLeft: self topLeft + (4 at 4).
self width: (self width max: 200).
self addMorphFront: tm].
^ self].
+ fileName := ours size > 1 ifTrue: [ours at: (ours size - 1) "most recent .pr file"] ifFalse: [ours last "sexp"].
+ proj := fileName endsWith: '.pr'.
- fileName _ ours size > 1 ifTrue: [ours at: (ours size - 1) "most recent .pr file"] ifFalse: [ours last "sexp"].
- proj _ fileName endsWith: '.pr'.
Cursor wait showWhile: [
proj ifFalse: [
+ unzipped := WriteStream on: ByteArray new.
+ f := dir readOnlyFileNamed: fileName.
+ zipped := GZipReadStream on: f.
- unzipped _ WriteStream on: ByteArray new.
- f _ dir readOnlyFileNamed: fileName.
- zipped _ GZipReadStream on: f.
unzipped nextPutAll: zipped contents.
+ m := BookMorph bookFromPagesInSISSFormat: (DataStream on: (ReadStream on: (unzipped contents))) next.
- m _ BookMorph bookFromPagesInSISSFormat: (DataStream on: (ReadStream on: (unzipped contents))) next.
f close].
proj ifTrue: [
+ m := self loadPR: fileName dir: dir.
- m _ self loadPR: fileName dir: dir.
m ifNil: [^ self]].
m position: 0 at 0.
self position: 0 at 0.
self extent: m extent.
m setNamePropertyTo: guideName.
m beSticky.
self translateGuide: m.
self addMorph: m.
].
!
Item was changed:
----- Method: QuickGuideHolderMorph>>loadPR:dir: (in category 'file in/file out') -----
loadPR: fileName dir: dir
"load a guide from a .pr file"
| p book texts desc |
+ p := ProjectLoading loadName: fileName
- p _ ProjectLoading loadName: fileName
stream: (dir readOnlyFileNamed: fileName)
fromDirectory: dir withProjectView: #none. "don't create project view"
+ book := p world submorphs detect: [:b | b isMemberOf: BookMorph] ifNone: [nil].
- book _ p world submorphs detect: [:b | b isMemberOf: BookMorph] ifNone: [nil].
book ifNotNil: [
+ texts := book currentPage submorphs select: [:e | e isKindOf: TextMorph].
+ desc := texts isEmpty
- texts _ book currentPage submorphs select: [:e | e isKindOf: TextMorph].
- desc _ texts isEmpty
ifTrue: [^ nil]
ifFalse: [(texts asSortedCollection: [:x :y | x top < y top]) first contents asString].
" Descriptions at: p name put: desc.
Thumbnails at: p name put: (book imageForm magnifyBy: 0.25).
Colors at: p name put: book color.
"
book hidePageControls.
].
^ book!
Item was changed:
----- Method: QuickGuideMorph class>>defaultOrderIn: (in category 'defaults') -----
defaultOrderIn: helpCategory
| baseNames suggestedOrder ret last |
baseNames := FileNameStems. "don't reread every time"
+ suggestedOrder := self suggestedOrder.
- suggestedOrder _ self suggestedOrder.
helpCategory ifNotNil: [
+ suggestedOrder := suggestedOrder select: [:e | e beginsWith: helpCategory].
+ baseNames := baseNames select: [:e | e beginsWith: helpCategory]].
- suggestedOrder _ suggestedOrder select: [:e | e beginsWith: helpCategory].
- baseNames _ baseNames select: [:e | e beginsWith: helpCategory]].
+ ret := OrderedCollection new.
+ baseNames := baseNames collect: [:bb | bb withoutTrailingDigits].
- ret _ OrderedCollection new.
- baseNames _ baseNames collect: [:bb | bb withoutTrailingDigits].
suggestedOrder do: [:e |
(baseNames includes: e) ifTrue: [
baseNames remove: e.
ret add: e.
].
].
baseNames ifNotEmpty: [
baseNames asArray do: [:e |
+ last := ret reverse detect: [:b |
- last _ ret reverse detect: [:b |
b beginsWith: helpCategory]
ifNone: [ret ifEmpty: [nil] ifNotEmpty: [ret last]].
last ifNil: [ret add: e]
ifNotNil: [ret add: e after: last].
].
].
^ ret asArray.
!
Item was changed:
----- Method: QuickGuideMorph class>>fileNameStems (in category 'defaults') -----
fileNameStems
"Return a collection of the first part of all quickguide files on the disk. trailing parts are removed (.sexp.data.gz .xxx.pr)."
| dir prs |
+ dir := FileDirectory on: QuickGuideMorph guidePath.
+ FileNameStems := ((dir fileNames select: [:f | f endsWith: '.sexp.data.gz']) collect:
- dir _ FileDirectory on: QuickGuideMorph guidePath.
- FileNameStems _ ((dir fileNames select: [:f | f endsWith: '.sexp.data.gz']) collect:
[:f | f copyFrom: 1 to: f size - '.sexp.data.gz' size]) asSet.
prs := ((dir fileNames select: [:f | f endsWith: '.pr']) collect:
[:f | f copyFrom: 1 to: f size - '.pr' size]).
prs := prs collect: [:nn | (nn atWrap: nn size-3) = $.
ifTrue: [nn allButLast: 4]
ifFalse: [nn]].
^ FileNameStems addAll: prs
!
Item was changed:
----- Method: QuickGuideMorph class>>getWordyName:forCategory: (in category 'initialization') -----
getWordyName: guideName forCategory: guideCategory
"With guideName and category already filled in, make a name in words. Remove the cat name, and trailing digits. Separate words at capital letters. NavBarHowToUse3 -> 'How To Use' "
| gn mm tt |
+ gn := guideName allButFirst: guideCategory size.
+ gn := gn withoutTrailingDigits.
+ mm := gn size.
- gn _ guideName allButFirst: guideCategory size.
- gn _ gn withoutTrailingDigits.
- mm _ gn size.
gn reversed doWithIndex: [:cc :ind |
ind < mm ifTrue: [
cc isUppercase ifTrue: [
+ tt := mm + 1 - ind.
+ gn := (gn copyFrom: 1 to: tt-1), ' ', (gn copyFrom: tt to: gn size)].
- tt _ mm + 1 - ind.
- gn _ (gn copyFrom: 1 to: tt-1), ' ', (gn copyFrom: tt to: gn size)].
cc == $- ifTrue: [
+ tt := mm + 1 - ind.
- tt _ mm + 1 - ind.
gn at: tt put: $ ]. "convert dash to space"
]].
^ gn!
Item was changed:
----- Method: QuickGuideMorph class>>indexPageMimeString: (in category 'initialization') -----
indexPageMimeString: aString
+ IndexPageMimeString := aString.
- IndexPageMimeString _ aString.
!
Item was changed:
----- Method: QuickGuideMorph class>>purgeIndexProjects (in category 'initialization') -----
purgeIndexProjects
"remove all projects that came from loading the index guide."
| px nn |
+ [px := Project allProjects detect: [:pp | pp name beginsWith: 'index'] ifNone: [nil].
- [px _ Project allProjects detect: [:pp | pp name beginsWith: 'index'] ifNone: [nil].
px ifNotNil: [
+ nn := Project allProjects indexOf: px.
- nn _ Project allProjects indexOf: px.
Project allProjects removeAt: nn].
px == nil] whileFalse.
Smalltalk garbageCollect.
!
Item was changed:
----- Method: QuickGuideMorph>>allTextIn: (in category 'write web pages') -----
allTextIn: aPage
"Return a string of all the text in all the textMorphs on this page. separated by period space space."
| tt |
^ String streamContents: [:strm |
aPage allMorphsDo: [:mm |
(mm isKindOf: TextMorph) ifTrue: [
+ tt := mm contents string withBlanksTrimmed.
- tt _ mm contents string withBlanksTrimmed.
strm nextPutAll: tt.
(tt size > 0 and: [tt last ~= $.]) ifTrue: [strm nextPut: $.].
strm space; space]]].!
Item was changed:
----- Method: QuickGuideMorph>>checkForIndexOnDisk (in category 'transition') -----
checkForIndexOnDisk
"For localization. Look on disk every time for a new Index. Overwrite IndexPage if found."
| dir holder |
+ dir := FileDirectory on: QuickGuideMorph guidePath.
- dir _ FileDirectory on: QuickGuideMorph guidePath.
(dir fileExists: 'index.pr') ifFalse: [
(dir fileExists: 'index.sexp.data.gz') ifFalse: [^ false]].
+ holder := pages first.
- holder _ pages first.
holder guideName: 'index'.
holder guideCategory: ''.
holder load. "allow index.sexp.data.gz"
+ IndexPage := holder submorphs first.
- IndexPage _ holder submorphs first.
^ true
+ " IndexPage := QuickGuideHolderMorph new loadPR: 'index.pr' dir: dir. "
- " IndexPage _ QuickGuideHolderMorph new loadPR: 'index.pr' dir: dir. "
!
Item was changed:
----- Method: QuickGuideMorph>>goToCardNamed: (in category 'menu actions') -----
goToCardNamed: cardName
| page inner |
+ page := pages detect: [:p | p guideName = cardName] ifNone: [nil].
- page _ pages detect: [:p | p guideName = cardName] ifNone: [nil].
page ifNotNil: [self goToPage: (self pageNumberOf: page).
(inner := currentPage findA: BookMorph) ifNotNil: [
inner currentPage player ifNotNil: [
inner currentPage player runAllOpeningScripts]]].
!
Item was changed:
----- Method: QuickGuideMorph>>guideToWebWithJPEGs: (in category 'write web pages') -----
guideToWebWithJPEGs: withPics
"Write all the info in this guide to a web page. Pages are images (jPEGs). Create a page to hold them."
| dir qgh bk strm ff allText thisText |
+ dir := FileDirectory default directoryNamed: 'QG-web'.
- dir _ FileDirectory default directoryNamed: 'QG-web'.
"picutres of guide pages"
+ qgh := self submorphOfClass: QuickGuideHolderMorph.
+ (bk := qgh submorphOfClass: BookMorph) ifNil: [^ self].
+ strm := WriteStream on: (String new: 500).
- qgh _ self submorphOfClass: QuickGuideHolderMorph.
- (bk _ qgh submorphOfClass: BookMorph) ifNil: [^ self].
- strm _ WriteStream on: (String new: 500).
strm nextPutAll: (self htmlPreamble: qgh guideNameInWords). "includes index side bar"
+ allText := ''.
- allText _ ''.
1 to: bk pages size do: [:ii |
withPics ifTrue: [ "Make images of pages"
bk goToPage: ii. "show it"
self jPegOutDir: dir].
+ thisText := self allTextIn: (bk pages at: ii).
- thisText _ self allTextIn: (bk pages at: ii).
strm nextPutAll: ' <tr><td> <img alt="'.
strm nextPutAll: qgh guideName, ', page ', ii printString,'. ', thisText, '" src="./'.
strm nextPutAll: qgh guideName , '-', ii printString,'.jpg"> </tr></tc>
'.
+ allText := allText, thisText].
- allText _ allText, thisText].
strm nextPutAll: ' </table>
</td></tc>
</table>
<p><a href="#thetop">Jump to Top</a></p>
<p>Squeak Etoys is a "media authoring tool"-- software that you can download to your computer <br>
and then use to create your own media. You can write out your project and share it with others. <br>
Etoys runs on any Mac or Windows machine, as well as on the OLPC XO machine. <br>
It is free.
<a href="http://www.squeakland.org/whatis/whatismain.html">Find out about Etoys.</a></p>
<p><br><br>Text of this guide (for searching): ', allText, '</p>
</body>
</html> '.
+ ff := dir fileNamed: qgh guideName, '.html'.
- ff _ dir fileNamed: qgh guideName, '.html'.
ff nextPutAll: strm contents; close.!
Item was changed:
----- Method: QuickGuideMorph>>guidesIndexForWiki (in category 'write web pages') -----
guidesIndexForWiki
"Create the html for a long list of guide categories and guides. Each is a clickable link. For the laptop.org wiki. An index to the web pages for the Guides.
Inspect a Guide and go up the owner chain to a QuickGuideMorph. self guidesIndexForWiki "
| strm |
+ strm := WriteStream on: (String new: 6000).
- strm _ WriteStream on: (String new: 6000).
strm nextPutAll: 'At the top left of the screen in Etoys is a "?" button. Clicking it brings up a help flap with more than 50 QuickGuides. These tell how to use different parts of Etoys.
[[Image:Help-icon.jpeg]]
The QuickGuides are also available on the web. Note that the active buttons and Etoys controls will not work in the web version.
__NOTOC__'; cr.
strm nextPutAll: '=== Guides about topics in EToys ==='; cr; cr.
self class categoryNamesDo: [:catName |
strm nextPutAll: '==== '; nextPutAll: catName translated; nextPutAll: ' ===='; cr.
pages do: [:pp |
pp guideCategory = catName ifTrue: [
strm nextPutAll: '* [http://tinlizzie.org/olpc/QG-web/', pp guideName, '.html'.
strm space; nextPutAll: pp guideNameInWords translated; nextPutAll: ']'; cr.
]].
].
^ strm contents
" "!
Item was changed:
----- Method: QuickGuideMorph>>htmlForJumpTo (in category 'write web pages') -----
htmlForJumpTo
"Create the html for a long list of guide categories and guides. Each is a clickable link. Store in the class var HTMLJumpTo. For creating web pages from the Guides."
| strm ap |
1 to: pages size do: [:ii | self goToPage: ii]. "create all pages"
+ strm := WriteStream on: (String new: 500).
- strm _ WriteStream on: (String new: 500).
strm nextPutAll: '<b>Guides about topics in EToys</b><br>
<i>Help screens for the OLPC<br> XO machine.</i><br>'.
Categories do: [:pair |
strm nextPutAll: pair second translated; nextPutAll: '<br>'; cr.
(PagesForCategory at: pair first) do: [:gPair |
ap := pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = gPair first]] ifNone: [nil].
(ap submorphOfClass: BookMorph) ifNotNil: ["exists"
strm tab; tab.
strm nextPutAll: ' <a href="./', gPair first, '.html">'.
strm nextPutAll: gPair second; nextPutAll: '</a><br>'; cr]]].
+ ^ HTMLJumpTo := strm contents!
- ^ HTMLJumpTo _ strm contents!
Item was changed:
----- Method: QuickGuideMorph>>htmlPreamble: (in category 'write web pages') -----
htmlPreamble: theGuideName
"All the stuff at the beginning of an html file. Includes the JumpTo menu of links to other Guides."
| strm |
+ strm := WriteStream on: (String new: 500).
- strm _ WriteStream on: (String new: 500).
strm nextPutAll: '<!!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>'.
strm nextPutAll: theGuideName.
strm nextPutAll: ', an Etoys Quick Guide</title>
</head>
<body bgcolor="#cef2ff" text="#000000">
<A NAME="thetop">
<h1 align="center">'.
strm nextPutAll: theGuideName.
strm nextPutAll: '</h1>'.
strm nextPutAll: '<h3 align="center">A Quick Guide for Etoys on the OLPC XO</h3>
<table border="0" cellspacing="0" cellpadding="6">
<tc valign ="top"><td valign ="top">
<br>'.
strm nextPutAll: HTMLJumpTo. "Jump to menu"
strm nextPutAll: '
</td></tc>
<tc> <td>
<table border="0" cellspacing="0" cellpadding="12">
'.
^ strm contents!
Item was changed:
----- Method: QuickGuideMorph>>initialize (in category 'initialization') -----
initialize
| newPage |
self beSticky.
+ newPagePrototype := QuickGuideHolderMorph new.
- newPagePrototype _ QuickGuideHolderMorph new.
newPagePrototype guideName: 'empty'.
newPagePrototype setProperty: #transitionSpec toValue: (Array with: 'silence' with: #none with: #none).
super initialize.
+ order := OrderedCollection with: 'index'.
- order _ OrderedCollection with: 'index'.
+ newPage := newPagePrototype veryDeepCopy.
- newPage _ newPagePrototype veryDeepCopy.
newPage guideName: 'index'.
self insertPage: newPage pageSize: 100 at 100 atIndex: 1.
self goToPage: 2.
self deletePageBasic.
self pageControlsAtTop: false.
self jumpToAdjust: self pageControls.!
Item was changed:
----- Method: QuickGuideMorph>>initializeIndexPage (in category 'initialization') -----
initializeIndexPage
| indexPage firstPage |
"debugging only -- look on disk"
self checkForIndexOnDisk ifTrue: [
self goToPage: 1.
^ self]. "Done. sets IndexPage every time if found"
IndexPage ifNotNil: [
+ indexPage := IndexPage veryDeepCopy.
+ firstPage := pages first.
- indexPage _ IndexPage veryDeepCopy.
- firstPage _ pages first.
indexPage position: firstPage position.
indexPage beSticky.
firstPage extent: indexPage extent.
firstPage submorphs size > 0 ifTrue: [firstPage submorphs last delete].
firstPage submorphs size > 0 ifTrue: [firstPage submorphs last delete].
firstPage addMorph: indexPage.
self goToPage: 1.
].
!
Item was changed:
----- Method: QuickGuideMorph>>jPegOutDir: (in category 'write web pages') -----
jPegOutDir: fileDir
"Write the current page of the current Guide as an image file on the directory"
"Does it need to be showing?"
| fName gn num qgh bk |
+ qgh := self submorphOfClass: QuickGuideHolderMorph.
+ bk := qgh submorphOfClass: BookMorph.
+ num := (bk pages indexOf: bk currentPage ifAbsent: [0]) printString.
+ gn := qgh guideName.
+ fName := fileDir pathName, fileDir pathNameDelimiter asString, gn, '-', num, '.jpg'.
- qgh _ self submorphOfClass: QuickGuideHolderMorph.
- bk _ qgh submorphOfClass: BookMorph.
- num _ (bk pages indexOf: bk currentPage ifAbsent: [0]) printString.
- gn _ qgh guideName.
- fName _ fileDir pathName, fileDir pathNameDelimiter asString, gn, '-', num, '.jpg'.
currentPage imageForm writeJPEGfileNamed: fName.
"need to go deeper??"
^ ''!
Item was changed:
----- Method: QuickGuideMorph>>jumpToAdjust: (in category 'page controls') -----
jumpToAdjust: pageControlColumn
"Change look of JumpTo: button, since specs don't have enough options."
| bar jump |
+ bar := pageControlColumn firstSubmorph firstSubmorph.
+ jump := bar submorphThat: [:mm |
- bar _ pageControlColumn firstSubmorph firstSubmorph.
- jump _ bar submorphThat: [:mm |
mm class == SimpleButtonMorph and: [mm actionSelector == #showJumpToMenu]
] ifNone: [^ nil].
jump color: (Color r: 0.839 g: 1.0 b: 0.806);
borderColor: (Color gray: 0.6);
actWhen: #buttonUp.
!
Item was changed:
----- Method: QuickGuideMorph>>loadPages (in category 'initialization') -----
loadPages
| pageCount newPages page unusedPages |
pageCount := PagesForCategory inject: 0 into: [:arg :each | arg + (each size)].
+ newPages := OrderedCollection new: pageCount.
- newPages _ OrderedCollection new: pageCount.
+ page := pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = 'index']] ifNone: [nil].
- page _ pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = 'index']] ifNone: [nil].
page ifNil: [
+ page := QuickGuideHolderMorph new.
- page _ QuickGuideHolderMorph new.
page guideName: 'index' translated.
page setProperty: #transitionSpec toValue: (Array with: 'silence' with: #none with: #none).
].
page guideNameInWords ifNil: [
page guideNameInWords: 'Index' translated].
newPages add: page.
Categories do: [:categoryRec | | catKey |
catKey := categoryRec first.
(PagesForCategory at: catKey) do: [: rec || guideName guideTitle |
guideName := rec first.
guideTitle := rec second.
+ page := pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = guideName]] ifNone: [nil].
- page _ pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = guideName]] ifNone: [nil].
page ifNil: [
+ page := QuickGuideHolderMorph new.
- page _ QuickGuideHolderMorph new.
page guideName: guideName.
page guideNameInWords: guideTitle.
page setProperty: #transitionSpec toValue: (Array with: 'silence' with: #none with: #none).
].
newPages add: page.
].
].
+ unusedPages := pages reject: [:e | (newPages includes: e)].
- unusedPages _ pages reject: [:e | (newPages includes: e)].
self newPages: (newPages, unusedPages) currentIndex: 1.!
Item was changed:
----- Method: QuickGuideMorph>>makeCategoryMenu: (in category 'menu actions') -----
makeCategoryMenu: catName
"return a menu with all guides in this category. No title"
| subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
- subMenu _ MenuMorph new defaultTarget: self.
PagesForCategory ifNil: [self class loadIndexAndPeekOnDisk].
(PagesForCategory at: catName ifAbsent: [#()])
do: [:articleRec |
subMenu add: (articleRec second)
target: self
selector: #goToCardNamed:
argument: (articleRec first)].
^ subMenu!
Item was changed:
----- Method: QuickGuideMorph>>nextPage (in category 'menu actions') -----
nextPage
| b |
+ b := currentPage findA: BookMorph.
- b _ currentPage findA: BookMorph.
b ifNotNil: [b nextPage. ^ self].
!
Item was changed:
----- Method: QuickGuideMorph>>order: (in category 'initialization') -----
order: names
| newPages page unusedPages |
+ newPages := OrderedCollection new: names size.
- newPages _ OrderedCollection new: names size.
((Array with: 'index'), names asArray) do: [:n |
+ page := pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = n]] ifNone: [nil].
- page _ pages detect: [:p | (p hasProperty: #quickGuideHolder) and: [p knownName = n]] ifNone: [nil].
page ifNil: [
+ page := QuickGuideHolderMorph new.
- page _ QuickGuideHolderMorph new.
page guideName: n.
page setProperty: #transitionSpec toValue: (Array with: 'silence' with: #none with: #none).
].
newPages add: page.
].
+ unusedPages := pages reject: [:e | (newPages includes: e)].
- unusedPages _ pages reject: [:e | (newPages includes: e)].
self newPages: (newPages, unusedPages) currentIndex: 1.
+ order := names.
- order _ names.
!
Item was changed:
----- Method: QuickGuideMorph>>pageNumberReport (in category 'page controls') -----
pageNumberReport
| b |
+ b := currentPage findA: BookMorph.
- b _ currentPage findA: BookMorph.
b ifNotNil: [^ b pageNumberReport].
^ super pageNumberReport.
!
Item was changed:
----- Method: QuickGuideMorph>>previousPage (in category 'menu actions') -----
previousPage
| b |
+ b := currentPage findA: BookMorph.
- b _ currentPage findA: BookMorph.
b ifNotNil: [b previousPage. ^ self].
!
Item was changed:
----- Method: QuickGuideMorph>>showDescriptionMenu: (in category 'menu actions') -----
showDescriptionMenu: evt
"The Jump To menu. Choose a guide to see next"
| aMenu subMenu aWorld pos |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'Quick Guides' translated.
self class categoryNamesDo: [:catName |
+ subMenu := self makeCategoryMenu: catName.
- subMenu _ self makeCategoryMenu: catName.
subMenu items ifNotEmpty: [
aMenu add: (self class categoryTitleOf: catName)
subMenu: subMenu]].
aMenu add: 'Index' translated action: #goToIndex.
+ aWorld := aMenu currentWorld.
+ pos := aWorld primaryHand position - (aMenu fullBounds extent) + (-2 at 30).
- aWorld _ aMenu currentWorld.
- pos _ aWorld primaryHand position - (aMenu fullBounds extent) + (-2 at 30).
aMenu popUpAt: pos forHand: aWorld primaryHand in: aWorld.
!
Item was changed:
----- Method: QuickGuideMorph>>showMenuCategory: (in category 'menu actions') -----
showMenuCategory: catName
"put up a menu with all guides in this category"
| subMenu |
+ subMenu := self makeCategoryMenu: catName.
- subMenu _ self makeCategoryMenu: catName.
subMenu addTitle: (self class categoryTitleOf: catName).
subMenu popUpInWorld.!
Item was changed:
----- Method: RadioButtonInput>>button: (in category 'private-initialization') -----
button: aMorph
+ button := aMorph!
- button _ aMorph!
Item was changed:
----- Method: RadioButtonInput>>inputSet:value: (in category 'private-initialization') -----
inputSet: anInputSet value: aString
+ inputSet := anInputSet.
+ value := aString.
+ state := false.!
- inputSet _ anInputSet.
- value _ aString.
- state _ false.!
Item was changed:
----- Method: RadioButtonInput>>pressed: (in category 'button state') -----
pressed: aBoolean
+ state := aBoolean.
- state _ aBoolean.
self changed: #pressed.
button ifNotNil: [button step].
^true!
Item was changed:
----- Method: RadioButtonSetInput>>defaultButton: (in category 'access') -----
defaultButton: aButton
"set which button to toggle on after a reset"
+ defaultButton := aButton!
- defaultButton _ aButton!
Item was changed:
----- Method: RadioButtonSetInput>>name: (in category 'private-initialization') -----
name: aString
+ name := aString.
+ buttons := OrderedCollection new.!
- name _ aString.
- buttons _ OrderedCollection new.!
Item was changed:
----- Method: RandomNumberTile>>parseNodeWith: (in category '*Etoys-Squeakland-accessing') -----
parseNodeWith: encoder
| phrase player costume |
+ phrase := self outermostMorphThat: [:m| m isKindOf: PhraseTileMorph].
- phrase _ self outermostMorphThat: [:m| m isKindOf: PhraseTileMorph].
phrase ifNil: [^ self basicParseNodeWith: encoder].
+ player := phrase associatedPlayer.
- player _ phrase associatedPlayer.
player ifNil: [^ self basicParseNodeWith: encoder].
+ costume := player costume.
- costume _ player costume.
costume ifNil: [^ self basicParseNodeWith: encoder].
(player isKindOf: KedamaExamplerPlayer) ifTrue: [
^ self kedamaParseNodeWith: encoder actualObject: player costume renderedMorph kedamaWorld player].
(costume renderedMorph isMemberOf: KedamaMorph) ifTrue: [
^ self kedamaParseNodeWith: encoder actualObject: self].
^ self basicParseNodeWith: encoder.
!
Item was changed:
----- Method: RandomNumberTile>>storeCodeOn:indent: (in category 'accessing') -----
storeCodeOn: aStream indent: tabCount
| phrase player costume |
+ phrase := self outermostMorphThat: [:m| m isKindOf: PhraseTileMorph].
- phrase _ self outermostMorphThat: [:m| m isKindOf: PhraseTileMorph].
phrase ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].
+ player := phrase associatedPlayer.
- player _ phrase associatedPlayer.
player ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].
+ costume := player costume.
- costume _ player costume.
costume ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].
(player isKindOf: KedamaExamplerPlayer) ifTrue: [
^ self kedamaStoreCodeOn: aStream indent: tabCount actualObject: player costume renderedMorph kedamaWorld player].
(costume renderedMorph isMemberOf: KedamaMorph) ifTrue: [
^ self kedamaStoreCodeOn: aStream indent: tabCount actualObject: self].
^ self basicStoreCodeOn: aStream indent: tabCount.!
Item was changed:
----- Method: ReadWriteStream>>fileOutVersionCheckNotification (in category '*Etoys-Squeakland-fileIn/Out') -----
fileOutVersionCheckNotification
"Put a version-check bumper onto the project stream."
self nextChunkPut: ' | cont | (Smalltalk includesKey: #MorphExtensionPlus) ifFalse: [self inform: ''This project cannot be loaded into an older system.\Please use an OLPC Etoys compatible image.'' translated withCRs.
+ cont := thisContext.
- cont _ thisContext.
[cont notNil] whileTrue: [
cont selector == #handleEvent: ifTrue: [cont return: nil].
+ cont := cont sender.
- cont _ cont sender.
]]'; cr.
self nextChunkPut: ' | cont | (Smalltalk includesKey: #CalendarMorph) ifFalse:
[(self confirm: ''This project was created from a more recent\version of Etoys, and may not load or\work properly in an older system.\Ideally use Etoys 5.0 or newer\proceed anyway?'' translated withCRs) ifFalse:
+ [cont := thisContext.
- [cont _ thisContext.
[cont notNil] whileTrue: [
cont selector == #handleEvent: ifTrue: [cont return: nil].
+ cont := cont sender.
- cont _ cont sender.
]]]'; cr.
!
Item was changed:
----- Method: RecordingControls>>addRecordLevelSliderIn: (in category 'initialization') -----
addRecordLevelSliderIn: aPoint
"Add the slider that allows the record-level to be adjusted."
| levelSlider r aLabel |
+ levelSlider := SimpleSliderMorph new
- levelSlider _ SimpleSliderMorph new
color: color darker;
extent: (aPoint x * 0.75) asInteger@(aPoint y*0.6) asInteger;
target: recorder;
actionSelector: #recordLevel:;
adjustToValue: recorder recordLevel.
levelSlider sliderBalloonHelp: 'Drag to set the record level' translated.
+ r := AlignmentMorph newRow
- r _ AlignmentMorph newRow
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #rigid;
height: aPoint y + 2.
aLabel := StringMorph contents: '0 ' font: ScriptingSystem fontForEToyButtons.
r addMorphBack: aLabel.
aLabel setBalloonText: 'minimum record-level' translated.
r addMorphBack: levelSlider.
aLabel := StringMorph contents: '10 ' font: ScriptingSystem fontForEToyButtons.
aLabel setBalloonText: 'maximum record-level' translated.
r addMorphBack: aLabel.
self addMorphBack: r.
!
Item was changed:
----- Method: RecordingControls>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver."
| r full |
super initialize.
self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ borderWidth := 2.
- borderWidth _ 2.
self listDirection: #topToBottom.
+ recorder := SoundRecorder new.
- recorder _ SoundRecorder new.
recordingSaved := false.
full := self addButtonRows.
self changeCodec: OggSpeexCodec name: 'Speex'.
"self addRecordLevelSliderIn: full." "Doesn't work in most or maybe even all platforms..."
+ r := AlignmentMorph newRow vResizing: #shrinkWrap.
- r _ AlignmentMorph newRow vResizing: #shrinkWrap.
r addMorphBack: (self makeRecordMeterIn: full).
self addMorphBack: r.
self extent: 10 at 10. "make minimum size"
self setButtonEnablement
!
Item was changed:
----- Method: RecordingControls>>makeRecordMeterIn: (in category 'initialization') -----
makeRecordMeterIn: aPoint
"Create the morph that will serve as the receiver's record meter, using the given point for its extent."
| outerBox h |
h := (aPoint y * 0.6) asInteger.
+ outerBox := Morph new extent: (aPoint x) asInteger at h; color: Color gray.
+ recordMeter := Morph new extent: 1 at h; color: Color yellow.
- outerBox _ Morph new extent: (aPoint x) asInteger at h; color: Color gray.
- recordMeter _ Morph new extent: 1 at h; color: Color yellow.
recordMeter position: outerBox topLeft + (1 at 1).
outerBox addMorph: recordMeter.
^ outerBox
!
Item was changed:
----- Method: RecordingControls>>makeSoundMorph (in category 'private') -----
makeSoundMorph
"Hand the user an anonymous-sound object representing the receiver's sound."
| m aName |
recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
recorder pause.
recordingSaved := true.
+ m := AnonymousSoundMorph new.
- m _ AnonymousSoundMorph new.
m sound: recorder recordedSound interimName: (aName := 'Unnamed Sound').
m setNameTo: aName.
ActiveHand attachMorph: m!
Item was changed:
----- Method: RecordingControls>>makeStatusLight (in category 'initialization') -----
makeStatusLight
"Make the recordingStatusLight, plce it in the #recordingStatusLight instance variable, and answer it. It is the responsibility of the sender to add it to the tool's structure."
+ recordingStatusLight := EllipseMorph new extent: 24 at 24.
- recordingStatusLight _ EllipseMorph new extent: 24 at 24.
recordingStatusLight borderWidth: 1; borderColor: Color gray lighter.
recordingStatusLight color: Color transparent.
recordingStatusLight setBalloonText: 'When red, it means you are currently recording' translated.
^ recordingStatusLight
!
Item was changed:
----- Method: RecordingControls>>saveButtonHit (in category 'button commands') -----
saveButtonHit
"The user hit the 'save' button."
| sndName tile |
recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
recorder pause.
+ sndName := FillInTheBlank
- sndName _ FillInTheBlank
request: 'Sound name?' translated
initialAnswer: 'unnamed' translated .
sndName isEmpty ifTrue: [^ self].
sndName = 'unnamed' translated
ifTrue:
[^ self saveAnonymousSound].
+ sndName := SampledSound unusedSoundNameLike: sndName.
- sndName _ SampledSound unusedSoundNameLike: sndName.
recorder codecSignature
ifNil: [SampledSound
addLibrarySoundNamed: sndName
samples: recorder condensedSamples
samplingRate: recorder samplingRate]
ifNotNil: [SampledSound
addLibrarySoundNamed: sndName
bytes: recorder condensedChannels
codecSignature: recorder codecSignature].
recordingSaved := true.
+ tile := SoundTile new literal: sndName.
- tile _ SoundTile new literal: sndName.
tile bounds: tile fullBounds.
tile openInHand!
Item was changed:
----- Method: RecordingControls>>showEditor (in category 'menu commands') -----
showEditor
"Show my samples in a WaveEditor."
| ed w |
recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
recorder pause.
+ ed := WaveEditor new.
- ed _ WaveEditor new.
ed data: recorder condensedSamples.
ed samplingRate: recorder samplingRate.
+ w := self world.
- w _ self world.
w activeHand
ifNil: [w addMorph: ed]
ifNotNil: [w activeHand attachMorph: ed].
!
Item was changed:
----- Method: RecordingControls>>updateReferencesUsing: (in category 'copying') -----
updateReferencesUsing: aDictionary
"Copy my recorder."
super updateReferencesUsing: aDictionary.
+ recorder := SoundRecorder new.
- recorder _ SoundRecorder new.
!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>cleanUpChanges (in category 'utilities') -----
cleanUpChanges
"Clean up the change sets"
"ReleaseBuilder new cleanUpChanges"
| projectChangeSetNames |
"Delete all changesets except those currently used by existing projects."
+ projectChangeSetNames := Project allSubInstances collect: [:proj | proj changeSet name].
- projectChangeSetNames _ Project allSubInstances collect: [:proj | proj changeSet name].
ChangeSorter removeChangeSetsNamedSuchThat:
[:cs | (projectChangeSetNames includes: cs) not].
!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>fixObsoleteReferences (in category 'utilities') -----
fixObsoleteReferences
"ReleaseBuilder new fixObsoleteReferences"
| informee obsoleteBindings obsName realName realClass |
Preference allInstances do: [:each |
+ informee := each instVarNamed: #changeInformee.
- informee _ each instVarNamed: #changeInformee.
((informee isKindOf: Behavior)
and: [informee isObsolete])
ifTrue: [
Transcript show: each name; cr.
each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
CompiledMethod allInstances do: [:method |
+ obsoleteBindings := method literals select: [:literal |
- obsoleteBindings _ method literals select: [:literal |
literal isVariableBinding
and: [literal value isBehavior]
and: [literal value isObsolete]].
obsoleteBindings do: [:binding |
+ obsName := binding value name.
- obsName _ binding value name.
Transcript show: obsName; cr.
+ realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
+ realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
- realName _ obsName copyReplaceAll: 'AnObsolete' with: ''.
- realClass _ Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
binding isSpecialWriteBinding
ifTrue: [binding privateSetKey: binding key value: realClass]
ifFalse: [binding key: binding key value: realClass]]].
Behavior flushObsoleteSubclasses.
Smalltalk garbageCollect; garbageCollect.
SystemNavigation default obsoleteBehaviors size > 0
ifTrue: [SystemNavigation default inspect]!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>initialCleanup (in category 'utilities') -----
initialCleanup
"ReleaseBuilder new initialCleanup"
Browser initialize.
ChangeSorter removeChangeSetsNamedSuchThat:
[:cs| cs name ~= ChangeSet current name].
"Perform various image cleanups in preparation for making a Squeak gamma release candidate image."
Undeclared removeUnreferencedKeys.
StandardScriptingSystem initialize.
Object reInitializeDependentsFields.
"(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents']."
"Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared']."
Browser initialize.
ObjectScanner new. "clear ObjectScanner's class pool"
self cleanUpChanges.
ChangeSet current clear.
ChangeSet current name: 'Unnamed1'.
Smalltalk garbageCollect.
"Reinitialize DataStream; it may hold on to some zapped entitities"
DataStream initialize.
Smalltalk garbageCollect.
+ ScheduledControllers := nil.
- ScheduledControllers _ nil.
Smalltalk garbageCollect.
SMSqueakMap default purge.!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>makeSqueaklandReleasePhaseFinalSettings (in category 'squeakland') -----
makeSqueaklandReleasePhaseFinalSettings
"ReleaseBuilder new makeSqueaklandReleasePhaseFinalSettings"
| serverName serverURL serverDir updateServer highestUpdate newVersion |
"ProjectLauncher splashMorph: (FileDirectory default readOnlyFileNamed: 'scripts\SqueaklandSplash.morph') fileInObjectAndCode."
"Dump all morphs so we don't hold onto anything"
"World submorphsDo:[:m| m delete]."
#(
(honorDesktopCmdKeys false)
(warnIfNoChangesFile false)
(warnIfNoSourcesFile false)
(showDirectionForSketches true)
(menuColorFromWorld false)
(unlimitedPaintArea true)
(useGlobalFlaps false)
(mvcProjectsAllowed false)
(projectViewsInWindows false)
(automaticKeyGeneration true)
(securityChecksEnabled true)
(showSecurityStatus false)
(startInUntrustedDirectory true)
(warnAboutInsecureContent false)
(promptForUpdateServer false)
(fastDragWindowForMorphic false)
(externalServerDefsOnly true)
(expandedFormat false)
(allowCelesteTell false)
(eToyFriendly true)
(eToyLoginEnabled true)
(magicHalos true)
(mouseOverHalos true)
(biggerHandles false)
(selectiveHalos true)
(includeSoundControlInNavigator true)
(readDocumentAtStartup true)
(preserveTrash true)
(slideDismissalsToTrash true)
) do:[:spec|
Preferences setPreference: spec first toValue: spec last].
"Workaround for bug"
Preferences enable: #readDocumentAtStartup.
World color: (Color r: 0.9 g: 0.9 b: 1.0).
"Clear all server entries"
ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each].
SystemVersion current resetHighestUpdate.
"Add the squeakalpha update stream"
+ serverName := 'Squeakalpha'.
+ serverURL := 'squeakalpha.org'.
+ serverDir := serverURL , '/'.
- serverName _ 'Squeakalpha'.
- serverURL _ 'squeakalpha.org'.
- serverDir _ serverURL , '/'.
+ updateServer := ServerDirectory new.
- updateServer _ ServerDirectory new.
updateServer
server: serverURL;
directory: 'updates/';
altUrl: serverDir;
user: 'sqland';
password: nil.
Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.
"Add the squeakland update stream"
+ serverName := 'Squeakland'.
+ serverURL := 'squeakland.org'.
+ serverDir := serverURL , '/'.
- serverName _ 'Squeakland'.
- serverURL _ 'squeakland.org'.
- serverDir _ serverURL , '/'.
+ updateServer := ServerDirectory new.
- updateServer _ ServerDirectory new.
updateServer
server: serverURL;
directory: 'public_html/updates/';
altUrl: serverDir.
Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.
+ highestUpdate := SystemVersion current highestUpdate.
- highestUpdate _ SystemVersion current highestUpdate.
(self confirm: 'Reset highest update (' , highestUpdate printString , ')?')
ifTrue: [SystemVersion current highestUpdate: 0].
+ newVersion := FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString.
- newVersion _ FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString.
SystemVersion newVersion: newVersion.
(self confirm: SystemVersion current asString, '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>makeSqueaklandReleasePhasePrepare (in category 'squeakland') -----
makeSqueaklandReleasePhasePrepare
"ReleaseBuilder new makeSqueaklandReleasePhasePrepare"
Undeclared removeUnreferencedKeys.
StandardScriptingSystem initialize.
Preferences initialize.
"(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents']."
"Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared']."
"Dump all projects"
Project allSubInstancesDo:[:prj| prj == Project current ifFalse:[Project deletingProject: prj]].
"Set new look so we don't need older fonts later"
"StandardScriptingSystem applyNewEToyLook."
Browser initialize.
ScriptingSystem deletePrivateGraphics.
ChangeSorter removeChangeSetsNamedSuchThat:
[:cs| cs name ~= ChangeSet current name].
ChangeSet current clear.
ChangeSet current name: 'Unnamed1'.
Smalltalk garbageCollect.
"Reinitialize DataStream; it may hold on to some zapped entitities"
DataStream initialize.
"Remove existing player references"
References keys do:[:k| References removeKey: k].
Smalltalk garbageCollect.
+ ScheduledControllers := nil.
- ScheduledControllers _ nil.
Smalltalk garbageCollect.
!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>setupServerDirectoryForSqueakland (in category 'squeakland') -----
setupServerDirectoryForSqueakland
| d |
"
ReleaseBuilderSqueakland new setupServerDirectoryForSqueakland
"
Utilities authorName: nil.
+ d := (Smalltalk classNamed: 'DAVMultiUserServerDirectory') on: 'http://content.squeakland.org/showcase/'.
- d _ DAVMultiUserServerDirectory on: 'http://content.squeakland.org/showcase/'.
d altUrl: 'http://content.squeakland.org/showcase/'.
d moniker: 'My Squeakland'.
d acceptsUploads: true.
d useDefaultAccount: true.
d origDirectory: '/showcase'.
d setupSelector: #setupPersonalDirectory:.
ServerDirectory inImageServers at: 'My Squeakland' put: d.
+ d := (Smalltalk classNamed: 'DAVMultiUserServerDirectory') on: 'http://content.squeakland.org/showcase/'.
- d _ DAVMultiUserServerDirectory on: 'http://content.squeakland.org/showcase/'.
d altUrl: 'http://content.squeakland.org/showcase/'.
d moniker: 'Squeakland Showcase'.
d user: 'etoys'.
d useDefaultAccount: true.
d acceptsUploads: false.
d instVarNamed: 'passwordHolder' put: 'kaeuqs'.
ServerDirectory inImageServers at: 'Squeakland Showcase' put: d.
EtoysUtilities loggedIn: false.
!
Item was changed:
----- Method: ReleaseBuilderSqueakland>>setupUpdateStreamForSqueakland (in category 'squeakland') -----
setupUpdateStreamForSqueakland
| base url d |
base := 'etoys.squeak.org/'.
url := 'http://', base, 'updates'.
+ d := (Smalltalk classNamed: 'DAVMultiUserServerDirectory') on: url.
- d := DAVMultiUserServerDirectory on: url.
d altUrl: url.
d moniker: 'Etoys Updates'.
d groupName: 'etoys'.
Utilities classPool at: #UpdateUrlLists put: nil.
ServerDirectory inImageServers keysDo: [:k | ServerDirectory inImageServers removeKey: k].
ServerDirectory inImageServers at: d moniker put: d.
Utilities updateUrlLists add: {d moniker. {base}}.
"SystemVersion newVersion: 'etoys4.1'."
"SystemVersion current resetHighestUpdate."
!
Item was changed:
----- Method: ReturnNode>>emitForReturn:on: (in category '*Etoys-Squeakland-code generation') -----
emitForReturn: stack on: strm
expr emitForReturn: stack on: strm.
+ pc := strm position!
- pc _ strm position!
Item was changed:
----- Method: ReturnNode>>emitForValue:on: (in category '*Etoys-Squeakland-code generation') -----
emitForValue: stack on: strm
expr emitForReturn: stack on: strm.
+ pc := strm position!
- pc _ strm position!
Item was changed:
----- Method: ReturnNode>>replaceNode:with: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
replaceNode: childNode with: newNode
+ childNode = expr ifTrue: [expr := newNode].
- childNode = expr ifTrue: [expr _ newNode].
!
Item was changed:
----- Method: RulerMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| s |
super drawOn: aCanvas.
+ s := self width printString, 'x', self height printString.
- s _ self width printString, 'x', self height printString.
aCanvas drawString: s in: (bounds insetBy: borderWidth + 5) font: nil color: Color red.
!
Item was changed:
----- Method: SameGame>>board (in category 'access') -----
board
board ifNil:
+ [board := SameGameBoard new
- [board _ SameGameBoard new
target: self;
actionSelector: #selection].
^ board!
Item was changed:
----- Method: SameGame>>board: (in category 'access') -----
board: aSameGameBoard
+ board := aSameGameBoard!
- board _ aSameGameBoard!
Item was changed:
----- Method: SameGame>>buildButton:target:label:selector: (in category 'initialization') -----
buildButton: aButton target: aTarget label: aLabel selector: aSelector
"wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"
| a |
aButton
target: aTarget;
label: aLabel;
actionSelector: aSelector;
borderColor: #raised;
borderWidth: 2;
color: color.
+ a := AlignmentMorph newColumn
- a _ AlignmentMorph newColumn
wrapCentering: #center; cellPositioning: #topCenter;
hResizing: #spaceFill;
vResizing: #shrinkWrap;
color: color.
a addMorph: aButton.
^ a
!
Item was changed:
----- Method: SameGame>>helpText (in category 'access') -----
helpText
helpText ifNil:
+ [helpText := PluggableTextMorph new
- [helpText _ PluggableTextMorph new
width: board width;
editString: self helpString].
^ helpText!
Item was changed:
----- Method: SameGame>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
wrapCentering: #center;
cellPositioning: #topCenter;
vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
layoutInset: 3;
addMorph: self makeControls;
addMorph: self board.
+ helpText := nil.
- helpText _ nil.
self newGame!
Item was changed:
----- Method: SameGame>>makeControls (in category 'initialization') -----
makeControls
| row |
+ row := AlignmentMorph newRow
- row _ AlignmentMorph newRow
color: color;
borderWidth: 0;
layoutInset: 3.
row hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; extent: 5 at 5.
row addMorph:
(self
buildButton: SimpleSwitchMorph new
target: self
label: 'Help' translated
selector: #help:).
row addMorph:
(self
buildButton: SimpleButtonMorph new
target: self
label: 'Quit' translated
selector: #delete).
row addMorph:
(self
buildButton: SimpleButtonMorph new
target: self board
label: 'Hint' translated
selector: #hint).
row addMorph:
(self
buildButton: SimpleButtonMorph new
target: self
label: 'New game' translated
selector: #newGame).
+ selectionDisplay := LedMorph new
- selectionDisplay _ LedMorph new
digits: 2;
extent: (2*10 at 15).
row addMorph: (self wrapPanel: selectionDisplay label: 'Selection:' translated).
+ scoreDisplay := LedMorph new
- scoreDisplay _ LedMorph new
digits: 4;
extent: (4*10 at 15).
row addMorph: (self wrapPanel: scoreDisplay label: 'Score:' translated).
^ row!
Item was changed:
----- Method: SameGame>>wrapPanel:label: (in category 'initialization') -----
wrapPanel: anLedPanel label: aLabel
"wrap an LED panel in an alignmentMorph with a label to its left"
| a |
+ a := AlignmentMorph newRow
- a _ AlignmentMorph newRow
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 0;
layoutInset: 3;
color: color lighter.
a addMorph: anLedPanel.
a addMorph: (StringMorph contents: aLabel).
^ a
!
Item was changed:
----- Method: SameGameBoard>>actionSelector: (in category 'accessing') -----
actionSelector: aSymbolOrString
(nil = aSymbolOrString or:
['nil' = aSymbolOrString or:
[aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
- ifTrue: [^ actionSelector _ nil].
+ actionSelector := aSymbolOrString asSymbol.
- actionSelector _ aSymbolOrString asSymbol.
!
Item was changed:
----- Method: SameGameBoard>>adjustTiles (in category 'private') -----
adjustTiles
"add or remove new protoTile submorphs to fill out my new bounds"
| newSubmorphs requiredSubmorphs count r c |
+ columns := self width // protoTile width.
+ rows := self height // protoTile height.
+ requiredSubmorphs := rows * columns.
+ newSubmorphs := OrderedCollection new.
+ r := 0.
+ c := 0.
- columns _ self width // protoTile width.
- rows _ self height // protoTile height.
- requiredSubmorphs _ rows * columns.
- newSubmorphs _ OrderedCollection new.
- r _ 0.
- c _ 0.
self submorphCount > requiredSubmorphs
ifTrue: "resized smaller -- delete rows or columns"
+ [count := 0.
- [count _ 0.
submorphs do:
[:m |
count < requiredSubmorphs
ifTrue:
[m position: self position + (protoTile extent * (c @ r)).
m arguments: (Array with: c @ r).
newSubmorphs add: m]
ifFalse: [m privateOwner: nil].
+ count := count + 1.
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]]]
- count _ count + 1.
- c _ c + 1.
- c >= columns ifTrue: [c _ 0. r _ r + 1]]]
ifFalse: "resized larger -- add rows or columns"
[submorphs do:
[:m |
m position: self position + (self protoTile extent * (c @ r)).
m arguments: (Array with: c @ r).
newSubmorphs add: m.
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]].
- c _ c + 1.
- c >= columns ifTrue: [c _ 0. r _ r + 1]].
1 to: (requiredSubmorphs - self submorphCount) do:
[:m |
newSubmorphs add:
(protoTile copy
position: self position + (self protoTile extent * (c @ r));
actionSelector: #tileClickedAt:newSelection:;
arguments: (Array with: c @ r);
target: self;
privateOwner: self).
+ c := c + 1.
+ c >= columns ifTrue: [c := 0. r := r + 1]]].
+ submorphs := newSubmorphs asArray.
- c _ c + 1.
- c >= columns ifTrue: [c _ 0. r _ r + 1]]].
- submorphs _ newSubmorphs asArray.
!
Item was changed:
----- Method: SameGameBoard>>collapseColumn:fromRow: (in category 'actions') -----
collapseColumn: col fromRow: row
| targetTile sourceTile |
+ (targetTile := self tileAt: col at row) disabled ifTrue:
- (targetTile _ self tileAt: col at row) disabled ifTrue:
[row - 1 to: 0 by: -1 do:
[:r |
+ (sourceTile := self tileAt: col at r) disabled ifFalse:
- (sourceTile _ self tileAt: col at r) disabled ifFalse:
[targetTile color: sourceTile color.
targetTile disabled: false.
sourceTile disabled: true.
^ true]]].
^ false
!
Item was changed:
----- Method: SameGameBoard>>collapseColumns: (in category 'actions') -----
collapseColumns: columnsToCollapse
| columnsToRemove |
+ columnsToRemove := OrderedCollection new.
- columnsToRemove _ OrderedCollection new.
columnsToCollapse do:
[:c |
rows - 1 to: 0 by: -1 do: [:r | self collapseColumn: c fromRow: r].
(self tileAt: c@(rows-1)) disabled ifTrue: [columnsToRemove add: c]].
self world displayWorld.
columnsToRemove reverseDo: [:c | self removeColumn: c].
!
Item was changed:
----- Method: SameGameBoard>>deselectSelection (in category 'actions') -----
deselectSelection
selection ifNotNil:
[selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
+ selection := nil.
+ flash := false]!
- selection _ nil.
- flash _ false]!
Item was changed:
----- Method: SameGameBoard>>findSelection (in category 'actions') -----
findSelection
"find a possible selection and return it, or nil if no selection"
| tile k testTile |
0 to: rows-1 do:
[:r |
0 to: columns-1 do:
[:c |
+ tile := self tileAt: c at r.
- tile _ self tileAt: c at r.
tile disabled ifFalse:
+ [k := tile color.
- [k _ tile color.
c+1 < columns ifTrue:
+ [testTile := self tileAt: (c+1)@r.
- [testTile _ self tileAt: (c+1)@r.
(testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]].
r+1 < rows ifTrue:
+ [testTile := self tileAt: c@(r+1).
- [testTile _ self tileAt: c@(r+1).
(testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]]]]].
^ nil
!
Item was changed:
----- Method: SameGameBoard>>hint (in category 'actions') -----
hint
"find a possible selection and select it"
| tile |
self deselectSelection.
+ tile := self findSelection.
- tile _ self findSelection.
tile ifNotNil: [tile mouseDown: MouseButtonEvent new]!
Item was changed:
----- Method: SameGameBoard>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ target := nil.
+ actionSelector := #selection.
+ arguments := #().
- target _ nil.
- actionSelector _ #selection.
- arguments _ #().
self layoutPolicy: nil.
self hResizing: #rigid.
self vResizing: #rigid.
+ rows := self preferredRows.
+ columns := self preferredColumns.
- rows _ self preferredRows.
- columns _ self preferredColumns.
+ palette := (Color wheel: self preferredTileTypes + 1) asOrderedCollection.
+ flashColor := palette removeLast.
+ flash := false.
- palette _ (Color wheel: self preferredTileTypes + 1) asOrderedCollection.
- flashColor _ palette removeLast.
- flash _ false.
self extent: self protoTile extent * (columns @ rows).
self resetBoard!
Item was changed:
----- Method: SameGameBoard>>protoTile (in category 'accessing') -----
protoTile
+ protoTile ifNil: [protoTile := SameGameTile new].
- protoTile ifNil: [protoTile _ SameGameTile new].
^ protoTile!
Item was changed:
----- Method: SameGameBoard>>protoTile: (in category 'accessing') -----
protoTile: aTile
+ protoTile := aTile!
- protoTile _ aTile!
Item was changed:
----- Method: SameGameBoard>>removeColumn: (in category 'actions') -----
removeColumn: column
| sourceTile |
column+1 to: columns-1 do:
[:c |
0 to: rows-1 do:
[:r |
+ sourceTile := self tileAt: c at r.
- sourceTile _ self tileAt: c at r.
(self tileAt: c-1 at r)
color: sourceTile color;
disabled: sourceTile disabled]].
0 to: rows-1 do:
[:r | (self tileAt: columns-1 at r) disabled: true]!
Item was changed:
----- Method: SameGameBoard>>resetBoard (in category 'initialization') -----
resetBoard
Collection initialize. "randomize"
+ selection := nil.
- selection _ nil.
self purgeAllCommands.
self submorphsDo:
[:m |
m disabled: false.
m setSwitchState: false.
m color: palette atRandom].
!
Item was changed:
----- Method: SameGameBoard>>selectTilesAdjacentTo: (in category 'actions') -----
selectTilesAdjacentTo: location
| al at |
{-1 at 0. 0@ -1. 1 at 0. 0 at 1} do:
[:offsetPoint |
+ al := location + offsetPoint.
- al _ location + offsetPoint.
((al x between: 0 and: columns - 1) and: [al y between: 0 and: rows - 1]) ifTrue:
+ [at := self tileAt: al.
- [at _ self tileAt: al.
(at color = selectionColor and: [at switchState not and: [at disabled not]]) ifTrue:
[selection add: al.
at setSwitchState: true.
self selectTilesAdjacentTo: al]]]
!
Item was changed:
----- Method: SameGameBoard>>step (in category 'stepping and presenter') -----
step
| newColor |
selection ifNotNil:
+ [newColor := flash
- [newColor _ flash
ifTrue: [selectionColor]
ifFalse: [flashColor].
selection do: [:loc | (self tileAt: loc) color: newColor].
+ flash := flash not]
- flash _ flash not]
!
Item was changed:
----- Method: SameGameBoard>>target: (in category 'accessing') -----
target: anObject
+ target := anObject!
- target _ anObject!
Item was changed:
----- Method: SameGameBoard>>undoFromCapturedState: (in category 'undo') -----
undoFromCapturedState: st
self copyFrom: st first.
st second do: [:assn | (submorphs at: assn key) copyFrom: assn value].
selection ifNotNil:
[selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
+ selection := nil].
- selection _ nil].
owner scoreDisplay flash: st third. "score display"
owner scoreDisplay value: st fourth.
self changed.!
Item was changed:
----- Method: SameGameTile>>color: (in category 'accessing') -----
color: aColor
super color: aColor.
+ onColor := aColor.
+ offColor := aColor.
- onColor _ aColor.
- offColor _ aColor.
self changed!
Item was changed:
----- Method: SameGameTile>>disabled: (in category 'accessing') -----
disabled: aBoolean
+ disabled := aBoolean.
- disabled _ aBoolean.
disabled
ifTrue:
[self color: owner color.
self borderColor: owner color]
ifFalse:
[self setSwitchState: self switchState]!
Item was changed:
----- Method: SameGameTile>>initialize (in category 'initialization') -----
initialize
super initialize.
self label: ''.
self borderWidth: 2.
+ bounds := 0 at 0 corner: 16 at 16.
+ offColor := Color gray.
+ onColor := Color gray.
+ switchState := false.
+ oldSwitchState := false.
+ disabled := false.
- bounds _ 0 at 0 corner: 16 at 16.
- offColor _ Color gray.
- onColor _ Color gray.
- switchState _ false.
- oldSwitchState _ false.
- disabled _ false.
self useSquareCorners
!
Item was changed:
----- Method: SameGameTile>>mouseDown: (in category 'event handling') -----
mouseDown: evt
disabled ifFalse:
+ [oldSwitchState := switchState.
- [oldSwitchState _ switchState.
self setSwitchState: (oldSwitchState = false).
self doButtonAction].
!
Item was changed:
----- Method: SameGameTile>>setSwitchState: (in category 'accessing') -----
setSwitchState: aBoolean
+ switchState := aBoolean.
- switchState _ aBoolean.
disabled ifFalse:
[switchState
ifTrue:
[self borderColor: #inset.
self color: onColor]
ifFalse:
[self borderColor: #raised.
self color: offColor]]!
Item was changed:
----- Method: Scanner>>initScanner (in category '*Etoys-Squeakland-initialize-release') -----
initScanner
+ buffer := WriteStream on: (String new: 40).
+ typeTable := TypeTable!
- buffer _ WriteStream on: (String new: 40).
- typeTable _ TypeTable!
Item was changed:
----- Method: Scanner>>nextLiteral (in category '*Etoys-Squeakland-expression types') -----
nextLiteral
"Same as advance, but -4 comes back as a number instead of two tokens"
| prevToken |
+ prevToken := self advance.
- prevToken _ self advance.
(prevToken == #- and: [token isKindOf: Number])
ifTrue:
[^self advance negated].
^prevToken!
Item was changed:
----- Method: ScorePlayerMorph class>>playMidiStream: (in category '*Etoys-Squeakland-class initialization') -----
playMidiStream: aStream
"Read a MIDI file stream. Does nothing if called with nil name."
| f score |
Smalltalk at: #MIDIFileReader ifPresent: [:midiReader |
+ f := aStream binary.
+ score := (midiReader new readMIDIFrom: f) asScore.
- f _ aStream binary.
- score _ (midiReader new readMIDIFrom: f) asScore.
f close.
self openOn: score title: aStream name]
!
Item was changed:
----- Method: ScriptActivationButton>>establishLabelWording (in category 'label') -----
establishLabelWording
"Set the label wording, unless it has already been manually edited"
| itsName |
+ itsName := target externalName.
- itsName _ target externalName.
(self hasProperty: #labelManuallyEdited)
ifFalse:
[self label: (itsName, ' ', arguments first) font: Preferences standardEToysButtonFont].
self setBalloonText:
('click to run the script "{1}" in player named "{2}"' translated format: {arguments first. itsName}).
!
Item was changed:
----- Method: ScriptActivationButton>>setLabel (in category 'miscellaneous') -----
setLabel
"Allow the user to enter a new label for this button"
| newLabel existing |
+ existing := self label.
+ newLabel := FillInTheBlank
- existing _ self label.
- newLabel _ FillInTheBlank
request: 'Please enter a new label for this button' translated
initialAnswer: existing.
(newLabel isEmptyOrNil not and: [newLabel ~= existing]) ifTrue:
[self setProperty: #labelManuallyEdited toValue: true.
self label: newLabel font: Preferences standardEToysButtonFont].
!
Item was changed:
----- Method: ScriptCompiler>>evaluate:in:to:notifying:ifFail:logged: (in category 'as yet unclassified') -----
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
"Compiles the sourceStream into a parse tree, then generates code into a
method. This method is then installed in the receiver's class so that it
can be invoked. In other words, if receiver is not nil, then the text can
refer to instance variables of that receiver (the Inspector uses this). If
aContext is not nil, the text can refer to temporaries in that context (the
Debugger uses this). If aRequestor is not nil, then it will receive a
notify:at: message before the attempt to evaluate is aborted. Finally, the
compiled method is invoked from here as DoIt or (in the case of
evaluation in aContext) DoItIn:. The method is subsequently removed
from the class, but this will not get done if the invocation causes an
error which is terminated. Such garbage can be removed by executing:
Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector:
#DoItIn:]."
| class methodNode method value selector toLog itsSelectionString itsSelection |
class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
methodNode := self parser new
parse: textOrStream readStream
class: class
noPattern: true
context: aContext
notifying: aRequestor
ifFail: [^ failBlock value] for: receiver.
+ method := methodNode generate: (CompiledMethodTrailer empty sourceCode: (methodNode sourceText); yourself).
- method _ methodNode generate: (CompiledMethodTrailer empty sourceCode: (methodNode sourceText); yourself).
self interactive ifTrue:
+ [method := method copyWithTempNames: methodNode tempNames].
- [method _ method copyWithTempNames: methodNode tempNames].
+ selector := aContext isNil
- selector _ aContext isNil
ifTrue: [#DoIt]
ifFalse: [#DoItIn:].
class addSelectorSilently: selector withMethod: method.
+ value := aContext isNil
- value _ aContext isNil
ifTrue: [receiver DoIt]
ifFalse: [receiver DoItIn: aContext].
InMidstOfFileinNotification signal
ifFalse: [class basicRemoveSelector: selector].
logFlag ifTrue:
+ [toLog := ((aRequestor respondsTo: #selection) and:
- [toLog _ ((aRequestor respondsTo: #selection) and:
[(itsSelection := aRequestor selection) notNil] and:
+ [(itsSelectionString := itsSelection asString) isEmptyOrNil not] )
- [(itsSelectionString _ itsSelection asString) isEmptyOrNil not] )
ifTrue:
[itsSelectionString]
ifFalse:
[textOrStream readStream contents].
SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext].
^ value!
Item was changed:
----- Method: ScriptEditorMorph class>>clearEvaluator (in category '*Etoys-Squeakland-Tweak-Kedama') -----
clearEvaluator
"
ScriptEditorMorph clearEvaluator.
"
+ Evaluator := nil.
- Evaluator _ nil.
!
Item was changed:
----- Method: ScriptEditorMorph class>>generateParseNodeDirectly: (in category '*Etoys-Squeakland-accessing') -----
generateParseNodeDirectly: aBoolean
"Set the value for the class variable GenerateParseNodeDirectly, which governs an option of how to compile tile scripts."
+ GenerateParseNodeDirectly := aBoolean.
- GenerateParseNodeDirectly _ aBoolean.
"
ScriptEditorMorph generateParseNodeDirectly: true
ScriptEditorMorph generateParseNodeDirectly: false
"
!
Item was changed:
----- Method: ScriptEditorMorph class>>setDefaultEvaluator (in category '*Etoys-Squeakland-Tweak-Kedama') -----
setDefaultEvaluator
+ Evaluator := KedamaAttributeEvaluator new.
- Evaluator _ KedamaAttributeEvaluator new.
Evaluator defineSyntaxFrom: KedamaAttributeEvaluator squeakParseNodes.
Evaluator readDefinitionsFrom: KedamaTurtleMethodAttributionDefinition2.
Evaluator compileEvaluator.
!
Item was changed:
----- Method: ScriptEditorMorph class>>setRewriteFlag: (in category '*Etoys-Squeakland-Tweak-Kedama') -----
setRewriteFlag: aBoolean
+ Rewrite := aBoolean.
- Rewrite _ aBoolean.
!
Item was changed:
----- Method: ScriptEditorMorph class>>trackedEditor: (in category '*Etoys-Squeakland-tracking') -----
trackedEditor: anObject
+ TrackedEditor := anObject.
- TrackedEditor _ anObject.
!
Item was changed:
----- Method: ScriptEditorMorph>>acceptDroppingMorph:event: (in category 'dropping/grabbing') -----
acceptDroppingMorph: aMorph event: evt
"Allow the user to add tiles and program fragments just by dropping them on this morph."
| i slideMorph p1 p2 |
self prepareToUndoDropOf: aMorph.
"Find where it will go, and prepare to animate the move..."
+ i := self rowInsertionIndexFor: aMorph fullBounds center.
+ slideMorph := aMorph imageForm offset: 0 at 0.
+ p1 := aMorph screenRectangle topLeft.
- i _ self rowInsertionIndexFor: aMorph fullBounds center.
- slideMorph _ aMorph imageForm offset: 0 at 0.
- p1 _ aMorph screenRectangle topLeft.
aMorph delete.
self stopTracking.
self world displayWorld. "Clear old image prior to animation"
(aMorph isKindOf: PhraseTileMorph orOf: CompoundTileMorph) ifTrue:
[aMorph aboutToBeAcceptedInScriptor].
aMorph tileRows do: [:tileList |
self insertTileRow: (Array with:
(tileList first rowOfRightTypeFor: owner forActor: aMorph associatedPlayer))
after: i.
+ i := i + 1].
- i _ i + 1].
self removeSpaces.
self enforceTileColorPolicy.
self layoutChanged.
self fullBounds. "force layout"
"Now animate the move, before next Morphic update.
NOTE: This probably should use ZoomMorph instead"
+ p2 := (self submorphs atPin: (i-1 max: firstTileRow)) screenRectangle topLeft.
- p2 _ (self submorphs atPin: (i-1 max: firstTileRow)) screenRectangle topLeft.
slideMorph slideFrom: p1 to: p2 nSteps: 5 delay: 50 andStay: true.
self playSoundNamed: 'scritch'.
self topEditor scriptEdited "Keep me for editing, a copy goes into lastAcceptedScript"!
Item was changed:
----- Method: ScriptEditorMorph>>actuallyDestroyScript (in category 'customevents-buttons') -----
actuallyDestroyScript
"Carry out the actual destruction of the associated script."
| aHandler itsCostume |
self delete.
playerScripted removeScriptNamed: scriptName.
playerScripted actorState instantiatedUserScriptsDictionary removeKey: scriptName ifAbsent: [].
"not quite enough yet in the multiple-instance case..."
+ itsCostume := playerScripted costume.
+ (aHandler := itsCostume renderedMorph eventHandler) ifNotNil:
- itsCostume _ playerScripted costume.
- (aHandler _ itsCostume renderedMorph eventHandler) ifNotNil:
[aHandler forgetDispatchesTo: scriptName].
itsCostume removeActionsSatisfying: [ :act | act receiver == playerScripted and: [ act selector == scriptName ]].
itsCostume currentWorld removeActionsSatisfying: [ :act | act receiver == playerScripted and: [ act selector == scriptName ]].
playerScripted updateAllViewersAndForceToShow: ScriptingSystem nameForScriptsCategory!
Item was changed:
----- Method: ScriptEditorMorph>>addGoldBoxItemsTo: (in category '*Etoys-Squeakland-other') -----
addGoldBoxItemsTo: aMenu
"Add gold-box-related submenu to the scriptor menu"
| subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
- subMenu _ MenuMorph new defaultTarget: self.
subMenu addTitle: 'gold box' translated.
subMenu addTranslatedList: #(
('hand me a test-yest-no tile' addYesNoToHand)
('hand me a "repeat..times" tile' handUserTimesRepeatTile)
('hand me a "random number" tile' handUserRandomTile)
('hand me a "function" tile' handUserFunctionTile)
('hand me a "button up?" tile' handUserButtonUpTile)
('hand me a "button down?" tile' handUserButtonDownTile)
('hand me a tile for self ' handUserTileForSelf)
('hand me a numeric-constant tile' handUserNumericConstantTile)
) translatedNoop.
aMenu add: 'gold box items' translated subMenu: subMenu!
Item was changed:
----- Method: ScriptEditorMorph>>buttonRowForEditor (in category 'buttons') -----
buttonRowForEditor
"Answer a row of buttons that comprise the header at the top of the Scriptor"
| aRow aString aStatusMorph aButton aTile aMorph goldBoxButton aBox |
+ aRow := AlignmentMorph newRow color: ScriptingSystem baseColor; layoutInset: 1.
- aRow _ AlignmentMorph newRow color: ScriptingSystem baseColor; layoutInset: 1.
aRow hResizing: #spaceFill.
aRow vResizing: #shrinkWrap.
self addDismissButtonTo: aRow.
aRow addTransparentSpacerOfSize: 9.
"Player's name"
+ aString := playerScripted externalName.
+ aMorph := StringMorph contents: aString font: ScriptingSystem fontForTiles.
- aString _ playerScripted externalName.
- aMorph _ StringMorph contents: aString font: ScriptingSystem fontForTiles.
aMorph setNameTo: 'title'.
aRow addMorphBack: aMorph.
aRow addTransparentSpacerOfSize: 6.
"Script's name"
aBox := AlignmentMorph newRow.
aBox hResizing: #shrinkWrap; vResizing: #shrinkWrap.
aBox color: (Color r: 0.839 g: 1.0 b: 0.806).
aBox borderWidth: 1.
aBox borderColor: (Color r: 0.645 g: 0.774 b: 0.613).
+ aButton := UpdatingStringMorph new.
- aButton _ UpdatingStringMorph new.
aButton useStringFormat;
target: self;
getSelector: #scriptTitle;
setNameTo: 'script name';
font: ScriptingSystem fontForNameEditingInScriptor;
putSelector: #setScriptNameTo:;
setProperty: #okToTextEdit toValue: true;
step;
yourself.
aBox addMorph: aButton.
aRow addMorphBack: aBox.
aBox setBalloonText: 'Click here to edit the name of the script.' translated.
"aRow addTransparentSpacerOfSize: 9."
aRow addVariableTransparentSpacer.
"Try It button"
self hasParameter ifFalse:
[aRow addMorphBack:
((ThreePhaseButtonMorph
labelSymbol: #TryIt
target: self
actionSelector: #tryMe
arguments: #())
actWhen: #whilePressed;
balloonTextSelector: #tryMe).
aRow addTransparentSpacerOfSize: 3].
"Step button"
self hasParameter ifFalse:
[aRow addMorphBack: (aButton := ThreePhaseButtonMorph
labelSymbol: #StepMe
target: self
actionSelector: #stepMe
arguments: #()).
aButton balloonTextSelector: #stepMe.
aRow addTransparentSpacerOfSize: 3].
"Status controller"
self hasParameter
ifTrue:
+ [aTile := TypeListTile new choices: Vocabulary typeChoicesForUserVariables dataType: nil.
- [aTile _ TypeListTile new choices: Vocabulary typeChoicesForUserVariables dataType: nil.
aTile addArrows.
aTile setLiteral: self typeForParameter.
aRow addMorphBack: aTile.
aTile borderColor: Color red.
aTile color: ScriptingSystem uniformTileInteriorColor.
aTile setBalloonText: 'Drag from here to get a parameter tile' translated.
aTile addCaretsAsAppropriate: true]
ifFalse:
+ [aRow addMorphBack: (aStatusMorph := self scriptInstantiation statusControlMorph)].
- [aRow addMorphBack: (aStatusMorph _ self scriptInstantiation statusControlMorph)].
"aRow addTransparentSpacerOfSize: 3."
aRow addVariableTransparentSpacer.
"Gold-box"
+ aRow addMorphBack: (goldBoxButton := IconicButton new).
- aRow addMorphBack: (goldBoxButton _ IconicButton new).
goldBoxButton borderWidth: 0;
labelGraphic: (ScriptingSystem formAtKey: 'RoundGoldBox'); color: Color transparent;
actWhen: #buttonDown;
target: self;
actionSelector: #offerGoldBoxMenu;
shedSelvedge;
setBalloonText: 'click here to get a palette of useful tiles to use in your script.' translated.
aRow addTransparentSpacerOfSize: 6 at 1.
"Menu Button"
+ aButton := self menuButton.
- aButton _ self menuButton.
aButton actionSelector: #offerScriptorMenu.
aRow addMorphBack: aButton.
(playerScripted existingScriptInstantiationForSelector: scriptName)
ifNotNilDo:
[:inst | inst updateStatusMorph: aStatusMorph].
^ aRow!
Item was changed:
----- Method: ScriptEditorMorph>>dismiss (in category 'buttons') -----
dismiss
"Dismiss the scriptor, usually nondestructively. Possibly animate the dismissal."
| endPoint aForm startPoint topRend |
owner ifNil: [^ self].
scriptName ifNil: [^ self delete]. "ad hoc fixup for bkwrd compat"
endPoint := self viewerTile ifNotNilDo: [:tile | tile topLeft] ifNil: [owner topRight].
aForm := (topRend := self topRendererOrSelf) imageForm offset: (0 at 0).
+ handWithTile := nil.
- handWithTile _ nil.
startPoint := topRend topLeft.
topRend topRendererOrSelf delete.
(playerScripted isExpendableScript: scriptName) ifTrue: [^ playerScripted removeScript: scriptName fromWorld: ActiveWorld].
ActiveWorld displayWorld.
aForm slideFrom: startPoint to: endPoint nSteps: 4 delay: 30.
"The OLPC Virtual Screen wouldn't notice the last update here."
Display forceToScreen: (endPoint extent: aForm extent).
!
Item was changed:
----- Method: ScriptEditorMorph>>goldBoxMenu (in category '*Etoys-Squeakland-gold box') -----
goldBoxMenu
"Answer a graphical menu to be put up in conjunction with the Gold Box"
| aBox |
+ aBox := ActiveWorld findA: GoldBoxMenu.
+ aBox ifNil: [aBox := GoldBoxMenu new].
- aBox _ ActiveWorld findA: GoldBoxMenu.
- aBox ifNil: [aBox _ GoldBoxMenu new].
aBox initializeFor: self.
^ aBox!
Item was changed:
----- Method: ScriptEditorMorph>>handUserFunctionTile (in category '*Etoys-Squeakland-other') -----
handUserFunctionTile
"Hand the user a function tile, presumably to drop in the script"
| functionPhrase argTile aPad |
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
argTile := (Vocabulary vocabularyNamed: 'Number') defaultArgumentTile.
aPad := TilePadMorph new setType: #Number.
aPad addMorphBack: argTile.
functionPhrase operator: #abs pad: aPad.
functionPhrase openInHand!
Item was changed:
----- Method: ScriptEditorMorph>>handUserRandomTile (in category 'other') -----
handUserRandomTile
"Hand the user a random-number tile, presumably to drop in the script"
| functionPhrase argTile aPad |
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
argTile := (Vocabulary vocabularyNamed: 'Number') defaultArgumentTile.
aPad := TilePadMorph new setType: #Number.
aPad addMorphBack: argTile.
functionPhrase operator: #random pad: aPad.
functionPhrase openInHand!
Item was changed:
----- Method: ScriptEditorMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self listDirection: #topToBottom;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
cellPositioning: #topLeft;
setProperty: #autoFitContents toValue: true;
layoutInset: 2.
self useRoundedCornersInEtoys.
self borderColor: ScriptingSystem borderColor.
self setNameTo: 'Script Editor' translated.
+ firstTileRow := 1.
- firstTileRow _ 1.
"index of first tile-carrying submorph"
self addNewRow.
+ showingMethodPane := false.
- showingMethodPane _ false.
!
Item was changed:
----- Method: ScriptEditorMorph>>insertTileRow:after: (in category 'private') -----
insertTileRow: tileList after: index
"Return a row to be used to insert an entire row of tiles."
| row |
+ row := AlignmentMorph newRow
- row _ AlignmentMorph newRow
vResizing: #spaceFill;
layoutInset: 0;
extent: (bounds width)@(TileMorph defaultH);
color: Color transparent.
row position: self position.
row addAllMorphs: tileList.
tileList do: [:t | t justAddedAsTileRow].
self privateAddMorph: row atIndex: index + 1.
!
Item was changed:
----- Method: ScriptEditorMorph>>methodNode (in category '*Etoys-Squeakland-customevents-buttons') -----
methodNode
"Answer the source-code string for the receiver. This is for use by classic tiles, but is also used in universal tiles to formulate an initial method declaration for a nascent user-defined script; in universalTiles mode, the codeString (at present anyway) is empty -- the actual code derives from the SyntaxMorph in that case"
| evaluator rewriter node |
(submorphs size = 2 and: [(submorphs second isMemberOf: MethodMorph)]) ifTrue: [
^ playerScripted class compilerClass new
compile: submorphs second model contents
in: playerScripted class
notifying: nil
ifFail: [] for: playerScripted.
].
+ node := self scriptParseNodeIn: self referenceWorld.
- node _ self scriptParseNodeIn: self referenceWorld.
self hasKedamaTurtlePlayer ifFalse: [^ node].
Evaluator ifNil: [
self class setDefaultEvaluator.
].
+ evaluator := Evaluator.
- evaluator _ Evaluator.
evaluator makeAttributedTreeWith: node forReceiver: playerScripted.
evaluator addGraphEdgesRoot.
evaluator evaluateAllOccurence.
Rewrite ifTrue: [
+ rewriter := KedamaVectorParseTreeRewriter new.
- rewriter _ KedamaVectorParseTreeRewriter new.
rewriter attributedTree: evaluator attributedTree.
rewriter parseTree: evaluator attributedTree tree.
rewriter setEncoderFor: playerScripted in: self referenceWorld.
rewriter visit: evaluator attributedTree tree andParent: nil.
^ playerScripted class compilerClass new compile: rewriter parseTree decompileString in: playerScripted class notifying: nil ifFail: [^nil] for: playerScripted.
] ifFalse: [
evaluator attributedTree inspect.
^ evaluator parseTree
].
!
Item was changed:
----- Method: ScriptEditorMorph>>methodString (in category 'other') -----
methodString
"Answer the source-code string for the receiver. This is for use by classic tiles, but is also used in universal tiles to formulate an initial method declaration for a nascent user-defined script; in universalTiles mode, the codeString (at present anyway) is empty -- the actual code derives from the SyntaxMorph in that case"
| string evaluator rewriter |
(submorphs size = 2 and: [(submorphs second isMemberOf: MethodMorph)]) ifTrue: [
^ submorphs second model contents
].
+ string := String streamContents:
- string _ String streamContents:
[:aStream |
aStream nextPutAll: scriptName.
scriptName endsWithAColon ifTrue:
[aStream nextPutAll: ' parameter'].
aStream cr; cr; tab.
aStream nextPutAll: self codeString.
].
self hasKedamaTurtlePlayer ifFalse: [^ string].
Evaluator ifNil: [
self class setDefaultEvaluator.
].
+ evaluator := Evaluator.
- evaluator _ Evaluator.
playerScripted class compileSilently: string classified: 'temporary'.
evaluator makeAttributedTreeWith: ((playerScripted class compiledMethodAt: scriptName) decompileClass: playerScripted class selector: scriptName) forReceiver: playerScripted.
evaluator addGraphEdgesRoot.
evaluator evaluateAllOccurence.
Rewrite ifTrue: [
+ rewriter := KedamaVectorParseTreeRewriter new.
- rewriter _ KedamaVectorParseTreeRewriter new.
rewriter attributedTree: evaluator attributedTree.
rewriter parseTree: evaluator attributedTree tree.
rewriter setEncoderFor: playerScripted in: self referenceWorld.
rewriter visit: evaluator attributedTree tree andParent: nil.
^ rewriter parseTree printString.
] ifFalse: [
evaluator attributedTree inspect.
^ string
].
!
Item was changed:
----- Method: ScriptEditorMorph>>mouseEnter: (in category 'event handling') -----
mouseEnter: evt
| hand tile |
+ hand := evt hand.
- hand _ evt hand.
hand submorphs size = 1 ifFalse: [^self].
+ tile := hand firstSubmorph renderedMorph.
- tile _ hand firstSubmorph renderedMorph.
"self class = BooleanScriptEditor ifTrue: [self halt]."
(self wantsDroppedMorph: tile event: evt) ifFalse: [^self].
+ handWithTile := hand.
- handWithTile _ hand.
self startTracking.
!
Item was changed:
----- Method: ScriptEditorMorph>>offerScriptorMenu (in category 'other') -----
offerScriptorMenu
"Put up a menu in response to the user's clicking in the menu-request area of the scriptor's heaer"
| aMenu count |
self modernize.
ActiveHand showTemporaryCursor: nil.
Preferences eToyFriendly ifTrue: [^ self offerSimplerScriptorMenu].
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: scriptName asString.
aMenu addStayUpItem. "NB: the kids version in #offerSimplerScriptorMenu does not deploy the stay-up item"
aMenu addList: (self hasParameter
ifTrue: [{
{'remove parameter' translated. #ceaseHavingAParameter}}]
ifFalse: [{
{'add parameter' translated. #addParameter}}]).
self hasParameter ifFalse:
[aMenu addTranslatedList: {
{'button to fire this script' translatedNoop. #tearOfButtonToFireScript}.
{'fires per tick...' translatedNoop. #chooseFrequency}.
#-
}].
aMenu addUpdating: #showingCaretsString target: self action: #toggleShowingCarets.
aMenu addLine.
aMenu addList: {
{'edit balloon help for this script' translated. #editMethodDescription}.
{'explain status alternatives' translated. #explainStatusAlternatives}.
{'button to show/hide this script' translated. #buttonToOpenOrCloseThisScript}.
#-
}.
Preferences universalTiles ifFalse:
+ [count := self savedTileVersionsCount.
- [count _ self savedTileVersionsCount.
self showingMethodPane
ifFalse: "currently showing tiles"
[aMenu add: 'show code textually' translated action: #toggleWhetherShowingTiles.
count > 0 ifTrue:
[aMenu add: 'revert to tile version...' translated action: #revertScriptVersion].
aMenu add: 'save this version' translated action: #saveScriptVersion]
ifTrue: "current showing textual source"
[count >= 1 ifTrue:
[aMenu add: 'revert to tile version' translated action: #toggleWhetherShowingTiles]]].
"aMenu addLine.
self addGoldBoxItemsTo: aMenu."
aMenu addLine.
aMenu add: 'grab this object' translated target: playerScripted selector: #grabPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'This will actually pick up the object bearing this script and hand it to you. Click the (left) button to drop it' translated.
aMenu add: 'reveal this object' translated target: playerScripted selector: #revealPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'If you have misplaced the object bearing this script, use this item to (try to) make it visible' translated.
aMenu add: 'tile representing this object' translated target: playerScripted action: #tearOffTileForSelf.
aMenu balloonTextForLastItem: 'choose this to obtain a tile which represents the object associated with this script' translated.
aMenu addTranslatedList: {
#-.
{'open viewer' translatedNoop. #openObjectsViewer. 'open the viewer of the object to which this script belongs' translatedNoop}.
{'detached method pane' translatedNoop. #makeIsolatedCodePane. 'open a little window that shows the Smalltalk code underlying this script.' translatedNoop}.
#-.
{'destroy this script' translatedNoop. #destroyScript}
}.
aMenu popUpInWorld: self currentWorld.
!
Item was changed:
----- Method: ScriptEditorMorph>>offerSimplerScriptorMenu (in category '*Etoys-Squeakland-other') -----
offerSimplerScriptorMenu
"Put up a menu in response to the user's clicking in the menu-request area of the scriptor's heaer. This variant is used when eToyFriendly preference is true."
| aMenu count |
ActiveHand showTemporaryCursor: nil.
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: scriptName asString.
aMenu addList: (self hasParameter
ifTrue: [{
{'remove parameter' translated. #ceaseHavingAParameter}}]
ifFalse: [{
{'add parameter' translated. #addParameter}}]).
self hasParameter ifFalse:
[aMenu addTranslatedList: #(
('button to fire this script' tearOfButtonToFireScript)
-) translatedNoop].
aMenu addUpdating: #showingCaretsString target: self action: #toggleShowingCarets.
aMenu addLine.
aMenu addList: {
{'edit balloon help for this script' translated. #editMethodDescription}.
{'explain status alternatives' translated. #explainStatusAlternatives}.
{'button to show/hide this script' translated. #buttonToOpenOrCloseThisScript}.
#-
}.
Preferences universalTiles ifFalse:
+ [count := self savedTileVersionsCount.
- [count _ self savedTileVersionsCount.
self showingMethodPane
ifFalse: "currently showing tiles"
[aMenu add: 'show code textually' translated action: #toggleWhetherShowingTiles.
count > 0 ifTrue:
[aMenu add: 'revert to tile version...' translated action: #revertScriptVersion].
aMenu add: 'save this version' translated action: #saveScriptVersion]
ifTrue: "current showing textual source"
[count >= 1 ifTrue:
[aMenu add: 'revert to tile version' translated action: #toggleWhetherShowingTiles]]].
aMenu addLine.
aMenu add: 'grab this object' translated target: playerScripted selector: #grabPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'This will actually pick up the object bearing this script and hand it to you. Click the (left) button to drop it' translated.
aMenu add: 'reveal this object' translated target: playerScripted selector: #revealPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'If you have misplaced the object bearing this script, use this item to (try to) make it visible' translated.
aMenu add: 'tile representing this object' translated target: playerScripted action: #tearOffTileForSelf.
aMenu balloonTextForLastItem: 'choose this to obtain a tile which represents the object associated with this script' translated.
aMenu addLine.
aMenu addTranslatedList: #(
-
('open viewer' openObjectsViewer 'open the viewer of the object to which this script belongs')
-
('destroy this script' destroyScript)) translatedNoop.
aMenu popUpInWorld: self currentWorld.
!
Item was changed:
----- Method: ScriptEditorMorph>>parseNodeWith: (in category '*Etoys-Squeakland-other') -----
parseNodeWith: encoder
| statements ret |
+ statements := WriteStream on: (Array new: self tileRows size).
- statements _ WriteStream on: (Array new: self tileRows size).
self tileRows do: [:r |
r do: [:m |
((m isKindOf: TileMorph)
or: [(m isKindOf: CompoundTileMorph)
or: [m isKindOf: PhraseTileMorph]]) ifTrue: [
statements nextPut: (m parseNodeWith: encoder asStatement: true)]]].
+ statements := statements contents.
+ ret := ReturnNode new expr: (encoder encodeVariable: 'self').
- statements _ statements contents.
- ret _ ReturnNode new expr: (encoder encodeVariable: 'self').
^ BlockNode new arguments: #() statements: (statements copyWith: ret) returns: true from: encoder.
!
Item was changed:
----- Method: ScriptEditorMorph>>phrase: (in category 'initialization') -----
phrase: aPhraseTileMorph
"Make the receiver be a Scriptor for a new script whose initial contents is the given phrase."
| aHolder |
+ firstTileRow := 2.
+ aHolder := AlignmentMorph newRow.
- firstTileRow _ 2.
- aHolder _ AlignmentMorph newRow.
aHolder beTransparent; layoutInset: 0.
aHolder addMorphBack: aPhraseTileMorph.
self addMorphBack: aHolder.
self scriptEdited!
Item was changed:
----- Method: ScriptEditorMorph>>removeSpaces (in category 'dropping/grabbing') -----
removeSpaces
"Remove vertical space"
dropSpaces ifNotNil: [dropSpaces do: [:m | m delete]].
+ dropSpaces := nil.
- dropSpaces _ nil.
self removeEmptyRows.
submorphs isEmpty ifTrue: [self height: self minHeight].
!
Item was changed:
----- Method: ScriptEditorMorph>>renameScriptTo: (in category 'other') -----
renameScriptTo: newSelector
"Rename the receiver's script so that it bears a new selector"
| aMethodNodeMorph methodMorph methodSource pos newMethodSource |
+ scriptName := newSelector.
- scriptName _ newSelector.
self updateHeader.
Preferences universalTiles
ifFalse: "classic tiles"
[self showingMethodPane
ifTrue:
["textually coded -- need to change selector"
+ methodMorph := self findA: MethodMorph.
+ methodSource := methodMorph text string.
+ pos := methodSource indexOf: Character cr ifAbsent: [self error: 'no cr'].
+ newMethodSource := newSelector.
+ newSelector numArgs > 0 ifTrue: [newMethodSource := newMethodSource, ' t1']. "for the parameter"
+ newMethodSource := newMethodSource, (methodSource copyFrom: pos to: methodSource size).
- methodMorph _ self findA: MethodMorph.
- methodSource _ methodMorph text string.
- pos _ methodSource indexOf: Character cr ifAbsent: [self error: 'no cr'].
- newMethodSource _ newSelector.
- newSelector numArgs > 0 ifTrue: [newMethodSource _ newMethodSource, ' t1']. "for the parameter"
- newMethodSource _ newMethodSource, (methodSource copyFrom: pos to: methodSource size).
methodMorph editString: newMethodSource.
methodMorph model changeMethodSelectorTo: newSelector.
playerScripted class compileSilently: newMethodSource classified: 'scripts'.
methodMorph accept]
ifFalse:
[self install]]
ifTrue: "universal tiles..."
+ [(aMethodNodeMorph := self methodNodeMorph) ifNotNil:
- [(aMethodNodeMorph _ self methodNodeMorph) ifNotNil:
[aMethodNodeMorph acceptInCategory: 'scripts']]!
Item was changed:
----- Method: ScriptEditorMorph>>rowInsertionIndexFor: (in category 'private') -----
rowInsertionIndexFor: aPoint
"Return the row into which the given morph should be inserted."
| m |
firstTileRow to: submorphs size do: [:i |
+ m := submorphs at: i.
- m _ submorphs at: i.
((m top <= aPoint y) and: [m bottom >= aPoint y]) ifTrue:
[(aPoint y > m center y)
ifTrue: [^ i]
ifFalse: [^ (i - 1) max: firstTileRow]]].
^ firstTileRow > submorphs size
ifTrue:
[submorphs size]
ifFalse:
[(submorphs at: firstTileRow) top > aPoint y
ifTrue: [firstTileRow - 1 max: 1 ]
ifFalse: [submorphs size]]
!
Item was changed:
----- Method: ScriptEditorMorph>>scriptEdited (in category 'private') -----
scriptEdited
"The script was edited in some way. Recompile the script and be sure appropriate carets are showing."
| anEditor |
+ (anEditor := self topEditor) ifNotNil:
- (anEditor _ self topEditor) ifNotNil:
[anEditor recompileScript.
anEditor fixUpCarets]!
Item was changed:
----- Method: ScriptEditorMorph>>scriptParseNodeIn: (in category '*Etoys-Squeakland-other') -----
scriptParseNodeIn: aWorld
| n selOrFalse arguments block encoder |
+ encoder := ScriptEncoder new init: playerScripted class context: nil notifying: nil; referenceObject: aWorld.
+ n := MethodNode new.
+ selOrFalse := encoder encodeSelector: scriptName.
- encoder _ ScriptEncoder new init: playerScripted class context: nil notifying: nil; referenceObject: aWorld.
- n _ MethodNode new.
- selOrFalse _ encoder encodeSelector: scriptName.
playerScripted class scripts at: scriptName ifPresent: [:uniclassScript |
+ arguments := uniclassScript argumentVariables asArray collect: [:each |
- arguments _ uniclassScript argumentVariables asArray collect: [:each |
encoder bindArg: each variableName.
].
].
arguments ifNil: [
"In some sort of transition. Initial creation or name change."
scriptName numArgs = 0 ifTrue: [
+ arguments := #().
- arguments _ #().
] ifFalse: [
+ arguments := (Array with: (encoder bindArg: 'parameter')).
- arguments _ (Array with: (encoder bindArg: 'parameter')).
].
].
+ block := self parseNodeWith: encoder.
- block _ self parseNodeWith: encoder.
^ n
selector: selOrFalse
arguments: arguments
precedence: scriptName precedence
temporaries: #()
block: block
encoder: encoder
primitive: 0.
!
Item was changed:
----- Method: ScriptEditorMorph>>setupMethodMorph (in category '*Etoys-Squeakland-buttons') -----
setupMethodMorph
"create textual source instead"
| aCodePane |
+ aCodePane := MethodHolder
- aCodePane _ MethodHolder
isolatedCodePaneForClass: playerScripted class
selector: scriptName.
aCodePane
hResizing: #spaceFill;
vResizing: #spaceFill;
minHeight: 100.
self
hResizing: #shrinkWrap;
vResizing: #shrinkWrap.
self addMorphBack: aCodePane.
self fullBounds.
self
listDirection: #topToBottom;
hResizing: #rigid;
vResizing: #rigid;
rubberBandCells: true;
minWidth: self width.
+ showingMethodPane := true.
- showingMethodPane _ true.
self currentWorld startSteppingSubmorphsOf: self!
Item was changed:
----- Method: ScriptEditorMorph>>startTracking (in category '*Etoys-Squeakland-dropping/grabbing') -----
startTracking
| ed |
+ ((ed := ScriptEditorMorph trackedEditor) notNil and: [ed ~~ self]) ifTrue: [
- ((ed _ ScriptEditorMorph trackedEditor) notNil and: [ed ~~ self]) ifTrue: [
ed stopSteppingSelector: #trackDropZones.
ed removeSpaces.
].
ScriptEditorMorph trackedEditor: self.
self startSteppingSelector: #trackDropZones.!
Item was changed:
----- Method: ScriptEditorMorph>>stopTracking (in category '*Etoys-Squeakland-dropping/grabbing') -----
stopTracking
| ed |
+ (((ed := ScriptEditorMorph trackedEditor) notNil) and: [ed ~~ self]) ifTrue: [
- (((ed _ ScriptEditorMorph trackedEditor) notNil) and: [ed ~~ self]) ifTrue: [
ed stopSteppingSelector: #trackDropZones.
ed removeSpaces.
].
self stopSteppingSelector: #trackDropZones.
+ handWithTile := nil.
- handWithTile _ nil.
ScriptEditorMorph trackedEditor: nil.
!
Item was changed:
----- Method: ScriptEditorMorph>>trackDropZones (in category 'dropping/grabbing') -----
trackDropZones
"The fundamental heart of script-editor layout, by Dan Ingalls in fall 1997, though many hands have touched it since."
| hand insertion i space1 d space2 insHt nxtHt prevBot ht2 c1 c2 ii where |
+ hand := handWithTile ifNil: [self primaryHand].
- hand _ handWithTile ifNil: [self primaryHand].
previousDropHandPosition = hand position ifTrue: [^ self].
+ previousDropHandPosition := hand position.
- previousDropHandPosition _ hand position.
((self hasOwner: hand) not and: [hand submorphCount > 0])
ifTrue:
+ [insertion := hand firstSubmorph renderedMorph.
+ insHt := insertion fullBounds height.
- [insertion _ hand firstSubmorph renderedMorph.
- insHt _ insertion fullBounds height.
self removeDropSpaces.
+ where := self globalPointToLocal: hand position"insertion fullBounds topLeft".
+ i := (ii := self indexOfMorphAbove: where) min: submorphs size-1.
+ prevBot := i <= 0 ifTrue: [(self innerBounds) top]
- where _ self globalPointToLocal: hand position"insertion fullBounds topLeft".
- i _ (ii _ self indexOfMorphAbove: where) min: submorphs size-1.
- prevBot _ i <= 0 ifTrue: [(self innerBounds) top]
ifFalse: [(self submorphs at: i) bottom].
+ nxtHt := (submorphs isEmpty
- nxtHt _ (submorphs isEmpty
ifTrue: [(self owner isMemberOf: AlignmentMorph) ifTrue: [Morph new extent: 0 at 10] ifFalse: [insertion]]
ifFalse: [self submorphs at: i+1]) height max: 1.
"nxtHt printString displayAt: 0 at 0."
+ d := ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
- d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
ifFalse: [0 max: (where y - prevBot min: nxtHt)].
"Top and bottom spacer heights cause continuous motion..."
+ c1 := Color green. c2 := Color transparent.
+ ht2 := d*insHt//nxtHt.
- c1 _ Color green. c2 _ Color transparent.
- ht2 _ d*insHt//nxtHt.
"'d, insHt, nxtHt', d printString, ' ', insHt printString, ' ', nxtHt printString, ' ', ht2 printString, ' ' displayAt: 0 at 50."
dropSpaces ifNil: [
+ dropSpaces := Array new: 2.
- dropSpaces _ Array new: 2.
dropSpaces at: 1 put: Morph new.
dropSpaces at: 2 put: Morph new.
].
+ space1 := dropSpaces at: 1.
+ space2 := dropSpaces at: 2.
- space1 _ dropSpaces at: 1.
- space2 _ dropSpaces at: 2.
space1 privateBounds: (0 at 0 extent: (self width - (self borderWidth*2) - 10)@(insHt-ht2));
color: ((insHt-ht2) > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
space2 privateBounds: (0 at 0 extent: (self width - (self borderWidth*2) - 10)@ht2);
color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
self privateAddMorph: (space1 position: where) atIndex: (i+1 max: 1).
self privateAddMorph: (space2 position: where) atIndex: (i+3 min: submorphs size+1).
]
ifFalse:
[self stopTracking. self removeSpaces]!
Item was changed:
----- Method: ScriptEditorMorph>>typeInFrequency (in category 'frequency') -----
typeInFrequency
| reply aNumber |
+ reply := FillInTheBlank request: 'Number of firings per tick: ' translated initialAnswer: self scriptInstantiation frequency printString.
- reply _ FillInTheBlank request: 'Number of firings per tick: ' translated initialAnswer: self scriptInstantiation frequency printString.
reply ifNotNil:
+ [aNumber := reply asNumber.
- [aNumber _ reply asNumber.
aNumber > 0 ifTrue:
[self setFrequencyTo: aNumber]]!
Item was changed:
----- Method: ScriptEditorMorph>>userScriptObject (in category 'other') -----
userScriptObject
"Answer the user-script object associated with the receiver. This is expected to be called only for objects that actually reside within 'Scriptors', but will return nil, rather than fail, of there is no userScriptObject found."
| aPlayerScripted topEd |
+ aPlayerScripted := (topEd := self topEditor) playerScripted.
- aPlayerScripted _ (topEd _ self topEditor) playerScripted.
^ aPlayerScripted ifNotNil: [ aPlayerScripted class userScriptForPlayer: aPlayerScripted selector: topEd scriptName]!
Item was changed:
----- Method: ScriptEditorMorph>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
+ scriptName := scriptName veryDeepCopyWith: deepCopier.
+ firstTileRow := firstTileRow veryDeepCopyWith: deepCopier.
+ timeStamp := timeStamp veryDeepCopyWith: deepCopier.
+ playerScripted := playerScripted. "Weakly copied"
+ handWithTile := nil. "Just a cache"
+ showingMethodPane := showingMethodPane. "boolean"
+ threadPolygon := nil. "Just a cache".
+ previousDropHandPosition := nil.
+ dropSpaces := nil.
- scriptName _ scriptName veryDeepCopyWith: deepCopier.
- firstTileRow _ firstTileRow veryDeepCopyWith: deepCopier.
- timeStamp _ timeStamp veryDeepCopyWith: deepCopier.
- playerScripted _ playerScripted. "Weakly copied"
- handWithTile _ nil. "Just a cache"
- showingMethodPane _ showingMethodPane. "boolean"
- threadPolygon _ nil. "Just a cache".
- previousDropHandPosition _ nil.
- dropSpaces _ nil.
!
Item was changed:
----- Method: ScriptEditorMorphBuilder>>context:playerScripted: (in category 'initialization') -----
context: c playerScripted: p
+ context := c.
+ playerScripted := p.
- context _ c.
- playerScripted _ p.
!
Item was changed:
----- Method: ScriptEditorMorphBuilder>>context:playerScripted:topEditor: (in category 'initialization') -----
context: c playerScripted: p topEditor: t
+ context := c.
+ playerScripted := p.
+ topEditor := t.
- context _ c.
- playerScripted _ p.
- topEditor _ t.
!
Item was changed:
----- Method: ScriptEncoder>>encodePlayer: (in category 'as yet unclassified') -----
encodePlayer: anObject
| n |
+ n := referenceObject uniqueNameForReferenceFor: anObject.
- n _ referenceObject uniqueNameForReferenceFor: anObject.
^ self encodeVariable: n.
!
Item was changed:
----- Method: ScriptEncoder>>referenceObject: (in category 'as yet unclassified') -----
referenceObject: anObject
+ referenceObject := anObject.
- referenceObject _ anObject.
!
Item was changed:
----- Method: ScriptInstantiation>>defineNewEvent (in category 'customevents-status control') -----
defineNewEvent
| newEventName newEventHelp |
"Prompt the user for the name of a new event and install it into the custom event table"
+ newEventName := FillInTheBlankMorph request: 'What is the name of your new event?' translated.
- newEventName _ FillInTheBlankMorph request: 'What is the name of your new event?' translated.
newEventName isEmpty ifTrue: [ ^self ].
+ newEventName := newEventName asSymbol.
- newEventName _ newEventName asSymbol.
(ScriptingSystem customEventStati includes: newEventName) ifTrue: [
self inform: 'That event is already defined.' translated. ^self ].
+ newEventHelp := FillInTheBlankMorph request: 'Please describe this event:' translated.
- newEventHelp _ FillInTheBlankMorph request: 'Please describe this event:' translated.
ScriptingSystem addUserCustomEventNamed: newEventName help: newEventHelp.!
Item was changed:
----- Method: ScriptInstantiation>>offerMenuIn: (in category 'misc') -----
offerMenuIn: aStatusViewer
"Put up a menu."
| aMenu |
ActiveHand showTemporaryCursor: nil.
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu title: player knownName, ' ', selector.
aMenu addStayUpItem.
(player class instanceCount > 1) ifTrue:
[aMenu add: 'propagate status to siblings' translated selector: #assignStatusToAllSiblingsIn: argument: aStatusViewer.
aMenu balloonTextForLastItem: 'Make the status of this script in all of my sibling instances be the same as the status you see here' translated].
aMenu addLine.
aMenu add: 'grab this object' translated target: player selector: #grabPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'This will actually pick up the object bearing this script and hand it to you. Click the (left) button to drop it' translated.
aMenu add: 'reveal this object' translated target: player selector: #revealPlayerIn: argument: ActiveWorld.
aMenu balloonTextForLastItem: 'If you have misplaced the object bearing this script, use this item to (try to) make it visible' translated.
aMenu add: 'tile representing this object' translated target: player selector: #tearOffTileForSelf.
aMenu balloonTextForLastItem: 'choose this to obtain a tile which represents the object associated with this script' translated.
aMenu addLine.
aMenu add: 'open this script''s Scriptor' translated target: player selector: #grabScriptorForSelector:in: argumentList: {selector. aStatusViewer world}.
aMenu balloonTextForLastItem: 'Open up the Scriptor for this script' translated.
aMenu add: 'open this object''s Viewer' translated target: player selector: #beViewed.
aMenu balloonTextForLastItem: 'Open up a Viewer for this object' translated.
aMenu addLine.
aMenu add: 'more...' translated target: self selector: #offerShiftedMenuIn: argument: aStatusViewer.
aMenu balloonTextForLastItem: 'The "more..." branch offers you menu items that are less frequently used.' translated.
aMenu popUpInWorld: ActiveWorld!
Item was changed:
----- Method: ScriptInstantiation>>resetTo:ifCurrently: (in category '*Etoys-Squeakland-status control') -----
resetTo: newStatus ifCurrently: aStatus
"If my status *had been* aStatus, quietly reset it to newStatus, without tampering with event handlers. But get the physical display of all affected status morphs right"
status == aStatus ifTrue:
+ [status := newStatus.
- [status _ newStatus.
self updateAllStatusMorphs]!
Item was changed:
----- Method: ScriptInstantiation>>statusControlRowIn: (in category 'misc') -----
statusControlRowIn: aStatusViewer
"Answer an object that reports my status and lets the user change it"
| aRow aMorph buttonWithPlayerName |
+ aRow := ScriptStatusLine newRow beTransparent.
+ buttonWithPlayerName := UpdatingSimpleButtonMorph new.
- aRow _ ScriptStatusLine newRow beTransparent.
- buttonWithPlayerName _ UpdatingSimpleButtonMorph new.
buttonWithPlayerName font: Preferences standardEToysButtonFont.
buttonWithPlayerName
on: #mouseEnter send: #menuButtonMouseEnter: to: buttonWithPlayerName;
on: #mouseLeave send: #menuButtonMouseLeave: to: buttonWithPlayerName.
buttonWithPlayerName target: self; wordingSelector: #playersExternalName; actionSelector: #offerMenuIn:; arguments: {aStatusViewer}; beTransparent; actWhen: #buttonDown.
buttonWithPlayerName setBalloonText: 'This is the name of the player to which this script belongs; if you click here, you will get a menu of interesting options pertaining to this player and script' translated.
buttonWithPlayerName borderWidth: 1; borderColor: Color blue.
aRow addMorphBack: buttonWithPlayerName.
aRow addTransparentSpacerOfSize: 10 at 0.
aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
+ aMorph := UpdatingStringMorph on: self selector: #selector.
- aMorph _ UpdatingStringMorph on: self selector: #selector.
aMorph font: Preferences standardEToysButtonFont.
aMorph color: Color brown lighter; useStringFormat.
aMorph setBalloonText: 'This is the name of the script to which this entry pertains.' translated.
aRow addMorphBack: aMorph.
aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
aRow addTransparentSpacerOfSize: 10 at 0.
aRow addMorphBack: self statusControlMorph.
aRow submorphsDo: [:m | m wantsSteps ifTrue: [m step]].
^ aRow!
Item was changed:
----- Method: ScriptInstantiation>>typeInTickingRate (in category 'status control') -----
typeInTickingRate
| reply aNumber |
+ reply := FillInTheBlank request: 'Number of ticks per second: ' translated initialAnswer: self tickingRate printString.
- reply _ FillInTheBlank request: 'Number of ticks per second: ' translated initialAnswer: self tickingRate printString.
reply ifNotNil:
+ [aNumber := reply asNumber.
- [aNumber _ reply asNumber.
aNumber > 0 ifTrue:
[self tickingRate: aNumber]]!
Item was changed:
----- Method: ScriptInstantiation>>updateStatusMorph: (in category 'status control') -----
updateStatusMorph: statusControlMorph
"the status control may need to reflect an externally-induced change in status"
| colorSelector statusReadoutButton |
statusControlMorph ifNil: [^ self].
self pausedOrTicking
ifTrue:
[statusControlMorph assurePauseTickControlsShow]
ifFalse:
[statusControlMorph maybeRemovePauseTickControls].
+ statusReadoutButton := statusControlMorph submorphs last.
+ colorSelector := ScriptingSystem statusColorSymbolFor: self status.
- statusReadoutButton _ statusControlMorph submorphs last.
- colorSelector _ ScriptingSystem statusColorSymbolFor: self status.
statusReadoutButton color: (Color perform: colorSelector) muchLighter.
statusReadoutButton label: self translatedStatus asString font: ScriptingSystem fontForEToyButtons!
Item was changed:
----- Method: ScriptNameType>>defaultArgumentTile (in category 'tiles') -----
defaultArgumentTile
"Answer a tile to represent the type"
| aTile |
+ aTile := ScriptNameTile new dataType: self vocabularyName.
- aTile _ ScriptNameTile new dataType: self vocabularyName.
aTile addArrows.
'empty script' translatedNoop.
aTile setLiteral: #emptyScript.
^ aTile!
Item was changed:
----- Method: ScriptParser>>parse:class:noPattern:context:notifying:ifFail: (in category 'as yet unclassified') -----
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock
"Answer a MethodNode for the argument, sourceStream, that is the root of
a parse tree. Parsing is done with respect to the argument, class, to find
instance, class, and pool variables; and with respect to the argument,
ctxt, to find temporary variables. Errors in parsing are reported to the
argument, req, if not nil; otherwise aBlock is evaluated. The argument
noPattern is a Boolean that is true if the the sourceStream does not
contain a method header (i.e., for DoIts)."
"Copied from superclass, use ScriptEncoder and give it a referenceWorld. This assumes worldLoading has been set to the right world this player belongs to. --bf 5/4/2010"
| methNode repeatNeeded myStream parser s p |
(req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]])
+ ifTrue: [parser := self as: DialectParser]
+ ifFalse: [parser := self].
+ myStream := sourceStream.
+ [repeatNeeded := false.
+ p := myStream position.
+ s := myStream upToEnd.
- ifTrue: [parser _ self as: DialectParser]
- ifFalse: [parser _ self].
- myStream _ sourceStream.
- [repeatNeeded _ false.
- p _ myStream position.
- s _ myStream upToEnd.
myStream position: p.
parser init: myStream notifying: req failBlock: [^ aBlock value].
+ doitFlag := noPattern.
+ failBlock := aBlock.
+ [methNode := parser method: noPattern context: ctxt
- doitFlag _ noPattern.
- failBlock _ aBlock.
- [methNode _ parser method: noPattern context: ctxt
encoder: (ScriptEncoder new init: class context: ctxt notifying: parser;
referenceObject: ActiveWorld referenceWorld )]
on: ParserRemovedUnusedTemps
do:
+ [ :ex | repeatNeeded := (requestor isKindOf: TextMorphEditor) not.
+ myStream := ReadStream on: requestor text string.
- [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
- myStream _ ReadStream on: requestor text string.
ex resume].
repeatNeeded] whileTrue.
+ encoder := failBlock := requestor := parseNode := nil. "break cycles & mitigate refct overflow"
- encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
methNode sourceText: s.
^ methNode!
Item was changed:
----- Method: ScriptParser>>parse:class:noPattern:context:notifying:ifFail:for: (in category 'as yet unclassified') -----
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock for: anInstance
| methNode repeatNeeded myStream parser s p |
(req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]])
+ ifTrue: [parser := self as: DialectParser]
+ ifFalse: [parser := self].
+ myStream := sourceStream.
+ [repeatNeeded := false.
+ p := myStream position.
+ s := myStream upToEnd.
- ifTrue: [parser _ self as: DialectParser]
- ifFalse: [parser _ self].
- myStream _ sourceStream.
- [repeatNeeded _ false.
- p _ myStream position.
- s _ myStream upToEnd.
myStream position: p.
parser init: myStream notifying: req failBlock: [^ aBlock value].
+ doitFlag := noPattern.
+ failBlock := aBlock.
+ [methNode := parser method: noPattern context: ctxt
- doitFlag _ noPattern.
- failBlock _ aBlock.
- [methNode _ parser method: noPattern context: ctxt
encoder: (ScriptEncoder new init: class context: ctxt notifying: parser; referenceObject: (anInstance costume ifNotNil: [anInstance costume referenceWorld] ifNil: [ActiveWorld]))]
on: ParserRemovedUnusedTemps
do:
+ [ :ex | repeatNeeded := (requestor isKindOf: TextMorphEditor) not.
+ myStream := ReadStream on: requestor text string.
- [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
- myStream _ ReadStream on: requestor text string.
ex resume].
repeatNeeded] whileTrue.
+ encoder := failBlock := requestor := parseNode := nil. "break cycles & mitigate refct overflow"
- encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
methNode sourceText: s.
^ methNode!
Item was changed:
----- Method: ScriptStatusControl>>initializeFor: (in category 'initialization') -----
initializeFor: aScriptInstantiation
"Answer a control that will serve to reflect and allow the user to change the status of the receiver"
| statusReadout |
self hResizing: #shrinkWrap.
self vResizing: #shrinkWrap.
self cellInset: 0 at 0.
self layoutInset: 0.
+ scriptInstantiation := aScriptInstantiation.
+ tickPauseButtonsShowing := false.
- scriptInstantiation _ aScriptInstantiation.
- tickPauseButtonsShowing _ false.
+ self addMorphBack: (statusReadout := UpdatingSimpleButtonMorph new).
- self addMorphBack: (statusReadout _ UpdatingSimpleButtonMorph new).
statusReadout label: aScriptInstantiation status asString font: ScriptingSystem fontForEToyButtons.
statusReadout setNameTo: 'trigger'.
statusReadout height: statusReadout height - 4.
statusReadout vResizing: #rigid.
statusReadout target: aScriptInstantiation; wordingSelector: #translatedStatus; actionSelector: #presentScriptStatusPopUp.
statusReadout setBalloonText: 'when this script should run' translated.
statusReadout actWhen: #buttonDown.
self assurePauseTickControlsShow.
aScriptInstantiation updateStatusMorph: self!
Item was changed:
----- Method: ScriptableButton>>label: (in category 'accessing') -----
label: aString
"Set the receiver's label as indicated"
| aLabel |
+ (aLabel := self findA: StringMorph)
- (aLabel _ self findA: StringMorph)
ifNotNil:
[aLabel contents: aString]
ifNil:
+ [aLabel := StringMorph contents: aString font: Preferences standardEToysButtonFont.
- [aLabel _ StringMorph contents: aString font: Preferences standardEToysButtonFont.
self addMorph: aLabel].
self extent: aLabel extent + (borderWidth + 6).
aLabel position: self center - (aLabel extent // 2).
aLabel lock!
Item was changed:
----- Method: ScriptableButton>>setLabel (in category 'menu') -----
setLabel
"Invoked from a menu, let the user change the label of the button"
| newLabel |
+ newLabel := FillInTheBlank
- newLabel _ FillInTheBlank
request:
'Enter a new label for this button' translated
initialAnswer: self label.
newLabel isEmpty ifFalse: [self label: newLabel font: nil].
!
Item was changed:
----- Method: ScrollBar>>hideMenuButton (in category '*Etoys-Squeakland-access') -----
hideMenuButton
self setProperty: #withMenuButton toValue: false.
+ menuButton := nil.
- menuButton _ nil.
self removeAllMorphs; initializeSlider.
!
Item was changed:
----- Method: ScrollPane>>scrollHorizontallyToShow: (in category '*Etoys-Squeakland-access') -----
scrollHorizontallyToShow: aRectangle
"scroll horizontally to include as much of aRectangle as possible, where aRectangle is in the scroller's local space"
| range |
((aRectangle left - scroller offset x) >= 0 and:
[(aRectangle right - scroller offset x) <= (self innerBounds width) ])
ifTrue:[ "already visible" ^self ].
+ range := self hLeftoverScrollRange.
- range _ self hLeftoverScrollRange.
hScrollBar value: (range > 0
ifTrue: [((aRectangle left) / self hLeftoverScrollRange)
truncateTo: hScrollBar scrollDelta]
ifFalse: [0]).
scroller offset: (range * hScrollBar value) @ -3.
!
Item was changed:
----- Method: ScrollingToolHolder>>stamps: (in category '*Etoys-Squeakland-as yet unclassified') -----
stamps: anOrderedCollection
+ stamps := anOrderedCollection!
- stamps _ anOrderedCollection!
Item was changed:
----- Method: ScrollingToolHolder>>thumbnailPics: (in category '*Etoys-Squeakland-as yet unclassified') -----
thumbnailPics: oc
+ thumbnailPics := oc!
- thumbnailPics _ oc!
Item was changed:
----- Method: SearchingViewer>>addNamePaneTo: (in category 'initialization') -----
addNamePaneTo: header
"Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer"
| searchButton aStringMorph aBox |
+ namePane := AlignmentMorph newRow vResizing: #spaceFill; height: 14.
- namePane _ AlignmentMorph newRow vResizing: #spaceFill; height: 14.
namePane color: Color transparent.
namePane hResizing: #spaceFill.
namePane listDirection: #leftToRight.
aBox := PasteUpMorph new.
aBox beTransparent.
aBox beSticky.
aBox hResizing: #spaceFill; vResizing: #rigid; height: Preferences standardEToysFont height.
aBox borderWidth: 1; borderColor: Color gray.
aStringMorph := UpdatingStringMorph new.
aStringMorph useStringFormat.
aStringMorph target: self; getSelector: #searchString; putSelector: #searchString:notifying:.
aStringMorph hResizing: #spaceFill.
aStringMorph height: Preferences standardEToysFont height rounded; vResizing: #rigid.
aStringMorph stepTime: 5000.
aStringMorph font: Preferences standardEToysFont.
aBox addMorphBack: aStringMorph.
aBox on: #mouseDown send: #mouseDown: to: aStringMorph.
aStringMorph topLeft: (aBox topLeft + (3 at 0)).
+ searchButton := SimpleButtonMorph new
- searchButton _ SimpleButtonMorph new
target: self;
beTransparent;
actionSelector: #doSearchFrom:;
arguments: {aStringMorph}.
searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all tiles that match what you typed will appear in the list below.' translated.
namePane addMorphFront: searchButton.
namePane addTransparentSpacerOfSize: 6 at 0.
namePane addMorphBack: aBox.
header addMorphBack: namePane.
self updateSearchButtonLabel.!
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 anInterface useTranslations scriptNames addedMorphs |
searchString := aSource isString
ifTrue:
[aSource]
ifFalse:
[(aSource isKindOf: PluggableTextMorph) "old"
ifTrue:
[aSource text string]
ifFalse:
[aSource contents asString]].
+ searchFor := searchString asLowercaseAlphabetic.
- searchFor _ searchString asLowercaseAlphabetic.
+ aVocab := self outerViewer currentVocabulary.
+ (useTranslations := (scriptedPlayer isPlayerLike) and: [aVocab isEToyVocabulary])
- aVocab _ self outerViewer currentVocabulary.
- (useTranslations _ (scriptedPlayer isPlayerLike) and: [aVocab isEToyVocabulary])
ifTrue:
+ [all := scriptedPlayer costume selectorsForViewer.
+ all addAll: (scriptNames := scriptedPlayer class namedTileScriptSelectors)]
- [all _ scriptedPlayer costume selectorsForViewer.
- all addAll: (scriptNames _ scriptedPlayer class namedTileScriptSelectors)]
ifFalse:
+ [all := scriptNames := scriptedPlayer class allSelectors].
+ aList := all select:
- [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 asString asLowercaseAlphabetic includesSubstring: searchFor caseSensitive: true]])
- [(useTranslations and: [(anInterface _ aVocab methodInterfaceAt: aSelector ifAbsent: [nil]) notNil and: [anInterface wording asString asLowercaseAlphabetic includesSubstring: searchFor caseSensitive: true]])
or:
[((scriptNames includes: aSelector) or: [useTranslations not]) and:
[aSelector includesSubstring: searchFor caseSensitive: false]]]].
+ aList := aList asSortedArray.
- aList _ aList asSortedArray.
self removeAllButFirstSubmorph. "that being the header"
self addAllMorphs:
+ ((addedMorphs := scriptedPlayer tilePhrasesForSelectorList: aList inViewer: self)).
- ((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:
[searchFor ifNotEmpty:
[self inform: ('No matches found for "' translated), searchFor, '"']]]!
Item was changed:
----- Method: SelectionInput>>name:defaultValue:list:values: (in category 'private-initialization') -----
name: name0 defaultValue: defaultValue0 list: list0 values: values0
+ name := name0.
+ defaultValue := defaultValue0.
+ listMorph := list0.
+ values := values0.!
- name _ name0.
- defaultValue _ defaultValue0.
- listMorph _ list0.
- values _ values0.!
Item was changed:
----- Method: ServerDirectory class>>inImageServers (in category '*Etoys-Squeakland-available servers') -----
inImageServers
+ Servers ifNil: [Servers := Dictionary new].
- Servers ifNil: [Servers _ Dictionary new].
^Servers!
Item was changed:
----- Method: Set>>init: (in category '*Etoys-Squeakland-private') -----
init: n
"Initialize array to an array size of n"
+ array := Array new: n.
+ tally := 0!
- array _ Array new: n.
- tally _ 0!
Item was changed:
----- Method: Set>>noCheckAdd: (in category '*Etoys-Squeakland-private') -----
noCheckAdd: anObject
array at: (self findElementOrNil: anObject) put: anObject.
+ tally := tally + 1!
- tally _ tally + 1!
Item was changed:
----- Method: Set>>withArray: (in category '*Etoys-Squeakland-private') -----
withArray: anArray
"private -- for use only in copy"
+ array := anArray!
- array _ anArray!
Item was changed:
----- Method: SharedQueue>>init: (in category '*Etoys-Squeakland-private') -----
init: size
+ contentsArray := Array new: size.
+ readPosition := 1.
+ writePosition := 1.
+ accessProtect := Semaphore forMutualExclusion.
+ readSynch := Semaphore new!
- contentsArray _ Array new: size.
- readPosition _ 1.
- writePosition _ 1.
- accessProtect _ Semaphore forMutualExclusion.
- readSynch _ Semaphore new!
Item was changed:
----- Method: SimpleButtonMorph>>labelString:font: (in category '*Etoys-Squeakland-accessing') -----
labelString: aString font: aFont
| existingLabel |
+ (existingLabel := self findA: StringMorph)
- (existingLabel _ self findA: StringMorph)
ifNil:
[self label: aString font: aFont]
ifNotNil:
[existingLabel font: aFont; contents: aString.
self fitContents]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>on:list:selected:changeSelected:menu:keystroke:autoExpand: (in category '*Etoys-Squeakland-initialization') -----
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel autoExpand: aBoolean
self setProperty: #autoExpand toValue: aBoolean.
self model: anObject.
+ getListSelector := getListSel.
+ getSelectionSelector := getSelectionSel.
+ setSelectionSelector := setSelectionSel.
+ getMenuSelector := getMenuSel.
+ keystrokeActionSelector := keyActionSel.
+ autoDeselect := true.
- getListSelector _ getListSel.
- getSelectionSelector _ getSelectionSel.
- setSelectionSelector _ setSelectionSel.
- getMenuSelector _ getMenuSel.
- keystrokeActionSelector _ keyActionSel.
- autoDeselect _ true.
self borderWidth: 1.
self list: self getList.
!
Item was changed:
----- Method: SketchEditorMorph>>addHelpNextButton (in category '*Etoys-Squeakland-start & finish') -----
addHelpNextButton
"This is a TOTAL hack. When the Help Guide is showing, and the user starts painting, the next-page button in the Guide is obscured. A beginner will not know what to do to see the next page of help. He can see the next page button, but clicking paints a dot.
To cure this, we make a copy of the NextPage button and put it on top of the paint area. Clicking it turns the page in the guide.
If the user closes help while painting, we do not delete the button."
| np gg nextPageButton |
+ gg := Project current helpGuideIfOpen ifNil: [^ nil].
+ np := gg pageControls findDeepSubmorphThat: [:mm |
- gg _ Project current helpGuideIfOpen ifNil: [^ nil].
- np _ gg pageControls findDeepSubmorphThat: [:mm |
(mm respondsTo: #actionSelector)
ifTrue: [mm actionSelector == #nextPage]
ifFalse: [false] ]
ifAbsent: [^ nil].
(np bounds intersects: self bounds) ifFalse: [^ nil].
+ nextPageButton := np veryDeepCopy.
- nextPageButton _ np veryDeepCopy.
nextPageButton on: #mouseEnter send: #mouseLeave: to: self.
"Hide brush cursor"
nextPageButton on: #mouseLeave send: #mouseEnter: to: self.
"Show brush cursor"
"nextPageButton hasRolloverBorder: true. Just too much"
self addMorph: nextPageButton.!
Item was changed:
----- Method: SketchMorph>>form:rotationCenter: (in category '*Etoys-Squeakland-accessing') -----
form: aForm rotationCenter: aCenter
"Set the receiver's form, honoring a rotation center. Maintains existing cartesian location of the receiver across the changed form and rotation center."
| loc |
loc := self topRendererOrSelf assuredPlayer getLocation.
(self hasProperty: #baseGraphic) ifFalse: [self setProperty: #baseGraphic toValue: aForm].
+ originalForm := aForm.
- originalForm _ aForm.
self rotationCenter: aCenter.
self layoutChanged.
self topRendererOrSelf player setLocation: loc!
Item was changed:
----- Method: SketchMorph>>recolorPixelsOfColor: (in category '*Etoys-Squeakland-menu') -----
recolorPixelsOfColor: evt
"Let the user select a color to be remapped, and then a color to map that color to, then carry it out."
| c d newForm map newC |
self inform: 'choose the color you want to replace' translated.
self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand. "color to replace"
+ c := self rememberedColor ifNil: [Color red].
- c _ self rememberedColor ifNil: [Color red].
self inform: 'now choose the color you want to replace it with' translated.
self changeColorTarget: self selector: #rememberedColor: originalColor: c hand: evt hand. "new color"
+ newC := self rememberedColor ifNil: [Color blue].
+ d := originalForm depth.
+ newForm := Form extent: originalForm extent depth: d.
+ map := (Color cachedColormapFrom: d to: d) copy.
- newC _ self rememberedColor ifNil: [Color blue].
- d _ originalForm depth.
- newForm _ Form extent: originalForm extent depth: d.
- map _ (Color cachedColormapFrom: d to: d) copy.
map at: (c indexInMap: map) put: (newC pixelValueForDepth: d).
newForm copyBits: newForm boundingBox
from: originalForm at: 0 at 0
colorMap: map.
self form: newForm.
!
Item was changed:
----- Method: SolidSugarSuppliesTab>>mouseMove: (in category 'event handling') -----
mouseMove: evt
"Handle a mouse-move within the solid tab."
| aPosition newReferentThickness adjustedPosition thick |
+ dragged ifFalse: [(thick := self referentThickness) > 0
+ ifTrue: [lastReferentThickness := thick]].
- dragged ifFalse: [(thick _ self referentThickness) > 0
- ifTrue: [lastReferentThickness _ thick]].
+ aPosition := evt cursorPoint.
- aPosition _ evt cursorPoint.
edgeToAdhereTo == #top
ifTrue:
+ [adjustedPosition := aPosition - evt hand targetOffset.
+ newReferentThickness := adjustedPosition y - sugarNavTab height]
- [adjustedPosition _ aPosition - evt hand targetOffset.
- newReferentThickness _ adjustedPosition y - sugarNavTab height]
ifFalse:
[adjustedPosition := aPosition + evt hand targetOffset.
newReferentThickness := self world height - (adjustedPosition y + sugarNavTab height)].
self applyThickness: newReferentThickness.
+ dragged := true.
- dragged _ true.
self fitOnScreen.
self computeEdgeFraction!
Item was changed:
----- Method: SolidSugarSuppliesTab>>positionObject:atEdgeOf: (in category 'mechanics') -----
positionObject: anObject atEdgeOf: container
"Position an object -- either the receiver or its referent -- on the edge of the container."
| extra |
+ extra := (sugarNavTab notNil and: [referent isInWorld])
- extra _ (sugarNavTab notNil and: [referent isInWorld])
ifTrue:
[sugarNavTab height]
ifFalse:
[0].
edgeToAdhereTo == #top ifTrue:
[^ anObject top: container top + extra].
"bottom..."
anObject == self
ifFalse: "the parts bin"
[anObject bottom: (container bottom - extra)]
ifTrue: "the tab"
[anObject bottom: (container bottom - (self referentThickness + extra))] !
Item was changed:
----- Method: SolidSugarSuppliesTab>>sugarNavTab: (in category 'initialization') -----
sugarNavTab: anObject
"Set the receiver's sugarNavTab."
+ sugarNavTab := anObject!
- sugarNavTab _ anObject!
Item was changed:
----- Method: SoundCodec>>encodeSoundBufferNoReset: (in category '*Etoys-Squeakland-compress/decompress') -----
encodeSoundBufferNoReset: aSoundBuffer
"Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data."
| codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs |
+ frameSize := self samplesPerFrame.
+ fullFrameCount := aSoundBuffer monoSampleCount // frameSize.
+ lastFrameSamples := aSoundBuffer monoSampleCount - (fullFrameCount * frameSize).
+ codeFrameSize := self bytesPerEncodedFrame.
- frameSize _ self samplesPerFrame.
- fullFrameCount _ aSoundBuffer monoSampleCount // frameSize.
- lastFrameSamples _ aSoundBuffer monoSampleCount - (fullFrameCount * frameSize).
- codeFrameSize _ self bytesPerEncodedFrame.
codeFrameSize = 0 ifTrue:
["Allow room for 1 byte per sample for variable-length compression"
+ codeFrameSize := frameSize].
- codeFrameSize _ frameSize].
lastFrameSamples > 0
+ ifTrue: [result := ByteArray new: (fullFrameCount + 1) * codeFrameSize]
+ ifFalse: [result := ByteArray new: fullFrameCount * codeFrameSize].
- ifTrue: [result _ ByteArray new: (fullFrameCount + 1) * codeFrameSize]
- ifFalse: [result _ ByteArray new: fullFrameCount * codeFrameSize].
"self reset."
+ increments := self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1.
- increments _ self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1.
lastFrameSamples > 0 ifTrue: [
+ finalFrame := SoundBuffer newMonoSampleCount: frameSize.
+ i := fullFrameCount * frameSize.
- finalFrame _ SoundBuffer newMonoSampleCount: frameSize.
- i _ fullFrameCount * frameSize.
1 to: lastFrameSamples do: [:j |
+ finalFrame at: j put: (aSoundBuffer at: (i := i + 1))].
+ lastIncs := self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second.
+ increments := Array with: increments first + lastIncs first
- finalFrame at: j put: (aSoundBuffer at: (i _ i + 1))].
- lastIncs _ self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second.
- increments _ Array with: increments first + lastIncs first
with: increments second + lastIncs second].
increments second < result size
ifTrue: [^ result copyFrom: 1 to: increments second]
ifFalse: [^ result]
!
Item was changed:
----- Method: SoundDemoMorph>>initializeSoundColumn (in category 'initialization') -----
initializeSoundColumn
"initialize the receiver's soundColumn"
+ soundColumn := AlignmentMorph newColumn.
- soundColumn _ AlignmentMorph newColumn.
soundColumn enableDragNDrop.
self addMorphBack: soundColumn!
Item was changed:
----- Method: SoundDemoMorph>>makeControls (in category 'as yet unclassified') -----
makeControls
| bb r cc |
+ cc := Color black.
+ r := AlignmentMorph newRow.
- cc _ Color black.
- r _ AlignmentMorph newRow.
r color: cc; borderWidth: 0; layoutInset: 0.
r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 at 5.
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
r addMorphBack: (bb label: 'V1'; actionSelector: #playV1).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
r addMorphBack: (bb label: 'V2'; actionSelector: #playV2).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
r addMorphBack: (bb label: 'V3'; actionSelector: #playV3).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
r addMorphBack: (bb label: 'All'; actionSelector: #playAll).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
r addMorphBack: (bb label: 'Stop'; actionSelector: #stopSound).
^ r
!
Item was changed:
----- Method: SoundDemoMorph>>playAll (in category 'as yet unclassified') -----
playAll
| snd |
soundColumn submorphs isEmpty
ifTrue: [^ self].
self setTimbreFromTile: soundColumn submorphs first.
+ snd := SampledSound bachFugueVoice1On: SampledSound new.
- snd _ SampledSound bachFugueVoice1On: SampledSound new.
soundColumn submorphs size >= 2
ifTrue: [""self setTimbreFromTile: soundColumn submorphs second.
+ snd := snd
- snd _ snd
+ (AbstractSound bachFugueVoice2On: SampledSound new)].
soundColumn submorphs size >= 3
ifTrue: [""self setTimbreFromTile: soundColumn submorphs third.
+ snd := snd
- snd _ snd
+ (AbstractSound bachFugueVoice3On: SampledSound new)].
snd play!
Item was changed:
----- Method: SoundLibraryTool>>addSoundList (in category 'initialization') -----
addSoundList
"Add the sounds list to the tool."
+ listBox := PluggableMultiColumnListMorph
- listBox _ PluggableMultiColumnListMorph
on: self
list: #listing
selected: #soundIndex
changeSelected: #soundIndex:.
listBox hResizing: #spaceFill.
listBox hideMenuButton.
listBox height: 240.
listBox font: Preferences standardEToysFont.
self addMorphBack: listBox!
Item was changed:
----- Method: SoundLibraryTool>>handMeATile (in category 'menu') -----
handMeATile
| tile |
soundIndex = 0 ifTrue:[^nil].
+ tile := SoundTile new literal: self soundName.
- tile _ SoundTile new literal: self soundName.
tile bounds: tile fullBounds.
tile openInHand!
Item was changed:
----- Method: SoundLibraryTool>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ showCompression := false.
- showCompression _ false.
self hResizing: #shrinkWrap;
vResizing: #shrinkWrap.
self cellPositioning: #topLeft.
self listDirection: #topToBottom.
self borderWidth: 2;
borderColor: Color black.
self addHeaderRow.
self addButtonRow.
soundIndex := 1.
self addSoundList.
self soundIndex: 1.
self on: #mouseEnter send: #verifyContents to: listBox!
Item was changed:
----- Method: SoundLibraryTool>>listing (in category 'initialization') -----
listing
| list newList format soundData selectorList formatList |
list := SampledSound soundLibrary keys asSortedArray.
selectorList := OrderedCollection new.
+ formatList := OrderedCollection new.
- formatList _ OrderedCollection new.
list
do: [:each |
soundData := (SampledSound soundLibrary at: each) second.
soundData isNumber
ifTrue: [format := 'uncompressed']
ifFalse: [(soundData includesSubString: 'Vorbis')
ifTrue: [format := 'Vorbis']
ifFalse: [(soundData includesSubString: 'Speex')
ifTrue: [format := 'Speex']
ifFalse: [(soundData includesSubString: 'GSM')
ifTrue: [format := 'GSM']]]].
selectorList add: each.
formatList add: format].
+ newList := OrderedCollection new.
- newList _ OrderedCollection new.
newList add: selectorList asArray.
showCompression
ifTrue:[newList add: formatList asArray]
ifFalse:[newList add: (Array new: (formatList size) withAll:' ')].
^newList!
Item was changed:
----- Method: SoundLibraryTool>>toggleShowCompression (in category 'menu') -----
toggleShowCompression
+ showCompression := showCompression not.
- showCompression _ showCompression not.
self update!
Item was changed:
----- Method: SoundMorph>>buildImage (in category 'as yet unclassified') -----
buildImage
| scale env h imageColor |
+ owner ifNil: [scale := 128 at 128] "Default is 128 pix/second, 128 pix fullscale"
+ ifNotNil: [scale := owner soundScale].
+ env := sound volumeEnvelopeScaledTo: scale.
- owner ifNil: [scale _ 128 at 128] "Default is 128 pix/second, 128 pix fullscale"
- ifNotNil: [scale _ owner soundScale].
- env _ sound volumeEnvelopeScaledTo: scale.
self image: (ColorForm extent: env size @ env max).
1 to: image width do:
+ [:x | h := env at: x.
- [:x | h _ env at: x.
image fillBlack: ((x-1)@(image height-h//2) extent: 1 at h)].
+ imageColor := #(black red orange green blue) atPin:
- imageColor _ #(black red orange green blue) atPin:
(sound pitch / 110.0) rounded highBit.
image colors: (Array with: Color transparent with: (Color perform: imageColor)).
!
Item was changed:
----- Method: SoundMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: aMorph event: anEvent
| relPosition |
+ relPosition := self position - aMorph innerBounds topLeft.
+ relPosition := (relPosition x roundTo: 8) @ relPosition y.
- relPosition _ self position - aMorph innerBounds topLeft.
- relPosition _ (relPosition x roundTo: 8) @ relPosition y.
self position: aMorph innerBounds topLeft + relPosition.
sound copy play.
^super justDroppedInto: aMorph event: anEvent!
Item was changed:
----- Method: SoundMorph>>sound: (in category 'as yet unclassified') -----
sound: aSound
+ sound := aSound copy.
- sound _ aSound copy.
sound reset.
self buildImage!
Item was changed:
----- Method: SoundSequencerMorph>>makeControlPanel (in category 'as yet unclassified') -----
makeControlPanel
| bb cc |
+ cc := Color black.
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
+ controlPanel := AlignmentMorph newRow.
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- cc _ Color black.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
- controlPanel _ AlignmentMorph newRow.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
controlPanel color: bb color; borderWidth: 0; layoutInset: 0.
controlPanel hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 at 5.
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
controlPanel addMorphBack: (bb label: 'reset'; actionSelector: #reset).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
controlPanel addMorphBack: (bb label: 'stop'; actionSelector: #stop).
+ bb := SimpleButtonMorph new target: self; borderColor: cc.
- bb _ SimpleButtonMorph new target: self; borderColor: cc.
controlPanel addMorphBack: (bb label: 'play'; actionSelector: #play).
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>addButtonRow (in category 'private') -----
addButtonRow
| r |
+ r := AlignmentMorph newRow vResizing: #shrinkWrap.
- r _ AlignmentMorph newRow vResizing: #shrinkWrap.
r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
r addMorphBack: (Morph new extent: 4 at 1; color: Color transparent).
r addMorphBack: (self buttonName: 'Start' translated action: #start).
r addMorphBack: (Morph new extent: 4 at 1; color: Color transparent).
r addMorphBack: (self buttonName: 'Stop' translated action: #stop).
r addMorphBack: (Morph new extent: 12 at 1; color: Color transparent).
self addMorphBack: r.
^ r fullBounds.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>addLevelSlider (in category 'private') -----
addLevelSlider
| levelSlider r |
+ levelSlider := SimpleSliderMorph new
- levelSlider _ SimpleSliderMorph new
color: color;
extent: 100 at 2;
target: soundInput;
actionSelector: #recordLevel:;
adjustToValue: soundInput recordLevel.
+ r := AlignmentMorph newRow
- r _ AlignmentMorph newRow
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #rigid;
height: 24.
r addMorphBack: (StringMorph contents: '0 ').
r addMorphBack: levelSlider.
r addMorphBack: (StringMorph contents: ' 10').
self addMorphBack: r.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>addLevelSliderIn: (in category 'private') -----
addLevelSliderIn: aPoint
| levelSlider r |
+ levelSlider := SimpleSliderMorph new
- levelSlider _ SimpleSliderMorph new
color: color;
extent: (aPoint x * 0.75) asInteger@(aPoint y*0.6) asInteger;
target: soundInput;
actionSelector: #recordLevel:;
adjustToValue: soundInput recordLevel.
+ r := AlignmentMorph newRow
- r _ AlignmentMorph newRow
color: color;
layoutInset: 0;
wrapCentering: #center; cellPositioning: #leftCenter;
hResizing: #shrinkWrap;
vResizing: #rigid;
height: aPoint y + 2.
r addMorphBack: (StringMorph contents: '0 ' font: Preferences standardEToysButtonFont).
r addMorphBack: levelSlider.
r addMorphBack: (StringMorph contents: ' 10' font: Preferences standardEToysButtonFont).
self addMorphBack: r.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| full |
super initialize.
""
self listDirection: #topToBottom.
+ soundInput := SoundInputStream new samplingRate: 22050.
+ fft := FFT new: 512.
+ displayType := 'sonogram'.
- soundInput _ SoundInputStream new samplingRate: 22050.
- fft _ FFT new: 512.
- displayType _ 'sonogram'.
self hResizing: #shrinkWrap.
self vResizing: #shrinkWrap.
full := self addButtonRow.
submorphs last addMorphBack: (self makeStatusLightIn: full extent).
self addLevelSliderIn: full extent.
self addMorphBack: (self makeLevelMeterIn: full extent).
self addMorphBack: (Morph new extent: 10 @ 10;
color: Color transparent).
"spacer"
self resetDisplay!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>invokeMenu (in category 'menu and buttons') -----
invokeMenu
"Invoke the settings menu."
| aMenu |
+ aMenu := CustomMenu new.
- aMenu _ CustomMenu new.
aMenu addList: {
{'set sampling rate' translated. #setSamplingRate}.
{'set FFT size' translated. #setFFTSize}.
{'set display type' translated. #setDisplayType}}.
aMenu invokeOn: self defaultSelection: nil.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>makeLevelMeter (in category 'private') -----
makeLevelMeter
| outerBox |
+ outerBox := RectangleMorph new extent: 125 at 14; color: Color lightGray.
+ levelMeter := Morph new extent: 2 at 10; color: Color yellow.
- outerBox _ RectangleMorph new extent: 125 at 14; color: Color lightGray.
- levelMeter _ Morph new extent: 2 at 10; color: Color yellow.
levelMeter position: outerBox topLeft + (2 at 2).
outerBox addMorph: levelMeter.
^ outerBox
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>makeLevelMeterIn: (in category 'private') -----
makeLevelMeterIn: aPoint
| outerBox h |
h := (aPoint y * 0.6) asInteger.
+ outerBox := Morph new extent: (aPoint x) asInteger at h; color: Color gray.
+ levelMeter := Morph new extent: 1 at h; color: Color yellow.
- outerBox _ Morph new extent: (aPoint x) asInteger at h; color: Color gray.
- levelMeter _ Morph new extent: 1 at h; color: Color yellow.
levelMeter position: outerBox topLeft + (1 at 1).
outerBox addMorph: levelMeter.
^ outerBox
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>makeStatusLight (in category 'private') -----
makeStatusLight
| s |
+ statusLight := RectangleMorph new extent: 24 at 19.
- statusLight _ RectangleMorph new extent: 24 at 19.
statusLight color: Color gray.
+ s := StringMorph contents: 'On' translated.
- s _ StringMorph contents: 'On' translated.
s position: statusLight center - (s extent // 2).
statusLight addMorph: s.
^ statusLight
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>makeStatusLightIn: (in category 'private') -----
makeStatusLightIn: aPoint
| s p |
+ p := (aPoint x min: aPoint y) asPoint.
+ statusLight := RectangleMorph new extent: p.
- p _ (aPoint x min: aPoint y) asPoint.
- statusLight _ RectangleMorph new extent: p.
statusLight color: Color gray.
+ s := StringMorph contents: 'On' translated font: Preferences standardEToysFont.
- s _ StringMorph contents: 'On' translated font: Preferences standardEToysFont.
s position: statusLight center - (s extent // 2).
statusLight addMorph: s.
^ statusLight
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>removeAllDisplays (in category 'private') -----
removeAllDisplays
"Remove all currently showing displays."
sonogramMorph ifNotNil: [sonogramMorph delete].
graphMorph ifNotNil: [graphMorph delete].
+ sonogramMorph := graphMorph := nil.
- sonogramMorph _ graphMorph _ nil.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>setDisplayType (in category 'menu and buttons') -----
setDisplayType
"Set the display type."
| aMenu choice on |
+ aMenu := CustomMenu new title: ('display type (currently {1})' translated format:{displayType}).
- aMenu _ CustomMenu new title: ('display type (currently {1})' translated format:{displayType}).
aMenu addList: {
{'signal' translated. 'signal'}.
{'spectrum' translated. 'spectrum'}.
{'sonogram' translated. 'sonogram'}}.
+ choice := aMenu startUp.
- choice _ aMenu startUp.
choice ifNil: [^ self].
+ on := soundInput isRecording.
- on _ soundInput isRecording.
self stop.
+ displayType := choice.
- displayType _ choice.
self resetDisplay.
on ifTrue: [self start].
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>setFFTSize (in category 'menu and buttons') -----
setFFTSize
"Set the size of the FFT used for frequency analysis."
| aMenu sz on |
+ aMenu := CustomMenu new title: ('FFT size (currently {1})' translated format:{fft n}).
- aMenu _ CustomMenu new title: ('FFT size (currently {1})' translated format:{fft n}).
((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r].
+ sz := aMenu startUp.
- sz _ aMenu startUp.
sz ifNil: [^ self].
+ on := soundInput isRecording.
- on _ soundInput isRecording.
self stop.
+ fft := FFT new: sz.
- fft _ FFT new: sz.
self resetDisplay.
on ifTrue: [self start].
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>setSamplingRate (in category 'menu and buttons') -----
setSamplingRate
"Set the sampling rate to be used for incoming sound data."
| aMenu rate on |
+ aMenu := CustomMenu new title:
- aMenu _ CustomMenu new title:
('Sampling rate (currently {1})' translated format:{soundInput samplingRate}).
#(11025 22050 44100) do:[:r | aMenu add: r printString action: r].
+ rate := aMenu startUp.
- rate _ aMenu startUp.
rate ifNil: [^ self].
+ on := soundInput isRecording.
- on _ soundInput isRecording.
self stop.
soundInput samplingRate: rate.
self resetDisplay.
on ifTrue: [self start].
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>showSignal (in category 'private') -----
showSignal
"Display the actual signal waveform."
+ displayType := 'signal'.
- displayType _ 'signal'.
self removeAllDisplays.
+ graphMorph := GraphMorph new.
- graphMorph _ GraphMorph new.
graphMorph extent: (400 + (2 * graphMorph borderWidth))@128.
graphMorph data: (Array new: 100 withAll: 0).
graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0).
self addMorphBack: graphMorph.
self extent: 10 at 10. "shrink to minimum size"
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>showSonogram (in category 'private') -----
showSonogram
"Display a sonogram showing the frequency spectrum versus time."
| zeros h w |
+ displayType := 'sonogram'.
- displayType _ 'sonogram'.
self removeAllDisplays.
+ h := fft n // 2.
+ h := h min: 512 max: 64.
+ w := 400.
- h _ fft n // 2.
- h _ h min: 512 max: 64.
- w _ 400.
sonogramMorph _
Sonogram new
extent: w at h
minVal: 0.0
maxVal: 1.0
scrollDelta: w.
+ zeros := Array new: sonogramMorph height withAll: 0.
- zeros _ Array new: sonogramMorph height withAll: 0.
sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros].
self addMorphBack: sonogramMorph.
self extent: 10 at 10. "shrink to minimum size"
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>showSpectrum (in category 'private') -----
showSpectrum
"Display the frequency spectrum."
+ displayType := 'spectrum'.
- displayType _ 'spectrum'.
self removeAllDisplays.
+ graphMorph := GraphMorph new.
- graphMorph _ GraphMorph new.
graphMorph extent: ((fft n // 2) + (2 * graphMorph borderWidth))@128.
graphMorph data: (Array new: fft n // 2 withAll: 0).
self addMorphBack: graphMorph.
self extent: 10 at 10. "shrink to minimum size"
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>step (in category 'stepping and presenter') -----
step
"Update the record light, level meter, and display."
| w |
"update the record light and level meter"
soundInput isRecording
ifTrue: [statusLight color: Color yellow]
ifFalse: [statusLight color: Color gray].
+ w := ((121 * soundInput meterLevel) // 100) max: 1.
- w _ ((121 * soundInput meterLevel) // 100) max: 1.
levelMeter width ~= w ifTrue: [levelMeter width: w].
"update the display if any data is available"
self updateDisplay.
!
Item was changed:
----- Method: SpectrumAnalyzerMorph>>updateDisplay (in category 'private') -----
updateDisplay
"Update the display if any data is available."
| buf bufCount |
soundInput bufferCount = 0 ifTrue: [^ self].
graphMorph ifNotNil: [
[soundInput bufferCount > 0] whileTrue: [
"skip to the most recent buffer"
+ buf := soundInput nextBufferOrNil].
- buf _ soundInput nextBufferOrNil].
^ self processBuffer: buf].
sonogramMorph ifNotNil: [
"at small buffer sizes we have to update the sonogram in
batches or we may get behind; shoot for 8 updates/second"
+ bufCount := (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
- bufCount _ (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
[bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [
self processBuffer: (soundInput nextBufferOrNil)]].
!
Item was changed:
----- Method: StackMorph>>goToCard (in category 'card access') -----
goToCard
"prompt the user for an ordinal number, and use that as a basis for choosing a new card to install in the receiver"
| reply index |
+ reply := FillInTheBlank request: 'Which card number? ' translated initialAnswer: '1'.
- reply _ FillInTheBlank request: 'Which card number? ' translated initialAnswer: '1'.
reply isEmptyOrNil ifTrue: [^ self].
+ ((index := reply asNumber) > 0 and: [index <= self privateCards size])
- ((index _ reply asNumber) > 0 and: [index <= self privateCards size])
ifFalse: [^ self inform: 'no such card' translated].
self goToCard: (self privateCards at: index)!
Item was changed:
----- Method: StackMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aCardMorph
"Install the card inside a new stack. Make no border or controls, so I the card's look is unchanged. Card already has a CardPlayer."
| wld |
+ wld := aCardMorph world.
- wld _ aCardMorph world.
self initialize.
self pageSize: aCardMorph extent.
self borderWidth: 0; layoutInset: 0; color: Color transparent.
+ pages := Array with: aCardMorph.
- pages _ Array with: aCardMorph.
self currentPage: aCardMorph.
self privateCards: (OrderedCollection with: currentPage currentDataInstance).
currentPage beAStackBackground.
self position: aCardMorph position.
submorphs last delete.
self addMorph: currentPage.
self showPageControls: self fullControlSpecs.
wld addMorph: self.
!
Item was changed:
----- Method: StackMorph>>insertAsBackground:resize: (in category 'background') -----
insertAsBackground: newPage resize: doResize
"Make a new background for the stack. Obtain a name for it from the user. It starts out life empty"
| aName |
+ aName := FillInTheBlank request: 'What should we call this new background?' translated initialAnswer: 'alternateBackground' translated.
- aName _ FillInTheBlank request: 'What should we call this new background?' translated initialAnswer: 'alternateBackground' translated.
aName isEmptyOrNil ifTrue: [^ self].
newPage beSticky.
doResize ifTrue: [newPage extent: currentPage extent].
newPage beAStackBackground.
newPage setNameTo: aName.
newPage vResizeToFit: false.
pages isEmpty
ifTrue: [pages add: newPage]
ifFalse: [pages add: newPage after: currentPage].
self privateCards add: newPage currentDataInstance after: currentPage currentDataInstance.
self nextPage.
!
Item was changed:
----- Method: StackMorph>>offerBookishMenu (in category 'menu') -----
offerBookishMenu
"Offer a menu with book-related items in it"
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'Stack / Book' translated.
aMenu addStayUpItem.
aMenu addList:
#(('sort pages' sortPages)
('uncache page sorter' uncachePageSorter)).
(self hasProperty: #dontWrapAtEnd)
ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true]
ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false].
aMenu addList:
#(('make bookmark' bookmarkForThisPage)
('make thumbnail' thumbnailForThisPage)).
aMenu addLine.
aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:.
aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:.
aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:.
aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:.
aMenu addLine.
(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
[aMenu add: 'paste book page' translated action: #pasteBookPage].
aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype.
newPagePrototype ifNotNil: [
aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype].
aMenu add: (self dragNDropEnabled ifTrue: ['close' translated ] ifFalse: ['open' translated]) , ' dragNdrop' translated
action: #toggleDragNDrop.
aMenu addLine.
aMenu add: 'make all pages this size' translated action: #makeUniformPageSize.
aMenu addUpdating: #keepingUniformPageSizeString target: self action: #toggleMaintainUniformPageSize.
aMenu addLine.
aMenu add: 'send all pages to server' translated action: #savePagesOnURL.
aMenu add: 'send this page to server' translated action: #saveOneOnURL.
aMenu add: 'reload all from server' translated action: #reload.
aMenu add: 'copy page url to clipboard' translated action: #copyUrl.
aMenu add: 'keep in one file' translated action: #keepTogether.
aMenu addLine.
aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook.
aMenu add: 'background color for all pages...' translated action: #setPageColor.
aMenu popUpEvent: self world activeHand lastEvent in: self world
!
Item was changed:
----- Method: StandardFileStream class>>fileDoesNotExistUserHandling: (in category '*Etoys-Squeakland-error handling') -----
fileDoesNotExistUserHandling: fullFileName
| selection newName |
+ selection := (PopUpMenu labels:
- selection _ (PopUpMenu labels:
'create a new file
choose another name
cancel' translated)
startUpWithCaption: ('{1}
does not exist.' translated format: {FileDirectory localNameFor: fullFileName}) .
selection = 1 ifTrue:
[^ self new open: fullFileName forWrite: true].
selection = 2 ifTrue:
+ [ newName := FillInTheBlank request: 'Enter a new file name' translated
- [ newName _ FillInTheBlank request: 'Enter a new file name' translated
initialAnswer: fullFileName.
^ self oldFileNamed:
(self fullName: newName)].
^ self error: 'Could not open a file'!
Item was changed:
----- Method: StandardFileStream class>>fileExistsUserHandling: (in category '*Etoys-Squeakland-error handling') -----
fileExistsUserHandling: fullFileName
| dir localName choice newName newFullFileName |
+ dir := FileDirectory forFileName: fullFileName.
+ localName := FileDirectory localNameFor: fullFileName.
+ choice := (PopUpMenu
- dir _ FileDirectory forFileName: fullFileName.
- localName _ FileDirectory localNameFor: fullFileName.
- choice _ (PopUpMenu
labels:
'overwrite that file\choose another name\cancel' translated withCRs)
startUpWithCaption: ('{1}
already exists.' translated format: {localName}).
choice = 1 ifTrue: [
dir deleteFileNamed: localName
ifAbsent: [self error: 'Could not delete the old version of that file' translated].
^ self new open: fullFileName forWrite: true].
choice = 2 ifTrue: [
+ newName := FillInTheBlank request: 'Enter a new file name' translated initialAnswer: fullFileName.
+ newFullFileName := self fullName: newName.
- newName _ FillInTheBlank request: 'Enter a new file name' translated initialAnswer: fullFileName.
- newFullFileName _ self fullName: newName.
^ self newFileNamed: newFullFileName].
self error: 'Please close this to abort file opening' translated!
Item was changed:
----- Method: StandardFileStream class>>readOnlyFileDoesNotExistUserHandling: (in category '*Etoys-Squeakland-error handling') -----
readOnlyFileDoesNotExistUserHandling: fullFileName
| dir files choices selection newName fileName |
+ dir := FileDirectory forFileName: fullFileName.
+ files := dir fileNames.
+ fileName := FileDirectory localNameFor: fullFileName.
+ choices := fileName correctAgainst: files.
- dir _ FileDirectory forFileName: fullFileName.
- files _ dir fileNames.
- fileName _ FileDirectory localNameFor: fullFileName.
- choices _ fileName correctAgainst: files.
choices add: 'Choose another name' translated.
choices add: 'Cancel' translated.
+ selection := (PopUpMenu labelArray: choices lines: (Array with: 5) )
- selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) )
startUpWithCaption: ( '{1}
does not exist.' translated format: {FileDirectory localNameFor: fullFileName}).
selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"].
selection < (choices size - 1) ifTrue: [
+ newName := (dir pathName , FileDirectory slash , (choices at: selection))].
- newName _ (dir pathName , FileDirectory slash , (choices at: selection))].
selection = (choices size - 1) ifTrue: [
+ newName := FillInTheBlank
- newName _ FillInTheBlank
request: 'Enter a new file name' translated
initialAnswer: fileName].
newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)].
^ self error: 'Could not open a file'!
Item was changed:
----- Method: StandardScriptingSystem>>acceptableSlotNameFrom:forSlotCurrentlyNamed:asSlotNameIn:world: (in category '*Etoys-universal slots & scripts') -----
acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: currentName asSlotNameIn: aPlayer world: aWorld
"Produce an acceptable slot name, derived from the current name, for aPlayer. This method will always return a valid slot name that will be suitable for use in the given situation, though you might not like its beauty sometimes."
| aString stemAndSuffix proscribed stem suffix putative |
+ aString := originalString asIdentifier: false. "get an identifier not lowercase"
+ stemAndSuffix := aString stemAndNumericSuffix.
+ proscribed := #(self super thisContext costume costumes dependents #true #false size), aPlayer class allInstVarNames, Vocabulary eToyVocabulary systemSlotNames.
- aString _ originalString asIdentifier: false. "get an identifier not lowercase"
- stemAndSuffix _ aString stemAndNumericSuffix.
- proscribed _ #(self super thisContext costume costumes dependents #true #false size), aPlayer class allInstVarNames, Vocabulary eToyVocabulary systemSlotNames.
+ stem := stemAndSuffix first.
+ suffix := stemAndSuffix last.
+ putative := aString asSymbol.
- stem _ stemAndSuffix first.
- suffix _ stemAndSuffix last.
- putative _ aString asSymbol.
[(putative ~~ currentName) and: [(proscribed includes: putative)
or: [(aPlayer respondsTo: putative)
or: [Smalltalk includesKey: putative]]]]
whileTrue:
+ [suffix := suffix + 1.
+ putative := (stem, suffix printString) asSymbol].
- [suffix _ suffix + 1.
- putative _ (stem, suffix printString) asSymbol].
^ putative!
Item was changed:
----- Method: StandardScriptingSystem>>helpStringOrNilForOperator: (in category '*Etoys-utilities') -----
helpStringOrNilForOperator: anOperator
"Answer the help string associated with the given operator, nil if none found."
| anIndex opsAndHelp |
+ (anIndex := (opsAndHelp := self arithmeticalOperatorsAndHelpStrings) first indexOf: anOperator) > 0
- (anIndex _ (opsAndHelp _ self arithmeticalOperatorsAndHelpStrings) first indexOf: anOperator) > 0
ifTrue: [^ (opsAndHelp second at: anIndex) translated].
+ (anIndex := (opsAndHelp := self numericComparitorsAndHelpStrings) first indexOf: anOperator) > 0
- (anIndex _ (opsAndHelp _ self numericComparitorsAndHelpStrings) first indexOf: anOperator) > 0
ifTrue: [^ (opsAndHelp second at: anIndex) translated].
+ (anIndex := (opsAndHelp := self numericFunctionsAndHelpStrings) first indexOf: anOperator) > 0
- (anIndex _ (opsAndHelp _ self numericFunctionsAndHelpStrings) first indexOf: anOperator) > 0
ifTrue: [^ (opsAndHelp second at: anIndex) translated].
^ nil!
Item was changed:
----- Method: StandardScriptingSystem>>newScriptingSpace2 (in category '*Etoys-utilities') -----
newScriptingSpace2
"Answer a complete scripting space"
| aTemplate aPlayfield aControl |
+ (aTemplate := PasteUpMorph new)
- (aTemplate _ PasteUpMorph new)
setNameTo: 'etoy';
extent: 638 @ 470;
color: Color white;
impartPrivatePresenter;
setProperty: #automaticPhraseExpansion toValue: true;
beSticky.
aTemplate useRoundedCorners; borderWidth: 2.
+ aControl := ScriptingSystem scriptControlButtons setToAdhereToEdge: #bottomLeft.
- aControl _ ScriptingSystem scriptControlButtons setToAdhereToEdge: #bottomLeft.
aControl beSticky; borderWidth: 0; beTransparent.
aTemplate addMorphBack: aControl.
aTemplate presenter addTrashCan.
+ aTemplate addMorph: (aPlayfield := PasteUpMorph new).
- aTemplate addMorph: (aPlayfield _ PasteUpMorph new).
aPlayfield
setNameTo: 'playfield';
useRoundedCorners;
setToAdhereToEdge: #topLeft;
extent: 340 at 300;
position: aTemplate topRight - (400 at 0);
beSticky;
automaticViewing: true;
wantsMouseOverHalos: true.
aTemplate presenter standardPlayfield: aPlayfield.
aTemplate setProperty: #tutorial toValue: true.
^ aTemplate
!
Item was changed:
----- Method: StandardScriptingSystem>>randomNumberTile (in category '*Etoys-Squeakland-gold box') -----
randomNumberTile
"Answer a new Random Number tile"
| functionPhrase argTile aPad |
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
argTile := (Vocabulary vocabularyNamed: 'Number') defaultArgumentTile.
aPad := TilePadMorph new setType: #Number.
aPad addMorphBack: argTile.
functionPhrase operator: #random pad: aPad.
^ functionPhrase!
Item was changed:
----- Method: StandardScriptingSystem>>reportToUser: (in category '*Etoys-utilities') -----
reportToUser: aString
"Make a message accessible to the user. "
| trigger current baseTriggerer topTriggerer mclass sel topSelector |
+ trigger := Player compiledMethodAt: #triggerScript:.
+ current := thisContext.
+ baseTriggerer := nil.
+ topTriggerer := nil.
- trigger _ Player compiledMethodAt: #triggerScript:.
- current _ thisContext.
- baseTriggerer _ nil.
- topTriggerer _ nil.
[current notNil] whileTrue: [
topTriggerer ifNil: [
current receiver class isUniClass ifTrue: [
"Look for the top-most uniclass script in the call chain."
+ sel := current receiver class selectorAtMethod: current method setClass: [:c | mclass := c].
- sel _ current receiver class selectorAtMethod: current method setClass: [:c | mclass _ c].
mclass = current receiver class ifTrue: [
+ topTriggerer := current.
+ topSelector := sel.
- topTriggerer _ current.
- topSelector _ sel.
].
].
].
(current method = trigger and: [current class == MethodContext]) ifTrue: [
"Look for the bottom-most #triggerScript: and its selector."
+ baseTriggerer := current
- baseTriggerer _ current
].
+ current := current sender.
- current _ current sender.
].
baseTriggerer ifNotNil: [
(baseTriggerer receiver scriptInstantiationForSelector: (baseTriggerer at: 1)) resetTo: #paused ifCurrently: #ticking.
].
(topTriggerer notNil and: [topSelector notNil]) ifTrue: [
^ self eToysError: aString, '\', topTriggerer receiver knownName, '\', topSelector.
].
self error: aString.
!
Item was changed:
----- Method: StandardScriptingSystem>>seminalFunctionTile (in category '*Etoys-Squeakland-gold box') -----
seminalFunctionTile
"Answer a prototypical function tile"
| functionPhrase argTile aPad |
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
argTile := (Vocabulary vocabularyNamed: 'Number') defaultArgumentTile.
aPad := TilePadMorph new setType: #Number.
aPad addMorphBack: argTile.
functionPhrase operator: #abs pad: aPad.
^ functionPhrase!
Item was changed:
----- Method: StandardScriptingSystem>>stopUp:with: (in category '*Etoys-script-control') -----
stopUp: dummy with: theButton
| aPresenter |
Cursor wait showWhile: [
+ (aPresenter := theButton presenter) flushPlayerListCache. "catch guys not in cache but who're running"
- (aPresenter _ theButton presenter) flushPlayerListCache. "catch guys not in cache but who're running"
aPresenter stopRunningScriptsFrom: theButton
]!
Item was changed:
----- Method: StandardViewer>>addCategoryViewerFor:atEnd: (in category 'categories') -----
addCategoryViewerFor: categoryInfo atEnd: atEnd
"Add a category viewer for the given category info. If atEnd is true, add it at the end, else add it just after the header morph"
| aViewer |
Cursor wait showWhile: [
+ aViewer := self categoryViewerFor: categoryInfo.
- aViewer _ self categoryViewerFor: categoryInfo.
atEnd
ifTrue:
[self addMorphBack: aViewer]
ifFalse:
[self addMorph: aViewer after: submorphs first].
aViewer establishContents.
self world ifNotNil: [self world startSteppingSubmorphsOf: aViewer].
self fitFlap.
aViewer assureCategoryFullyVisible
].
!
Item was changed:
----- Method: StandardViewer>>addHeaderMorphWithBarHeight:includeDismissButton: (in category 'initialization') -----
addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean
"Add the header morph to the receiver, using anInteger as a guide for its height, and if aBoolean is true, include a dismiss buton for it"
| header aButton aTextMorph nail wrpr costs headWrapper |
+ header := AlignmentMorph newRow color: Color transparent; wrapCentering: #center; cellPositioning: #leftCenter.
- header _ AlignmentMorph newRow color: Color transparent; wrapCentering: #center; cellPositioning: #leftCenter.
aBoolean ifTrue:
+ [aButton := self tanOButton.
- [aButton _ self tanOButton.
header addMorph: aButton.
aButton actionSelector: #dismiss;
setBalloonText: 'remove this entire Viewer from the screen
don''t worry -- nothing will be lost!!.' translated.
header addTransparentSpacerOfSize: 3].
+ costs := scriptedPlayer costumes.
- costs _ scriptedPlayer costumes.
costs ifNotNil:
[(costs size > 1 or: [costs size = 1 and: [costs first ~~ scriptedPlayer costume]]) ifTrue:
[header addUpDownArrowsFor: self.
"addArrowsOn: adds the box with two arrow at the front."
+ (wrpr := header submorphs first) submorphs second setBalloonText: 'switch to previous costume' translated.
- (wrpr _ header submorphs first) submorphs second setBalloonText: 'switch to previous costume' translated.
wrpr submorphs first setBalloonText: 'switch to next costume' translated].
header addTransparentSpacerOfSize: 3].
self viewsMorph ifTrue: [scriptedPlayer costume assureExternalName].
+ aTextMorph := UpdatingStringMorph new
- aTextMorph _ UpdatingStringMorph new
useStringFormat;
target: scriptedPlayer;
getSelector: #nameForViewer;
setNameTo: 'name';
font: ScriptingSystem fontForNameEditingInScriptor.
self viewsMorph ifTrue:
[aTextMorph putSelector: #setName:.
aTextMorph setProperty: #okToTextEdit toValue: true].
aTextMorph step.
header addMorphBack: aTextMorph.
aTextMorph setBalloonText: 'Click here to edit the player''s name.' translated.
header addMorphBack: ((self transparentSpacerOfSize: 0) hResizing: #spaceFill; color: Color red).
aButton := ThreePhaseButtonMorph
labelSymbol: #AddInstanceVariable
target: scriptedPlayer
actionSelector: #addInstanceVariable
arguments: #().
aButton setBalloonText: 'click here to add a variable
to this object.' translated.
header addMorphBack: aButton.
header addTransparentSpacerOfSize: 3.
+ nail := (self hasProperty: #noInteriorThumbnail)
- nail _ (self hasProperty: #noInteriorThumbnail)
ifFalse:
[ThumbnailMorph new objectToView: scriptedPlayer viewSelector: #costume]
ifTrue:
[ImageMorph new image: (ScriptingSystem formAtKey: #MenuIcon)].
nail on: #mouseDown send: #offerViewerMenuForEvt:morph: to: scriptedPlayer.
header addMorphBack: nail.
nail setBalloonText: 'click here to get a menu
that will allow you to
locate this object,
tear off a tile, etc..' translated.
(self hasProperty: #noInteriorThumbnail)
ifFalse:
[nail borderWidth: 3; borderColor: #raised].
header addTransparentSpacerOfSize: 3.
+ aButton := ThreePhaseButtonMorph labelSymbol: #AddCategoryViewer.
- aButton _ ThreePhaseButtonMorph labelSymbol: #AddCategoryViewer.
aButton
actWhen: #buttonUp;
target: self;
actionSelector: #addCategoryViewer;
setBalloonText: 'click here to add
another category pane' translated.
header addMorphBack: aButton.
header beSticky.
anInteger > 0
ifTrue:
+ [headWrapper := AlignmentMorph newColumn color: self color.
- [headWrapper _ AlignmentMorph newColumn color: self color.
headWrapper addTransparentSpacerOfSize: (0 @ anInteger).
headWrapper addMorphBack: header.
self addMorph: headWrapper]
ifFalse:
[self addMorph: header]!
Item was changed:
----- Method: StandardViewer>>initializeFor:barHeight:includeDismissButton:showCategories: (in category 'initialization') -----
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: categoryInfo
"Initialize the receiver to be a look inside the given Player. The categoryInfo, if present, describes which categories should be present in it, in which order"
+ scriptedPlayer := aPlayer.
- scriptedPlayer _ aPlayer.
self listDirection: #topToBottom;
hResizing: #spaceFill;
width: 550;
vResizing: #shrinkWrap;
layoutInset: 3;
cellInset: 3;
borderWidth: 1.
self color: self standardViewerColor.
self borderColor: ScriptingSystem borderColor.
self addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean.
categoryInfo isEmptyOrNil
ifFalse: "Reincarnating an pre-existing list"
[categoryInfo do:
[:aCat | self addCategoryViewerFor: aCat]]
ifTrue: "starting fresh"
[self addSearchPane.
self addCategoryViewer.
self addCategoryViewer.
(self categoriesCurrentlyShowing includes: ScriptingSystem nameForInstanceVariablesCategory translated) ifTrue: [self addCategoryViewer].
(self categoriesCurrentlyShowing includes: ScriptingSystem nameForScriptsCategory translated) ifTrue: [self addCategoryViewer].
(scriptedPlayer isPlayerLike and: [scriptedPlayer costume isMemberOf: KedamaMorph])ifTrue: [self addCategoryViewer]]
!
Item was changed:
----- Method: StaticChangeSetCategory>>reconstituteList (in category 'updating') -----
reconstituteList
"Reformulate the list. Here, since we have a manually-maintained list, at this juncture we only make sure change-set-names are still up to date, and we purge moribund elements"
| survivors |
+ survivors := elementDictionary select: [:aChangeSet | aChangeSet isMoribund not].
- survivors _ elementDictionary select: [:aChangeSet | aChangeSet isMoribund not].
self clear.
(survivors asSortedCollection: [:a :b | a name <= b name]) reverseDo:
[:aChangeSet | self addChangeSet: aChangeSet]!
Item was changed:
----- Method: StaticTextMorph>>handlesKeyboard: (in category 'event handling') -----
handlesKeyboard: evt
"Don't do text editing, unless the receiver is outfitted with an explicit keyboard handler."
+ editor := nil. "just to be sure"
- editor _ nil. "just to be sure"
self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt].
^ false!
Item was changed:
----- Method: StaticTextMorph>>handlesMouseDown: (in category 'resisting rotation') -----
handlesMouseDown: evt
"Decline to handle text-editing-inducing mouse-downs, so that the receiver can be easily grabbed for relocation"
| eh |
+ ^ (eh := self eventHandler) notNil and:
- ^ (eh _ self eventHandler) notNil and:
[eh handlesMouseDown: evt]!
Item was changed:
----- Method: StrikeFont class>>newForSimplifiedChineseFromEFontBDFFile:name:overrideWith: (in category '*Etoys-Squeakland-instance creation') -----
newForSimplifiedChineseFromEFontBDFFile: fileName name: aString overrideWith: otherFileName
| n |
+ n := self new.
- n _ self new.
n readEFontBDFForSimplifiedChineseFromFile: fileName name: aString overrideWith: otherFileName.
^ n.
!
Item was changed:
----- Method: StrikeFont>>readEFontBDFForSimplifiedChineseFromFile:name:overrideWith: (in category '*Etoys-Squeakland-file in/out') -----
readEFontBDFForSimplifiedChineseFromFile: fileName name: aString overrideWith: otherFileName
| fontReader stream |
+ fontReader := EFontBDFFontReaderForRanges readOnlyFileNamed: fileName.
+ stream := ReadStream on: (fontReader readRangesForSimplifiedChinese: fontReader rangesForSimplifiedChinese overrideWith: otherFileName otherRanges: {Array with: 16rFF00 with: 16rFF60} additionalOverrideRange: fontReader additionalRangesForSimplifiedChinese).
+ xTable := stream next.
+ glyphs := stream next.
+ minAscii := stream next.
+ maxAscii := stream next.
+ maxWidth := stream next.
+ ascent := stream next.
+ descent := stream next.
+ pointSize := stream next.
+ name := aString.
+ type := 0. "no one see this"
+ superscript := ascent - descent // 3.
+ subscript := descent - ascent // 3.
+ emphasis := 0.
- fontReader _ EFontBDFFontReaderForRanges readOnlyFileNamed: fileName.
- stream _ ReadStream on: (fontReader readRangesForSimplifiedChinese: fontReader rangesForSimplifiedChinese overrideWith: otherFileName otherRanges: {Array with: 16rFF00 with: 16rFF60} additionalOverrideRange: fontReader additionalRangesForSimplifiedChinese).
- xTable _ stream next.
- glyphs _ stream next.
- minAscii _ stream next.
- maxAscii _ stream next.
- maxWidth _ stream next.
- ascent _ stream next.
- descent _ stream next.
- pointSize _ stream next.
- name _ aString.
- type _ 0. "no one see this"
- superscript _ ascent - descent // 3.
- subscript _ descent - ascent // 3.
- emphasis _ 0.
self reset.
!
Item was changed:
----- Method: StrikeFont>>setupDefaultFallbackTextStyleTo: (in category '*Etoys-Squeakland-multibyte character methods') -----
setupDefaultFallbackTextStyleTo: aTextStyle
| fonts f |
fonts := aTextStyle fontArray.
+ f := fonts first.
- f _ fonts first.
f familyName = self familyName ifTrue: [^ self].
1 to: fonts size do: [:i |
+ self height > (fonts at: i) height ifTrue: [f := fonts at: i].
- self height > (fonts at: i) height ifTrue: [f _ fonts at: i].
].
self fallbackFont: f.
self reset.
!
Item was changed:
----- Method: StrikeFontSet class>>createExternalFontFileForUnicodeSimplifiedChinese: (in category '*Etoys-Squeakland-as yet unclassified') -----
createExternalFontFileForUnicodeSimplifiedChinese: fileName
"
Smalltalk garbageCollect.
StrikeFontSet createExternalFontFileForUnicodeSimplifiedChinese: 'uSimplifiedChineseFont.out'.
"
| file array f installDirectory |
+ file := FileStream newFileNamed: fileName.
+ installDirectory := Smalltalk at: #M17nInstallDirectory ifAbsent: [].
+ installDirectory := installDirectory
- file _ FileStream newFileNamed: fileName.
- installDirectory _ Smalltalk at: #M17nInstallDirectory ifAbsent: [].
- installDirectory _ installDirectory
ifNil: [String new]
ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString].
+ array := Array
- array _ Array
with: (StrikeFont newForSimplifiedChineseFromEFontBDFFile: installDirectory , 'wenquanyi_9pt.bdf' name: 'SimplifiedChinese10' overrideWith: 'shnmk12.bdf')
with: ((StrikeFont newForSimplifiedChineseFromEFontBDFFile: installDirectory , 'wenquanyi_10pt.bdf' name: 'SimplifiedChinese12' overrideWith: 'shnmk12.bdf') "fixAscent: 14 andDescent: 1 head: 1")
with: ((StrikeFont newForSimplifiedChineseFromEFontBDFFile: installDirectory , 'wenquanyi_12pt.bdf' name: 'SimplifiedChinese14' overrideWith: 'shnmk16.bdf') fixAscent: 16 andDescent: 4 head: 4)
" with: (StrikeFont newForSimplifiedChineseFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'SimplifiedChinese18' overrideWith: 'gb16st.bdf')".
TextConstants at: #forceFontWriting put: true.
+ f := ReferenceStream on: file.
- f _ ReferenceStream on: file.
f nextPut: array.
file close.
TextConstants removeKey: #forceFontWriting.
!
Item was changed:
----- Method: StrikeFontSet>>hasGlyphWithFallbackOf: (in category '*Etoys-Squeakland-accessing') -----
hasGlyphWithFallbackOf: aCharacter
| index f |
+ index := aCharacter leadingChar +1.
- index _ aCharacter leadingChar +1.
fontArray size < index ifTrue: [^ false].
+ (f := fontArray at: index) ifNil: [^ false].
- (f _ fontArray at: index) ifNil: [^ false].
^ f hasGlyphWithFallbackOf: aCharacter.
!
Item was changed:
----- Method: String>>composeAccents (in category '*Etoys-Squeakland-converting') -----
composeAccents
| stream |
+ stream := UnicodeCompositionStream on: (String new: 16).
- stream _ UnicodeCompositionStream on: (String new: 16).
self do: [:e | stream nextPut: e].
^ stream contents.
!
Item was changed:
----- Method: String>>putInteger32:at: (in category '*Etoys-Squeakland-encoding') -----
putInteger32: anInteger at: location
| integer |
<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
"IntegerPokerPlugin doPrimitive: #putInteger"
"the following is close to 20x faster than the above if the primitive is not compiled"
+ "PUTCOUNTER := PUTCOUNTER + 1."
+ integer := anInteger.
- "PUTCOUNTER _ PUTCOUNTER + 1."
- integer _ anInteger.
integer < 0 ifTrue: [integer := 1073741824 - integer. ].
self at: location+3 put: (Character value: (integer \\ 256)).
self at: location+2 put: (Character value: (integer bitShift: -8) \\ 256).
self at: location+1 put: (Character value: (integer bitShift: -16) \\ 256).
self at: location put: (Character value: (integer bitShift: -24) \\ 256).
"Smalltalk at: #PUTCOUNTER put: 0"!
Item was changed:
----- Method: StrokePoint>>backwardDirection (in category 'accessing') -----
backwardDirection
"Compute the backward direction to the previous point in the stroke."
| dir |
+ dir := prev ifNil:[0 at 0] ifNotNil:[self position - prev position].
+ dir isZero ifFalse:[dir := dir normalized].
- dir _ prev ifNil:[0 at 0] ifNotNil:[self position - prev position].
- dir isZero ifFalse:[dir _ dir normalized].
^dir!
Item was changed:
----- Method: StrokePoint>>defineIntermediatePoint (in category 'accessing') -----
defineIntermediatePoint
"Define an intermediate point for an extreme change in direction"
| pt |
+ pt := self class on: position.
- pt _ self class on: position.
pt width: self width.
pt prevPoint: self.
pt nextPoint: next.
next ifNotNil:[next prevPoint: pt].
self nextPoint: pt.
pt isFinal: self isFinal.!
Item was changed:
----- Method: StrokePoint>>forwardDirection (in category 'accessing') -----
forwardDirection
"Compute the forward direction to the next point in the stroke."
| dir |
+ dir := next ifNil:[0 at 0] ifNotNil:[next position - self position].
+ dir isZero ifFalse:[dir := dir normalized].
- dir _ next ifNil:[0 at 0] ifNotNil:[next position - self position].
- dir isZero ifFalse:[dir _ dir normalized].
^dir!
Item was changed:
----- Method: StrokePoint>>intersectFrom:with:to:with: (in category 'intersecting') -----
intersectFrom: startPt with: startDir to: endPt with: endDir
"Compute the intersection of two lines, e.g., compute alpha and beta for
startPt + (alpha * startDir) = endPt + (beta * endDir).
Reformulating this yields
(alpha * startDir) - (beta * endDir) = endPt - startPt.
or
(alpha * startDir) + (-beta * endDir) = endPt - startPt.
or
(alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x.
(alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y.
which is trivial to solve using Cramer's rule. Note that since
we're really only interested in the intersection point we need only
one of alpha or beta since the resulting intersection point can be
computed based on either one."
| det deltaPt alpha |
+ det := (startDir x * endDir y) - (startDir y * endDir x).
- det _ (startDir x * endDir y) - (startDir y * endDir x).
det = 0.0 ifTrue:[^nil]. "There's no solution for it"
+ deltaPt := endPt - startPt.
+ alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x).
+ alpha := alpha / det.
- deltaPt _ endPt - startPt.
- alpha _ (deltaPt x * endDir y) - (deltaPt y * endDir x).
- alpha _ alpha / det.
"And compute intersection"
^startPt + (alpha * startDir)!
Item was changed:
----- Method: StrokePoint>>isFinal: (in category 'flags') -----
isFinal: aBool
+ flags := aBool ifTrue:[flags bitOr: 1] ifFalse:[flags bitClear: 1].
- flags _ aBool ifTrue:[flags bitOr: 1] ifFalse:[flags bitClear: 1].
(aBool and:[prev notNil and:[prev isFinal not]]) ifTrue:[prev isFinal: true].!
Item was changed:
----- Method: StrokePoint>>isProcessed: (in category 'flags') -----
isProcessed: aBool
+ flags := aBool ifTrue:[flags bitOr: 2] ifFalse:[flags bitClear: 2].!
- flags _ aBool ifTrue:[flags bitOr: 2] ifFalse:[flags bitClear: 2].!
Item was changed:
----- Method: StrokePoint>>nextPoint: (in category 'accessing') -----
nextPoint: aPoint
"Set the next point in the stroke"
+ next := aPoint!
- next _ aPoint!
Item was changed:
----- Method: StrokePoint>>on: (in category 'initialize') -----
on: aPoint
+ flags := 0.
- flags _ 0.
self position: aPoint.!
Item was changed:
----- Method: StrokePoint>>position: (in category 'accessing') -----
position: aPoint
"Set the position of the receiver to aPoint"
+ position := aPoint.!
- position _ aPoint.!
Item was changed:
----- Method: StrokePoint>>prevPoint: (in category 'accessing') -----
prevPoint: aPoint
"Set the previous point of the stroke"
+ prev := aPoint!
- prev _ aPoint!
Item was changed:
----- Method: StrokePoint>>removeIntermediatePoint (in category 'accessing') -----
removeIntermediatePoint
"Remove an intermediate point for an extreme change in direction"
next ifNil:[^self].
prev ifNil:[^self].
next position = self position ifTrue:[
+ next := next nextPoint.
- next _ next nextPoint.
next ifNotNil:[next prevPoint: self].
^self removeIntermediatePoint]!
Item was changed:
----- Method: StrokeSimplifier class>>flattenExample (in category 'examples') -----
flattenExample "StrokeSimplifier flattenExample"
"This example demonstrate how aggressive the stroke recorder simplifies series of points"
| pts fc lastPt nextPt |
[Sensor anyButtonPressed] whileFalse.
+ fc := FormCanvas on: Display.
+ pts := self new.
+ lastPt := Sensor cursorPoint.
- fc _ FormCanvas on: Display.
- pts _ self new.
- lastPt _ Sensor cursorPoint.
pts add: lastPt.
[Sensor anyButtonPressed] whileTrue:[
+ nextPt := Sensor cursorPoint.
- nextPt _ Sensor cursorPoint.
nextPt = lastPt ifFalse:[
fc line: lastPt to: nextPt width: 3 color: Color black.
pts add: nextPt.
+ lastPt := nextPt.
- lastPt _ nextPt.
].
].
pts closeStroke.
(PolygonMorph vertices: pts finalStroke color: Color transparent borderWidth: 3 borderColor: Color black) makeOpen; addHandles; openInWorld.
!
Item was changed:
----- Method: StrokeSimplifier class>>smoothen:length: (in category 'instance creation') -----
smoothen: pointList length: unitLength
| prevPt curPt nextPt out prevMid nextMid segment length steps deltaT |
+ out := WriteStream on: (Array new: pointList size).
+ prevPt := pointList at: pointList size-1.
+ curPt := pointList last.
+ prevMid := (curPt + prevPt) * 0.5.
- out _ WriteStream on: (Array new: pointList size).
- prevPt _ pointList at: pointList size-1.
- curPt _ pointList last.
- prevMid _ (curPt + prevPt) * 0.5.
1 to: pointList size do:[:i|
+ nextPt := pointList at: i.
+ nextMid := (nextPt + curPt) * 0.5.
+ segment := Bezier2Segment from: prevMid to: nextMid via: curPt.
+ length := segment length.
+ steps := (length / unitLength) asInteger.
+ steps < 1 ifTrue:[steps := 1].
+ deltaT := 1.0 / steps.
- nextPt _ pointList at: i.
- nextMid _ (nextPt + curPt) * 0.5.
- segment _ Bezier2Segment from: prevMid to: nextMid via: curPt.
- length _ segment length.
- steps _ (length / unitLength) asInteger.
- steps < 1 ifTrue:[steps _ 1].
- deltaT _ 1.0 / steps.
1 to: steps-1 do:[:k|
out nextPut: (segment valueAt: deltaT * k)].
out nextPut: nextMid.
+ prevPt := curPt.
+ curPt := nextPt.
+ prevMid := nextMid.
- prevPt _ curPt.
- curPt _ nextPt.
- prevMid _ nextMid.
].
^out contents!
Item was changed:
----- Method: StrokeSimplifier>>addFirstPoint (in category 'simplification') -----
addFirstPoint
"No points in stroke yet. Add the very first point."
self addNextPoint.
+ finalPoint := firstPoint := lastPoint.
- finalPoint _ firstPoint _ lastPoint.
self addPoint: firstPoint position.!
Item was changed:
----- Method: StrokeSimplifier>>addNextPoint (in category 'simplification') -----
addNextPoint
lastStrokePoint ifNotNil:[
lastStrokePoint releaseCachedState.
lastStrokePoint nextPoint: lastPoint.
lastPoint prevPoint: lastStrokePoint.
self simplifyLineFrom: lastPoint.
].
+ lastStrokePoint := lastPoint.
+ distance := 0. "Distance since last stroke point"
+ samples := 0. "Samples since last stroke point"
+ time := 0. "Time since last stroke point"!
- lastStrokePoint _ lastPoint.
- distance _ 0. "Distance since last stroke point"
- samples _ 0. "Samples since last stroke point"
- time _ 0. "Time since last stroke point"!
Item was changed:
----- Method: StrokeSimplifier>>addPoint: (in category 'simplification') -----
addPoint: aPoint
| strokePoint |
+ strokePoint := self asStrokePoint: aPoint.
- strokePoint _ self asStrokePoint: aPoint.
strokePoint prevPoint: lastPoint.
lastPoint ifNotNil:[
+ lastPoint do:[:pt| lastPoint := pt].
- lastPoint do:[:pt| lastPoint _ pt].
lastPoint nextPoint: strokePoint.
lastPoint releaseCachedState].
+ lastPoint := strokePoint.
- lastPoint _ strokePoint.
points add: strokePoint.
simplifyStroke ifTrue:[self simplifyIncrementally].
!
Item was changed:
----- Method: StrokeSimplifier>>closeStroke (in category 'public') -----
closeStroke
"Close the current stroke"
+ lastPoint do:[:pt| lastPoint := pt].
- lastPoint do:[:pt| lastPoint _ pt].
lastPoint nextPoint: firstPoint.
self simplifyLineFrom: firstPoint.
+ firstPoint := firstPoint nextPoint.
- firstPoint _ firstPoint nextPoint.
self simplifyLineFrom: firstPoint.
+ firstPoint := firstPoint nextPoint.
- firstPoint _ firstPoint nextPoint.
self simplifyLineFrom: firstPoint.
firstPoint prevPoint nextPoint: nil.
firstPoint prevPoint: nil. !
Item was changed:
----- Method: StrokeSimplifier>>currentStroke (in category 'public') -----
currentStroke
"Return a copy of the current stroke.
As far as we have it, that is."
| pts |
+ pts := WriteStream on: (Array new: 100).
- pts _ WriteStream on: (Array new: 100).
firstPoint do:[:pt| pts nextPut: pt position].
^pts contents!
Item was changed:
----- Method: StrokeSimplifier>>finalizeStroke (in category 'public') -----
finalizeStroke
"Finalize the current stroke, e.g., remove the last point(s) if necessary"
| prevPt |
+ prevPt := lastPoint prevPoint.
- prevPt _ lastPoint prevPoint.
(prevPt prevPoint == nil or:[prevPt position = lastPoint position])
+ ifFalse:[lastPoint := prevPt].
- ifFalse:[lastPoint _ prevPt].
lastPoint nextPoint: nil.
firstPoint do:[:pt| pt isFinal: true].!
Item was changed:
----- Method: StrokeSimplifier>>initialize (in category 'initialize') -----
initialize
+ removeDuplicates := true.
+ simplifyStroke := true.
+ maxDistance := 10 squared.
+ maxSamples := 10.
+ maxTime := 1000.
- removeDuplicates _ true.
- simplifyStroke _ true.
- maxDistance _ 10 squared.
- maxSamples _ 10.
- maxTime _ 1000.
self reset.!
Item was changed:
----- Method: StrokeSimplifier>>next (in category 'public') -----
next
"Returns the next 'final' point, e.g., one that will not be affected by simplification later"
| thePoint |
(finalPoint notNil and:[finalPoint isFinal]) ifFalse:[^nil].
+ thePoint := finalPoint.
+ finalPoint := finalPoint nextPoint.
- thePoint _ finalPoint.
- finalPoint _ finalPoint nextPoint.
^thePoint!
Item was changed:
----- Method: StrokeSimplifier>>reset (in category 'initialize') -----
reset
+ points := OrderedCollection new: 100.
+ lastPoint := nil.
+ lastStrokePoint := nil.!
- points _ OrderedCollection new: 100.
- lastPoint _ nil.
- lastStrokePoint _ nil.!
Item was changed:
----- Method: StrokeSimplifier>>simplifyIncrementally (in category 'simplification') -----
simplifyIncrementally
"Simplify the last point that was added"
| prevPt dir |
lastStrokePoint ifNil:[^self addFirstPoint].
+ prevPt := (points at: points size-1).
+ dir := lastPoint position - prevPt position.
+ distance := distance + (dir dotProduct: dir). "e.g., distance^2"
+ samples := samples + 1.
+ "time := time + (points last key - (points at: points size-1) key)."
- prevPt _ (points at: points size-1).
- dir _ lastPoint position - prevPt position.
- distance _ distance + (dir dotProduct: dir). "e.g., distance^2"
- samples _ samples + 1.
- "time _ time + (points last key - (points at: points size-1) key)."
"If we have sampled too many points or went too far,
add the next point. This may eventually result in removing earlier points."
(samples >= maxSamples or:[distance >= maxDistance "or:[time > maxTime]"])
ifTrue:[^self addNextPoint].
"Note: We may want to add a time/speed feature in the future."!
Item was changed:
----- Method: StrokeSimplifier>>simplifyLineFrom: (in category 'simplification') -----
simplifyLineFrom: p5
"Remove a point if it represents the intermediate point of a line.
We only remove 'inner' points of a line, that is, for a sequence of points like
p1----p2----p3----p4---p5
we will remove only p3. This is so that any curve can be adequately represented, e.g., so that for a stroke running like:
p0
|
p1----p2----p3----p4----p5
|
|
p6
we will neither touch p2 (required for the curve p0,p1,p2) nor p5 yet (the shape of the curve relies on p6 which is not yet recorded."
| p4 p3 p2 p1 d1 d2 d3 d4 cosValue |
+ p4 := p5 prevPoint ifNil:[^self].
- p4 _ p5 prevPoint ifNil:[^self].
"Note: p4 (actually p1 from above) is final after we know the next point."
+ p3 := p4 prevPoint ifNil:[^p4 isFinal: true].
+ p2 := p3 prevPoint ifNil:[^self].
+ p1 := p2 prevPoint ifNil:[^self].
- p3 _ p4 prevPoint ifNil:[^p4 isFinal: true].
- p2 _ p3 prevPoint ifNil:[^self].
- p1 _ p2 prevPoint ifNil:[^self].
"First, compute the change in direction at p3 (this is the point we are *really* interested in)."
+ d2 := p2 forwardDirection.
+ d3 := p3 forwardDirection.
+ cosValue := d2 dotProduct: d3.
- d2 _ p2 forwardDirection.
- d3 _ p3 forwardDirection.
- cosValue _ d2 dotProduct: d3.
"See if the change is below the threshold for linearity.
Note that the above computes the cosine of the directional change
at p2,p3,p4 so that a value of 1.0 means no change at all, and -1.0
means a reversal of 180 degrees."
cosValue < 0.99 ifTrue:[
"0.999 arcCos radiansToDegrees is approx. 2.56 degrees.
If the cosine is less than we consider this line to be curved."
^p2 isFinal: true]. "we're done here"
"Okay, so the line is straight. Now make sure that the previous and the
next segment are straight as well (so that we don't remove a point which
defines the start/end of a curved segment)"
+ d1 := p1 forwardDirection.
+ cosValue := d1 dotProduct: d2.
- d1 _ p1 forwardDirection.
- cosValue _ d1 dotProduct: d2.
cosValue < 0.95 ifTrue:[
"0.99 arcCos radiansToDegrees is approx. 8 degrees"
^p2 isFinal: true].
"And the same for the last segment"
+ d4 := p4 forwardDirection.
+ cosValue := d3 dotProduct: d4.
- d4 _ p4 forwardDirection.
- cosValue _ d3 dotProduct: d4.
cosValue < 0.95 ifTrue:[
"0.99 arcCos radiansToDegrees is approx. 8 degrees"
^p2 isFinal: true].
"Okay, so p3 defines an inner point of a pretty straight line.
Let's get rid of it."
p2 nextPoint: p4.
p4 prevPoint: p2.
p2 releaseCachedState.
p3 releaseCachedState.
p4 releaseCachedState.!
Item was changed:
----- Method: Subdivision class>>example1 (in category 'examples') -----
example1 "Subdivision example1"
| ptList subdivision |
+ ptList := ((5 to: 35) collect:[:i| i*10 at 50]),
- ptList _ ((5 to: 35) collect:[:i| i*10 at 50]),
{350 at 75. 70 at 75. 70 at 100},
((7 to: 35) collect:[:i| i*10 at 100]),
{350 at 125. 50 at 125}.
+ subdivision := self points: ptList.
- subdivision _ self points: ptList.
self exampleDraw: subdivision points: ptList.
!
Item was changed:
----- Method: Subdivision class>>example2 (in category 'examples') -----
example2 "Subdivision example2"
"Same as example1, but this time using the outline constraints"
| ptList subdivision |
+ ptList := ((5 to: 35) collect:[:i| i*10 at 50]),
- ptList _ ((5 to: 35) collect:[:i| i*10 at 50]),
{350 at 75. 70 at 75. 70 at 100},
((7 to: 35) collect:[:i| i*10 at 100]),
{350 at 125. 50 at 125}.
+ subdivision := (self points: ptList) constraintOutline: ptList; yourself.
- subdivision _ (self points: ptList) constraintOutline: ptList; yourself.
self exampleDraw: subdivision points: ptList.
!
Item was changed:
----- Method: Subdivision class>>example3 (in category 'examples') -----
example3 "Subdivision example3"
"Same as example2 but marking edges"
| ptList subdivision |
+ ptList := ((5 to: 35) collect:[:i| i*10 at 50]),
- ptList _ ((5 to: 35) collect:[:i| i*10 at 50]),
{350 at 75. 70 at 75. 70 at 100},
((7 to: 35) collect:[:i| i*10 at 100]),
{350 at 125. 50 at 125}.
+ subdivision := (self points: ptList) constraintOutline: ptList; yourself.
- subdivision _ (self points: ptList) constraintOutline: ptList; yourself.
subdivision markExteriorEdges.
self exampleDraw: subdivision points: ptList.
!
Item was changed:
----- Method: Subdivision class>>example4 (in category 'examples') -----
example4 "Subdivision example4"
"A nasty self-intersecting shape"
"Same as example2 but marking edges"
| ptList subdivision |
+ ptList := {
- ptList _ {
50 at 100.
100 at 100.
150 at 100.
150 at 150.
100 at 150.
100 at 100.
100 at 50.
300 at 50.
300 at 300.
50 at 300.
}.
+ subdivision := (self points: ptList) constraintOutline: ptList; yourself.
- subdivision _ (self points: ptList) constraintOutline: ptList; yourself.
subdivision markExteriorEdges.
self exampleDraw: subdivision points: ptList.
!
Item was changed:
----- Method: Subdivision class>>exampleDraw:points: (in category 'examples') -----
exampleDraw: subdivision points: ptList
| canvas |
Display fillWhite.
+ canvas := Display getCanvas.
- canvas _ Display getCanvas.
subdivision edgesDo:[:e|
canvas line: e origin to: e destination width: 1 color: e classificationColor].
ptList do:[:pt|
canvas fillRectangle: (pt - 1 extent: 3 at 3) color: Color red.
].
Display restoreAfter:[].!
Item was changed:
----- Method: Subdivision>>assureEdgeFrom:to:lastEdge: (in category 'constraints') -----
assureEdgeFrom: lastPt to: nextPt lastEdge: lastEdge
"Find and return the edge connecting nextPt and lastPt.
lastEdge starts at lastPt so we can simply run around all
the edges at lastPt and find one that ends in nextPt.
If none is found, subdivide between lastPt and nextPt."
| nextEdge destPt |
+ nextEdge := lastEdge.
+ [destPt := nextEdge destination.
- nextEdge _ lastEdge.
- [destPt _ nextEdge destination.
destPt x = nextPt x and:[destPt y = nextPt y]] whileFalse:[
+ nextEdge := nextEdge originNext.
- nextEdge _ nextEdge originNext.
nextEdge = lastEdge ifTrue:[
"Edge not found. Subdivide and start over"
+ nextEdge := self insertEdgeFrom: lastPt to: nextPt lastEdge: lastEdge.
- nextEdge _ self insertEdgeFrom: lastPt to: nextPt lastEdge: lastEdge.
nextEdge ifNil:[^nil].
].
].
nextEdge isBorderEdge: true.
^nextEdge
!
Item was changed:
----- Method: Subdivision>>assureEdgeFrom:to:lastEdge:into: (in category 'constraints') -----
assureEdgeFrom: lastPt to: nextPt lastEdge: lastEdge into: outPoints
"Find and return the edge connecting nextPt and lastPt.
lastEdge starts at lastPt so we can simply run around all
the edges at lastPt and find one that ends in nextPt.
If none is found, subdivide between lastPt and nextPt."
| nextEdge destPt |
+ nextEdge := lastEdge.
+ [destPt := nextEdge destination.
- nextEdge _ lastEdge.
- [destPt _ nextEdge destination.
destPt x = nextPt x and:[destPt y = nextPt y]] whileFalse:[
+ nextEdge := nextEdge originNext.
- nextEdge _ nextEdge originNext.
nextEdge = lastEdge ifTrue:[
"Edge not found. Subdivide and start over"
+ nextEdge := self insertEdgeFrom: lastPt to: nextPt lastEdge: lastEdge into: outPoints.
- nextEdge _ self insertEdgeFrom: lastPt to: nextPt lastEdge: lastEdge into: outPoints.
nextEdge ifNil:[^nil].
].
].
nextEdge isBorderEdge: true.
^nextEdge
!
Item was changed:
----- Method: Subdivision>>constraintOutline: (in category 'constraints') -----
constraintOutline: pointList
"Make sure all line segments in the given closed outline appear in the triangulation."
| lastPt nextPt lastEdge nextEdge outPoints |
+ outlineThreshold ifNil:[outlineThreshold := 1.0e-3].
+ lastPt := pointList last.
+ lastEdge := self locatePoint: lastPt.
- outlineThreshold ifNil:[outlineThreshold _ 1.0e-3].
- lastPt _ pointList last.
- lastEdge _ self locatePoint: lastPt.
lastEdge origin = lastPt
+ ifFalse:[lastEdge := lastEdge symmetric].
- ifFalse:[lastEdge _ lastEdge symmetric].
outPoints := WriteStream on: (Array new: pointList size).
1 to: pointList size do:[:i|
+ nextPt := pointList at: i.
- nextPt _ pointList at: i.
lastPt = nextPt ifFalse:[
+ nextEdge := self assureEdgeFrom: lastPt to: nextPt lastEdge: lastEdge into: outPoints.
- nextEdge _ self assureEdgeFrom: lastPt to: nextPt lastEdge: lastEdge into: outPoints.
outPoints nextPut: nextPt.
nextEdge ifNil:[
+ nextEdge := self locatePoint: nextPt.
- nextEdge _ self locatePoint: nextPt.
lastEdge destination = nextPt
+ ifFalse:[lastEdge := lastEdge symmetric].
- ifFalse:[lastEdge _ lastEdge symmetric].
].
+ lastEdge := nextEdge symmetric originNext].
+ lastPt := nextPt.
- lastEdge _ nextEdge symmetric originNext].
- lastPt _ nextPt.
].
^outPoints contents!
Item was changed:
----- Method: Subdivision>>debugDraw (in category 'private') -----
debugDraw
| scale ofs |
+ scale := 100.
+ ofs := 400.
- scale _ 100.
- ofs _ 400.
self edgesDo:[:e|
Display getCanvas line: e origin * scale + ofs to: e destination * scale + ofs width: 3 color: e classificationColor].!
Item was changed:
----- Method: Subdivision>>edgesDo: (in category 'private') -----
edgesDo: aBlock
+ startingEdge first edgesDo: aBlock stamp: (stamp := stamp + 1).!
- startingEdge first edgesDo: aBlock stamp: (stamp _ stamp + 1).!
Item was changed:
----- Method: Subdivision>>faces (in category 'accessing') -----
faces
"Construct and return triangles"
| firstEdge nextEdge lastEdge |
+ firstEdge := nextEdge := startingEdge first.
+ [lastEdge := nextEdge.
+ nextEdge := nextEdge originNext.
- firstEdge _ nextEdge _ startingEdge first.
- [lastEdge _ nextEdge.
- nextEdge _ nextEdge originNext.
nextEdge == firstEdge] whileFalse:[
"Make up a triangle between lastEdge and nextEdge"
].
!
Item was changed:
----- Method: Subdivision>>findEdgeFrom:to:lastEdge: (in category 'constraints') -----
findEdgeFrom: lastPt to: nextPt lastEdge: lastEdge
"Find and return the edge connecting nextPt and lastPt.
lastEdge starts at lastPt so we can simply run around all
the edges at lastPt and find one that ends in nextPt."
| nextEdge destPt |
+ nextEdge := lastEdge.
+ [destPt := nextEdge destination.
- nextEdge _ lastEdge.
- [destPt _ nextEdge destination.
destPt x = nextPt x and:[destPt y = nextPt y]] whileFalse:[
+ nextEdge := nextEdge originNext.
- nextEdge _ nextEdge originNext.
nextEdge = lastEdge ifTrue:[^nil].
].
^nextEdge!
Item was changed:
----- Method: Subdivision>>innerTriangleEdgesDo: (in category 'private') -----
innerTriangleEdgesDo: aBlock
+ startingEdge first triangleEdges: (stamp := stamp + 1) do:
- startingEdge first triangleEdges: (stamp _ stamp + 1) do:
[:e1 :e2 :e3|
self assert:[e1 origin = e3 destination].
self assert:[e2 origin = e1 destination].
self assert:[e3 origin = e2 destination].
(e1 isExteriorEdge or:[e2 isExteriorEdge or:[e3 isExteriorEdge]]) ifFalse:[
aBlock value: e1 value: e2 value: e3.
].
].
!
Item was changed:
----- Method: Subdivision>>innerTriangleVerticesDo: (in category 'private') -----
innerTriangleVerticesDo: aBlock
+ startingEdge first triangleEdges: (stamp := stamp + 1) do:
- startingEdge first triangleEdges: (stamp _ stamp + 1) do:
[:e1 :e2 :e3|
self assert:[e1 origin = e3 destination].
self assert:[e2 origin = e1 destination].
self assert:[e3 origin = e2 destination].
(e1 isExteriorEdge or:[e2 isExteriorEdge or:[e3 isExteriorEdge]]) ifFalse:[
aBlock value: e1 origin value: e2 origin value: e3 origin.
].
].
!
Item was changed:
----- Method: Subdivision>>innerTriangles (in category 'private') -----
innerTriangles
| out |
+ out := WriteStream on: (Array new: 100).
- out _ WriteStream on: (Array new: 100).
self innerTriangleVerticesDo:[:p1 :p2 :p3| out nextPut: {p1. p2. p3}].
^out contents!
Item was changed:
----- Method: Subdivision>>insertEdgeFrom:to:lastEdge: (in category 'constraints') -----
insertEdgeFrom: lastPt to: nextPt lastEdge: prevEdge
| midPt lastEdge nextEdge dst |
+ dst := lastPt - nextPt.
- dst _ lastPt - nextPt.
(dst dotProduct: dst) < outlineThreshold ifTrue:[^nil].
+ midPt := lastPt interpolateTo: nextPt at: 0.5.
- midPt _ lastPt interpolateTo: nextPt at: 0.5.
self insertPoint: midPt.
+ lastEdge := prevEdge.
+ nextEdge := self assureEdgeFrom: lastPt to: midPt lastEdge: lastEdge.
- lastEdge _ prevEdge.
- nextEdge _ self assureEdgeFrom: lastPt to: midPt lastEdge: lastEdge.
nextEdge ifNil:[^nil].
+ lastEdge := nextEdge symmetric originNext.
+ nextEdge := self assureEdgeFrom: midPt to: nextPt lastEdge: lastEdge.
- lastEdge _ nextEdge symmetric originNext.
- nextEdge _ self assureEdgeFrom: midPt to: nextPt lastEdge: lastEdge.
^nextEdge!
Item was changed:
----- Method: Subdivision>>insertEdgeFrom:to:lastEdge:into: (in category 'constraints') -----
insertEdgeFrom: lastPt to: nextPt lastEdge: prevEdge into: outPoints
| midPt lastEdge nextEdge dst |
+ dst := lastPt - nextPt.
- dst _ lastPt - nextPt.
(dst dotProduct: dst) < outlineThreshold ifTrue:[^nil].
+ midPt := lastPt interpolateTo: nextPt at: 0.5.
- midPt _ lastPt interpolateTo: nextPt at: 0.5.
self insertPoint: midPt.
+ lastEdge := prevEdge.
+ nextEdge := self assureEdgeFrom: lastPt to: midPt lastEdge: lastEdge into: outPoints.
- lastEdge _ prevEdge.
- nextEdge _ self assureEdgeFrom: lastPt to: midPt lastEdge: lastEdge into: outPoints.
outPoints nextPut: midPt.
nextEdge ifNil:[^nil].
+ lastEdge := nextEdge symmetric originNext.
+ nextEdge := self assureEdgeFrom: midPt to: nextPt lastEdge: lastEdge into: outPoints.
- lastEdge _ nextEdge symmetric originNext.
- nextEdge _ self assureEdgeFrom: midPt to: nextPt lastEdge: lastEdge into: outPoints.
^nextEdge!
Item was changed:
----- Method: Subdivision>>insertSpine (in category 'constraints') -----
insertSpine
| ptList start end |
+ ptList := WriteStream on: (Array new: 100).
- ptList _ WriteStream on: (Array new: 100).
self edgesDo:[:e|
(e isBorderEdge or:[e isExteriorEdge]) ifFalse:[
+ start := e origin.
+ end := e destination.
- start _ e origin.
- end _ e destination.
ptList nextPut: (start + end * 0.5).
].
].
ptList contents do:[:pt| self insertPoint: pt].!
Item was changed:
----- Method: Subdivision>>markExteriorEdges (in category 'constraints') -----
markExteriorEdges
"Recursively flag all edges that are known to be exterior edges.
If the outline shape is not simple this may result in marking all edges."
| firstEdge |
+ firstEdge := self locatePoint: point1.
- firstEdge _ self locatePoint: point1.
firstEdge origin = point1
+ ifFalse:[firstEdge := firstEdge symmetric].
+ firstEdge markExteriorEdges: (stamp := stamp + 1).!
- ifFalse:[firstEdge _ firstEdge symmetric].
- firstEdge markExteriorEdges: (stamp _ stamp + 1).!
Item was changed:
----- Method: Subdivision>>markExteriorEdges:in: (in category 'constraints') -----
markExteriorEdges: thisWay in: pointList
"Mark edges as exteriors"
| lastPt nextPt lastEdge nextEdge |
+ lastPt := pointList last.
+ lastEdge := self locatePoint: lastPt.
- lastPt _ pointList last.
- lastEdge _ self locatePoint: lastPt.
lastEdge origin = lastPt
+ ifFalse:[lastEdge := lastEdge symmetric].
+ nextEdge := self findEdgeFrom: lastPt to: (pointList atWrap: pointList size-1) lastEdge: lastEdge.
- ifFalse:[lastEdge _ lastEdge symmetric].
- nextEdge _ self findEdgeFrom: lastPt to: (pointList atWrap: pointList size-1) lastEdge: lastEdge.
lastEdge := nextEdge.
1 to: pointList size do:[:i|
+ nextPt := pointList at: i.
- nextPt _ pointList at: i.
lastPt = nextPt ifFalse:[
+ nextEdge := self findEdgeFrom: lastPt to: nextPt lastEdge: lastEdge.
- nextEdge _ self findEdgeFrom: lastPt to: nextPt lastEdge: lastEdge.
nextEdge ifNil:[
+ nextEdge := self locatePoint: nextPt.
- nextEdge _ self locatePoint: nextPt.
lastEdge destination = nextPt
+ ifFalse:[lastEdge := lastEdge symmetric].
- ifFalse:[lastEdge _ lastEdge symmetric].
] ifNotNil:[
self flagExteriorEdgesFrom: lastEdge to: nextEdge direction: thisWay.
].
+ lastEdge := nextEdge symmetric].
+ lastPt := nextPt.
- lastEdge _ nextEdge symmetric].
- lastPt _ nextPt.
].
!
Item was changed:
----- Method: Subdivision>>outlineThreshold: (in category 'accessing') -----
outlineThreshold: aNumber
"Set the current outline threshold.
The outline threshold determines when to stop recursive
subdivision of outline edges in the case of non-simple
(that is self-intersecting) polygons."
+ outlineThreshold := aNumber!
- outlineThreshold _ aNumber!
Item was changed:
----- Method: Subdivision>>p1:p2:p3: (in category 'initialize-release') -----
p1: pt1 p2: pt2 p3: pt3
| ea eb ec |
+ point1 := pt1.
+ point2 := pt2.
+ point3 := pt3.
+ stamp := 0.
- point1 _ pt1.
- point2 _ pt2.
- point3 _ pt3.
- stamp _ 0.
ea := self quadEdgeClass new.
(ea first) origin: pt1; destination: pt2.
eb := self quadEdgeClass new.
self splice: ea first symmetric with: eb first.
(eb first) origin: pt2; destination: pt3.
ec := self quadEdgeClass new.
self splice: eb first symmetric with: ec first.
(ec first) origin: pt3; destination: pt1.
self splice: ec first symmetric with: ea first.
startingEdge := ea.
!
Item was changed:
----- Method: Subdivision>>trianglesDo: (in category 'private') -----
trianglesDo: aBlock
"Return the full triangulation of the receiver"
+ startingEdge first triangleEdges: (stamp := stamp + 1) do: aBlock.
- startingEdge first triangleEdges: (stamp _ stamp + 1) do: aBlock.
!
Item was changed:
----- Method: SubdivisionHalfEdge>>markExteriorEdges: (in category 'enumeration') -----
markExteriorEdges: timeStamp
| nextEdge |
quadEdge timeStamp = timeStamp ifTrue:[^self].
quadEdge timeStamp: timeStamp.
self isExteriorEdge: true.
+ nextEdge := self.
+ [nextEdge := nextEdge originNext.
- nextEdge _ self.
- [nextEdge _ nextEdge originNext.
nextEdge == self or:[nextEdge isBorderEdge]] whileFalse:[
nextEdge symmetric markExteriorEdges: timeStamp.
].
+ nextEdge := self.
+ [nextEdge := nextEdge originPrev.
- nextEdge _ self.
- [nextEdge _ nextEdge originPrev.
nextEdge == self or:[nextEdge isBorderEdge]] whileFalse:[
nextEdge symmetric markExteriorEdges: timeStamp.
].!
Item was changed:
----- Method: SubdivisionHalfEdge>>nextBorderEdge (in category 'accessing') -----
nextBorderEdge
| edge |
+ edge := self originNext.
- edge _ self originNext.
[edge == self] whileFalse:[
edge isBorderEdge ifTrue:[^edge symmetric].
+ edge := edge originNext].
- edge _ edge originNext].
^nil!
Item was changed:
----- Method: SubdivisionHalfEdge>>triangleEdges:do: (in category 'enumeration') -----
triangleEdges: timeStamp do: aBlock
| e1 e2 e3 |
"Evaluate aBlock with all edges making up triangles"
quadEdge timeStamp = timeStamp ifTrue:[^self].
quadEdge timeStamp: timeStamp.
+ e1 := self.
+ e3 := self originNext symmetric.
+ e2 := e3 originNext symmetric.
- e1 _ self.
- e3 _ self originNext symmetric.
- e2 _ e3 originNext symmetric.
(e2 timeStamp = timeStamp or:[e3 timeStamp = timeStamp])
ifFalse:[aBlock value: e1 value: e2 value: e3].
+ e1 := self originPrev.
+ e3 := self symmetric.
+ e2 := e3 originNext symmetric.
- e1 _ self originPrev.
- e3 _ self symmetric.
- e2 _ e3 originNext symmetric.
(e1 timeStamp = timeStamp or:[e2 timeStamp = timeStamp])
ifFalse:[aBlock value: e1 value: e2 value: e3].
self originNext triangleEdges: timeStamp do: aBlock.
self originPrev triangleEdges: timeStamp do: aBlock.
self destNext triangleEdges: timeStamp do: aBlock.
self destPrev triangleEdges: timeStamp do: aBlock.!
Item was changed:
----- Method: SubdivisionQuadEdge>>classificationColor (in category 'accessing') -----
classificationColor
"Return the classification index of the receiver"
| r g b |
+ r := self isInteriorEdge ifTrue:[1] ifFalse:[0].
+ g := self isExteriorEdge ifTrue:[1] ifFalse:[0].
+ b := self isBorderEdge ifTrue:[1] ifFalse:[0].
- r _ self isInteriorEdge ifTrue:[1] ifFalse:[0].
- g _ self isExteriorEdge ifTrue:[1] ifFalse:[0].
- b _ self isBorderEdge ifTrue:[1] ifFalse:[0].
^Color r: r g: g b: b.!
Item was changed:
----- Method: SubdivisionQuadEdge>>flags: (in category 'accessing') -----
flags: newFlags
+ flags := newFlags!
- flags _ newFlags!
Item was changed:
----- Method: SubdivisionQuadEdge>>initialize (in category 'initialize-release') -----
initialize
edges := Array new: 4.
1 to: 4 do:[:i| edges at: i put: (self edgeClass new id: i owner: self)].
(edges at: 1) next: (edges at: 1).
(edges at: 2) next: (edges at: 4).
(edges at: 3) next: (edges at: 3).
(edges at: 4) next: (edges at: 2).
timeStamp := 0.
+ flags := 0.!
- flags _ 0.!
Item was changed:
----- Method: SubdivisionQuadEdge>>isBorderEdge: (in category 'accessing') -----
isBorderEdge: aBool
+ flags := aBool ifTrue:[flags bitOr: 1] ifFalse:[flags bitClear: 1].!
- flags _ aBool ifTrue:[flags bitOr: 1] ifFalse:[flags bitClear: 1].!
Item was changed:
----- Method: SubdivisionQuadEdge>>isExteriorEdge: (in category 'accessing') -----
isExteriorEdge: aBool
+ flags := aBool ifTrue:[flags bitOr: 4] ifFalse:[flags bitClear: 4].!
- flags _ aBool ifTrue:[flags bitOr: 4] ifFalse:[flags bitClear: 4].!
Item was changed:
----- Method: SubdivisionQuadEdge>>isInteriorEdge: (in category 'accessing') -----
isInteriorEdge: aBool
+ flags := aBool ifTrue:[flags bitOr: 2] ifFalse:[flags bitClear: 2].!
- flags _ aBool ifTrue:[flags bitOr: 2] ifFalse:[flags bitClear: 2].!
Item was changed:
----- Method: SugarButton>>disabledImage: (in category 'accessing') -----
disabledImage: aForm
+ disabledImage := aForm.
- disabledImage _ aForm.
!
Item was changed:
----- Method: SugarButton>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| origin |
+ image ifNil: [origin := 0 at 0] ifNotNil: [origin := bounds origin + ((bounds extent - image extent) // 2)].
- image ifNil: [origin _ 0 at 0] ifNotNil: [origin _ bounds origin + ((bounds extent - image extent) // 2)].
state == #disabled ifTrue: [
aCanvas fillRectangle: self bounds fillStyle: color.
disabledImage ifNotNil: [^ aCanvas translucentImage: disabledImage at: origin]].
state == #off ifTrue: [
aCanvas fillRectangle: self bounds fillStyle: color.
offImage ifNotNil: [^ aCanvas translucentImage: offImage at: origin]].
image ifNotNil: [
aCanvas fillRectangle: self bounds fillStyle: (highLightColor ifNil: [color]).
aCanvas translucentImage: image at: origin].!
Item was changed:
----- Method: SugarButton>>highLightColor: (in category 'accessing') -----
highLightColor: aColor
+ highLightColor := aColor.
- highLightColor _ aColor.
!
Item was changed:
----- Method: SugarButton>>initialize (in category 'initialization') -----
initialize
super initialize.
+ highLightColor := Color black.
- highLightColor _ Color black.
self setProperty: #wantsHaloFromClick toValue: false.
!
Item was changed:
----- Method: SugarButton>>mouseDown: (in category 'event handling') -----
mouseDown: evt
super mouseDown: evt.
+ mouseDownTime := Time millisecondClockValue.
+ didMenu := nil.
- mouseDownTime _ Time millisecondClockValue.
- didMenu _ nil.
!
Item was changed:
----- Method: SugarButton>>mouseStillDown: (in category 'event handling') -----
mouseStillDown: evt
(mouseDownTime isNil or: [(Time millisecondClockValue - mouseDownTime) abs < 1000]) ifTrue: [
^super mouseStillDown: evt
].
didMenu ifNotNil: [^super mouseStillDown: evt].
+ didMenu := target showMenuFor: actionSelector event: evt.
- didMenu _ target showMenuFor: actionSelector event: evt.
!
Item was changed:
----- Method: SugarButton>>naviHeight: (in category 'geometry') -----
naviHeight: anInteger
| imageSize |
+ imageSize := image
- imageSize _ image
ifNotNil: [(anInteger * (image height asFloat / self height)) asInteger]
ifNil: [(anInteger * 0.6) asInteger].
+ imageSize := imageSize at imageSize.
- imageSize _ imageSize at imageSize.
+ image ifNotNil: [image := image scaledToSize: imageSize].
+ offImage ifNotNil: [offImage := offImage scaledToSize: imageSize].
+ pressedImage ifNotNil: [pressedImage := pressedImage scaledToSize: imageSize].
+ disabledImage ifNotNil: [disabledImage := disabledImage scaledToSize: imageSize].
- image ifNotNil: [image _ image scaledToSize: imageSize].
- offImage ifNotNil: [offImage _ offImage scaledToSize: imageSize].
- pressedImage ifNotNil: [pressedImage _ pressedImage scaledToSize: imageSize].
- disabledImage ifNotNil: [disabledImage _ disabledImage scaledToSize: imageSize].
super extent: anInteger at anInteger.
!
Item was changed:
----- Method: SugarLibrary class>>clearDefault (in category 'singleton management') -----
clearDefault
"
SugarLibrary clearDefault
"
+ Default := nil.
- Default _ nil.
!
Item was changed:
----- Method: SugarLibrary class>>default (in category 'singleton management') -----
default
"Answer the default instance of the receiver, which is held as a class variable. If the Default is not yet set up, set it up at this time."
+ ^ Default ifNil: [Default := self newDefault].
- ^ Default ifNil: [Default _ self newDefault].
"
Default := nil.
"
!
Item was changed:
----- Method: SugarLibrary>>imageFor:color:grayOutColor: (in category 'icon images') -----
imageFor: aString color: aColor grayOutColor: grayOutColor
"Answer an image corresponding to the given string, using the specified color scheme."
| icon g h orig w height ret f |
+ icon := self iconAt: aString ifAbsent: [self iconAt: #missingIcon].
- icon _ self iconAt: aString ifAbsent: [self iconAt: #missingIcon].
icon unhibernate.
grayOutColor ifNotNil: [
+ f := Form extent: icon extent depth: 32.
- f _ Form extent: icon extent depth: 32.
f fillColor: grayOutColor.
icon displayOn: f at: 0 at 0 rule: 37.
+ icon := f.
- icon _ f.
].
+ orig := Form new hackBits: icon bits.
+ height := icon width * icon height.
- orig _ Form new hackBits: icon bits.
- height _ icon width * icon height.
+ g := Form extent: icon extent depth: 32.
+ h := Form new hackBits: g bits.
- g _ Form extent: icon extent depth: 32.
- h _ Form new hackBits: g bits.
+ w := WarpBlt current toForm: h.
- w _ WarpBlt current toForm: h.
w sourceForm: orig.
w cellSize: 1.
w combinationRule: Form over.
w copyQuad: {1 at 0. 1 at height. 2 at height. 2 at 0} toRect: (0 at 0 corner: 4@(height + 1)).
+ ret := (Form extent: icon extent depth: 32) fillColor: aColor.
- ret _ (Form extent: icon extent depth: 32) fillColor: aColor.
g displayOn: ret at: 0 rule: 34.
^ ret asFormOfDepth: 16!
Item was changed:
----- Method: SugarLibrary>>initialize (in category 'icon images') -----
initialize
super initialize.
+ iconDictionary := Dictionary new.
- iconDictionary _ Dictionary new.
!
Item was changed:
----- Method: SugarLibrary>>makeButton:balloonText:for:target:baseColor:highLightColor: (in category 'icon images') -----
makeButton: aString balloonText: anotherString for: aSymbol target: target baseColor: baseColor highLightColor: highLightColor
"Answer a SugarButton constructed from the arguments."
| s keyString img |
+ keyString := aSymbol asString.
+ s := SugarButton new.
+ img := self iconAt: aString ifAbsent: [self iconAt: #missingIcon].
- keyString _ aSymbol asString.
- s _ SugarButton new.
- img _ self iconAt: aString ifAbsent: [self iconAt: #missingIcon].
self recolorButton: s for: keyString baseColor: baseColor highLightColor: highLightColor.
s extent: img extent + (25 at 25).
s target: target.
s actionSelector: aSymbol.
s setBalloonText: anotherString.
^ s!
Item was changed:
----- Method: SugarLibrary>>recolorButton:for:baseColor:highLightColor: (in category 'icon images') -----
recolorButton: aSugarButton for: aSymbol baseColor: baseColor highLightColor: highLightColor
| keyString |
+ keyString := aSymbol asString.
- keyString _ aSymbol asString.
aSugarButton color: baseColor.
aSugarButton onImage: (self imageFor: keyString color: highLightColor).
aSugarButton offImage: (self imageFor: keyString color: baseColor).
aSugarButton disabledImage: (self imageFor: keyString color: baseColor grayOutColor: Color gray).
aSugarButton highLightColor: highLightColor.
^ aSugarButton.
!
Item was changed:
----- Method: SugarNavTab>>changeNaviHeight (in category 'events') -----
changeNaviHeight
| f n |
referent ifNil: [^ self].
+ f := FillInTheBlank request: 'new height of the bar' initialAnswer: referent height asString.
+ n := f asNumber min: (Display height // 2) max: 0.
- f _ FillInTheBlank request: 'new height of the bar' initialAnswer: referent height asString.
- n _ f asNumber min: (Display height // 2) max: 0.
self naviHeight: n.!
Item was changed:
----- Method: SugarNavTab>>setEdgeToAdhereTo (in category 'menu') -----
setEdgeToAdhereTo
| aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
#(top bottom) do:
[:sym | aMenu add: sym asString translated target: self selector: #setEdge: argument: sym].
aMenu popUpEvent: self currentEvent in: self world!
Item was changed:
----- Method: SugarNavTab>>showFlap (in category 'positioning') -----
showFlap
"Open the flap up"
| thicknessToUse flapOwner |
"19 sept 2000 - going for all paste ups <- raa note"
self lazyUnhibernate.
+ flapOwner := self pasteUpMorph.
- flapOwner _ self pasteUpMorph.
self referentThickness <= 0
ifTrue:
+ [thicknessToUse := lastReferentThickness ifNil: [100].
- [thicknessToUse _ lastReferentThickness ifNil: [100].
self orientation == #horizontal
ifTrue:
[referent height: thicknessToUse]
ifFalse:
[referent width: thicknessToUse]].
inboard ifTrue:
[self stickOntoReferent]. "makes referent my owner, and positions me accordingly"
referent pasteUpMorph == flapOwner
ifFalse:
[flapOwner accommodateFlap: self. "Make room if needed"
self addMorph: referent.
flapOwner startSteppingSubmorphsOf: referent.
self positionReferent.
referent adaptToWorld: flapOwner].
inboard ifFalse:
[self adjustPositionVisAVisFlap].
+ flapShowing := false. "This is really tricky... It is a way to always show it"
- flapShowing _ false. "This is really tricky... It is a way to always show it"
self owner addMorphBack: self.
!
Item was changed:
----- Method: SugarNavTab>>spanWorld (in category 'positioning') -----
spanWorld
"Make the receiver's height or width commensurate with that of the container."
| container |
self collapsedMode ifTrue:
[^ self occupyTopRightCorner].
+ container := self pasteUpMorph ifNil: [self currentWorld].
- container _ self pasteUpMorph ifNil: [self currentWorld].
(self orientation == #vertical) ifTrue: [
referent vResizing == #rigid
ifTrue:[referent spanContainerVertically: container height].
referent hResizing == #rigid
ifTrue:[referent width: (referent width min: container width - self width)].
referent top: container top + self referentMargin y.
] ifFalse: [
referent hResizing == #rigid
ifTrue:[referent width: container width].
referent vResizing == #rigid
ifTrue:[referent height: (referent height min: container height - self height)].
referent left: container left + self referentMargin x.
] !
Item was changed:
----- Method: SugarNavigatorBar class>>current (in category 'instance creation') -----
current
| flap |
+ flap := Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
- flap _ Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
flap ifNil: [^ nil].
(flap referent isMemberOf: SugarNavigatorBar) ifFalse: [^ nil].
^ flap referent.
!
Item was changed:
----- Method: SugarNavigatorBar class>>putUpInitialBalloonHelp (in category 'utilitity') -----
putUpInitialBalloonHelp
| flap |
+ flap := Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
- flap _ Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
flap ifNil: [^ self].
(flap referent isMemberOf: SugarNavigatorBar) ifFalse: [^ self].
flap referent putUpInitialBalloonHelp
!
Item was changed:
----- Method: SugarNavigatorBar class>>refreshButRetainOldContents (in category 'instance creation') -----
refreshButRetainOldContents
"
SugarNavigatorBar refreshButRetainOldContents
"
| supplies objects nav nonStandard color highlight height |
+ nav := Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
- nav _ Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
nav ifNotNil: [
+ nonStandard := nav nonStandardMorphs.
+ color := nav referent color.
+ highlight := nav referent highlightColor.
+ height := nav referent height.
- nonStandard _ nav nonStandardMorphs.
- color _ nav referent color.
- highlight _ nav referent highlightColor.
- height _ nav referent height.
] ifNil: [
+ nonStandard := #().
+ color := nil.
+ highlight := nil.
+ height := nil].
+ supplies := Flaps globalFlapTabWithID: 'Supplies' translated.
+ supplies ifNotNil: [supplies := supplies referent].
+ (supplies isMemberOf: PartsBin) ifTrue: [objects := supplies savedUserDefinedObjects] ifFalse: [objects := nil].
- nonStandard _ #().
- color _ nil.
- highlight _ nil.
- height _ nil].
- supplies _ Flaps globalFlapTabWithID: 'Supplies' translated.
- supplies ifNotNil: [supplies _ supplies referent].
- (supplies isMemberOf: PartsBin) ifTrue: [objects _ supplies savedUserDefinedObjects] ifFalse: [objects _ nil].
Flaps disableGlobalFlaps: false.
Flaps enableEToyFlaps.
+ nav := Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
- nav _ Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated.
nonStandard ifNotNil: [
nonStandard do: [:p |
nav addMorphFront: p first.
p first position: (nav position + p second)
]
].
(color notNil and: [highlight notNil and: [height notNil]]) ifTrue: [nav referent color: color highLightColor: highlight. nav naviHeight: height].
objects ifNotNil: [
+ supplies := Flaps globalFlapTabWithID: 'Supplies' translated.
+ supplies ifNotNil: [supplies := supplies referent].
- supplies _ Flaps globalFlapTabWithID: 'Supplies' translated.
- supplies ifNotNil: [supplies _ supplies referent].
(supplies isMemberOf: PartsBin) ifTrue: [supplies restoreUserDefinedObjectsFrom: objects].
]!
Item was changed:
----- Method: SugarNavigatorBar>>availableDisplayModes (in category 'buttons creation') -----
availableDisplayModes
"Answer an array of available screen modes. The full-screen item is not included now."
| ret actual desired |
+ ret := OrderedCollection new: 3.
- ret _ OrderedCollection new: 3.
ret add: #physical.
+ actual := DisplayScreen actualScreenSize.
+ desired := OLPCVirtualScreen virtualScreenExtent.
- actual _ DisplayScreen actualScreenSize.
- desired _ OLPCVirtualScreen virtualScreenExtent.
actual = desired ifTrue: [^ ret].
ret add: #scaledVirtual.
(actual x > desired x and: [actual y > desired y]) ifTrue:
[ret add: #centeredVirtual].
^ ret asArray!
Item was changed:
----- Method: SugarNavigatorBar>>buttonShare (in category 'buttons creation') -----
buttonShare
"Answer an new instance of a 'Share' button."
+ ^ shareButton := self makeButton: 'Share'
- ^ shareButton _ self makeButton: 'Share'
balloonText: 'Enable sharing. When another user joins, you can exchange objects.' translated
for: #shareMenu!
Item was changed:
----- Method: SugarNavigatorBar>>buttonUndo (in category 'buttons creation') -----
buttonUndo
"Build and return a fresh Undo button for me."
+ undoButton := self makeButton: 'undo' balloonText: 'Undo the last change' translated for: #undoOrRedoLastCommand.
- undoButton _ self makeButton: 'undo' balloonText: 'Undo the last change' translated for: #undoOrRedoLastCommand.
^ undoButton.
!
Item was changed:
----- Method: SugarNavigatorBar>>checkForResize (in category 'morphic interaction') -----
checkForResize
"Check to see if the receiver needs to be reconfigured because of a world resize."
| shouldResize h worldBounds inset |
(owner isKindOf: SugarNavTab) ifFalse: [^ self]. "e.g. being held by hand."
owner edgeToAdhereTo = #topRight ifTrue: [^ owner occupyTopRightCorner].
+ shouldResize := false.
+ worldBounds := self world bounds.
+ (self layoutInset ~= (inset := SugarLauncher isRunningInSugar ifTrue: [75 at 0] ifFalse: [0 at 0]))
- shouldResize _ false.
- worldBounds _ self world bounds.
- (self layoutInset ~= (inset _ SugarLauncher isRunningInSugar ifTrue: [75 at 0] ifFalse: [0 at 0]))
ifTrue: [self layoutInset: inset].
+ worldBounds width ~= self width ifTrue: [shouldResize := true].
- worldBounds width ~= self width ifTrue: [shouldResize _ true].
Preferences useArtificialSweetenerBar ifTrue: [
+ h := submorphs first submorphs first height.
- h _ submorphs first submorphs first height.
(worldBounds extent x >= 1024 and: [worldBounds extent y >= 768]) ifTrue: [
+ h = 40 ifTrue: [self naviHeight: 75. shouldResize := true]]
+ ifFalse: [h = 75 ifTrue: [self naviHeight: 40. shouldResize := true]]].
+ (h := self submorphBounds height) ~= self height ifTrue: [shouldResize := true].
- h = 40 ifTrue: [self naviHeight: 75. shouldResize _ true]]
- ifFalse: [h = 75 ifTrue: [self naviHeight: 40. shouldResize _ true]]].
- (h _ self submorphBounds height) ~= self height ifTrue: [shouldResize _ true].
(owner notNil and: [owner isFlapTab]) ifTrue: [
owner edgeToAdhereTo == #top ifTrue: [
+ self topLeft ~= worldBounds topLeft ifTrue: [shouldResize := true].
- self topLeft ~= worldBounds topLeft ifTrue: [shouldResize _ true].
].
owner edgeToAdhereTo == #bottom ifTrue: [
+ self bottomLeft ~= worldBounds bottomLeft ifTrue: [shouldResize := true].
- self bottomLeft ~= worldBounds bottomLeft ifTrue: [shouldResize _ true].
].
shouldResize ifTrue: [
owner edgeToAdhereTo == #top ifTrue: [
self bounds: (0 at 0 corner: (worldBounds width at h)).
].
owner edgeToAdhereTo == #bottom ifTrue: [
self bounds: (0@(worldBounds height - h) corner: (worldBounds bottomRight)).
].
self resizeProjectNameField.
owner layoutChanged.
].
].!
Item was changed:
----- Method: SugarNavigatorBar>>chooseScreenSetting (in category 'buttons creation') -----
chooseScreenSetting
"Put up a menu allowing the user to choose between virtual-olpc-display mode and normal-display mode."
| aMenu availableModes |
+ aMenu := MenuMorph new defaultTarget: self.
- aMenu _ MenuMorph new defaultTarget: self.
aMenu addTitle: 'display mode' translated.
Preferences noviceMode
ifFalse: [aMenu addStayUpItem].
+ availableModes := self availableDisplayModes.
- availableModes _ self availableDisplayModes.
availableModes do:
[:mode |
aMenu addUpdating: #stringForDisplayModeIs: target: self selector: #toggleScreenSetting: argumentList: {mode}.
(self balloonTextForMode: mode) ifNotNilDo:
[:help |
aMenu balloonTextForLastItem: help translated]].
aMenu addLine.
aMenu addUpdating: #stringForFullScreenToggle target: self action: #toggleFullScreen.
aMenu popUpInWorld
"(Flaps globalFlapTabWithID: 'Sugar Navigator Flap' translated) referent chooseScreenSetting"!
Item was changed:
----- Method: SugarNavigatorBar>>color: (in category 'accessing') -----
color: aColor
| oldHeight |
color = aColor ifTrue: [^ self].
+ oldHeight := self buttonHeight.
- oldHeight _ self buttonHeight.
super color: aColor.
submorphs ifNotEmpty: [self rebuildButtons].
self buttonHeight ~= oldHeight ifTrue: [
self naviHeight: oldHeight.
].
!
Item was changed:
----- Method: SugarNavigatorBar>>color:highLightColor: (in category 'accessing') -----
color: baseColor highLightColor: hColor
| oldHeight |
+ oldHeight := self buttonHeight.
- oldHeight _ self buttonHeight.
(color = baseColor and: [highLightColor = hColor]) ifTrue: [^ self].
super color: baseColor.
+ highLightColor := hColor.
- highLightColor _ hColor.
submorphs ifNotEmpty: [self rebuildButtons].
self buttonHeight ~= oldHeight ifTrue: [
self naviHeight: oldHeight.
].
!
Item was changed:
----- Method: SugarNavigatorBar>>doNewPainting (in category 'button actions') -----
doNewPainting
| w |
+ w := self world.
- w _ self world.
w assureNotPaintingElse: [^ self].
w makeNewDrawing: (self primaryHand lastEvent copy setPosition: w center)
!
Item was changed:
----- Method: SugarNavigatorBar>>highLightColor: (in category 'accessing') -----
highLightColor: aColor
| oldHeight |
highLightColor = aColor ifTrue: [^ self].
+ highLightColor := aColor.
+ oldHeight := self buttonHeight.
- highLightColor _ aColor.
- oldHeight _ self buttonHeight.
submorphs ifNotEmpty: [self rebuildButtons].
self buttonHeight ~= oldHeight ifTrue: [
self naviHeight: oldHeight.
].
!
Item was changed:
----- Method: SugarNavigatorBar>>makeBadgeLabelIn: (in category 'the actions') -----
makeBadgeLabelIn: aPoint
| aMorph icon string |
+ aMorph := Morph new.
- aMorph _ Morph new.
aMorph extent: aPoint.
aMorph color: Color transparent.
+ icon := SketchMorph new form: (SugarLibrary default imageFor: 'miniShare' color: self color).
+ string := StringMorph new label: 'Make a Badge' translated font: Preferences standardEToysFont.
- icon _ SketchMorph new form: (SugarLibrary default imageFor: 'miniShare' color: self color).
- string _ StringMorph new label: 'Make a Badge' translated font: Preferences standardEToysFont.
string color: Color white.
icon center: (icon width // 2)@(aPoint y // 2).
string center: (icon width // 2)@(aPoint y // 2).
string left: icon right + 1.
aMorph addMorph: icon.
aMorph addMorph: string.
^ aMorph.
!
Item was changed:
----- Method: SugarNavigatorBar>>makeMyNeighborhoodLabelIn: (in category 'the actions') -----
makeMyNeighborhoodLabelIn: aPoint
| aMorph icon string |
+ aMorph := Morph new.
- aMorph _ Morph new.
aMorph extent: aPoint.
aMorph color: Color transparent.
+ icon := SketchMorph new form: (SugarLibrary default imageFor: 'miniShare' color: self color).
+ string := StringMorph new label: 'My Neighborhood' translated font: Preferences standardEToysFont.
- icon _ SketchMorph new form: (SugarLibrary default imageFor: 'miniShare' color: self color).
- string _ StringMorph new label: 'My Neighborhood' translated font: Preferences standardEToysFont.
string color: Color white.
icon center: (icon width // 2)@(aPoint y // 2).
string center: (icon width // 2)@(aPoint y // 2).
string left: icon right + 1.
aMorph addMorph: icon.
aMorph addMorph: string.
^ aMorph.
!
Item was changed:
----- Method: SugarNavigatorBar>>makePrivateLabelIn: (in category 'the actions') -----
makePrivateLabelIn: aPoint
| aMorph icon string |
+ aMorph := Morph new.
- aMorph _ Morph new.
aMorph extent: aPoint.
aMorph color: Color transparent.
+ icon := SketchMorph new form: (SugarLibrary default imageFor: 'miniPrivate' color: self color).
+ string := StringMorph new label: 'Private' translated font: Preferences standardEToysFont.
- icon _ SketchMorph new form: (SugarLibrary default imageFor: 'miniPrivate' color: self color).
- string _ StringMorph new label: 'Private' translated font: Preferences standardEToysFont.
string color: Color white.
icon center: (icon width // 2)@(aPoint y // 2).
string center: (icon width // 2)@(aPoint y // 2).
string left: icon right + 1.
aMorph addMorph: icon.
aMorph addMorph: string.
^ aMorph.
!
Item was changed:
----- Method: SugarNavigatorBar>>makeProjectNameLabel (in category 'the actions') -----
makeProjectNameLabel
| t |
+ projectNameField := SugarRoundedField new.
+ t := UpdatingStringMorph new.
- projectNameField _ SugarRoundedField new.
- t _ UpdatingStringMorph new.
t setProperty: #okToTextEdit toValue: true.
t putSelector: #projectNameChanged:.
t getSelector: #projectName.
projectNameField backgroundColor: self color.
t target: self.
t useStringFormat.
t beSticky.
t label: ActiveWorld project name font: (StrikeFont familyName: 'BitstreamVeraSans' size: 24).
t color: Color black.
t width: projectNameField width - 10.
projectNameField label: t.
projectNameField setBalloonText: self projectNameFieldBalloonHelp.
projectNameField on: #mouseDown send: #mouseDown: to: t.
projectNameField on: #mouseUp send: #mouseUp: to: t.
self resizeProjectNameField.
^projectNameField.
!
Item was changed:
----- Method: SugarNavigatorBar>>putUpInitialBalloonHelp (in category 'initialization') -----
putUpInitialBalloonHelp
"
SugarNavigatorBar putUpInitialBalloonHelp
"
| suppliesButton b1 b2 p b |
+ suppliesButton := paintButton owner submorphs detect: [:e | e isButton and: [e actionSelector = #toggleSupplies]].
- suppliesButton _ paintButton owner submorphs detect: [:e | e isButton and: [e actionSelector = #toggleSupplies]].
+ b1 := BalloonMorph string: self paintButtonInitialExplanation for: paintButton corner: #topRight force: false.
+ b2 := BalloonMorph string: self suppliesButtonInitialExplanation for: suppliesButton corner: #topLeft force: true.
- b1 _ BalloonMorph string: self paintButtonInitialExplanation for: paintButton corner: #topRight force: false.
- b2 _ BalloonMorph string: self suppliesButtonInitialExplanation for: suppliesButton corner: #topLeft force: true.
+ p := PasteUpMorph new.
- p _ PasteUpMorph new.
p clipSubmorphs: false.
p color: Color transparent.
p borderWidth: 0.
p addMorph: b1.
p addMorph: b2.
+ b := BalloonMorph string: p for: World corner: #bottomLeft.
- b _ BalloonMorph string: p for: World corner: #bottomLeft.
b color: Color transparent.
b borderWidth: 0.
[(Delay forSeconds: 1) wait. b popUpForHand: ActiveHand] fork.
!
Item was changed:
----- Method: SugarNavigatorBar>>putUpInitialBalloonHelpFor: (in category 'initialization') -----
putUpInitialBalloonHelpFor: quads
"Given a list of quads of the form <selector> <help-msg> <corner> <force-boolean> (see senders for examples), put up initial balloon help for them."
"
SugarNavigatorBar someInstance putUpInitialBalloonHelpFor: #((doNewPainting 'make a new painting' topRight false) (toggleSupplies 'open the supplies bin' topLeft true))
SugarNavigatorBar someInstance putUpInitialBalloonHelpFor: #((showNavBar 'show the tool bar' bottomLeft false) (hideNavBar 'hide the tool bar' bottomLeft false))
"
| b1 p b |
+ p := PasteUpMorph new.
- p _ PasteUpMorph new.
p clipSubmorphs: false.
p color: Color transparent.
p borderWidth: 0.
quads do: [:aQuad |
(submorphs first submorphs detect: [:e | e isButton and: [e actionSelector = aQuad first]] ifNone: [nil]) ifNotNilDo:
[:aButton |
b1 := BalloonMorph string: aQuad second for: aButton corner: aQuad third force: aQuad fourth.
p addMorph: b1]].
+ b := BalloonMorph string: p for: World corner: #bottomLeft.
- b _ BalloonMorph string: p for: World corner: #bottomLeft.
b color: Color transparent.
b borderWidth: 0.
[(Delay forSeconds: 1) wait. b popUpForHand: ActiveHand] fork.
!
Item was changed:
----- Method: SugarNavigatorBar>>resizeProjectNameField (in category 'the actions') -----
resizeProjectNameField
"The height should be 45 according to the Sugar guilde line, but an odd number makes the circle distorted. To be general, it uses 60% of the height of bar."
| h |
+ h := (self height * 0.6) roundTo: 2.
- h _ (self height * 0.6) roundTo: 2.
projectNameField ifNotNil: [
projectNameField extent: (Display width >= 1200 ifTrue: [220] ifFalse: [130])@h.
projectNameField resizeLabel].!
Item was changed:
----- Method: SugarNavigatorBar>>setupSuppliesFlap (in category 'buttons creation') -----
setupSuppliesFlap
| i f |
sugarLib ifNil: [^ self].
+ supplies := Flaps globalFlapTabWithID: 'Supplies' translated.
- supplies _ Flaps globalFlapTabWithID: 'Supplies' translated.
supplies ifNotNil: [
+ i := sugarLib imageFor: 'supplies' color: color.
+ f := Form extent: 75 at 75 depth: 16.
- i _ sugarLib imageFor: 'supplies' color: color.
- f _ Form extent: 75 at 75 depth: 16.
f fillColor: color.
i displayOn: f at: (f extent - i extent)//2 rule: Form over.
supplies sugarNavTab: self icon: f.
].
!
Item was changed:
----- Method: SugarNavigatorBar>>shareMenu (in category 'the actions') -----
shareMenu
| menu item ext |
+ menu := MenuMorph new.
+ ext := 200 at 50.
- menu _ MenuMorph new.
- ext _ 200 at 50.
#((stopSharing makePrivateLabelIn:) (startSharing makeMyNeighborhoodLabelIn:) "(shareThisWorld makeBadgeLabelIn:)") do: [:pair |
+ item := MenuItemMorph new
- item _ MenuItemMorph new
contents: '';
target: self;
selector: pair first;
arguments: #().
item color: Color black.
item addMorph: (self perform: pair second with: ext).
item setProperty: #minHeight toValue: ext y.
item fitContents.
item extent: ext.
item setProperty: #selectionFillStyle toValue: (Color gray alpha: 0.5).
menu addMorphBack: item.
].
menu color: Color black.
menu borderColor: Color white.
^ menu invokeModalAt: shareButton position + (10 at 20) in: ActiveWorld allowKeyboard: false.!
Item was changed:
----- Method: SugarNavigatorBar>>stopSharing (in category 'sharing') -----
stopSharing
SugarLauncher current leaveSharedActivity.
+ listener ifNotNil: [listener stopListening. listener := nil].
- listener ifNotNil: [listener stopListening. listener _ nil].
ActiveWorld remoteServer: nil.
ActiveWorld submorphs do: [:e | (e isMemberOf: NebraskaServerMorph) ifTrue: [e delete]].
self sharingChanged.!
Item was changed:
----- Method: SugarNavigatorBar>>sugarLib: (in category 'initialization') -----
sugarLib: anObject
+ sugarLib := anObject.
- sugarLib _ anObject.
!
Item was changed:
----- Method: SugarNavigatorBar>>toggleHelp (in category 'help flap') -----
toggleHelp
"Open the help-cards flap, or close it if open."
| ref f guide |
+ f := Flaps globalFlapTab: 'Help' translated.
- f _ Flaps globalFlapTab: 'Help' translated.
f ifNotNil:
[
f isInWorld
ifTrue:
+ [ref := f referent.
+ ref ifNotNil: [guide := ref findDeeplyA: QuickGuideMorph].
- [ref _ f referent.
- ref ifNotNil: [guide _ ref findDeeplyA: QuickGuideMorph].
guide ifNotNil: [guide unloadPages].
Flaps removeFlapTab: f keepInList: false]
ifFalse:
[f openInWorld.
f showFlap.
+ ref := f referent.
- ref _ f referent.
ref ifNotNil: [
+ guide := ref findDeeplyA: QuickGuideMorph].
- guide _ ref findDeeplyA: QuickGuideMorph].
guide ifNotNil: [Cursor wait showWhile: [guide initializeIndexPage]]]]
ifNil:
[QuickGuideMorph guidePath
ifNil: [^self inform: 'There are no QuickGuides installed' translated].
Cursor wait showWhile: [self buildAndOpenHelpFlap]]!
Item was changed:
----- Method: SugarNavigatorBar>>toggleSupplies (in category 'button actions') -----
toggleSupplies
| ref f |
+ f := (Flaps globalFlapTab: 'Supplies' translated).
+ ref := f referent.
- f _ (Flaps globalFlapTab: 'Supplies' translated).
- ref _ f referent.
ref isInWorld ifTrue: [f hideFlap] ifFalse: [
f showFlap.
(owner notNil and: [owner isFlapTab]) ifTrue: [
owner edgeToAdhereTo == #top ifTrue: [
ref position: self bottomLeft.
].
owner edgeToAdhereTo == #bottom ifTrue: [
ref bottomLeft: self topLeft.
].
].
f position: 0@(f height negated)
].
!
Item was changed:
----- Method: SugarNavigatorBar>>undoButtonAppearance (in category 'event handling') -----
undoButtonAppearance
| wording |
undoButton ifNotNil: [
ActiveWorld commandHistory undoEnabled
ifTrue: [undoButton enabled]
ifFalse: [undoButton disabled].
+ wording := self undoButtonWording.
- wording _ self undoButtonWording.
undoButton setBalloonText: wording.
].
!
Item was changed:
----- Method: SugarRoundedField>>backgroundColor: (in category 'as yet unclassified') -----
backgroundColor: aColor
+ backgroundColor := aColor.
+ mask := self makeMask: self extent foregroundColor: color backgroundColor: backgroundColor.
- backgroundColor _ aColor.
- mask _ self makeMask: self extent foregroundColor: color backgroundColor: backgroundColor.
!
Item was changed:
----- Method: SugarRoundedField>>extent: (in category 'as yet unclassified') -----
extent: aPoint
+ mask := self makeMask: aPoint foregroundColor: color backgroundColor: backgroundColor.
- mask _ self makeMask: aPoint foregroundColor: color backgroundColor: backgroundColor.
"self recenterLabel."
super extent: aPoint.
!
Item was changed:
----- Method: SugarRoundedField>>initialize (in category 'as yet unclassified') -----
initialize
super initialize.
self color: Color white.
+ backgroundColor := (Color r: 0.258 g: 0.258 b: 0.258).
- backgroundColor _ (Color r: 0.258 g: 0.258 b: 0.258).
self clipSubmorphs: true.
self extent: 160 at 50.
!
Item was changed:
----- Method: SugarRoundedField>>label: (in category 'as yet unclassified') -----
label: aStringOrMorph
+ label ifNotNil: [label delete. label := nil].
+ label := aStringOrMorph.
- label ifNotNil: [label delete. label _ nil].
- label _ aStringOrMorph.
label isString ifTrue: [
+ label := StringMorph new label: label font: Preferences standardEToysFont
- label _ StringMorph new label: label font: Preferences standardEToysFont
].
self resizeLabel.
!
Item was changed:
----- Method: SugarRoundedField>>makeMask:foregroundColor:backgroundColor: (in category 'as yet unclassified') -----
makeMask: extent foregroundColor: fgColor backgroundColor: bgColor
| f c diameter |
+ f := Form extent: extent depth: 16.
- f _ Form extent: extent depth: 16.
f fillColor: bgColor.
+ c := f getCanvas asBalloonCanvas.
- c _ f getCanvas asBalloonCanvas.
c aaLevel: 2.
+ diameter := extent x min: extent y.
- diameter _ extent x min: extent y.
c drawOval: (0 at 0 extent: diameter at diameter) color: fgColor borderWidth: 0 borderColor: Color black.
c drawOval: (((extent x - diameter)@0) extent: diameter at diameter) color: fgColor borderWidth: 0 borderColor: Color black.
c fillRectangle: (((diameter // 2)@0) extent: ((extent x - diameter)@(extent y))) fillStyle: fgColor.
c finish.
^ f.
!
Item was changed:
----- Method: SugarSuppliesTab>>positionObject:atEdgeOf: (in category 'all') -----
positionObject: anObject atEdgeOf: container
| extra |
+ extra := (sugarNavTab notNil and: [referent isInWorld]) ifTrue: [sugarNavTab height] ifFalse: [0].
- extra _ (sugarNavTab notNil and: [referent isInWorld]) ifTrue: [sugarNavTab height] ifFalse: [0].
edgeToAdhereTo == #top ifTrue: [
^ anObject top: container innerBounds top + extra
].
edgeToAdhereTo == #bottom ifTrue: [
^ anObject bottom: container innerBounds bottom - extra
].
!
Item was changed:
----- Method: SugarSuppliesTab>>sugarNavTab:icon: (in category 'all') -----
sugarNavTab: anObject icon: aForm
+ sugarNavTab := anObject.
- sugarNavTab _ anObject.
aForm ifNotNil: [
self useTextualTab.
self setProperty: #priorGraphic toValue: aForm.
self useGraphicalTab.
].
!
Item was changed:
----- Method: SyntaxAttribute>>attributeList (in category 'accessing') -----
attributeList
"Answer a list of text attributes that characterize the receiver"
attributeList ifNil:
+ [attributeList := OrderedCollection new: 2.
- [attributeList _ OrderedCollection new: 2.
color ifNotNil: [attributeList add: (TextColor color: color)].
emphasis ifNotNil: [attributeList add: (TextEmphasis perform: emphasis)]].
^ attributeList!
Item was changed:
----- Method: SyntaxAttribute>>color: (in category 'accessing') -----
color: aTextColor
+ color := aTextColor.
+ attributeList := nil!
- color _ aTextColor.
- attributeList _ nil!
Item was changed:
----- Method: SyntaxAttribute>>emphasis: (in category 'accessing') -----
emphasis: aTextEmphasis
+ emphasis := aTextEmphasis.
+ attributeList := nil!
- emphasis _ aTextEmphasis.
- attributeList _ nil!
Item was changed:
----- Method: SyntaxMorph>>attachTileForCode:nodeType: (in category 'new tiles') -----
attachTileForCode: expression nodeType: nodeClass
| nn master tile |
"create a new tile for a part of speech, and put it into the hand"
"a few special cases"
expression = 'self' ifTrue: [
^ (((self string: expression toTilesIn: Object)
findA: ReturnNode) findA: nodeClass) attachToHand].
expression = '<me by name>' ifTrue: ["Tile for the variable in References"
+ nn := nodeClass knownName ifNil: [#+].
- nn _ nodeClass knownName ifNil: [#+].
(self world referencePool at: nn asSymbol ifAbsent: [nil]) == nodeClass ifTrue: [
^ self attachTileForCode: nn nodeType: LiteralVariableNode].
"otherwise just give a tile for self"
^ self attachTileForCode: 'self' nodeType: VariableNode].
expression = '<assignment>' ifTrue: ["do something really special"
+ master := self class new.
+ master addNoiseString: ' := ' emphasis: 1.
+ tile := master firstSubmorph.
- master _ self class new.
- master addNoiseString: ' _ ' emphasis: 1.
- tile _ master firstSubmorph.
^ (tile parseNode: AssignmentNode new) attachToHand]. "special marker"
"When this is dropped on a variable, enclose it in
a new assignment statement"
"general case -- a tile for a whole line of code is returned"
^ ((self string: expression toTilesIn: Object)
findA: nodeClass) attachToHand.!
Item was changed:
----- Method: SyntaxMorph>>translateToWordySetter: (in category 'alans styles') -----
translateToWordySetter: key
+ " setBlob: becomes 's blob := "
- " setBlob: becomes 's blob _ "
^ '''s ',
(self splitAtCapsAndDownshifted: (key asString allButFirst: 3) allButLast
withFirstCharacterDownshifted),
' _'!
Item was changed:
----- Method: SyntaxTestMethods>>makeRandomString (in category 'as yet unclassified') -----
makeRandomString
| newString foo |
+ newString := String new: Goal contents size.
+ foo := Goal contents size.
- newString _ String new: Goal contents size.
- foo _ Goal contents size.
^newString collect: [ :oldLetter | 'abcdefghijklmnopqrstuvwxyz' atRandom]
!
Item was changed:
----- Method: SystemDictionary>>condenseSources (in category '*Etoys-Squeakland-housekeeping') -----
condenseSources
"Move all the changes onto a compacted sources file."
"Smalltalk condenseSources"
| newVersionString |
+ newVersionString := FillInTheBlank request: 'Please designate the version
- newVersionString _ FillInTheBlank request: 'Please designate the version
for the new source code file...' initialAnswer: SmalltalkImage current sourceFileVersionString.
^ self condenseSourcesForVersion: newVersionString.
!
Item was changed:
----- Method: SystemDictionary>>condenseSourcesForVersion: (in category '*Etoys-Squeakland-housekeeping') -----
condenseSourcesForVersion: aString
"Move all the changes onto a compacted sources file."
"Smalltalk condenseSources"
| f classCount dir newVersionString |
Utilities fixUpProblemsWithAllCategory.
"The above removes any concrete, spurious '-- all --' categories, which mess up the process."
+ dir := FileDirectory default.
+ newVersionString := aString.
- dir _ FileDirectory default.
- newVersionString _ aString.
newVersionString ifNil: [^ self].
newVersionString = SmalltalkImage current sourceFileVersionString ifTrue:
[^ self error: 'The new source file must not be the same as the old.'].
SmalltalkImage current sourceFileVersionString: newVersionString.
"Write all sources with fileIndex 1"
+ f := FileStream newFileNamed: SmalltalkImage current sourcesName.
- f _ FileStream newFileNamed: SmalltalkImage current sourcesName.
f converter: UTF8TextConverter new. "This is needed only when converting from SqueakV3.sources."
f header; timeStamp.
'Condensing Sources File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
+ [:bar | classCount := 0.
- [:bar | classCount _ 0.
Smalltalk allClassesDo:
+ [:class | bar value: (classCount := classCount + 1).
- [:class | bar value: (classCount _ classCount + 1).
class fileOutOn: f moveSource: true toFile: 1]].
f trailer; close.
"Make a new empty changes file"
SmalltalkImage current closeSourceFiles.
dir rename: SmalltalkImage current changesName
toBe: SmalltalkImage current changesName , '.old'.
(FileStream newFileNamed: SmalltalkImage current changesName)
header; timeStamp; close.
SmalltalkImage current lastQuitLogPosition: 0.
self setMacFileInfoOn: SmalltalkImage current changesName.
self setMacFileInfoOn: SmalltalkImage current sourcesName.
SmalltalkImage current openSourceFiles.
self inform: 'Source files have been rewritten!!
Check that all is well,
and then save/quit.'!
Item was changed:
----- Method: SystemDictionary>>logError:inContext:to: (in category '*Etoys-Squeakland-miscellaneous') -----
logError: errMsg inContext: aContext to: aFilename
"Log the error message and a stack trace to the given file."
| ff |
[Preferences logDebuggerStackToConsole
ifTrue: [FileStream stderr ifNotNilDo: [:stderr |
stderr nextPutAll: '=========== ';
nextPutAll: aFilename;
nextPutAll: ' START =========='; cr;
nextPutAll: errMsg; cr;
nextPutAll: (String streamContents: [:strm |
aContext errorReportOn: strm]);
nextPutAll: '=========== ';
nextPutAll: aFilename;
nextPutAll: ' END =========='; cr]]] ifError: ["ignore"].
FileDirectory default deleteFileNamed: aFilename ifAbsent: [].
+ (ff := FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].
- (ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].
ff nextPutAll: errMsg; cr.
aContext errorReportOn: ff.
ff close.
!
Item was changed:
----- Method: SystemDictionary>>makeSqueaklandReleasePhaseCleanup (in category '*Etoys-Squeakland-squeakland') -----
makeSqueaklandReleasePhaseCleanup
"Smalltalk makeSqueaklandReleasePhaseCleanup"
Browser initialize.
ChangeSorter removeChangeSetsNamedSuchThat:
[:cs| cs name ~= ChangeSet current name].
ChangeSet current clear.
ChangeSet current name: 'Unnamed' translated , '1'.
Smalltalk garbageCollect.
"Reinitialize DataStream; it may hold on to some zapped entitities"
DataStream initialize.
"Remove existing player references"
References keys do:[:k| References removeKey: k].
Smalltalk garbageCollect.
+ ScheduledControllers := nil.
- ScheduledControllers _ nil.
Behavior flushObsoleteSubclasses.
Smalltalk garbageCollect; garbageCollect.
Smalltalk obsoleteBehaviors isEmpty ifFalse:[self error:'Still have obsolete behaviors'].
"Reinitialize DataStream; it may hold on to some zapped entitities"
DataStream initialize.
Smalltalk fixObsoleteReferences.
Smalltalk abandonTempNames.
Smalltalk zapAllOtherProjects.
Smalltalk forgetDoIts.
Smalltalk flushClassNameCache.
3 timesRepeat: [
Smalltalk garbageCollect.
Symbol compactSymbolTable.
].
!
Item was changed:
----- Method: SystemDictionary>>makeSqueaklandReleasePhaseFinalSettings (in category '*Etoys-Squeakland-squeakland') -----
makeSqueaklandReleasePhaseFinalSettings
"Smalltalk makeSqueaklandReleasePhaseFinalSettings"
| serverName serverURL serverDir updateServer highestUpdate newVersion |
ProjectLauncher splashMorph: ((FileDirectory default directoryNamed: 'scripts' )readOnlyFileNamed: 'SqueaklandSplash.morph') fileInObjectAndCode.
"Dump all morphs so we don't hold onto anything"
World submorphsDo:[:m| m delete].
#(
(honorDesktopCmdKeys false)
(warnIfNoChangesFile false)
(warnIfNoSourcesFile false)
(showDirectionForSketches true)
(menuColorFromWorld false)
(unlimitedPaintArea true)
(useGlobalFlaps false)
(mvcProjectsAllowed false)
(projectViewsInWindows false)
(automaticKeyGeneration true)
(securityChecksEnabled true)
(showSecurityStatus false)
(startInUntrustedDirectory true)
(warnAboutInsecureContent false)
(promptForUpdateServer false)
(fastDragWindowForMorphic false)
(externalServerDefsOnly true)
(expandedFormat false)
(allowCelesteTell false)
(eToyFriendly true)
(eToyLoginEnabled true)
(magicHalos true)
(mouseOverHalos true)
(biggerHandles false)
(selectiveHalos true)
(includeSoundControlInNavigator true)
(readDocumentAtStartup true)
(preserveTrash true)
(slideDismissalsToTrash true)
) do:[:spec|
Preferences setPreference: spec first toValue: spec last].
"Workaround for bug"
Preferences enable: #readDocumentAtStartup.
World color: (Color r: 0.9 g: 0.9 b: 1.0).
"Clear all server entries"
ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each].
SystemVersion current resetHighestUpdate.
"Add the squeakalpha update stream"
+ serverName := 'Squeakalpha'.
+ serverURL := 'squeakalpha.org'.
+ serverDir := serverURL , '/'.
- serverName _ 'Squeakalpha'.
- serverURL _ 'squeakalpha.org'.
- serverDir _ serverURL , '/'.
+ updateServer := ServerDirectory new.
- updateServer _ ServerDirectory new.
updateServer
server: serverURL;
directory: 'updates/';
altUrl: serverDir;
user: 'sqland';
password: nil.
Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.
"Add the squeakland update stream"
+ serverName := 'Squeakland'.
+ serverURL := 'squeakland.org'.
+ serverDir := serverURL , '/'.
- serverName _ 'Squeakland'.
- serverURL _ 'squeakland.org'.
- serverDir _ serverURL , '/'.
+ updateServer := ServerDirectory new.
- updateServer _ ServerDirectory new.
updateServer
server: serverURL;
directory: 'public_html/updates/';
altUrl: serverDir.
Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.
+ highestUpdate := SystemVersion current highestUpdate.
- highestUpdate _ SystemVersion current highestUpdate.
(self confirm: 'Reset highest update (' , highestUpdate printString , ')?')
ifTrue: [SystemVersion current highestUpdate: 0].
+ newVersion := FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString.
- newVersion _ FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString.
SystemVersion newVersion: newVersion.
(self confirm: self version , '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
!
Item was changed:
----- Method: SystemDictionary>>reconstructChanges (in category '*Etoys-Squeakland-housekeeping') -----
reconstructChanges
"Move all the changes and its histories onto another sources file."
"Smalltalk reconstructChanges"
| f oldChanges classCount |
+ f := FileStream fileNamed: 'ST80.temp'.
- f _ FileStream fileNamed: 'ST80.temp'.
f header; timeStamp.
'Condensing Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
+ [:bar | classCount := 0.
- [:bar | classCount _ 0.
Smalltalk allClassesDo:
+ [:class | bar value: (classCount := classCount + 1).
- [:class | bar value: (classCount _ classCount + 1).
class moveChangesWithVersionsTo: f.
class putClassCommentToCondensedChangesFile: f.
class class moveChangesWithVersionsTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
+ oldChanges := SourceFiles at: 2.
- oldChanges _ SourceFiles at: 2.
oldChanges close.
FileDirectory default
deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles at: 2
put: (FileStream oldFileNamed: oldChanges name)!
Item was changed:
----- Method: SystemDictionary>>reformatChangesToUTF8 (in category '*Etoys-Squeakland-housekeeping') -----
reformatChangesToUTF8
"Smalltalk reformatChangesToUTF8"
| f oldChanges classCount |
+ f := FileStream fileNamed: 'ST80.temp'.
- f _ FileStream fileNamed: 'ST80.temp'.
f converter: (UTF8TextConverter new).
f header; timeStamp.
'Condensing Changes File...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
+ [:bar | classCount := 0.
- [:bar | classCount _ 0.
Smalltalk allClassesDo:
+ [:class | bar value: (classCount := classCount + 1).
- [:class | bar value: (classCount _ classCount + 1).
class moveChangesTo: f.
class putClassCommentToCondensedChangesFile: f.
class class moveChangesTo: f]].
SmalltalkImage current lastQuitLogPosition: f position.
f trailer; close.
+ oldChanges := SourceFiles at: 2.
- oldChanges _ SourceFiles at: 2.
oldChanges close.
FileDirectory default
deleteFileNamed: oldChanges name , '.old';
rename: oldChanges name toBe: oldChanges name , '.old';
rename: f name toBe: oldChanges name.
self setMacFileInfoOn: oldChanges name.
SourceFiles at: 2
put: (FileStream oldFileNamed: oldChanges name).
MultiByteFileStream codeConverterClass: UTF8TextConverter.
(SourceFiles at: 2) converter: (UTF8TextConverter new).
!
Item was changed:
----- Method: SystemProgressMorph>>label:min:max: (in category '*Etoys-Squeakland-private') -----
label: shortDescription min: minValue max: maxValue
| slot range newBarSize barSize lastRefresh index |
+ ((range := maxValue - minValue) <= 0 or: [(slot := self nextSlotFor: shortDescription) = 0])
- ((range _ maxValue - minValue) <= 0 or: [(slot _ self nextSlotFor: shortDescription) = 0])
ifTrue: [^[:barVal| 0 ]].
self openInWorld.
activeSlots <= 1
ifTrue: [self align: self fullBounds center with: Display boundingBox center].
+ barSize := -1. "Enforces a inital draw of the morph"
+ lastRefresh := 0.
+ index := Preferences unifyNestedProgressBars ifFalse: [slot] ifTrue: [1].
- barSize _ -1. "Enforces a inital draw of the morph"
- lastRefresh _ 0.
- index _ Preferences unifyNestedProgressBars ifFalse: [slot] ifTrue: [1].
^[:barVal |
(barVal between: minValue and: maxValue) ifTrue: [
+ newBarSize := (barVal - minValue / range * BarWidth) truncated.
- newBarSize _ (barVal - minValue / range * BarWidth) truncated.
newBarSize > barSize ifTrue: [
+ barSize := newBarSize.
- barSize _ newBarSize.
(bars at: index) barSize: barSize.
Time primMillisecondClock - lastRefresh > 25 ifTrue: [
self currentWorld displayWorld.
+ lastRefresh := Time primMillisecondClock]]].
- lastRefresh _ Time primMillisecondClock]]].
slot]
!
Item was changed:
----- Method: SystemProgressMorph>>nextSlotUnifiedFor: (in category '*Etoys-Squeakland-private') -----
nextSlotUnifiedFor: shortDescription
| bar label index |
lock critical: [
+ activeSlots := activeSlots + 1.
+ index := 1.
+ bar := (bars at: index).
- activeSlots _ activeSlots + 1.
- index _ 1.
- bar _ (bars at: index).
bar ifNil: [
+ bar := bars at: 1 put: (SystemProgressBarMorph new extent: BarWidth at BarHeight).
+ label := labels at: 1 put: (StringMorph contents: shortDescription font: font).
- bar _ bars at: 1 put: (SystemProgressBarMorph new extent: BarWidth at BarHeight).
- label _ labels at: 1 put: (StringMorph contents: shortDescription font: font).
self
addMorphBack: label;
addMorphBack: bar.
].
bar owner ifNil: [
+ bar := bars at: index.
+ label := labels at: index.
- bar _ bars at: index.
- label _ labels at: index.
self
addMorphBack: (label contents: shortDescription);
addMorphBack: (bar barSize: 0).
]].
^ activeSlots.
!
Item was changed:
----- Method: TTCFont class>>familyName:pointSize:emphasized: (in category '*Etoys-Squeakland-instance creation') -----
familyName: n pointSize: s emphasized: code
"(TTCFont familyName: 'BitstreamVeraSans' pointSize: 12 emphasis: 0)"
| t ret index |
+ t := self registry at: n asSymbol ifAbsent: [#()].
- t _ self registry at: n asSymbol ifAbsent: [#()].
t isEmpty ifTrue: [
+ t := (TextConstants at: #DefaultTextStyle) fontArray.
+ ret := t first.
- t _ (TextConstants at: #DefaultTextStyle) fontArray.
- ret _ t first.
ret pointSize >= s ifTrue: [^ ret emphasis: code].
+ index := 2.
- index _ 2.
[index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [
+ ret := t at: index.
+ index := index + 1.
- ret _ t at: index.
- index _ index + 1.
].
^ ret emphasis: code.
].
^ ((TextStyle named: n) addNewFontSize: s) emphasis: code.
!
Item was changed:
----- Method: TTCFont>>setupDefaultFallbackTextStyleTo: (in category '*Etoys-Squeakland-friend') -----
setupDefaultFallbackTextStyleTo: aTextStyle
| fonts f |
aTextStyle isNil ifTrue: [^self].
+ fonts := aTextStyle fontArray.
+ f := fonts first.
- fonts _ aTextStyle fontArray.
- f _ fonts first.
f familyName = self familyName ifTrue: [^ self].
1 to: fonts size do: [:i |
+ self height >= (fonts at: i) height ifTrue: [f := fonts at: i].
- self height >= (fonts at: i) height ifTrue: [f _ fonts at: i].
].
self fallbackFont: f.
self reset.
!
Item was changed:
----- Method: TTCFontSet class>>installExternalFontFileName: (in category '*Etoys-Squeakland-file out/in') -----
installExternalFontFileName: aFileName
"
TTCFontSet installExternalFontFileName: 'GreekTT.out'.
TTCFontSet installExternalFontFileName: 'RussianTT.out'.
TTCFontSet installExternalFontFileName: 'JapaneseTT.out'.
"
| f |
+ f := FileStream readOnlyFileNamed: aFileName.
- f _ FileStream readOnlyFileNamed: aFileName.
TTCFontSet newTextStyleFromSmartRefStream: (SmartRefStream on: f)..
f close.
!
Item was changed:
----- Method: TTCFontSet class>>makeSmartRefFilesFrom:encodingTag:ranges:outputFileName: (in category '*Etoys-Squeakland-file out/in') -----
makeSmartRefFilesFrom: fileNames encodingTag: anInteger ranges: ranges outputFileName: outputFile
"
| dir |
+ dir := FileDirectory on: 'C:\tmp'.
+ dir := FileDirectory on: '/usr/share/fonts/dejavu-lgc'.
- dir _ FileDirectory on: 'C:\tmp'.
- dir _ FileDirectory on: '/usr/share/fonts/dejavu-lgc'.
((dir fileNames select: [:e | e endsWith: '.ttf']) collect: [:e | dir fullNameFor: e]).
TTCFontSet
makeSmartRefFilesFrom: ((dir fileNames select: [:e | e endsWith: '.ttf']) collect: [:e | dir fullNameFor: e])
encodingTag: GreekEnvironment leadingChar
ranges: EFontBDFFontReaderForRanges rangesForGreek
outputFileName: 'GreekTT.out'.
"
| f ref descriptions |
TTCFontReader encodingTag: anInteger.
+ descriptions := fileNames collect: [:ttfFile | TTCFontSet newTextStyleFromTTFile: ttfFile encodingTag: anInteger ranges: ranges].
- descriptions _ fileNames collect: [:ttfFile | TTCFontSet newTextStyleFromTTFile: ttfFile encodingTag: anInteger ranges: ranges].
+ f := FileStream newFileNamed: outputFile.
- f _ FileStream newFileNamed: outputFile.
TextConstants at: #forceFontWriting put: true.
+ ref := SmartRefStream on: f.
- ref _ SmartRefStream on: f.
ref nextPutObjOnly: descriptions.
ref close.
TextConstants at: #forceFontWriting put: false.
f close.
"
When you load a copyrighted font, be careful not to distribute the result.
TTCFontSet
makeSmartRefFilesFrom: #('C:\Windows\Fonts\MSGothic.ttc')
encodingTag: JapaneseEnvironment leadingChar
ranges: EFontBDFFontReaderForRanges basicNew rangesForJapanese
outputFileName: 'JapaneseTT.out'
"!
Item was changed:
----- Method: TTCFontSet class>>newTextStyleFromSmartRefStream: (in category '*Etoys-Squeakland-file out/in') -----
newTextStyleFromSmartRefStream: ref
| descriptions |
+ descriptions := TTFontDescription addFromSmartRefStream: ref.
- descriptions _ TTFontDescription addFromSmartRefStream: ref.
descriptions do: [:desc | self newTextStyleFromTT: desc].!
Item was changed:
----- Method: TTFontDescription class>>addSetFromTTFile: (in category '*Etoys-Squeakland-instance creations') -----
addSetFromTTFile: fileName
"
Execute the following only if you know what you are doing.
self addFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC'
"
| tt |
(fileName asLowercase endsWith: 'ttf') ifTrue: [
+ tt := TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName).
- tt _ TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName).
] ifFalse: [
+ tt := TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName).
- tt _ TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName).
].
^ self addToDescription: tt.
!
Item was changed:
----- Method: TabbedPalette>>viewMorph: (in category '*Etoys-viewer tab') -----
viewMorph: aMorph
"The receiver is expected to have a viewer tab; select it, and target it to aMorph"
| aPlayer aViewer oldOwner |
((currentPage isKindOf: Viewer) and: [currentPage scriptedPlayer == aMorph player])
ifTrue:
[^ self].
+ oldOwner := owner.
- oldOwner _ owner.
self delete.
self visible: false.
+ aPlayer := aMorph assuredPlayer.
- aPlayer _ aMorph assuredPlayer.
self showNoPalette.
+ aViewer := StandardViewer new initializeFor: aPlayer barHeight: 0.
- aViewer _ StandardViewer new initializeFor: aPlayer barHeight: 0.
aViewer enforceTileColorPolicy.
self showNoPalette.
currentPage ifNotNil: [currentPage delete].
self addMorphBack: (self currentPage: aViewer beSticky).
self snapToEdgeIfAppropriate.
tabsMorph highlightTab: nil.
self visible: true.
oldOwner addMorphFront: self.
self world startSteppingSubmorphsOf: aViewer.
self layoutChanged!
Item was changed:
----- Method: TelnetMachine class>>initialize (in category 'initialization') -----
initialize
"TelnetMachine initialize"
+ WILLChar := 251 asCharacter.
+ WONTChar := 252 asCharacter.
+ DOChar := 253 asCharacter.
+ DONTChar := 254 asCharacter.
+ IAC := 255 asCharacter.
- WILLChar _ 251 asCharacter.
- WONTChar _ 252 asCharacter.
- DOChar _ 253 asCharacter.
- DONTChar _ 254 asCharacter.
- IAC _ 255 asCharacter.
+ OPTEcho := 1 asCharacter.
- OPTEcho _ 1 asCharacter.
"set of characters that need special processing"
+ CSSpecialChars := CharacterSet
- CSSpecialChars _ CharacterSet
with: Character escape
with: Character cr
with: Character lf
with: Character tab.
!
Item was changed:
----- Method: TelnetMachine class>>open (in category 'user interface') -----
open
"TelnetMachine open"
| machine win displayMorph inputMorph |
Smalltalk isMorphic ifFalse: [ ^self notYetImplemented ].
+ machine := self new.
- machine _ self new.
+ win := SystemWindow labelled: 'telnet'.
- win _ SystemWindow labelled: 'telnet'.
win model: machine.
+ displayMorph := PluggableTextMorph on: machine text: #displayBuffer accept: nil readSelection: #displayBufferSelection menu: #menu:shifted:.
- displayMorph _ PluggableTextMorph on: machine text: #displayBuffer accept: nil readSelection: #displayBufferSelection menu: #menu:shifted:.
displayMorph color: Color black.
+ inputMorph := PluggableTextMorph on: machine text: nil accept: #sendLine:.
- inputMorph _ PluggableTextMorph on: machine text: nil accept: #sendLine:.
inputMorph acceptOnCR: true.
win addMorph: displayMorph frame: (0 at 0 extent: 1 at 0.9).
win addMorph: inputMorph frame: (0 at 0.9 extent: 1 at 0.1).
displayMorph color: Color black.
win openInWorld.
!
Item was changed:
----- Method: TelnetMachine>>addBoringStringInNormalMode: (in category 'screen management') -----
addBoringStringInNormalMode: aString
"add a string with no special characters, and assuming we are already in #normal mode"
|line inPos space amt |
aString do: [ :c | self displayChar: c ].
true ifTrue: [ ^self ].
+ line := displayLines at: cursorY.
+ inPos := 1.
- line _ displayLines at: cursorY.
- inPos _ 1.
[ inPos <= aString size ] whileTrue: [
"copy a line's worth"
+ space := 80 - cursorX + 1.
+ amt := space min: (aString size - inPos + 1).
- space _ 80 - cursorX + 1.
- amt _ space min: (aString size - inPos + 1).
line replaceFrom: cursorX to: cursorX+amt-1 with: aString startingAt: inPos.
line addAttribute: (TextColor color: foregroundColor) from: cursorX to: cursorX+amt-1.
+ inPos := inPos + amt.
- inPos _ inPos + amt.
"update cursor"
+ cursorX := cursorX + amt.
- cursorX _ cursorX + amt.
self possiblyWrapCursor.
].
!
Item was changed:
----- Method: TelnetMachine>>connect (in category 'IO') -----
connect
"connect to the name host"
| addr |
self isConnected ifTrue: [ self disconnect ].
Socket initializeNetwork.
+ addr := NetNameResolver addressForName: hostname.
- addr _ NetNameResolver addressForName: hostname.
addr ifNil: [ self error: 'could not find address for ', hostname ].
+ socket := Socket new.
- socket _ Socket new.
[socket connectTo: addr port: port]
on: ConnectionTimedOut
do: [:ex | self error: 'connection failed' ].
+ requestedRemoteEcho := true.
- requestedRemoteEcho _ true.
self do: OPTEcho.!
Item was changed:
----- Method: TelnetMachine>>displayBufferSelection (in category 'access') -----
displayBufferSelection
"where the selection should be in the display buffer. It should be where the cursor is"
| pos |
+ pos := cursorY * 81 + cursorX - 82.
- pos _ cursorY * 81 + cursorX - 82.
^pos+1 to: pos!
Item was changed:
----- Method: TelnetMachine>>displayChar: (in category 'screen management') -----
displayChar: c
| line |
displayMode = #sawEscape ifTrue: [
^self displayCharSawEscape: c ].
displayMode = #gatheringParameters ifTrue: [
^self displayCharGatheringParameters: c ].
c = Character escape ifTrue: [
+ displayMode := #sawEscape.
- displayMode _ #sawEscape.
^self ].
c = Character cr ifTrue: [
"go back to the beginning of the line"
+ cursorX := 1.
- cursorX _ 1.
^self ].
c = Character lf ifTrue: [
"go to the next line"
+ cursorY := cursorY + 1.
- cursorY _ cursorY + 1.
cursorY > 25 ifTrue: [
self scrollScreenBack: 1.
+ cursorY := 25 ].
- cursorY _ 25 ].
^self ].
c = Character tab ifTrue: [
"move to the next tab stop"
+ cursorX := cursorX + 8 // 8 * 8.
- cursorX _ cursorX + 8 // 8 * 8.
self possiblyWrapCursor.
^self ].
"default: display the character"
+ line := displayLines at: cursorY.
- line _ displayLines at: cursorY.
line at: cursorX put: c.
line addAttribute: (TextColor color: foregroundColor) from: cursorX to: cursorX.
+ cursorX := cursorX + 1.
- cursorX _ cursorX + 1.
self possiblyWrapCursor.!
Item was changed:
----- Method: TelnetMachine>>displayCharGatheringParameters: (in category 'screen management') -----
displayCharGatheringParameters: c
"display a character from the mode #gatheringParameters"
| colorName |
c isDigit ifTrue: [
"add a digit to the last parameter"
commandParams at: commandParams size put:
(commandParams last * 10 + c digitValue).
^self ].
c = $; ifTrue: [
"end of a parameter; begin another one"
commandParams add: 0.
^self ].
c = $m ifTrue: [
"change display modes"
+ displayMode := #normal.
- displayMode _ #normal.
commandParams do: [ :p |
p = 0 ifTrue: [
"reset"
+ foregroundColor := Color white ].
- foregroundColor _ Color white ].
(p >= 30 and: [ p <= 37 ]) ifTrue: [
"change color"
+ colorName := #(gray red green yellow blue blue cyan white) at: (p - 29).
+ foregroundColor := Color perform: colorName. ] ].
- colorName _ #(gray red green yellow blue blue cyan white) at: (p - 29).
- foregroundColor _ Color perform: colorName. ] ].
^self ].
"unrecognized character"
+ displayMode := #normal.
- displayMode _ #normal.
^self displayChar: c!
Item was changed:
----- Method: TelnetMachine>>displayCharSawEscape: (in category 'screen management') -----
displayCharSawEscape: c
"display a character from the mode #sawEscape"
c = $[ ifTrue: [
+ commandParams := OrderedCollection with: 0.
+ displayMode := #gatheringParameters.
- commandParams _ OrderedCollection with: 0.
- displayMode _ #gatheringParameters.
^self ].
+ displayMode := #normal.
- displayMode _ #normal.
^self displayChar: c!
Item was changed:
----- Method: TelnetMachine>>displayString: (in category 'screen management') -----
displayString: aString
"add aString to the display"
|pos specialIdx |
+ pos := 1. "pos steps through aString"
- pos _ 1. "pos steps through aString"
[ pos <= aString size ] whileTrue: [
displayMode = #normal ifTrue: [
"try to display a whole hunk of text at once"
+ specialIdx := aString indexOfAnyOf: CSSpecialChars startingAt: pos ifAbsent: [ aString size + 1 ].
- specialIdx _ aString indexOfAnyOf: CSSpecialChars startingAt: pos ifAbsent: [ aString size + 1 ].
specialIdx > pos ifTrue: [
self addBoringStringInNormalMode: (aString copyFrom: pos to: specialIdx-1).
+ pos := specialIdx. ] ].
- pos _ specialIdx. ] ].
pos <= aString size ifTrue: [
"either a special has been seen, or we're in a special mode"
self displayChar: (aString at: pos).
+ pos := pos + 1. ].
- pos _ pos + 1. ].
].
!
Item was changed:
----- Method: TelnetMachine>>initialize (in category 'private') -----
initialize
+ outputBuffer := WriteStream on: String new.
+ port := 23.
+ processingCommand := false.
+ displayLines := (1 to: 25) asOrderedCollection collect: [ :i |
- outputBuffer _ WriteStream on: String new.
- port _ 23.
- processingCommand _ false.
- displayLines _ (1 to: 25) asOrderedCollection collect: [ :i |
Text new: 80 withAll: Character space ].
+ cursorX := 1.
+ cursorY := 1.
+ foregroundColor := Color white.
+ displayMode := #normal.
+ requestedRemoteEcho := false.
+ remoteEchoAgreed := false.
+ hostname := ''.!
- cursorX _ 1.
- cursorY _ 1.
- foregroundColor _ Color white.
- displayMode _ #normal.
- requestedRemoteEcho _ false.
- remoteEchoAgreed _ false.
- hostname _ ''.!
Item was changed:
----- Method: TelnetMachine>>port: (in category 'access') -----
port: anInteger
"set which port to connect to"
+ port := anInteger!
- port _ anInteger!
Item was changed:
----- Method: TelnetMachine>>possiblyWrapCursor (in category 'screen management') -----
possiblyWrapCursor
"if the cursor has gone past the right margin, then wrap"
cursorX > 80 ifTrue: [
+ cursorX := 1.
+ cursorY := cursorY + 1.
- cursorX _ 1.
- cursorY _ cursorY + 1.
cursorY > 25 ifTrue: [
+ cursorY := 25.
- cursorY _ 25.
self scrollScreenBack: 1 ].
].
!
Item was changed:
----- Method: TelnetMachine>>processIO (in category 'IO') -----
processIO
"should be called periodically--this actually sends and recieves some bytes over the network"
| amountSent |
self isConnected ifFalse: [ ^ self ].
+ outputBuffer := outputBuffer contents. "convert to String for convenience in the loop. still not as optimal as it could be...."
- outputBuffer _ outputBuffer contents. "convert to String for convenience in the loop. still not as optimal as it could be...."
[outputBuffer size > 0 and: [ socket sendDone ]] whileTrue: [
"do some output"
+ amountSent := socket sendSomeData: outputBuffer.
+ outputBuffer := outputBuffer copyFrom: amountSent+1 to: outputBuffer size. ].
+ outputBuffer := WriteStream on: outputBuffer.
- amountSent _ socket sendSomeData: outputBuffer.
- outputBuffer _ outputBuffer copyFrom: amountSent+1 to: outputBuffer size. ].
- outputBuffer _ WriteStream on: outputBuffer.
"do some input"
self processInput: socket receiveAvailableData.!
Item was changed:
----- Method: TelnetMachine>>processInput: (in category 'private') -----
processInput: aString
"process input from the network"
| newDisplayText |
(processingCommand not and: [(aString indexOf: IAC) = 0]) ifTrue: [
"no commands here--display the whole string"
self displayString: aString.
self changed: #displayBuffer.
^self ].
Transcript show: 'slow.'; cr.
+ newDisplayText := WriteStream on: String new.
- newDisplayText _ WriteStream on: String new.
aString do: [ :c |
processingCommand ifTrue: [
"an IAC has been seen"
commandChar
ifNil: [
"c is the command character. act immediately if c=IAC, otherwise save it and wait fro the next character"
+ commandChar := c.
+ (commandChar = IAC) ifTrue: [ self displayChar: IAC. processingCommand := false ] ]
- commandChar _ c.
- (commandChar = IAC) ifTrue: [ self displayChar: IAC. processingCommand _ false ] ]
ifNotNil: [
commandChar == DOChar ifTrue: [ self processDo: c. ].
commandChar == DONTChar ifTrue: [ self processDont: c ].
commandChar == WILLChar ifTrue: [ self processWill: c ].
commandChar == WONTChar ifTrue: [ self processWont: c ].
+ processingCommand := false. ] ]
- processingCommand _ false. ] ]
ifFalse: [
"normal mode"
+ c = IAC ifTrue: [ processingCommand := true. commandChar := nil ] ifFalse: [
- c = IAC ifTrue: [ processingCommand _ true. commandChar _ nil ] ifFalse: [
newDisplayText nextPut: c ] ] ].
self displayString: newDisplayText contents.
self changed: #displayBuffer
!
Item was changed:
----- Method: TelnetMachine>>processWill: (in category 'private') -----
processWill: optionChar
optionChar == OPTEcho ifTrue: [
requestedRemoteEcho ifTrue: [
+ remoteEchoAgreed := true ]
- remoteEchoAgreed _ true ]
ifFalse: [
"they are offering remote echo, though we haven't asked. Answer: oh yes."
self do: OPTEcho.
+ requestedRemoteEcho := true.
+ remoteEchoAgreed := true. ].
- requestedRemoteEcho _ true.
- remoteEchoAgreed _ true. ].
^self ].
"they've requested an unknown option. reject it"
self dont: optionChar.!
Item was changed:
----- Method: TelnetMachine>>processWont: (in category 'private') -----
processWont: optionChar
optionChar == OPTEcho ifTrue: [
+ remoteEchoAgreed := false.
+ requestedRemoteEcho := false.
- remoteEchoAgreed _ false.
- requestedRemoteEcho _ false.
^self ].
!
Item was changed:
----- Method: TelnetMachine>>remoteHost: (in category 'access') -----
remoteHost: aString
"set which host to connect to"
+ hostname := aString!
- hostname _ aString!
Item was changed:
----- Method: TelnetMachine>>setHostName (in category 'menu') -----
setHostName
| newHostname |
+ newHostname := FillInTheBlank request: 'host to connect to' initialAnswer: hostname.
+ newHostname size > 0 ifTrue: [ hostname := newHostname ].!
- newHostname _ FillInTheBlank request: 'host to connect to' initialAnswer: hostname.
- newHostname size > 0 ifTrue: [ hostname _ newHostname ].!
Item was changed:
----- Method: TelnetMachine>>setPort (in category 'menu') -----
setPort
| portString |
+ portString := port printString.
+ portString := FillInTheBlank request: 'port to connect on' initialAnswer: portString.
+ portString := portString withBlanksTrimmed.
+ portString isEmpty ifFalse: [ port := portString asNumber asInteger ].!
- portString _ port printString.
- portString _ FillInTheBlank request: 'port to connect on' initialAnswer: portString.
- portString _ portString withBlanksTrimmed.
- portString isEmpty ifFalse: [ port _ portString asNumber asInteger ].!
Item was changed:
----- Method: TestCaseDebugger>>doneSemaphore: (in category 'as yet unclassified') -----
doneSemaphore: aSemaphore
+ doneSemaphore := aSemaphore.!
- doneSemaphore _ aSemaphore.!
Item was changed:
----- Method: Tetris>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ board := TetrisBoard new game: self.
- board _ TetrisBoard new game: self.
self listDirection: #topToBottom;
wrapCentering: #center;
vResizing: #shrinkWrap;
hResizing: #shrinkWrap;
layoutInset: 3;
addMorphBack: self makeGameControls;
addMorphBack: self makeMovementControls;
addMorphBack: self showScoreDisplay;
addMorphBack: board.
board newGame!
Item was changed:
----- Method: Tetris>>keyStroke: (in category 'event handling') -----
keyStroke: evt
| charValue |
+ charValue := evt keyCharacter asciiValue.
- charValue _ evt keyCharacter asciiValue.
charValue = 28 ifTrue: [board moveLeft].
charValue = 29 ifTrue: [board moveRight].
charValue = 30 ifTrue: [board rotateClockWise].
charValue = 31 ifTrue: [board rotateAntiClockWise].
charValue = 32 ifTrue: [board dropAllTheWay].
!
Item was changed:
----- Method: TetrisBlock class>>shapeChoices (in category 'as yet unclassified') -----
shapeChoices
^ ShapeChoices ifNil: [
+ ShapeChoices := {
- ShapeChoices _ {
{ { 0 @ 0 . 1 @ 0 . 0 @ 1 . 1 @ 1 } }. "square - one is sufficient here"
self flipShapes: { 0 @ 0 . -1 @ 0 . 1 @ 0 . 0 @ -1 }. "T"
{
{ 0 @ 0 . -1 @ 0 . 1 @ 0 . 2 @ 0 }.
{ 0 @ 0 . 0 @ -1 . 0 @ 1 . 0 @ 2 } "long - two are sufficient here"
}.
self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . 1 @ 1 }. "L"
self flipShapes: { 0 @ 0 . 0 @ -1 . 0 @ 1 . -1 @ 1 }. "inverted L"
self flipShapes: { 0 @ 0 . -1 @ 0 . 0 @ -1 . 1 @ -1 }. "S"
self flipShapes: { 0 @ 0 . 1 @ 0 . 0 @ -1 . -1 @ -1 } "Z"
}.
]
!
Item was changed:
----- Method: TetrisBlock>>board: (in category 'as yet unclassified') -----
board: theBoard
+ board := theBoard.
- board _ theBoard.
4 timesRepeat: [
self addMorph: (
RectangleMorph new
color: color;
extent: board cellSize;
borderRaised
)
].
self positionCellMorphs.!
Item was changed:
----- Method: TetrisBlock>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
"keep this puppy out of sight"
+ shapeInfo := self class shapeChoices atRandom.
+ baseCellNumber := 4 atRandom + 2 @ 1.
+ angle := 4 atRandom!
- shapeInfo _ self class shapeChoices atRandom.
- baseCellNumber _ 4 atRandom + 2 @ 1.
- angle _ 4 atRandom!
Item was changed:
----- Method: TetrisBlock>>moveDeltaX:deltaY:deltaAngle: (in category 'as yet unclassified') -----
moveDeltaX: deltaX deltaY: deltaY deltaAngle: deltaAngle
| delta |
+ delta := deltaX @ deltaY.
- delta _ deltaX @ deltaY.
(shapeInfo atWrap: angle + deltaAngle) do: [ :offsetThisCell |
(board emptyAt: baseCellNumber + offsetThisCell + delta) ifFalse: [^ false]
].
+ baseCellNumber := baseCellNumber + delta.
+ angle := angle + deltaAngle - 1 \\ 4 + 1.
- baseCellNumber _ baseCellNumber + delta.
- angle _ angle + deltaAngle - 1 \\ 4 + 1.
self positionCellMorphs.
^ true !
Item was changed:
----- Method: TetrisBlock>>positionCellMorphs (in category 'as yet unclassified') -----
positionCellMorphs
(shapeInfo atWrap: angle) withIndexDo: [ :each :index |
(submorphs at: index)
position: (board originForCell: baseCellNumber + each)
].
+ fullBounds := nil.
- fullBounds _ nil.
self changed.
!
Item was changed:
----- Method: TetrisBoard>>checkForFullRows (in category 'other') -----
checkForFullRows
| targetY morphsInRow bonus |
self numRows to: 2 by: -1 do: [ :row |
+ targetY := (self originForCell: 1 at row) y.
- targetY _ (self originForCell: 1 at row) y.
[
+ morphsInRow := self submorphsSatisfying: [ :each | each top = targetY].
- morphsInRow _ self submorphsSatisfying: [ :each | each top = targetY].
morphsInRow size = self numColumns
] whileTrue: [
+ bonus := (morphsInRow collect: [:each | each color]) asSet size = 1
- bonus _ (morphsInRow collect: [:each | each color]) asSet size = 1
ifTrue: [1000]
ifFalse: [100].
self score: score + bonus.
submorphs copy do: [ :each |
each top = targetY ifTrue: [
each delete
].
each top < targetY ifTrue: [
each position: each position + (0 at self cellSize y)
].
].
].
].
!
Item was changed:
----- Method: TetrisBoard>>emptyAt: (in category 'data') -----
emptyAt: aPoint
| cellOrigin |
(aPoint x between: 1 and: self numColumns) ifFalse: [^ false].
(aPoint y < 1) ifTrue: [^ true]. "handle early phases"
(aPoint y <= self numRows) ifFalse: [^ false].
+ cellOrigin := self originForCell: aPoint.
- cellOrigin _ self originForCell: aPoint.
^(self submorphsSatisfying: [ :each | each topLeft = cellOrigin]) isEmpty
!
Item was changed:
----- Method: TetrisBoard>>game: (in category 'accessing') -----
game: aTetris
+ game := aTetris!
- game _ aTetris!
Item was changed:
----- Method: TetrisBoard>>newGame (in category 'button actions') -----
newGame
self removeAllMorphs.
+ gameOver := paused := false.
+ delay := 500.
+ currentBlock := nil.
- gameOver _ paused _ false.
- delay _ 500.
- currentBlock _ nil.
self score: 0.
!
Item was changed:
----- Method: TetrisBoard>>pause (in category 'button actions') -----
pause
gameOver ifTrue: [^ self].
+ paused := paused not.
- paused _ paused not.
!
Item was changed:
----- Method: TetrisBoard>>score: (in category 'accessing') -----
score: aNumber
+ score := aNumber.
- score _ aNumber.
game score: score.!
Item was changed:
----- Method: TetrisBoard>>step (in category 'stepping and presenter') -----
step
(self ownerThatIsA: HandMorph) ifNotNil: [^self].
paused ifTrue: [^ self].
currentBlock ifNil: [
+ currentBlock := TetrisBlock new.
- currentBlock _ TetrisBlock new.
self addMorphFront: currentBlock.
currentBlock board: self.
] ifNotNil: [
currentBlock dropByOne ifFalse: [self storePieceOnBoard]
].
!
Item was changed:
----- Method: TetrisBoard>>storePieceOnBoard (in category 'other') -----
storePieceOnBoard
currentBlock submorphs do: [ :each |
self addMorph: each.
((each top - self top) // self cellSize y) < 3 ifTrue: [
+ paused := gameOver := true.
- paused _ gameOver _ true.
].
].
currentBlock delete.
+ currentBlock := nil.
- currentBlock _ nil.
self checkForFullRows.
self score: score + 10.
+ delay := delay - 2 max: 80.
- delay _ delay - 2 max: 80.
!
Item was changed:
----- Method: TextAnchorPlus>>emphasizeScanner: (in category 'as yet unclassified') -----
emphasizeScanner: scanner
anchoredMorph ifNil: [^self].
+ (anchoredMorph owner isKindOf: TextPlusPasteUpMorph) ifFalse: [^anchoredMorph := nil].
- (anchoredMorph owner isKindOf: TextPlusPasteUpMorph) ifFalse: [^anchoredMorph _ nil].
"follwing has been removed - there was no implementation for it"
"scanner setYFor: anchoredMorph"
!
Item was changed:
----- Method: TextComponent>>initPinSpecs (in category 'components') -----
initPinSpecs
+ pinSpecs := Array
- pinSpecs _ Array
with: (PinSpec new pinName: 'text' direction: #inputOutput
localReadSelector: nil localWriteSelector: nil
modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
defaultValue: 'some text' pinLoc: 1.5)!
Item was changed:
----- Method: TextInput>>name:defaultValue:textMorph: (in category 'private-initialization') -----
name: name0 defaultValue: defaultValue0 textMorph: textMorph0
+ name := name0.
+ defaultValue := defaultValue0.
+ textMorph := textMorph0.!
- name _ name0.
- defaultValue _ defaultValue0.
- textMorph _ textMorph0.!
Item was changed:
----- Method: TextLine>>justifiedPadFor: (in category '*Etoys-Squeakland-scanning') -----
justifiedPadFor: spaceIndex
"Compute the width of pad for a given space in a line of justified text."
| pad |
internalSpaces = 0 ifTrue: [^0].
+ pad := paddingWidth // internalSpaces.
- pad _ paddingWidth // internalSpaces.
spaceIndex <= (paddingWidth \\ internalSpaces)
ifTrue: [^pad + 1]
ifFalse: [^pad]!
Item was changed:
----- Method: TextLineInterval>>justifiedPadFor: (in category '*Etoys-Squeakland-scanning') -----
justifiedPadFor: spaceIndex
"Compute the width of pad for a given space in a line of justified text."
| pad |
internalSpaces = 0 ifTrue: [^0].
+ pad := paddingWidth // internalSpaces.
- pad _ paddingWidth // internalSpaces.
spaceIndex <= (paddingWidth \\ internalSpaces)
ifTrue: [^pad + 1]
ifFalse: [^pad]!
Item was changed:
----- Method: TextMorph class>>nonwrappingPrototype (in category '*Etoys-Squeakland-scripting') -----
nonwrappingPrototype
"Answer the default-text-object de jour; at this time, it's actually an instance of UserText."
| text style index baseFont textMorph |
text := Text fromString: 'Text' translated.
+ baseFont := Preferences standardEToysFont.
+ style := baseFont textStyle ifNil: [TextStyle default].
+ index := style fontIndexOfPointSize: 24.
- baseFont _ Preferences standardEToysFont.
- style _ baseFont textStyle ifNil: [TextStyle default].
- index _ style fontIndexOfPointSize: 24.
style defaultFontIndex: index.
text addAttribute: (TextFontChange fontNumber: index).
textMorph := UserText new.
textMorph
contentsWrapped: text;
setTextStyle: style;
margins: 0 at 0.
"Too ugly dirty hack from boldAuthoringPrototype."
textMorph wrapFlag: false.
textMorph fit.
textMorph usePango ifTrue: [textMorph wrapFlag: true].
^ textMorph
"
TextMorph nonwrappingPrototype openInHand
"!
Item was changed:
----- Method: TextMorph>>selectionColor (in category '*Etoys-Squeakland-private') -----
selectionColor
| ind attrs c |
+ ind := self editor startBlock stringIndex.
+ (ind isNil or: [ind < 1 or: [ind > text size]]) ifTrue: [ind := 1].
+ attrs := text attributesAt: ind.
+ c := attrs detect: [:attr | attr class = TextColor] ifNone: [].
- ind _ self editor startBlock stringIndex.
- (ind isNil or: [ind < 1 or: [ind > text size]]) ifTrue: [ind _ 1].
- attrs _ text attributesAt: ind.
- c _ attrs detect: [:attr | attr class = TextColor] ifNone: [].
^ c ifNil: [Color black] ifNotNil: [c color].
!
Item was changed:
----- Method: TextMorph>>selectionColor: (in category '*Etoys-Squeakland-private') -----
selectionColor: aColor
"Set the color of the current selection. If there is currently no selection, have the color apply to the entirety of the receiver's text."
| attribute int |
+ attribute := TextColor color: aColor.
+ int := self editor selectionInterval.
+ int size <= 0 ifTrue: [int := 1 to: text size].
- attribute _ TextColor color: aColor.
- int _ self editor selectionInterval.
- int size <= 0 ifTrue: [int _ 1 to: text size].
text addAttribute: attribute from: int first to: int last.
int size = text string size ifTrue:
+ [color := aColor].
- [color _ aColor].
self changed.
!
Item was changed:
----- Method: TextPropertiesMorph>>applyToWholeText: (in category '*Etoys-Squeakland-accessing') -----
applyToWholeText: anObject
"Set the value of applyToWholeText"
+ applyToWholeText := anObject!
- applyToWholeText _ anObject!
Item was changed:
----- Method: TextPropertiesMorph>>changeStyle (in category 'button actions') -----
changeStyle
"Put up a menu allowing the user to choose a new style for the TextMorph."
| aList reply style |
+ aList := StrikeFont actualFamilyNames.
- aList _ StrikeFont actualFamilyNames.
aList addFirst: 'DefaultTextStyle'.
+ reply := (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp.
- reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp.
reply ifNil: [^self].
+ (style := TextStyle named: reply) ifNil: [Beeper beep. ^ true].
- (style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true].
self applyToWholeText ifTrue: [self activeEditor selectAll].
self activeEditor changeStyleTo: style copy.
self activeTextMorph updateFromParagraph.
self activeTextMorph releaseEditor!
Item was changed:
----- Method: TextPropertiesMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ applyToWholeText := false.
- applyToWholeText _ false.
myTarget
ifNil:
+ [myTarget := TextMorph new openInWorld.
- [myTarget _ TextMorph new openInWorld.
myTarget contents: ''].
+ activeTextMorph := myTarget. "Formerly was a copy..."
- activeTextMorph _ myTarget. "Formerly was a copy..."
+ thingsToRevert := OrderedCollection new. "to control order of execution"
- thingsToRevert _ OrderedCollection new. "to control order of execution"
thingsToRevert
add: (#wrapFlag: -> myTarget isWrapped);
add: (#autoFit: -> myTarget isAutoFit);
add: (#setTextStyle: -> myTarget textStyle);
add: (#margins: -> myTarget margins);
add: (#extent: -> myTarget extent);
add: (#textColor: -> myTarget textColor);
add: (#restoreText: -> myTarget text deepCopy).
self rebuild!
Item was changed:
----- Method: TextPropertiesMorph>>offerFontMenu (in category 'button actions') -----
offerFontMenu
"Present a menu of available fonts, and if one is chosen, apply it to the current selection.
Use only names of Fonts of this paragraph "
| aList reply |
self establishSelectionInterval.
+ aList := self activeTextMorph textStyle fontNamesWithPointSizes.
+ reply := (SelectionMenu labelList: aList selections: aList) startUp.
- aList _ self activeTextMorph textStyle fontNamesWithPointSizes.
- reply _ (SelectionMenu labelList: aList selections: aList) startUp.
reply ifNil: [^self].
self establishSelectionInterval. "This really does need to be called again!!"
self activeEditor replaceSelectionWith:
(Text string: self activeEditor selection asString
attribute: (TextFontChange fontNumber: (aList indexOf: reply))).
self activeTextMorph updateFromParagraph.
self activeTextMorph releaseEditor!
Item was changed:
----- Method: TextPropertiesMorph>>selectionInterval: (in category '*Etoys-Squeakland-accessing') -----
selectionInterval: anObject
"Set the value of selectionInterval"
+ selectionInterval := anObject!
- selectionInterval _ anObject!
Item was changed:
----- Method: TextPropertiesMorph>>toggleSelectionAttribute: (in category 'button actions') -----
toggleSelectionAttribute: newAttribute
"Toggle the given text-attribute for the current text selection."
| selText oldAttributes |
self establishSelectionInterval.
self activeEditor selectFrom: selectionInterval start to: selectionInterval stop.
+ selText := self activeEditor selection asText.
+ oldAttributes := selText attributesAt: 1 forStyle: self activeTextMorph textStyle.
- selText _ self activeEditor selection asText.
- oldAttributes _ selText attributesAt: 1 forStyle: self activeTextMorph textStyle.
oldAttributes do: [:att |
(att dominates: newAttribute) ifTrue: [newAttribute turnOff]
].
self activeEditor replaceSelectionWith: (selText addAttribute: newAttribute).
self activeTextMorph updateFromParagraph.
self activeTextMorph releaseEditor!
Item was changed:
----- Method: TheWorldMenu class>>registerStandardInternetApps (in category '*Etoys-Squeakland-open-menu registry') -----
registerStandardInternetApps
"Register the three currently-built-in internet apps and the hook for SqueakMap with the open-menu registry. This is a one-time initialization affair, contending with the fact that the three apps are already in the image."
self registerOpenCommand:
{ 'Package Loader' translated. { TheWorldMenu . #openPackageLoader }. 'A tool that lets you browse and load packages from SqueakMap, an index of Squeak code available on the internet' translated}.
#(Scamper Celeste IRCConnection) do:
[:sym |
(Smalltalk at: sym ifAbsent: [nil]) ifNotNilDo:
[:aClass | aClass registerInOpenMenu]]
"
+ OpenMenuRegistry := nil.
- OpenMenuRegistry _ nil.
TheWorldMenu registerStandardInternetApps.
"!
Item was changed:
----- Method: TheWorldMenu>>buildShowSourceMenu (in category '*Etoys-Squeakland-construction') -----
buildShowSourceMenu
"Build the menu that is put up when the show-source button is hit."
| menu |
+ menu := MenuMorph new defaultTarget: self.
- menu _ MenuMorph new defaultTarget: self.
menu commandKeyHandler: self.
self colorForDebugging: menu.
menu addStayUpItem.
self fillIn: menu from: {
{'open...' translatedNoop. { self . #openWindow } }.
{'windows...' translatedNoop. { self . #windowsDo } }.
{'changes...' translatedNoop. { self . #changesDo } }}.
self fillIn: menu from: {
{'help...' translatedNoop. { self . #helpDo }. 'puts up a menu of useful items for updating the system, determining what version you are running, and much else' translatedNoop}.
{'appearance...' translatedNoop. { self . #appearanceDo }. 'put up a menu offering many controls over appearance.' translatedNoop}}.
self fillIn: menu from: {
{'do...' translatedNoop. { Utilities . #offerCommonRequests} . 'put up an editible list of convenient expressions, and evaluate the one selected.' translatedNoop}}.
self fillIn: menu from: {
nil.
{'objects (o)' translatedNoop. { #myWorld . #activateObjectsTool } . 'A tool for finding and obtaining many kinds of objects' translatedNoop}.
{'new morph...' translatedNoop. { self . #newMorph }. 'Offers a variety of ways to create new objects' translatedNoop}.
nil.
{'authoring tools...' translatedNoop. { self . #scriptingDo } . 'A menu of choices useful for authoring' translatedNoop}.
{'playfield options...' translatedNoop. { self . #playfieldDo } . 'A menu of options pertaining to this object as viewed as a playfield' translatedNoop}.
{'flaps...' translatedNoop. { self . #flapsDo } . 'A menu relating to use of flaps. For best results, use "keep this menu up"' translatedNoop}.
{'projects...' translatedNoop. { self . #projectDo }. 'A menu of commands relating to use of projects' translatedNoop}.
{'debug...' translatedNoop. { self . #debugDo } . 'a menu of debugging items' translatedNoop}.
nil.
{'edit this menu' translatedNoop. { self . #editShowSourceMenu } . 'open a code editor on the method that defines this menu' translatedNoop}}.
^ menu!
Item was changed:
----- Method: TheWorldMenu>>editShowSourceMenu (in category '*Etoys-Squeakland-as yet unclassified') -----
editShowSourceMenu
"Invoked from menu, opens up a single-msg browser on the method that defines the show-source menu."
| mr |
+ mr := MethodReference new setStandardClass: TheWorldMenu methodSymbol: #buildShowSourceMenu.
- mr _ MethodReference new setStandardClass: TheWorldMenu methodSymbol: #buildShowSourceMenu.
self systemNavigation browseMessageList: {mr} name: 'show-source menu' translated autoSelect: nil!
Item was changed:
----- Method: ThreePhaseButtonMorph class>>blackTriangularOpener (in category '*Etoys-Squeakland-instance creation') -----
blackTriangularOpener
"Answer a button pre-initialized with black triangular images images."
| f |
^ self new
+ onImage: (f := ScriptingSystem formAtKey: 'RightCaret');
- onImage: (f _ ScriptingSystem formAtKey: 'RightCaret');
pressedImage: (ScriptingSystem formAtKey: 'DownCaret');
offImage: (ScriptingSystem formAtKey: 'DownCaret');
extent: f extent + (2 at 0);
yourself
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>addTile (in category 'all') -----
addTile
| m1 desiredW m2 label |
self removeAllMorphs.
+ m1 := TilePadMorph new.
+ label := StringMorph contents: stringName translated font: ScriptingSystem fontForTiles.
- m1 _ TilePadMorph new.
- label _ StringMorph contents: stringName translated font: ScriptingSystem fontForTiles.
+ m2 := TileMorph new.
- m2 _ TileMorph new.
m2 extent: 20 at 22.
m2 minWidth: 20.
m1 extent: (m2 extent + (2 at 2)).
m1 setType: #Player.
m1 addMorph: m2.
+ desiredW := m1 width.
- desiredW _ m1 width.
self extent: (desiredW max: self basicWidth) @ self class defaultH.
m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
self addMorphBack: m1.
self addMorphFront: label.
+ playerTile := m1.
- playerTile _ m1.
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>initialize (in category 'all') -----
initialize
super initialize.
+ type := #Player.
+ operatorOrExpression := #getDistanceTo:.
+ stringName := 'distance to'.
- type _ #Player.
- operatorOrExpression _ #getDistanceTo:.
- stringName _ 'distance to'.
self addTile.
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>line1: (in category 'all') -----
line1: line1
| label |
self removeAllMorphs.
+ label := StringMorph contents: stringName translated font: ScriptingSystem fontForTiles.
- label _ StringMorph contents: stringName translated font: ScriptingSystem fontForTiles.
self addMorphBack: label.
self addMorphBack: playerTile.
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>operatorOrExpression: (in category 'all') -----
operatorOrExpression: aSymbol
+ operatorOrExpression := aSymbol.
- operatorOrExpression _ aSymbol.
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>stringName: (in category 'all') -----
stringName: aString
+ stringName := aString.
- stringName _ aString.
!
Item was changed:
----- Method: TileCommandWithArgumentMorph>>type: (in category 'all') -----
type: aSymbol
+ type := aSymbol.
- type _ aSymbol.
!
Item was changed:
----- Method: TileMorph class>>addArrowsOn: (in category '*Etoys-Squeakland-utilities') -----
addArrowsOn: aMorph
"add arrows on a morph, and answer {upArrow. downArrow}"
| downArrow upArrow holder |
+ downArrow := ImageMorph new image: TileMorph downPicture.
+ upArrow := ImageMorph new image: TileMorph upPicture.
+ holder := Morph new extent: downArrow width @ (upArrow height + downArrow height + 1).
- downArrow _ ImageMorph new image: TileMorph downPicture.
- upArrow _ ImageMorph new image: TileMorph upPicture.
- holder _ Morph new extent: downArrow width @ (upArrow height + downArrow height + 1).
holder beTransparent.
upArrow position: holder topLeft.
downArrow position: upArrow left @ (upArrow bottom + 1).
holder addMorph: upArrow.
holder addMorph: downArrow.
holder setProperty: #arrows toValue: true.
holder clipSubmorphs: true.
aMorph addMorphFront: holder.
^ Array with: upArrow with: downArrow!
Item was changed:
----- Method: TileMorph class>>fixCaretForms (in category 'class initialization') -----
fixCaretForms
"TileMorph fixCaretForms"
"UpPicture storeString"
"DownPicture storeString"
+ UpPicture := ((ColorForm
- UpPicture _ ((ColorForm
extent: 9 at 10
depth: 1
fromArray: #( 4152360960 4152360960 3816816640 3816816640 3246391296 3246391296 2155872256 2155872256 0 0)
offset: 0 at 0)
colorsFromArray: #(#(0.321 0.807 0.321) #( ) )).
+ DownPicture := ((ColorForm
- DownPicture _ ((ColorForm
extent: 9 at 10
depth: 1
fromArray: #( 0 0 2155872256 2155872256 3246391296 3246391296 3816816640 3816816640 4152360960 4152360960)
offset: 0 at 0)
colorsFromArray: #(#(0.321 0.807 0.321) #( ) )).
+ SuffixPicture := (((ColorForm
- SuffixPicture _ (((ColorForm
extent: 6 at 11
depth: 1
fromArray: #( 2080374784 1006632960 469762048 201326592 67108864 0 67108864 201326592 469762048 1006632960 2080374784)
offset: 0 at 0)
colorsFromArray: #(#(0.321 0.807 0.321) #( ) ))
colorsFromArray: #(#(0.321 0.807 0.321) #( ) )).
+ RetractPicture := ((ColorForm
- RetractPicture _ ((ColorForm
extent: 6 at 11
depth: 1
fromArray: #( 4160749568 4026531840 3758096384 3221225472 2147483648 0 2147483648 3221225472 3758096384 4026531840 4160749568)
offset: 0 at 0)
colorsFromArray: #(#(0.321 0.807 0.321) #( ) )).!
Item was changed:
----- Method: TileMorph class>>initialize (in category 'class initialization') -----
initialize
"TileMorph readInArrowGraphics -- call manually if necessary to bring graphics forward"
"TileMorph initialize"
+ UpdatingOperators := Dictionary new.
- UpdatingOperators _ Dictionary new.
UpdatingOperators at: #incr: put: #+.
UpdatingOperators at: #decr: put: #-.
UpdatingOperators at: #set: put: ''.
RetractPicture ifNil: [
+ RetractPicture := (SuffixPicture flipBy: #horizontal centerAt: (SuffixPicture center))].
+ SuffixArrowAllowance := 5 + SuffixPicture width + RetractPicture width.
+ UpArrowAllowance := 10.
- RetractPicture _ (SuffixPicture flipBy: #horizontal centerAt: (SuffixPicture center))].
- SuffixArrowAllowance _ 5 + SuffixPicture width + RetractPicture width.
- UpArrowAllowance _ 10.
+ EqualityOperators := Dictionary new.
- EqualityOperators _ Dictionary new.
EqualityOperators at: #< put: #eToysLT:.
EqualityOperators at: #<= put: #eToysLE:.
EqualityOperators at: #> put: #eToysGT:.
EqualityOperators at: #>= put: #eToysGE:.
EqualityOperators at: #= put: #eToysEQ:.
EqualityOperators at: #~= put: #eToysNE:.
!
Item was changed:
----- Method: TileMorph>>acceptNewLiteral (in category 'code generation') -----
acceptNewLiteral
"Tell the scriptEditor who I belong to that I have a new literal value."
| topScript |
+ topScript := self outermostMorphThat:
- topScript _ self outermostMorphThat:
[:m | m isKindOf: ScriptEditorMorph].
topScript ifNotNil: [topScript installWithNewLiteral].
(self ownerThatIsA: ViewerLine) ifNotNilDo:
[:aLine |
(self ownerThatIsA: PhraseTileMorph) ifNotNil:
[aLine removeHighlightFeedback.
self layoutChanged.
ActiveWorld doOneSubCycle.
aLine addCommandFeedback: nil]]!
Item was changed:
----- Method: TileMorph>>addRetractArrow (in category 'arrows') -----
addRetractArrow
"If it's appropriate, add the retract arrow. Only called when suffixArrow is already present and in submorph tree."
self couldRetract ifNil: [^ self rescindRetractArrow].
retractArrow ifNil:
+ [retractArrow := ImageMorph new image: RetractPicture].
- [retractArrow _ ImageMorph new image: RetractPicture].
self addMorph: retractArrow inFrontOf: suffixArrow.
+ fullBounds := nil.
- fullBounds _ nil.
self extent: self fullBounds extent!
Item was changed:
----- Method: TileMorph>>addRetractArrowAnyway (in category '*Etoys-Squeakland-arrows') -----
addRetractArrowAnyway
+ retractArrow := ImageMorph new image: RetractPicture.
- retractArrow _ ImageMorph new image: RetractPicture.
suffixArrow ifNotNil: [
self addMorph: retractArrow inFrontOf: suffixArrow].
+ fullBounds := nil.
- fullBounds _ nil.
self extent: self fullBounds extent!
Item was changed:
----- Method: TileMorph>>addSuffixArrow (in category 'arrows') -----
addSuffixArrow
"Add a suffix arrow to the receiver, and set it in my suffixArrow instance variable. If I already have something there, remove it first."
suffixArrow ifNotNil: [suffixArrow delete].
+ suffixArrow := ImageMorph new image: SuffixPicture.
- suffixArrow _ ImageMorph new image: SuffixPicture.
self addMorphBack: suffixArrow.!
Item was changed:
----- Method: TileMorph>>arrowAction: (in category 'arrows') -----
arrowAction: delta
"Do what is appropriate when an arrow on the tile is pressed; delta will
be +1 or -1"
| index options |
(type == #literal
and: [literal isNumber])
ifTrue: [self value:(((literal + delta) printShowingDecimalPlaces: self decimalPlaces) asNumber)]
+ ifFalse: [options := self options
- ifFalse: [options _ self options
ifNil: [^ self].
+ index := (options first indexOf: self value)
- index _ (options first indexOf: self value)
+ delta.
self
value: (options first atWrap: index).
(options second atWrap: index) ifNotNilDo:
[:bt |
submorphs last
setBalloonText: bt translated]]!
Item was changed:
----- Method: TileMorph>>arrowDelta (in category 'mouse handling') -----
arrowDelta
"Answer the amount by which a number I display should increase at a time"
| readout |
+ (readout := self findA: UpdatingStringMorph) ifNotNil: [^readout floatPrecision ].
- (readout _ self findA: UpdatingStringMorph) ifNotNil: [^readout floatPrecision ].
^1!
Item was changed:
----- Method: TileMorph>>couldRetract (in category 'arrows') -----
couldRetract
"See if it makes sense to retract this tile and the op before it. Return the phrase that gets retracted, or nil if not allowed."
| phrase pad |
(owner isKindOf: PhraseTileMorph) "car's x"
ifTrue:
[phrase := owner.
((pad := phrase owner) isKindOf: TilePadMorph)
ifFalse: [^ nil]]
ifFalse:
[(owner isKindOf: TilePadMorph) ifFalse: [^ nil].
phrase := owner owner.
((pad := phrase owner) isKindOf: TilePadMorph)
ifFalse: [^ nil]].
phrase firstSubmorph type == pad type ifFalse: "typically it will be of type Player, as in Car's x"
[phrase submorphs size < 3 ifFalse: [^ nil]. "types should have matched"
"Go up a level"
+ (phrase := pad ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
+ (pad := phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
- (phrase _ pad ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
- (pad _ phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
(phrase firstSubmorph "goodPad") type == pad type ifFalse: [^ nil]].
(self hasOwner: phrase submorphs last) ifFalse: [^ nil].
^ phrase
!
Item was changed:
----- Method: TileMorph>>decimalPlaces (in category '*Etoys-Squeakland-mouse handling') -----
decimalPlaces
"Answer the number of decimal places of the contained number"
| readout |
+ (readout := self findA: UpdatingStringMorph) ifNotNil: [^readout decimalPlaces ].
- (readout _ self findA: UpdatingStringMorph) ifNotNil: [^readout decimalPlaces ].
^0!
Item was changed:
----- Method: TileMorph>>deleteSuffixArrow (in category 'arrows') -----
deleteSuffixArrow
"Delete the suffix and retract arrows if present."
suffixArrow ifNotNil: [suffixArrow delete].
+ suffixArrow := nil.
- suffixArrow _ nil.
retractArrow ifNotNil: ["backward compat"
retractArrow delete.
+ retractArrow := nil].
- retractArrow _ nil].
self updateLiteralLabel!
Item was changed:
----- Method: TileMorph>>emblazonPlayerNameOnReferenceTileWithin: (in category '*Etoys-Squeakland-initialization') -----
emblazonPlayerNameOnReferenceTileWithin: scriptorOrViewer
"Make the string within the receiver be the right thing."
| newLabel usePad |
newLabel := actualObject externalName.
Preferences implicitSelfInTiles ifTrue:
[scriptorOrViewer ifNotNil:
[scriptorOrViewer playerScripted == actualObject ifTrue:
[newLabel := '']]].
(newLabel notEmpty and: [self isPossessive]) ifTrue:
+ [newLabel := newLabel, '''s' translated].
- [newLabel _ newLabel, '''s' translated].
self line1: newLabel.
usePad := owner isKindOf: TilePadMorph.
newLabel
ifEmpty:
[usePad ifTrue: [owner hResizing: #rigid; width: 0; clipSubmorphs: true].
self hResizing: #rigid; width: 0; borderWidth: 0]
ifNotEmpty:
[usePad ifTrue: [owner hResizing: #shrinkWrap; clipSubmorphs: false].
self hResizing: #shrinkWrap; borderWidth: 1]
!
Item was changed:
----- Method: TileMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self extent: 1 @ 1.
self
typeColor: (Color
r: 0.8
g: 1.0
b: 0.6).
+ type := #literal.
- type _ #literal.
"#literal, #slotRef, #objRef, #operator, #expression"
+ slotName := ''.
+ literal := 1.
- slotName _ ''.
- literal _ 1.
self layoutPolicy: TableLayout new.
self minCellSize: 0 @ TileMorph defaultH.
self cellInset: 2 @ 0.
self layoutInset: 1 @ 0.
self listDirection: #leftToRight.
self wrapCentering: #center.
self hResizing: #shrinkWrap.
self vResizing: #spaceFill!
Item was changed:
----- Method: TileMorph>>line1: (in category 'private') -----
line1: line1
"Emblazon the receiver with the requested label. If the receiver already has a label, make the new label be of the same class"
| m desiredW classToUse lab f |
+ classToUse := (lab := self labelMorph) ifNotNil: [lab class] ifNil: [StringMorph].
- classToUse _ (lab _ self labelMorph) ifNotNil: [lab class] ifNil: [StringMorph].
self removeAllMorphs.
+ f := ScriptingSystem fontForTiles.
- f _ ScriptingSystem fontForTiles.
(type = #operator and: [#(+ - * / // \\ < <= > >= = ~=) includes: operatorOrExpression]) ifTrue: [
+ f := f emphasized: 1].
+ m := classToUse contents: line1 font: f.
+ desiredW := m width + 6.
- f _ f emphasized: 1].
- m _ classToUse contents: line1 font: f.
- desiredW _ m width + 6.
self extent: (desiredW max: self minimumWidth) @ self class defaultH.
m position: self center - (m extent // 2).
self addMorph: m.
!
Item was changed:
----- Method: TileMorph>>phraseForOp:arg:resultType: (in category 'arrows') -----
phraseForOp: op arg: arg resultType: resultType
"Answer a numeric-valued phrase derived from the receiver, whose extension arrow has just been hit. Pass along my float-precision."
| phrase srcLabel distLabel |
+ phrase := self presenter
- phrase _ self presenter
phraseForReceiver: literal
op: op
arg: 1
resultType: #Number.
+ srcLabel := self findA: UpdatingStringMorph.
+ distLabel := phrase submorphs first submorphs first findA: UpdatingStringMorph.
- srcLabel _ self findA: UpdatingStringMorph.
- distLabel _ phrase submorphs first submorphs first findA: UpdatingStringMorph.
srcLabel ifNotNil:
[distLabel floatPrecision: srcLabel floatPrecision].
^ phrase!
Item was changed:
----- Method: TileMorph>>retractArrowHit (in category '*Etoys-Squeakland-arrows') -----
retractArrowHit
"The user hit the retract button; carry out the retraction."
| phrase pad goodPad |
+ (phrase := self couldRetract) ifNil: [^ self].
+ pad := phrase ownerThatIsA: TilePadMorph.
+ goodPad := phrase firstSubmorph.
- (phrase _ self couldRetract) ifNil: [^ self].
- pad _ phrase ownerThatIsA: TilePadMorph.
- goodPad _ phrase firstSubmorph.
pad owner replaceSubmorph: pad by: goodPad.
goodPad topEditor scriptEdited!
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 word |
+ menuChoices := (self options first collect: [:each | each asString]) collect: [:each |
- menuChoices _ (self options first collect: [:each | each asString]) collect: [:each |
word := self currentVocabulary translatedWordingFor: each asSymbol.
word isEmpty
ifTrue: ['<-']
ifFalse: [word]].
+ result := (SelectionMenu labelList: menuChoices lines: nil selections: self options first) startUp.
- result _ (SelectionMenu labelList: menuChoices lines: nil selections: self options first) startUp.
result
ifNotNil: [self value: result.
self scriptEdited]!
Item was changed:
----- Method: TileMorph>>showSuffixChoices (in category 'arrows') -----
showSuffixChoices
"The suffix arrow has been hit, so respond appropriately"
| plusPhrase phrase pad outer num |
ActiveEvent shiftPressed ifTrue: [^ self wrapPhraseInFunction].
+ (phrase := self ownerThatIsA: PhraseTileMorph orA: FunctionTile) ifNil: [nil].
- (phrase _ self ownerThatIsA: PhraseTileMorph orA: FunctionTile) ifNil: [nil].
(type == #literal) & (literal isNumber) ifTrue: ["Tile is a constant number"
(phrase isNil or: [phrase finalTilePadSubmorph == owner]) "pad"
ifTrue: ["we are adding the first time (at end of our phrase)"
+ plusPhrase := self phraseForOp: #+ arg: 1 resultType: #Number.
- plusPhrase _ self phraseForOp: #+ arg: 1 resultType: #Number.
plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
owner acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
+ num := plusPhrase firstSubmorph firstSubmorph.
- num _ plusPhrase firstSubmorph firstSubmorph.
num deleteSuffixArrow]].
(#(function expression parameter) includes: type) ifTrue:
+ [pad := self ownerThatIsA: TilePadMorph.
+ plusPhrase := self presenter phraseForReceiver: 1 op: #+ arg: 1 resultType: #Number.
- [pad _ self ownerThatIsA: TilePadMorph.
- plusPhrase _ self presenter phraseForReceiver: 1 op: #+ arg: 1 resultType: #Number.
plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
pad acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
plusPhrase firstSubmorph removeAllMorphs; addMorph: self.
pad topEditor scriptEdited "recompile"].
type = #operator ifTrue: ["Tile is accessor of an expression"
phrase resultType == #Number ifTrue:
+ [outer := phrase ownerThatIsA: PhraseTileMorph orA: TimesRepeatTile.
+ pad := self ownerThatIsA: TilePadMorph.
- [outer _ phrase ownerThatIsA: PhraseTileMorph orA: TimesRepeatTile.
- pad _ self ownerThatIsA: TilePadMorph.
outer ifNotNil:
[(outer lastSubmorph == pad or: [true]) ifTrue: [ "first time"
+ plusPhrase := self presenter phraseForReceiver: 1
- plusPhrase _ self presenter phraseForReceiver: 1
op: #+ arg: 1 resultType: #Number.
plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
pad acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
plusPhrase firstSubmorph removeAllMorphs; addMorph: phrase. "car's heading"
pad topEditor scriptEdited "recompile & deal with carets"]]]].
(self topEditor ifNil: [phrase ifNil: [^ self]]) enforceTileColorPolicy!
Item was changed:
----- Method: TileMorph>>storeCodeOn:indent: (in category 'code generation') -----
storeCodeOn: aStream indent: tabCount
"Store code representing the receiver onto the stream, with the given amount of indentation"
| op playerBearingCode |
playerBearingCode := self playerBearingCode. "Must determine whom is scripted for what follows to work; if it's ever nil, we've got trouble"
type = #expression
ifTrue:
[^aStream
nextPut: $(;
nextPutAll: operatorOrExpression;
nextPut: $)].
type = #literal
ifTrue:
[^aStream
nextPut: $(;
nextPutAll: literal printString;
nextPut: $)].
type == #objRef
ifTrue:
[^playerBearingCode == actualObject
ifTrue:
["If the object is the method's own 'self' then we MUST, rather than just MAY, put out 'self' rather than the referencer call, though the latter will temporarily work if only one instance of the uniclass exists."
aStream nextPutAll: 'self']
ifFalse:
[(actualObject isPlayerLike and: [actualObject isSequentialStub]) ifTrue: [
actualObject storeCodeOn: aStream indent: tabCount.
] ifFalse: [
Preferences capitalizedReferences
ifTrue:
["Global dictionary References"
self flag: #deferred. "Start deploying the meesage-receiver hints soon"
aStream nextPutAll: actualObject uniqueNameForReference]
ifFalse:
["old class-inst-var-based scheme used Feb 1998 to Oct 2000, and indeed
ongoing in school year 2000-01 at the open school"
aStream nextPutAll: 'self class '.
aStream
nextPutAll: (playerBearingCode class referenceSelectorFor: actualObject)]]]].
type = #operator
ifTrue:
[op := ((UpdatingOperators includesKey: operatorOrExpression)
and: [self precedingTileType = #slotRef])
ifTrue: [UpdatingOperators at: operatorOrExpression]
ifFalse: [operatorOrExpression].
^op isEmpty
ifTrue: [aStream position: aStream position - 1]
ifFalse: [aStream nextPutAll: (EqualityOperators at: op ifAbsent: [op])]].
"The following branch has long been disused
type = #slotRef ifTrue:
[self isThisEverCalled.
+ refType := self slotRefType.
- refType _ self slotRefType.
refType = #get ifTrue:
[^ aStream
nextPutAll: targetName;
space;
nextPutAll: (Utilities getterSelectorFor: slotName)].
refType = #set ifTrue:
[^ aStream
nextPutAll: targetName;
space;
nextPutAll: (Utilities setterSelectorFor: slotName);
nextPut: $:].
refType = #update ifTrue:
[^ aStream
nextPutAll: targetName;
space;
nextPutAll: slotName;
nextPutAll: ': ';
nextPutAll: targetName;
space;
nextPutAll: slotName]]"!
Item was changed:
----- Method: TileMorph>>updateWordingToMatchVocabulary (in category 'initialization') -----
updateWordingToMatchVocabulary
"The current vocabulary has changed; change the wording on my face, if appropriate"
| aMethodInterface |
type == #operator ifTrue:
[self line1: (self currentVocabulary tileWordingForSelector: operatorOrExpression).
(ScriptingSystem doesOperatorWantArrows: operatorOrExpression)
ifTrue: [self addArrows].
self updateLiteralLabel.
+ aMethodInterface := self currentVocabulary methodInterfaceAt: operatorOrExpression
- aMethodInterface _ self currentVocabulary methodInterfaceAt: operatorOrExpression
ifAbsent: [
Vocabulary eToyVocabulary
methodInterfaceAt: operatorOrExpression ifAbsent: [^ self]].
self setBalloonText: aMethodInterface documentation.
].
type == #objRef ifTrue: [
self isPossessive
ifTrue: [self bePossessive]
ifFalse: [
self labelMorph ifNotNilDo: [:label |
label contents: self actualObject nameForViewer asSymbol translated]
]
].
"submorphs last setBalloonText: aMethodInterface documentation"!
Item was changed:
----- Method: TileMorph>>wrapPhraseInFunction (in category '*Etoys-Squeakland-arrows') -----
wrapPhraseInFunction
"The user made a gesture requesting that the phrase for which the receiver bears the widget hit be wrapped in a function. This applies for the moment only to numeric functions"
| pad newPad functionPhrase |
+ pad := self ownerThatIsA: TilePadMorph. "Or something higher than that???"
- pad _ self ownerThatIsA: TilePadMorph. "Or something higher than that???"
(pad isNil or: [pad type ~= #Number]) ifTrue: [^ Beeper beep].
+ newPad := TilePadMorph new setType: #Number.
- newPad _ TilePadMorph new setType: #Number.
newPad hResizing: #shrinkWrap; vResizing: #spacefill.
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
newPad addMorphBack: functionPhrase.
pad owner replaceSubmorph: pad by: newPad.
functionPhrase operator: #abs pad: pad.
functionPhrase addSuffixArrow.
self scriptEdited
!
Item was changed:
----- Method: TilePadMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aMorph event: evt
"Accept the given morph within my bowels"
| editor wasPossessive morphToUse |
wasPossessive := submorphs notEmpty and: [submorphs first isPossessive].
+ morphToUse := self morphToDropFrom: aMorph.
- morphToUse _ self morphToDropFrom: aMorph.
self prepareToUndoDropOf: morphToUse.
self removeAllMorphs.
morphToUse position: self position.
self addMorph: morphToUse.
wasPossessive ifTrue: [morphToUse bePossessive].
((owner isKindOf: PhraseTileMorph) and: [self == owner submorphs last])
"Note: the non-phrase-tile-owner case is in the Times pane of a times/repeat complex"
ifTrue:
[self lastTileMorph addSuffixArrow].
self firstSubmorph hideWillingnessToAcceptDropFeedback.
(editor := self topEditor) ifNotNil: [editor scriptEdited]!
Item was changed:
----- Method: TilePadMorph>>lastTileMorph (in category '*Etoys-Squeakland-layout') -----
lastTileMorph
"Answer the final TileMorph in the receiver's tree -- this might be at any of three levels deep..."
| aMorph lastInPhrase |
submorphs ifEmpty: [^ nil]. "But should not normally happen."
+ ((aMorph := submorphs first) isTileMorph) ifTrue: [^ aMorph].
- ((aMorph _ submorphs first) isTileMorph) ifTrue: [^ aMorph].
"If first submorph is not a TileMorph, it will be a PhraseTileMorph so..."
(lastInPhrase := aMorph submorphs last) isTileMorph ifTrue: [^ lastInPhrase].
"If the last morph in the phrase is not a Tile, then it's a TilePadMorph..."
^ lastInPhrase lastTileMorph!
Item was changed:
----- Method: TilePadMorph>>scriptEdited (in category '*Etoys-Squeakland-miscellaneous') -----
scriptEdited
"Tell the scriptEditor who I belong to that I have changed."
| him |
+ (him := self outermostMorphThat: [:m| m isKindOf: ScriptEditorMorph])
- (him _ self outermostMorphThat: [:m| m isKindOf: ScriptEditorMorph])
ifNotNil: [him scriptEdited]!
Item was changed:
----- Method: TilePadMorph>>wrapInFunction (in category '*Etoys-Squeakland-miscellaneous') -----
wrapInFunction
"The user made a gesture requesting that the receiver be wrapped in a (numeric) function."
| newPad functionPhrase |
+ newPad := TilePadMorph new setType: #Number.
- newPad _ TilePadMorph new setType: #Number.
newPad hResizing: #shrinkWrap; vResizing: #spacefill.
+ functionPhrase := FunctionTile new.
- functionPhrase _ FunctionTile new.
newPad addMorphBack: functionPhrase.
owner replaceSubmorph: self by: newPad.
functionPhrase operator: #abs pad: self.
self scriptEdited!
Item was changed:
----- Method: TimesRepeatMorph>>initialize (in category 'initialization') -----
initialize
"Fully initialize the receiver."
| dummyColumn timesRow timesRepeatColumn repeatRow separator repeatLabel placeHolder doLabel ephemerum |
+ submorphs := #().
+ bounds := 0 at 0 corner: 50 at 40.
- submorphs _ #().
- bounds _ 0 at 0 corner: 50 at 40.
self color: Color orange muchLighter.
self layoutPolicy: TableLayout new.
self "border, and layout properties in alphabetical order..."
borderColor: self color darker;
borderWidth: 2;
cellSpacing: #none;
cellPositioning: #topLeft;
hResizing: #spaceFill;
layoutInset: 0;
listDirection: #leftToRight;
rubberBandCells: true;
vResizing: #shrinkWrap;
wrapCentering: #none.
self setNameTo: 'Repeat Complex'.
+ dummyColumn := AlignmentMorph newColumn.
- dummyColumn _ AlignmentMorph newColumn.
dummyColumn cellInset: 0; layoutInset: 0.
dummyColumn width: 0.
dummyColumn cellPositioning: #leftCenter.
dummyColumn hResizing: #shrinkWrap; vResizing: #spaceFill.
self addMorph: dummyColumn.
+ timesRepeatColumn := AlignmentMorph newColumn.
- timesRepeatColumn _ AlignmentMorph newColumn.
timesRepeatColumn setNameTo: 'Times Repeat'.
timesRepeatColumn cellPositioning: #topLeft.
timesRepeatColumn hResizing: #spaceFill.
timesRepeatColumn vResizing: #shrinkWrap.
timesRepeatColumn layoutInset: 0.
timesRepeatColumn borderWidth: 0.
timesRepeatColumn color: Color orange muchLighter.
+ timesRow := AlignmentMorph newRow color: color; layoutInset: 0.
- timesRow _ AlignmentMorph newRow color: color; layoutInset: 0.
timesRow minCellSize: (2 at 16).
timesRow setNameTo: 'Times'.
+ repeatLabel := StringMorph contents: 'Repeat' translated font: Preferences standardEToysFont.
- repeatLabel _ StringMorph contents: 'Repeat' translated font: Preferences standardEToysFont.
timesRow addMorphBack: repeatLabel.
timesRow vResizing: #shrinkWrap.
timesRow addMorphBack: (Morph new color: color; extent: 6 at 5). "spacer"
numberOfTimesToRepeatPart := TilePadMorph new setType: #Number.
numberOfTimesToRepeatPart hResizing: #shrinkWrap; color: Color transparent.
numberOfTimesToRepeatPart addMorphBack: (TileMorph new addArrows; setLiteral: 2).
numberOfTimesToRepeatPart borderWidth: 0; layoutInset: (1 at 0).
timesRow addMorphBack: numberOfTimesToRepeatPart.
timesRow addMorphBack: (StringMorph contents: ' times ' font: Preferences standardEToysFont).
timesRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
timesRepeatColumn addMorphBack: timesRow.
+ separator := AlignmentMorph newRow color: Color transparent.
- separator _ AlignmentMorph newRow color: Color transparent.
separator vResizing: #rigid; hResizing: #spaceFill; height: 2.
separator borderWidth: 0.
timesRepeatColumn addMorphBack: separator.
+ repeatRow := AlignmentMorph newRow color: color; layoutInset: 0.
- repeatRow _ AlignmentMorph newRow color: color; layoutInset: 0.
repeatRow minCellSize: (2 at 16).
repeatRow setNameTo: 'Repeat '.
+ placeHolder := Morph new.
- placeHolder _ Morph new.
placeHolder beTransparent; extent: (8 at 0).
repeatRow addMorphBack: placeHolder.
repeatRow vResizing: #shrinkWrap.
+ doLabel := StringMorph contents: 'Do' font: Preferences standardEToysFont.
- doLabel _ StringMorph contents: 'Do' font: Preferences standardEToysFont.
repeatRow addMorphBack: doLabel.
repeatRow addMorphBack: (Morph new color: color; extent: 5 at 5). "spacer"
+ repeatRow addMorphBack: (whatToRepeatPart := ScriptEditorMorph new borderWidth: 0; layoutInset: 0).
- repeatRow addMorphBack: (whatToRepeatPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 0).
whatToRepeatPart hResizing: #spaceFill.
whatToRepeatPart vResizing: #shrinkWrap.
whatToRepeatPart color: Color transparent.
whatToRepeatPart setNameTo: 'Script to repeat'.
whatToRepeatPart addMorphBack: (ephemerum := Morph new height: 14) beTransparent.
timesRepeatColumn addMorphBack: repeatRow.
self addMorphBack: timesRepeatColumn.
self bounds: self fullBounds.
ephemerum delete!
Item was changed:
----- Method: TimesRepeatMorph>>parseNodeWith: (in category 'code generation') -----
parseNodeWith: encoder
| rec selector arg |
+ rec := numberOfTimesToRepeatPart submorphs
- rec _ numberOfTimesToRepeatPart submorphs
ifEmpty:
[encoder encodeLiteral: 0]
ifNotEmpty:
[numberOfTimesToRepeatPart parseNodeWith: encoder].
+ selector := #timesRepeat:.
+ arg := self blockNode: whatToRepeatPart with: encoder.
- selector _ #timesRepeat:.
- arg _ self blockNode: whatToRepeatPart with: encoder.
^ MessageNode new
receiver: rec
selector: selector
arguments: (Array with: arg)
precedence: (selector precedence)
from: encoder
sourceRange: nil.
!
Item was changed:
----- Method: TimesRepeatMorph>>targetPartFor: (in category 'initialization') -----
targetPartFor: aMorph
"Return the row into which the given morph should be inserted."
| centerY |
+ centerY := aMorph fullBounds center y.
- centerY _ aMorph fullBounds center y.
{numberOfTimesToRepeatPart, whatToRepeatPart} do: [:m |
(centerY <= m bounds bottom) ifTrue: [^ m]].
^ noPart
!
Item was changed:
----- Method: TimesRepeatTile>>initialize (in category 'initialization') -----
initialize
"Fully initialize the receiver."
| dummyColumn timesRepeatColumn repeatRow separator placeHolder doLabel ephemerum |
+ submorphs := #().
+ bounds := 0 at 0 corner: 50 at 40.
- submorphs _ #().
- bounds _ 0 at 0 corner: 50 at 40.
self color: Color orange muchLighter.
self layoutPolicy: TableLayout new.
self "border, and layout properties in alphabetical order..."
borderColor: self color darker;
borderWidth: 2;
cellSpacing: #none;
cellPositioning: #topLeft;
hResizing: #spaceFill;
layoutInset: 0;
listDirection: #leftToRight;
rubberBandCells: true;
vResizing: #shrinkWrap;
wrapCentering: #none.
self setNameTo: 'Repeat Complex'.
+ dummyColumn := AlignmentMorph newColumn.
- dummyColumn _ AlignmentMorph newColumn.
dummyColumn cellInset: 0; layoutInset: 0.
dummyColumn width: 0.
dummyColumn cellPositioning: #leftCenter.
dummyColumn hResizing: #shrinkWrap; vResizing: #spaceFill.
self addMorph: dummyColumn.
+ timesRepeatColumn := AlignmentMorph newColumn.
- timesRepeatColumn _ AlignmentMorph newColumn.
timesRepeatColumn setNameTo: 'Times Repeat'.
timesRepeatColumn cellPositioning: #topLeft.
timesRepeatColumn hResizing: #spaceFill.
timesRepeatColumn vResizing: #shrinkWrap.
timesRepeatColumn layoutInset: 0.
timesRepeatColumn borderWidth: 0.
timesRepeatColumn color: Color orange muchLighter.
+ timesRow := TimesRow newRow color: color; layoutInset: 0.
- timesRow _ TimesRow newRow color: color; layoutInset: 0.
timesRepeatColumn addMorphBack: timesRow.
+ separator := AlignmentMorph newRow color: Color transparent.
- separator _ AlignmentMorph newRow color: Color transparent.
separator vResizing: #rigid; hResizing: #spaceFill; height: 2.
separator borderWidth: 0.
timesRepeatColumn addMorphBack: separator.
+ repeatRow := AlignmentMorph newRow color: color; layoutInset: 0.
- repeatRow _ AlignmentMorph newRow color: color; layoutInset: 0.
repeatRow minCellSize: (2 at 16).
repeatRow setNameTo: 'Repeat '.
+ placeHolder := Morph new.
- placeHolder _ Morph new.
placeHolder beTransparent; extent: (8 at 0).
repeatRow addMorphBack: placeHolder.
repeatRow vResizing: #shrinkWrap.
+ doLabel := StringMorph contents: 'Do' translated font: Preferences standardEToysFont.
- doLabel _ StringMorph contents: 'Do' translated font: Preferences standardEToysFont.
repeatRow addMorphBack: doLabel.
repeatRow addMorphBack: (Morph new color: color; extent: 5 at 5). "spacer"
+ repeatRow addMorphBack: (whatToRepeatPart := ScriptEditorMorph new borderWidth: 0; layoutInset: 0).
- repeatRow addMorphBack: (whatToRepeatPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 0).
whatToRepeatPart
hResizing: #spaceFill;
vResizing: #shrinkWrap;
color: (Color transparent);
height: (Preferences standardEToysFont height);
minHeight: (Preferences standardEToysFont height);
setNameTo: ('Script to repeat' translated);
addMorphBack: ((ephemerum := Morph new height: 14) beTransparent).
timesRepeatColumn addMorphBack: repeatRow.
self addMorphBack: timesRepeatColumn.
self bounds: self fullBounds.
ephemerum delete!
Item was changed:
----- Method: TimesRepeatTile>>parseNodeWith: (in category 'code generation') -----
parseNodeWith: encoder
"Answer a MessageNode representing the receiver."
| rec selector arg timesPart |
+ rec := (timesPart := self numberOfTimesToRepeatPart) submorphs
- rec _ (timesPart := self numberOfTimesToRepeatPart) submorphs
ifEmpty:
[encoder encodeLiteral: 0]
ifNotEmpty:
[timesPart parseNodeWith: encoder].
+ selector := #timesRepeat:.
+ arg := self blockNode: whatToRepeatPart with: encoder.
- selector _ #timesRepeat:.
- arg _ self blockNode: whatToRepeatPart with: encoder.
^ MessageNode new
receiver: rec
selector: selector
arguments: (Array with: arg)
precedence: (selector precedence)
from: encoder
sourceRange: nil
!
Item was changed:
----- Method: TimesRepeatTile>>targetPartFor: (in category 'initialization') -----
targetPartFor: aMorph
"Return the row into which the given morph should be inserted."
| centerY |
+ centerY := aMorph fullBounds center y.
- centerY _ aMorph fullBounds center y.
{self numberOfTimesToRepeatPart, whatToRepeatPart} do: [:m |
(centerY <= m bounds bottom) ifTrue: [^ m]].
^ noPart
!
Item was changed:
----- Method: TimesRow>>initialize (in category 'initialization') -----
initialize
"object initialization"
| repeatLabel |
super initialize.
self minCellSize: (2 at 16).
self setNameTo: 'Times'.
+ repeatLabel := StringMorph contents: 'Repeat' translated font: Preferences standardEToysFont.
- repeatLabel _ StringMorph contents: 'Repeat' translated font: Preferences standardEToysFont.
self addMorphBack: repeatLabel.
self vResizing: #shrinkWrap.
self addTransparentSpacerOfSize: (6 at 5).
timesPad := TilePadMorph new setType: #Number.
timesPad hResizing: #shrinkWrap; color: Color transparent.
timesPad addMorphBack: (TileMorph new addArrows; setLiteral: 2; addSuffixArrow; yourself).
timesPad borderWidth: 0; layoutInset: (1 at 0).
self addMorphBack: timesPad.
self addMorphBack: (StringMorph contents: (' ', ('times' translated), ' ') font: Preferences standardEToysFont).
self addMorphBack: AlignmentMorph newVariableTransparentSpacer!
Item was changed:
----- Method: TinyPaint>>brushColor: (in category 'menu') -----
brushColor: aColor
+ brushColor := aColor.
- brushColor _ aColor.
brush color: aColor.
!
Item was changed:
----- Method: TinyPaint>>clear (in category 'menu') -----
clear
self form: ((Form extent: 125 at 100 depth: 8) fillColor: color).
+ brush := Pen newOnForm: originalForm.
- brush _ Pen newOnForm: originalForm.
brush roundNib: brushSize.
brush color: brushColor.
!
Item was changed:
----- Method: TinyPaint>>fill (in category 'menu') -----
fill
| fillPt |
Cursor blank show.
Cursor crossHair showWhile:
+ [fillPt := Sensor waitButton - self position].
- [fillPt _ Sensor waitButton - self position].
originalForm shapeFill: brushColor interiorPoint: fillPt.
self changed.
!
Item was changed:
----- Method: TinyPaint>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ brushColor := Color red.
+ brushSize := 3.
- brushColor _ Color red.
- brushSize _ 3.
self clear!
Item was changed:
----- Method: TinyPaint>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ lastMouse := evt cursorPoint.
- lastMouse _ evt cursorPoint.
brush drawFrom: lastMouse - bounds origin to: lastMouse - bounds origin.
self invalidRect:
((lastMouse - brush sourceForm extent) corner:
(lastMouse + brush sourceForm extent)).
!
Item was changed:
----- Method: TinyPaint>>mouseMove: (in category 'event handling') -----
mouseMove: evt
| p |
+ p := evt cursorPoint.
- p _ evt cursorPoint.
p = lastMouse ifTrue: [^ self].
brush drawFrom: lastMouse - bounds origin to: p - bounds origin.
self invalidRect: (
((lastMouse min: p) - brush sourceForm extent) corner:
((lastMouse max: p) + brush sourceForm extent)).
+ lastMouse := p.
- lastMouse _ p.
!
Item was changed:
----- Method: TinyPaint>>setPenSize (in category 'menu') -----
setPenSize
| menu sizes nibSize |
+ menu := CustomMenu new.
+ sizes := (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
- menu _ CustomMenu new.
- sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
sizes do: [:w | menu add: w printString action: w].
+ nibSize := menu startUp.
- nibSize _ menu startUp.
nibSize ifNotNil: [
+ brushSize := nibSize.
- brushSize _ nibSize.
brush roundNib: nibSize].
!
Item was changed:
----- Method: ToggleButtonInput>>button: (in category 'private-initialize') -----
button: aButtonMorph
+ button := aButtonMorph!
- button _ aButtonMorph!
Item was changed:
----- Method: ToggleButtonInput>>name:value:checkedByDefault: (in category 'private-initialize') -----
name: aName value: aValue checkedByDefault: aFlag
+ name := aName.
+ value := aValue.
+ checkedByDefault := aFlag.
+ state := checkedByDefault!
- name _ aName.
- value _ aValue.
- checkedByDefault _ aFlag.
- state _ checkedByDefault!
Item was changed:
----- Method: ToggleButtonInput>>pressed: (in category 'button state') -----
pressed: aBoolean
+ state := aBoolean.
- state _ aBoolean.
self changed: #pressed.
button ifNotNil: [button step].
^true!
Item was changed:
----- Method: TopologicalSorter class>>test1 (in category 'as yet unclassified') -----
test1
"
MessageTally spyOn: [10000 timesRepeat: [TopologicalSorter test1]]
"
| t edges ret first second collection edgeCandidates |
+ t := TopologicalSorter new.
+ collection := #(1 2 3 4 5).
+ edgeCandidates := {
- t _ TopologicalSorter new.
- collection _ #(1 2 3 4 5).
- edgeCandidates _ {
{#(2 4). #(2 5). #(1 2)}.
{#(1 2)}.
{#(1 2). #(2 3). #(2 4)}.
{#(1 2). #(2 5). #(1 5)}.
{#(1 2). #(2 5). #(1 5). #(3 5)}.
{#(1 2). #(2 5). #(1 5). #(3 4)}.
}.
t collection: collection shuffled.
+ edges := edgeCandidates atRandom.
- edges _ edgeCandidates atRandom.
t edges: edges.
+ ret := t sort.
- ret _ t sort.
edges do: [:edge |
+ first := ret indexOf: edge first.
+ second := ret indexOf: edge second.
- first _ ret indexOf: edge first.
- second _ ret indexOf: edge second.
self assert: first < second
].
+ ret := ret reverse.
- ret _ ret reverse.
edges do: [:edge |
+ first := ret indexOf: edge first.
+ second := ret indexOf: edge second.
- first _ ret indexOf: edge first.
- second _ ret indexOf: edge second.
self assert: first > second
].
^ ret reverse.
!
Item was changed:
----- Method: TopologicalSorter class>>test2 (in category 'as yet unclassified') -----
test2
"
MessageTally spyOn: [10000 timesRepeat: [TopologicalSorter test2]]
"
| t edges ret first second collection edgeCandidates d |
+ t := TopologicalSorter new.
+ collection := #(1 2 3 4 5).
+ edgeCandidates := {
- t _ TopologicalSorter new.
- collection _ #(1 2 3 4 5).
- edgeCandidates _ {
{1. #(2). 2. #(4 5)}.
{1. #(2)}.
{1. #(2). 2. #(3 4)}.
{1. #(2 5). 2. #(5)}.
{1. #(2 5). 2. #(5). 3. #(5)}.
{1. #(2 5). 2. #(5). 3. #(4)}.
}.
+ edgeCandidates := edgeCandidates collect: [:list |
+ d := IdentityDictionary new.
- edgeCandidates _ edgeCandidates collect: [:list |
- d _ IdentityDictionary new.
1 to: list size by: 2 do: [:i | d at: (list at: i) put: (list at: i+1)].
d.
].
MessageTally spyOn: [10000 timesRepeat: [t collection: collection shuffled.
+ edges := edgeCandidates atRandom.
- edges _ edgeCandidates atRandom.
t edges: edges.
+ ret := t sort.]].
- ret _ t sort.]].
edges associationsDo: [:edge |
+ first := ret indexOf: edge key.
- first _ ret indexOf: edge key.
edge value do: [:value |
+ second := ret indexOf: value.
- second _ ret indexOf: value.
self assert: first < second
].
].
+ ret := ret reverse.
- ret _ ret reverse.
edges associationsDo: [:edge |
+ first := ret indexOf: edge key.
- first _ ret indexOf: edge key.
edge value do: [:value |
+ second := ret indexOf: value.
- second _ ret indexOf: value.
self assert: first > second
].
].
^ ret reverse.
!
Item was changed:
----- Method: TopologicalSorter>>collection: (in category 'all') -----
collection: aCollection
+ collection := aCollection.
+ firstGroup := OrderedCollection new: aCollection size.
+ secondGroup := OrderedCollection new: aCollection size.
- collection _ aCollection.
- firstGroup _ OrderedCollection new: aCollection size.
- secondGroup _ OrderedCollection new: aCollection size.
!
Item was changed:
----- Method: TopologicalSorter>>currentTimeStamp (in category 'all') -----
currentTimeStamp
+ currentTime := currentTime + 1.
- currentTime _ currentTime + 1.
^ currentTime.
!
Item was changed:
----- Method: TopologicalSorter>>edges: (in category 'all') -----
edges: collectionOfDictionaries
+ edges := collectionOfDictionaries.
+ currentTime := 0.
- edges _ collectionOfDictionaries.
- currentTime _ 0.
!
Item was changed:
----- Method: TopologicalSorter>>sort (in category 'all') -----
sort
| s |
collection do: [:e |
e outTime = 0 ifTrue: [firstGroup add: e] ifFalse: [secondGroup add: e].
e inTime < 0 ifTrue: [self visit: e]
].
+ s := secondGroup asSortedCollection: [:a :b | a outTime > b outTime].
- s _ secondGroup asSortedCollection: [:a :b | a outTime > b outTime].
^ firstGroup asArray, s.
!
Item was changed:
----- Method: TwoLevelDictionary>>initialize (in category 'as yet unclassified') -----
initialize
+ firstLevel := Dictionary new.!
- firstLevel _ Dictionary new.!
Item was changed:
----- Method: TwoLevelDictionary>>twoLevelKeys (in category 'as yet unclassified') -----
twoLevelKeys
| twoLevelSet |
+ twoLevelSet := TwoLevelSet new.
- twoLevelSet _ TwoLevelSet new.
self keysDo: [ :each | twoLevelSet add: each].
^twoLevelSet
!
Item was changed:
----- Method: TwoLevelSet>>copy (in category 'as yet unclassified') -----
copy
| answer |
+ answer := self class new initialize.
- answer _ self class new initialize.
self do: [ :each |
answer add: each
].
^answer!
Item was changed:
----- Method: TwoLevelSet>>initialize (in category 'as yet unclassified') -----
initialize
+ firstLevel := Dictionary new.!
- firstLevel _ Dictionary new.!
Item was changed:
----- Method: TwoLevelSet>>remove: (in category 'as yet unclassified') -----
remove: aPoint
| lev2 |
+ lev2 := firstLevel at: aPoint x ifAbsent: [^self].
- lev2 _ firstLevel at: aPoint x ifAbsent: [^self].
lev2 remove: aPoint y ifAbsent: [].
lev2 isEmpty ifTrue: [firstLevel removeKey: aPoint x].
!
Item was changed:
----- Method: TwoLevelSet>>removeAllXAndY: (in category 'as yet unclassified') -----
removeAllXAndY: aPoint
| deletes |
+ deletes := OrderedCollection new.
- deletes _ OrderedCollection new.
firstLevel removeKey: aPoint x ifAbsent: [].
firstLevel keysAndValuesDo: [ :x :lev2 |
lev2 remove: aPoint y ifAbsent: [].
lev2 isEmpty ifTrue: [deletes add: x].
].
deletes do: [ :each | firstLevel removeKey: each ifAbsent: []].!
Item was changed:
----- Method: TypeListTile>>addMenuIcon (in category 'arrows') -----
addMenuIcon
"Add a little menu icon; store it in my suffixArrow slot"
suffixArrow ifNotNil: [suffixArrow delete].
+ suffixArrow := ImageMorph new image: (ScriptingSystem formAtKey: #MenuTriangle).
- suffixArrow _ ImageMorph new image: (ScriptingSystem formAtKey: #MenuTriangle).
suffixArrow setBalloonText: 'click here to choose a new type for this parameter' translated.
self addMorphBack: suffixArrow!
Item was changed:
----- Method: UTF8GreekClipboardInterpreter>>fromSystemClipboard: (in category 'as yet unclassified') -----
fromSystemClipboard: aString
| str |
+ str := aString convertFromWithConverter: UTF8TextConverter new.
- str _ aString convertFromWithConverter: UTF8TextConverter new.
^ str collect: [:c |
(#(
16r20AC 16rFFFD 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021
16rFFFD 16r2030 16rFFFD 16r2039 16rFFFD 16rFFFD 16rFFFD 16rFFFD
16rFFFD 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014
16rFFFD 16r2122 16rFFFD 16r203A 16rFFFD 16rFFFD 16rFFFD 16rFFFD
16r00A0 16r0385 16r0386 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7
16r00A8 16r00A9 16rFFFD 16r00AB 16r00AC 16r00AD 16r00AE 16r2015
16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r00B5 16r00B6 16r00B7
16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F
16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397
16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F
16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7
16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF
16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7
16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF
16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7
16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16rFFFD
) includes: c charCode) ifTrue: [Character leadingChar: GreekEnvironment leadingChar code: c charCode] ifFalse: [c]].
!
Item was changed:
----- Method: UniclassScript>>becomeTextuallyCoded (in category 'textually coded') -----
becomeTextuallyCoded
"Transform the receiver into one which is textually coded"
+ isTextuallyCoded := true.
+ lastSourceString := (playerClass sourceCodeAt: selector) "Save this to compare when going back to tiles"!
- isTextuallyCoded _ true.
- lastSourceString _ (playerClass sourceCodeAt: selector) "Save this to compare when going back to tiles"!
Item was changed:
----- Method: UniclassScript>>instantiatedScriptEditorForPlayer: (in category 'script editor') -----
instantiatedScriptEditorForPlayer: aPlayer
"Return the current script editor, creating it if necessary"
currentScriptEditor ifNil:
+ [currentScriptEditor := (self playerClass includesSelector: selector)
- [currentScriptEditor _ (self playerClass includesSelector: selector)
ifTrue:
[Preferences universalTiles
ifFalse:
[self error: 'duplicate selector'].
ScriptEditorMorph new fromExistingMethod: selector forPlayer: aPlayer]
ifFalse:
[ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector].
(defaultStatus == #ticking and: [selector numArgs == 0]) ifTrue:
[aPlayer costume arrangeToStartStepping]]
ifNotNil: [
(currentScriptEditor = #textuallyCoded and: [self playerClass includesSelector: selector]) ifTrue: [
+ currentScriptEditor := ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector.
- currentScriptEditor _ ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector.
self becomeTextuallyCoded.
(currentScriptEditor submorphs copyFrom: 2 to: currentScriptEditor submorphs size) do: [:m | m delete].
currentScriptEditor showSourceInScriptor.
]
].
^ currentScriptEditor!
Item was changed:
----- Method: Unicode class>>digitValue: (in category '*Etoys-Squeakland-class methods') -----
digitValue: char
| value v |
+ value := char charCode.
- value _ char charCode.
value <= $9 asciiValue
ifTrue: [^value - $0 asciiValue].
value >= $A asciiValue
ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].
value > (DecimalProperty size - 1) ifTrue: [^ -1].
+ v := DecimalProperty at: value+1.
- v _ DecimalProperty at: value+1.
^ (v >= 0 and: [v < 255]) ifTrue: [v] ifFalse: [-1].
!
Item was changed:
----- Method: UnixEUCKRInputInterpreter>>initialize (in category 'as yet unclassified') -----
initialize
+ converter := EUCKRTextConverter new.
- converter _ EUCKRTextConverter new.
!
Item was changed:
----- Method: UnixEUCKRInputInterpreter>>nextCharFrom:firstEvt: (in category 'as yet unclassified') -----
nextCharFrom: sensor firstEvt: evtBuf
| firstChar secondChar peekEvent keyValue type stream multiChar |
+ keyValue := evtBuf third.
+ evtBuf fourth = EventKeyChar ifTrue: [type := #keystroke].
+ peekEvent := sensor peekEvent.
- keyValue _ evtBuf third.
- evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke].
- peekEvent _ sensor peekEvent.
(peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [
sensor nextEvent.
+ peekEvent := sensor peekEvent].
- peekEvent _ sensor peekEvent].
(type == #keystroke
and: [peekEvent notNil
and: [peekEvent first = EventTypeKeyboard
and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [
+ firstChar := keyValue asCharacter.
+ secondChar := (peekEvent third) asCharacter.
+ stream := ReadStream on: (String with: firstChar with: secondChar).
+ multiChar := converter nextFromStream: stream.
- firstChar _ keyValue asCharacter.
- secondChar _ (peekEvent third) asCharacter.
- stream _ ReadStream on: (String with: firstChar with: secondChar).
- multiChar _ converter nextFromStream: stream.
multiChar isOctetCharacter ifFalse: [sensor nextEvent].
^ multiChar].
^ keyValue asCharacter!
Item was changed:
----- Method: UpdatingStringMorphWithArgument>>argumentTarget:argumentGetSelector: (in category 'as yet unclassified') -----
argumentTarget: t argumentGetSelector: s
+ argumentTarget := t.
+ argumentGetSelector := s!
- argumentTarget _ t.
- argumentGetSelector _ s!
Item was changed:
----- Method: UpdatingStringMorphWithArgument>>readFromTarget (in category 'target access') -----
readFromTarget
| v |
argumentTarget ifNil: [^ super readFromTarget].
+ v := target perform: getSelector with: (argumentTarget perform: argumentGetSelector).
- v _ target perform: getSelector with: (argumentTarget perform: argumentGetSelector).
^ self acceptValueFromTarget: v!
Item was changed:
----- Method: UpdatingStringMorphWithArgument>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
super veryDeepFixupWith: deepCopier.
+ argumentTarget := deepCopier references at: argumentTarget
- argumentTarget _ deepCopier references at: argumentTarget
ifAbsent: [argumentTarget].
!
Item was changed:
----- Method: UpdatingStringMorphWithArgument>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
+ "argumentTarget := argumentTarget. Weakly copied"
+ argumentGetSelector := argumentGetSelector veryDeepCopyWith: deepCopier.!
- "argumentTarget _ argumentTarget. Weakly copied"
- argumentGetSelector _ argumentGetSelector veryDeepCopyWith: deepCopier.!
Item was changed:
----- Method: UpdatingTextMorph>>veryDeepFixupWith: (in category 'copying') -----
veryDeepFixupWith: deepCopier
"If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ getSelector := deepCopier references at: getSelector ifAbsent: [getSelector].
- target _ deepCopier references at: target ifAbsent: [target].
- getSelector _ deepCopier references at: getSelector ifAbsent: [getSelector].
!
Item was changed:
----- Method: UpdatingTextMorph>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
super veryDeepInner: deepCopier.
+ "target := target. Copy it weakly"
+ "getSelector := getSelector. Symbols are shared"
+ growable := growable veryDeepCopyWith: deepCopier.
+ stepTime := stepTime veryDeepCopyWith: deepCopier.
- "target _ target. Copy it weakly"
- "getSelector _ getSelector. Symbols are shared"
- growable _ growable veryDeepCopyWith: deepCopier.
- stepTime _ stepTime veryDeepCopyWith: deepCopier.
!
Item was changed:
----- Method: UserInputEvent>>position: (in category '*Etoys-Squeakland-accessing') -----
position: aPoint
"normally immutable, except in event recorder"
+ position := aPoint!
- position _ aPoint!
Item was changed:
----- Method: UserText>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver."
super initialize.
+ wrapFlag := false.
- wrapFlag _ false.
self margins: 6 at 0.
self autoFit: true.
!
Item was changed:
----- Method: Utilities class>>emptyScrapsBookGC (in category '*Etoys-Squeakland-scraps') -----
emptyScrapsBookGC
"Get rid of trashed siblings so they won't appear in allSiblingsDo:"
"Utilities emptyScrapsBookGC"
| doGC |
+ doGC := (ScrapsBook ifNotNil: [ScrapsBook pages size > 1]) ~~ false.
- doGC _ (ScrapsBook ifNotNil: [ScrapsBook pages size > 1]) ~~ false.
self emptyScrapsBook.
doGC ifTrue: [Smalltalk garbageCollect].!
Item was changed:
----- Method: VeryPickyMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ bounds := 0 at 0 extent: 8 at 10
+ "bounds := 0 at 0 extent: 17 at 22"
- bounds _ 0 at 0 extent: 8 at 10
- "bounds _ 0 at 0 extent: 17 at 22"
!
Item was changed:
----- Method: VeryPickyMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: targetMorph event: evt
passengerMorph ifNil: [^self "delete"].
passengerMorph noLongerBeingDragged.
(targetMorph isKindOf: IndentingListItemMorph) ifFalse: [
passengerMorph changed.
+ passengerMorph := nil.
- passengerMorph _ nil.
owner removeMorph: self.
self privateOwner: nil.
].!
Item was changed:
----- Method: VeryPickyMorph>>passengerMorph: (in category 'as yet unclassified') -----
passengerMorph: anotherMorph
+ passengerMorph := anotherMorph!
- passengerMorph _ anotherMorph!
Item was changed:
----- Method: Viewer>>angleToPhrase (in category 'special phrases') -----
angleToPhrase
| outerPhrase getTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Number
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ getTile := TileCommandWithArgumentMorph newKedamaAngleToTile.
- getTile _ TileCommandWithArgumentMorph newKedamaAngleToTile.
outerPhrase addMorphBack: getTile.
^outerPhrase!
Item was changed:
----- Method: Viewer>>bounceOnPhrase (in category 'special phrases') -----
bounceOnPhrase
| outerPhrase getTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Boolean
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ getTile := TileCommandWithArgumentMorph newKedamaBounceOnTile.
- getTile _ TileCommandWithArgumentMorph newKedamaBounceOnTile.
outerPhrase addMorphBack: getTile.
^outerPhrase.
!
Item was changed:
----- Method: Viewer>>distanceToPhrase (in category 'special phrases') -----
distanceToPhrase
| outerPhrase getTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Number
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ getTile := TileCommandWithArgumentMorph newKedamaDistanceToTile.
- getTile _ TileCommandWithArgumentMorph newKedamaDistanceToTile.
outerPhrase addMorphBack: getTile.
^outerPhrase!
Item was changed:
----- Method: Viewer>>patchUphillPhrase (in category 'special phrases') -----
patchUphillPhrase
| outerPhrase upHill |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Number
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ upHill := TileCommandWithArgumentMorph newKedamaGetUpHillTile.
- upHill _ TileCommandWithArgumentMorph newKedamaGetUpHillTile.
upHill setArgumentDefaultTo: (scriptedPlayer defaultPatchPlayer).
outerPhrase addMorphBack: upHill.
^outerPhrase.
!
Item was changed:
----- Method: Viewer>>patchValuePhrase (in category 'special phrases') -----
patchValuePhrase
| outerPhrase getTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Number
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ getTile := TileCommandWithArgumentMorph newKedamaGetPatchValueTile.
- getTile _ TileCommandWithArgumentMorph newKedamaGetPatchValueTile.
getTile setArgumentDefaultTo: (scriptedPlayer defaultPatchPlayer).
outerPhrase addMorphBack: getTile.
^outerPhrase!
Item was changed:
----- Method: Viewer>>seesColorPhrase (in category 'special phrases') -----
seesColorPhrase
"In classic tiles, answer a complete phrase that represents the seesColor test"
| outerPhrase seesColorTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Boolean
rcvrType: #Player
argType: #Color. "temp dummy"
"Install (ColorSeerTile new) in middle position"
(outerPhrase submorphs second) delete. "operator"
seesColorTile := TileMorph new setOperator: #seesColor:.
outerPhrase addMorphBack: seesColorTile.
(outerPhrase submorphs second) goBehind. "Make it third"
+ " selfTile := self tileForSelf bePossessive. Done by caller.
- " selfTile _ self tileForSelf bePossessive. Done by caller.
selfTile position: 1.
outerPhrase firstSubmorph addMorph: selfTile.
"
outerPhrase submorphs last addMorph: (ColorTileMorph new showPalette: false;
typeColor: (ScriptingSystem colorForType: #Color); yourself).
^outerPhrase!
Item was changed:
----- Method: Viewer>>turtleOfPhrase (in category 'special phrases') -----
turtleOfPhrase
| outerPhrase getTile |
outerPhrase := PhraseTileMorph new
setOperator: #+
type: #Player
rcvrType: #Player
argType: #Color. "temp dummy"
(outerPhrase submorphs second) delete. "operator"
(outerPhrase submorphs second) delete. "color"
+ getTile := TileCommandWithArgumentMorph newKedamaGetTurtleOfTile.
- getTile _ TileCommandWithArgumentMorph newKedamaGetTurtleOfTile.
outerPhrase addMorphBack: getTile.
^outerPhrase!
Item was changed:
----- Method: ViewerEntry>>contents:notifying: (in category 'contents') -----
contents: c notifying: k
"later, spruce this up so that it can accept input such as new method source"
| info |
+ (info := self userSlotInformation)
- (info _ self userSlotInformation)
ifNotNil:
[info documentation: c.
^ true].
Beeper beep.
^ false!
Item was changed:
----- Method: ViewerEntry>>userSlotInformation (in category 'slot') -----
userSlotInformation
"If the receiver represents a user-defined slot, then return its info; if not, retun nil"
| aSlotName info |
((self entryType == #systemSlot) or: [self entryType == #userSlot])
ifFalse:
[^ nil].
+ aSlotName := self slotName.
+ ^ ((info := self playerBearingCode slotInfo) includesKey: aSlotName)
- aSlotName _ self slotName.
- ^ ((info _ self playerBearingCode slotInfo) includesKey: aSlotName)
ifTrue:
[info at: aSlotName]
ifFalse:
[nil]!
Item was changed:
----- Method: ViewerLine>>addCommandFeedback: (in category '*Etoys-Squeakland-slot') -----
addCommandFeedback: evt
"Add screen feedback showing what would be torn off in a drag"
| aMorph |
+ aMorph := RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: (submorphs last bottomRight) + (2 at 1)).
- aMorph _ RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: (submorphs last bottomRight) + (2 at 1)).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem commandFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: nil!
Item was changed:
----- Method: ViewerLine>>addGetterFeedback (in category 'slot') -----
addGetterFeedback
"Add feedback during mouseover of a getter"
| aMorph endMorph |
endMorph _
(#(touchesA: #seesColor: #overlaps: color:sees: overlapsAny: bearingTo: bearingFrom: distanceToPlayer:) includes: self elementSymbol)
ifTrue:
[submorphs seventh]
ifFalse:
[submorphs fifth].
+ aMorph := RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: ((endMorph right @ submorphs third bottom) + (2 at 1))).
- aMorph _ RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: ((endMorph right @ submorphs third bottom) + (2 at 1))).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem getterFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: nil.
"
Color fromUser (Color r: 1.0 g: 0.355 b: 0.839)
"!
Item was changed:
----- Method: ViewerLine>>addSetterFeedback (in category 'slot') -----
addSetterFeedback
"Add screen feedback showing what would be torn off to make a setter"
| aMorph |
+ aMorph := RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: ((submorphs last right @ submorphs third bottom) + (2 at 1))).
- aMorph _ RectangleMorph new bounds: ((submorphs third topLeft - (2 at 1)) corner: ((submorphs last right @ submorphs third bottom) + (2 at 1))).
aMorph beTransparent; borderWidth: 2; borderColor: ScriptingSystem setterFeedback; lock.
ActiveWorld addHighlightMorph: aMorph for: nil!
Item was changed:
----- Method: ViewerRow>>elementSymbol: (in category 'access') -----
elementSymbol: aSymbol
+ elementSymbol := aSymbol!
- elementSymbol _ aSymbol!
Item was changed:
----- Method: WatchMorph>>antialias: (in category 'accessing') -----
antialias: aBoolean
+ antialias := aBoolean!
- antialias _ aBoolean!
Item was changed:
----- Method: WatchMorph>>centerColor: (in category 'accessing') -----
centerColor: aColor
"Set the center color as indicated; map nil into transparent"
+ cColor := aColor ifNil: [Color transparent]!
- cColor _ aColor ifNil: [Color transparent]!
Item was changed:
----- Method: WatchMorph>>createLabels (in category 'nil') -----
createLabels
| numeral font h r |
self removeAllMorphs.
+ font := StrikeFont familyName: fontName size: (h := self height min: self width)//8.
+ r := 1.0 - (1.4 * font height / h).
- font _ StrikeFont familyName: fontName size: (h _ self height min: self width)//8.
- r _ 1.0 - (1.4 * font height / h).
1 to: 12 do:
[:hour |
+ numeral := romanNumerals
- numeral _ romanNumerals
ifTrue: [#('I' 'II' 'III' 'IV' 'V' 'VI' 'VII' ' VIII' 'IX' 'X' 'XI' 'XII') at: hour]
ifFalse: [hour asString].
self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1)
center: (self radius: r hourAngle: hour)) lock].
!
Item was changed:
----- Method: WatchMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Draw the watch on the given canvas"
| pHour pMin pSec time centerColor |
+ time := Time now.
+ pHour := self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
+ pMin := self radius: 0.72 hourAngle: (time minutes / 5.0).
+ pSec := self radius: 0.8 hourAngle: (time seconds / 5.0).
+ centerColor := cColor
- time _ Time now.
- pHour _ self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
- pMin _ self radius: 0.72 hourAngle: (time minutes / 5.0).
- pSec _ self radius: 0.8 hourAngle: (time seconds / 5.0).
- centerColor _ cColor
ifNil:
[Color transparent]
ifNotNil:
[time hours < 12
ifTrue: [cColor muchLighter]
ifFalse: [cColor]].
antialias ifTrue:
[aCanvas asBalloonCanvas
aaLevel: 4;
drawOval: (bounds insetBy: borderWidth // 2 + 1) color: self fillStyle
borderWidth: borderWidth borderColor: borderColor;
drawOval: (bounds insetBy: self extent*0.35) color: centerColor
borderWidth: 0 borderColor: Color black;
drawPolygon: {self center. pHour}
color: Color transparent borderWidth: 3 borderColor: handsColor;
drawPolygon: {self center. pMin}
color: Color transparent borderWidth: 2 borderColor: handsColor;
drawPolygon: {self center. pSec}
color: Color transparent borderWidth: 1 borderColor: handsColor]
ifFalse:
[super drawOn: aCanvas.
aCanvas
fillOval: (bounds insetBy: self extent*0.35) color: centerColor;
line: self center to: pHour width: 3 color: handsColor;
line: self center to: pMin width: 2 color: handsColor;
line: self center to: pSec width: 1 color: handsColor]
!
Item was changed:
----- Method: WatchMorph>>fontName: (in category 'accessing') -----
fontName: aString
+ fontName := aString.
- fontName _ aString.
self createLabels!
Item was changed:
----- Method: WatchMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self handsColor: Color red.
self centerColor: Color gray.
+ romanNumerals := false.
+ antialias := false.
+ fontName := 'NewYork'.
- romanNumerals _ false.
- antialias _ false.
- fontName _ 'NewYork'.
self extent: 130 @ 130.
self start!
Item was changed:
----- Method: WatchMorph>>toggleAntialias (in category 'menus') -----
toggleAntialias
+ antialias := antialias not!
- antialias _ antialias not!
Item was changed:
----- Method: WatchMorph>>toggleRoman (in category 'menus') -----
toggleRoman
+ romanNumerals := romanNumerals not.
- romanNumerals _ romanNumerals not.
self createLabels!
Item was changed:
----- Method: WeekMorph>>initializeDays: (in category 'all') -----
initializeDays: modelOrNil
| extent days tile |
self removeAllMorphs.
+ days := OrderedCollection new: 7.
+ extent := self tile extent.
- days _ OrderedCollection new: 7.
- extent _ self tile extent.
week datesDo:
[:each |
+ tile := (self tileLabeled: each dayOfMonth printString) extent: extent.
- tile _ (self tileLabeled: each dayOfMonth printString) extent: extent.
each month = month ifFalse:
[tile color: Color gray; offColor: Color gray; onColor: Color veryLightGray].
modelOrNil ifNotNil:
[tile target: modelOrNil;
actionSelector: #setDate:fromButton:down:;
arguments: {each. tile}].
days add: tile].
days reverseDo: [:each | self addMorph: each]!
Item was changed:
----- Method: WeekMorph>>initializeForWeek:month:tileRect:model: (in category 'all') -----
initializeForWeek: aWeek month: aMonth tileRect: rect model: aModel
super initialize.
+ tileRect := rect.
- tileRect _ rect.
self
layoutInset: 0;
color: Color transparent;
listDirection: #leftToRight;
hResizing: #shrinkWrap;
disableDragNDrop;
height: tileRect height.
self week: aWeek month: aMonth model: aModel
!
Item was changed:
----- Method: WeekMorph>>selectedDates (in category 'all') -----
selectedDates
| answer |
+ answer := SortedCollection new.
- answer _ SortedCollection new.
self submorphsDo:
[:each |
((each respondsTo: #onColor) and: [each color = each onColor])
ifTrue:
[answer add:
(Date
newDay: each label asNumber
month: week firstDate monthName
year: week firstDate year)]].
^ answer!
Item was changed:
----- Method: WeekMorph>>tile (in category 'all') -----
tile
| onColor offColor |
+ offColor := Color r: 0.4 g: 0.8 b: 0.6.
+ onColor := offColor alphaMixed: 1/2 with: Color white.
- offColor _ Color r: 0.4 g: 0.8 b: 0.6.
- onColor _ offColor alphaMixed: 1/2 with: Color white.
^ SimpleSwitchMorph new
offColor: offColor;
onColor: onColor;
borderWidth: 1;
useSquareCorners;
extent: tileRect extent!
Item was changed:
----- Method: WeekMorph>>tileLabeled: (in category 'all') -----
tileLabeled: labelString
| onColor offColor |
+ offColor := Color r: 0.4 g: 0.8 b: 0.6.
+ onColor := offColor alphaMixed: 1/2 with: Color white.
- offColor _ Color r: 0.4 g: 0.8 b: 0.6.
- onColor _ offColor alphaMixed: 1/2 with: Color white.
^ (SimpleSwitchMorph newWithLabel: labelString)
offColor: offColor;
onColor: onColor;
borderWidth: 1;
useSquareCorners;
extent: tileRect extent;
setSwitchState: false!
Item was changed:
----- Method: WeekMorph>>title (in category 'all') -----
title
"Answer a title with the names of the days."
| title extent days |
+ title := AlignmentMorph new
- title _ AlignmentMorph new
layoutInset: 0;
color: Color red;
listDirection: #leftToRight;
vResizing: #shrinkWarp;
height: tileRect height.
+ extent := self tile extent.
- extent _ self tile extent.
+ days := (Week startDay = #Monday)
- days _ (Week startDay = #Monday)
ifTrue: [ #(2 3 4 5 6 7 1) ]
ifFalse: [ 1 to: 7 ].
(days reverse collect: [:each | Date nameOfDay: each]) do:
[:each |
title addMorph:
((self tileLabeled: (each copyFrom: 1 to: 2))
extent: extent)].
^ title
!
Item was changed:
----- Method: WeekMorph>>week:month:model: (in category 'all') -----
week: aWeek month: aMonth model: aModel
+ week := aWeek.
+ month := aMonth.
- week _ aWeek.
- month _ aMonth.
self initializeDays: aModel!
Item was changed:
----- Method: WiWPasteUpMorph class>>say: (in category 'as yet unclassified') -----
say: x
+ (Debug ifNil: [Debug := OrderedCollection new])
- (Debug ifNil: [Debug _ OrderedCollection new])
add: x asString,'
'.
+ Debug size > 500 ifTrue: [Debug := Debug copyFrom: 200 to: Debug size]!
- Debug size > 500 ifTrue: [Debug _ Debug copyFrom: 200 to: Debug size]!
Item was changed:
----- Method: WiWPasteUpMorph class>>show (in category 'as yet unclassified') -----
show
Debug inspect.
+ Debug := OrderedCollection new.!
- Debug _ OrderedCollection new.!
Item was changed:
----- Method: WiWPasteUpMorph>>becomeTheActiveWorldWith: (in category 'activation') -----
becomeTheActiveWorldWith: evt
"Make the receiver become the active world, and give its hand the event provided, if not nil"
| outerWorld |
World == self ifTrue: [^ self].
worldState resetDamageRecorder. "since we may have moved, old data no longer valid"
hostWindow setStripeColorsFrom: Color green.
worldState canvas: nil. "safer to start from scratch"
+ displayChangeSignatureOnEntry := Display displayChangeSignature.
- displayChangeSignatureOnEntry _ Display displayChangeSignature.
"Messy stuff to clear flaps from outer world"
Flaps globalFlapTabsIfAny do: [:f | f changed].
+ outerWorld := World.
+ World := self.
- outerWorld _ World.
- World _ self.
self installFlaps.
+ World := outerWorld.
- World _ outerWorld.
outerWorld displayWorld.
+ World := self.
- World _ self.
self viewBox: hostWindow panelRect.
self startSteppingSubmorphsOf: self.
self changed.
+ pendingEvent := nil.
- pendingEvent _ nil.
evt ifNotNil: [self primaryHand handleEvent: (evt setHand: self primaryHand)].
!
Item was changed:
----- Method: WiWPasteUpMorph>>doOneCycle (in category 'world state') -----
doOneCycle
pendingEvent ifNotNil: [
self primaryHand handleEvent: (pendingEvent setHand: self primaryHand).
+ pendingEvent := nil.
- pendingEvent _ nil.
].
^super doOneCycle.!
Item was changed:
----- Method: WiWPasteUpMorph>>hostWindow: (in category 'initialization') -----
hostWindow: x
+ hostWindow := x.
- hostWindow _ x.
worldState canvas: nil. "safer to start from scratch"
self viewBox: hostWindow panelRect.
!
Item was changed:
----- Method: WiWPasteUpMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ parentWorld := World.
- parentWorld _ World.
!
Item was changed:
----- Method: WiWPasteUpMorph>>resetViewBoxForReal (in category 'geometry') -----
resetViewBoxForReal
| newClip |
self viewBox ifNil: [^self].
+ newClip := self viewBox intersect: parentWorld viewBox.
- newClip _ self viewBox intersect: parentWorld viewBox.
worldState canvas: (
Display getCanvas
copyOffset: 0 at 0
clipRect: newClip
)!
Item was changed:
----- Method: WiWPasteUpMorph>>restartWorldCycleWithEvent: (in category 'WiW support') -----
restartWorldCycleWithEvent: evt
"redispatch that click in outer world"
+ pendingEvent := evt.
- pendingEvent _ evt.
CurrentProjectRefactoring currentSpawnNewProcessAndTerminateOld: true
!
Item was changed:
----- Method: WiWPasteUpMorph>>revertToParentWorldWithEvent: (in category 'activation') -----
revertToParentWorldWithEvent: evt
"RAA 27 Nov 99 - if the display changed while we were in charge, parent may need to redraw"
worldState resetDamageRecorder. "Terminate local display"
+ World := parentWorld.
- World _ parentWorld.
World assuredCanvas.
World installFlaps.
hostWindow setStripeColorsFrom: Color red.
(displayChangeSignatureOnEntry = Display displayChangeSignature) ifFalse: [
World fullRepaintNeeded; displayWorld
].
evt ifNotNil: [World restartWorldCycleWithEvent: evt].
!
Item was changed:
----- Method: WireMorph>>fromPin:toPin: (in category 'as yet unclassified') -----
fromPin: pin1 toPin: pin2
+ pins := Array with: pin1 with: pin2!
- pins _ Array with: pin1 with: pin2!
Item was changed:
----- Method: WireMorph>>pinMoved (in category 'as yet unclassified') -----
pinMoved
| newVerts |
+ newVerts := vertices copy.
- newVerts _ vertices copy.
newVerts at: 1 put: pins first wiringEndPoint.
newVerts at: newVerts size put: pins last wiringEndPoint.
self setVertices: newVerts!
Item was changed:
----- Method: WordArray>>eToysEQ: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysEQ: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primEQScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primEQArray: self and: other into: result.
].
^ super = other.
!
Item was changed:
----- Method: WordArray>>eToysGE: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysGE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primGEArray: self and: other into: result.
].
^ super >= other.
!
Item was changed:
----- Method: WordArray>>eToysGT: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysGT: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primGTScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primGTArray: self and: other into: result.
].
^ super > other.
!
Item was changed:
----- Method: WordArray>>eToysLE: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysLE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primLEArray: self and: other into: result.
].
^ super <= other.
!
Item was changed:
----- Method: WordArray>>eToysLT: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysLT: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primLTScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primLTArray: self and: other into: result.
].
^ super < other.
!
Item was changed:
----- Method: WordArray>>eToysNE: (in category '*Etoys-Squeakland-array arithmetic') -----
eToysNE: other
| result |
+ result := ByteArray new: self size.
- result _ ByteArray new: self size.
other isNumber ifTrue: [
^ self primNEScalar: self and: other into: result.
].
other isCollection ifTrue: [
^ self primNEArray: self and: other into: result.
].
^ super ~= other.
!
Item was changed:
----- Method: WordGameLetterMorph class>>initialize (in category 'class initialization') -----
initialize "WordGameLetterMorph initialize"
+ IDFont := StrikeFont familyName: 'ComicPlain' size: 13.
+ IDHeight := IDFont height.
+ LetterFont := StrikeFont familyName: 'ComicBold' size: 19.
+ LetterHeight := LetterFont height.
- IDFont _ StrikeFont familyName: 'ComicPlain' size: 13.
- IDHeight _ IDFont height.
- LetterFont _ StrikeFont familyName: 'ComicBold' size: 19.
- LetterHeight _ LetterFont height.
!
Item was changed:
----- Method: WordGameLetterMorph>>boxed (in category 'style inits') -----
boxed
+ style := #boxed!
- style _ #boxed!
Item was changed:
----- Method: WordGameLetterMorph>>id2: (in category 'initialization') -----
id2: idString
"Add further clue id for acrostic puzzles."
| idMorph |
idString ifNotNil:
+ [idMorph := StringMorph contents: idString font: IDFont.
- [idMorph _ StringMorph contents: idString font: IDFont.
idMorph align: idMorph bounds topRight with: self bounds topRight + (-1@ -1).
self addMorph: idMorph].
!
Item was changed:
----- Method: WordGameLetterMorph>>indexInQuote:id1: (in category 'initialization') -----
indexInQuote: qi id1: aString
"Initialize me with the given index and an optional aString"
| idMorph y |
style = #boxed
ifTrue: [aString isNil
ifTrue: [self extent: 18 @ 16;
borderWidth: 1]
ifFalse: [self extent: 26 @ 24;
borderWidth: 1]]
ifFalse: [aString isNil
ifTrue: [self extent: 18 @ 16;
borderWidth: 0]
ifFalse: [self extent: 18 @ 26;
borderWidth: 0]].
qi
ifNil: [^ self color: Color gray].
"blank"
self color: self normalColor.
+ indexInQuote := qi.
- indexInQuote _ qi.
style == #underlined
+ ifTrue: [y := self bottom - 2.
- ifTrue: [y _ self bottom - 2.
aString
+ ifNotNil: [y := y - IDFont ascent + 2].
+ lineMorph := PolygonMorph
- ifNotNil: [y _ y - IDFont ascent + 2].
- lineMorph _ PolygonMorph
vertices: {self left + 2 @ y. self right - 3 @ y}
color: Color gray
borderWidth: 1
borderColor: Color gray.
self addMorph: lineMorph.
aString
ifNil: [^ self].
+ idMorph := StringMorph contents: aString font: IDFont.
- idMorph _ StringMorph contents: aString font: IDFont.
idMorph align: idMorph bounds bottomCenter with: self bounds bottomCenter + (0 @ (IDFont descent - 1)).
self addMorphBack: idMorph]
ifFalse: [aString
ifNil: [^ self].
+ idMorph := StringMorph contents: aString font: IDFont.
- idMorph _ StringMorph contents: aString font: IDFont.
idMorph align: idMorph bounds topLeft with: self bounds topLeft + (2 @ -1).
self addMorph: idMorph
"
World addMorph: (WordGameLetterMorph new boxed
indexInQuote: 123 id1: '123';
id2: 'H'; setLetter: $W).
World addMorph: (WordGameLetterMorph new underlined
indexInQuote: 123 id1: '123';
setLetter: $W).
World addMorph: (WordGameLetterMorph new underlined
indexInQuote: 123 id1: nil;
setLetter: $W).
"]!
Item was changed:
----- Method: WordGameLetterMorph>>keyboardFocusChange: (in category 'event handling') -----
keyboardFocusChange: boolean
| panel |
boolean ifFalse:
+ [panel := self nearestOwnerThat: [:m | m respondsTo: #checkForLostFocus].
- [panel _ self nearestOwnerThat: [:m | m respondsTo: #checkForLostFocus].
panel ifNotNil: [panel checkForLostFocus]]!
Item was changed:
----- Method: WordGameLetterMorph>>plain (in category 'style inits') -----
plain
+ style := #plain!
- style _ #plain!
Item was changed:
----- Method: WordGameLetterMorph>>predecessor: (in category 'accessing') -----
predecessor: pred
+ predecessor := pred
- predecessor _ pred
!
Item was changed:
----- Method: WordGameLetterMorph>>successor: (in category 'accessing') -----
successor: succ
+ successor := succ
- successor _ succ
!
Item was changed:
----- Method: WordGameLetterMorph>>underlined (in category 'style inits') -----
underlined
+ style := #underlined!
- style _ #underlined!
Item was changed:
----- Method: WordGamePanelMorph>>mouseDownEvent:letterMorph: (in category 'events') -----
mouseDownEvent: evt letterMorph: morph
+ haveTypedHere := false.
- haveTypedHere _ false.
evt hand newKeyboardFocus: morph.
self highlight: morph!
Item was changed:
----- Method: WordNet class>>canTranslateFrom (in category 'miscellaneous') -----
canTranslateFrom
+ Languages ifNil: [Languages := #(English Portuguese).
+ CanTranslateFrom := #(French German Spanish English Portuguese
- Languages ifNil: [Languages _ #(English Portuguese).
- CanTranslateFrom _ #(French German Spanish English Portuguese
Italian Norwegian)]. "see www.freetranslation.com/"
^ CanTranslateFrom !
Item was changed:
----- Method: WordNet class>>definitionsFor: (in category 'services') -----
definitionsFor: aWord
| aDef parts item |
+ aDef := self new.
- aDef _ self new.
(aDef definition: aWord) ifNil:
[self inform: 'Sorry, cannot reach the WordNet
web site; task abandoned.'.
^ nil].
+ parts := aDef parts.
- parts _ aDef parts.
parts size = 0 ifTrue:
[self inform: 'Sorry, ', aWord, ' not found.'.
^ nil].
^ String streamContents:
[:defStream |
defStream nextPutAll: aWord; cr.
parts do:
[:aPart |
defStream cr.
1 to: (aDef sensesFor: aPart) do:
[:senseNumber |
defStream nextPutAll: aPart.
+ item := aDef def: senseNumber for: aPart.
- item _ aDef def: senseNumber for: aPart.
defStream nextPutAll: (' (', senseNumber printString, ') ', (item copyFrom: 2 to: item size - 1)).
defStream cr]]]
"WordNet definitionsFor: 'balloon'"
!
Item was changed:
----- Method: WordNet class>>languagePrefs (in category 'miscellaneous') -----
languagePrefs
"Set preference of which natural language is primary. Look up definitions in it, and correct speaLanguageing in it. Also, let user set languages to translate from and to."
| ch aLanguage |
self canTranslateFrom. "sets defaults"
+ ch := PopUpMenu withCaption: 'Choose the natural language to use for:'
- ch _ PopUpMenu withCaption: 'Choose the natural language to use for:'
chooseFrom: 'word definition and spelling verification (',
(Preferences parameterAt: #myLanguage ifAbsentPut: [#English]) asString ,')...\',
'language to translate FROM (now ',
(Preferences parameterAt: #languageTranslateFrom ifAbsentPut: [#English]) asString ,')...\',
'language to translate TO (now ',
(Preferences parameterAt: #languageTranslateTo ifAbsentPut: [#German]) asString ,')...\'.
ch = 1 ifTrue: [
+ aLanguage := PopUpMenu withCaption: 'The language for word definitions and speaLanguageing verification:'
- aLanguage _ PopUpMenu withCaption: 'The language for word definitions and speaLanguageing verification:'
chooseFrom: Languages.
aLanguage > 0 ifTrue:
[^ Preferences setParameter: #myLanguage to: (Languages at: aLanguage) asSymbol]].
ch = 2 ifTrue:
+ [aLanguage := PopUpMenu withCaption: 'The language to translate from:'
- [aLanguage _ PopUpMenu withCaption: 'The language to translate from:'
chooseFrom: CanTranslateFrom.
aLanguage > 0 ifTrue:
[^ Preferences setParameter: #languageTranslateFrom to: (CanTranslateFrom at: aLanguage) asSymbol]].
ch = 3 ifTrue:
+ [aLanguage := PopUpMenu withCaption: 'The language to translate to'
- [aLanguage _ PopUpMenu withCaption: 'The language to translate to'
chooseFrom: CanTranslateFrom.
aLanguage > 0 ifTrue:
[^ Preferences setParameter: #languageTranslateTo to: (CanTranslateFrom at: aLanguage) asSymbol]].
"Maybe let the user add another language if he knows the server can take it."
+ " ch := (PopUpMenu labelArray: Languages, {'other...'.
- " ch _ (PopUpMenu labelArray: Languages, {'other...'.
'Choose language to translate from...'})
startUpWithCaption: 'Choose the language of dictionary for word definitions.'.
ch = 0 ifTrue: [^ Preferences setParameter: #myLanguage to: #English].
+ (ch <= Languages size) ifTrue: [aLanguage := Languages at: ch].
- (ch <= Languages size) ifTrue: [aLanguage _ Languages at: ch].
ch = (Languages size + 1) ifTrue: [
+ aLanguage := FillInTheBlank request: 'Name of the primary language'].
- aLanguage _ FillInTheBlank request: 'Name of the primary language'].
aLanguage ifNotNil: [^ Preferences setParameter: #myLanguage to: aLanguage asSymbol].
"!
Item was changed:
----- Method: WordNet class>>lexiconServer (in category 'miscellaneous') -----
lexiconServer
"Look in Preferences to see what language the user wants, and what class knows about it."
| nl |
+ nl := Preferences parameterAt: #myLanguage ifAbsentPut: [#English].
- nl _ Preferences parameterAt: #myLanguage ifAbsentPut: [#English].
nl == #English ifTrue: [^ self]. "English, WordNet server"
nl == #Portuguese ifTrue: [^ PortugueseLexiconServer]. "www.priberam.pt"
" nl == #Deutsch ifTrue: [^ DeutschServerClass]. " "class that knows about a server"
self inform: 'Sorry, no known online dictionary in that language.'.
^ self languagePrefs!
Item was changed:
----- Method: WordNet class>>openScamperOn: (in category 'miscellaneous') -----
openScamperOn: aWord
| aUrl scamperWindow |
"Open a Scamper web browser on the WordNet entry for this word. If Scamper is already pointing at WordNet, use the same browser."
+ aUrl := 'http://www.cogsci.princeton.edu/cgi-bin/webwn/',
- aUrl _ 'http://www.cogsci.princeton.edu/cgi-bin/webwn/',
'?stage=1&word=', aWord.
+ scamperWindow := (WebBrowser default ifNil: [^self]) newOrExistingOn: aUrl.
- scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: aUrl.
scamperWindow model jumpToUrl: aUrl asUrl.
scamperWindow activate.
!
Item was changed:
----- Method: WordNet class>>verify: (in category 'services') -----
verify: aWord
"See if this spelling is in the WordNet lexicon. Return a string of success, no-such-word, or can't reach the server."
| aDef nl |
+ aDef := self new.
- aDef _ self new.
(aDef definition: aWord) ifNil:
[^ 'Sorry, cannot reach that web site. Task abandoned.
(Make sure you have an internet connection.)'].
+ nl := Preferences parameterAt: #myLanguage ifAbsentPut: [#English].
- nl _ Preferences parameterAt: #myLanguage ifAbsentPut: [#English].
(aDef parts) size = 0
ifTrue: [^ 'Sorry, ', aWord, ' not found. (', nl, ' lexicon)']
ifFalse: [^ aWord, ' is spelled correctly.']!
Item was changed:
----- Method: WordNet>>def:for: (in category 'as yet unclassified') -----
def: nth for: partOfSpeech
| ii strm |
parts ifNil: [self parts].
+ (ii := parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
+ strm := partStreams at: ii.
- (ii _ parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
- strm _ partStreams at: ii.
strm reset.
1 to: nth do: [:nn |
strm match: '<BR>',(String with: Character lf),nn printString, '. '.
strm match: ' -- '].
^ strm upToAll: '<BR>'!
Item was changed:
----- Method: WordNet>>definition: (in category 'as yet unclassified') -----
definition: theWord
"look this word up in the basic way. Return nil if there is trouble accessing the web site."
| doc |
+ word := theWord.
- word _ theWord.
Cursor wait showWhile: [
+ doc := HTTPSocket
- doc _ HTTPSocket
httpGetDocument: 'http://www.cogsci.princeton.edu/cgi-bin/webwn/'
args: 'stage=1&word=', word].
+ replyHTML := (doc isKindOf: MIMEDocument)
- replyHTML _ (doc isKindOf: MIMEDocument)
ifTrue:
[doc content]
ifFalse:
[nil].
"self parseReply."
^ replyHTML!
Item was changed:
----- Method: WordNet>>parts (in category 'as yet unclassified') -----
parts
"return the parts of speech this word can be. Keep the streams for each"
+ parts := OrderedCollection new.
+ partStreams := OrderedCollection new.
- parts _ OrderedCollection new.
- partStreams _ OrderedCollection new.
rwStream ifNil: [self stream].
rwStream reset.
rwStream match: '<HR>'.
[rwStream atEnd] whileFalse: [
partStreams add: (ReadStream on: (rwStream upToAll: '<HR>'))].
partStreams do: [:pp |
parts add: (self partOfSpeechIn: pp)].
parts size = 0 ifTrue: [^ parts].
parts last = '' ifTrue: [parts removeLast. partStreams removeLast].
^ parts !
Item was changed:
----- Method: WordNet>>senses (in category 'as yet unclassified') -----
senses
| ww |
+ ww := '"', word, '"'.
- ww _ '"', word, '"'.
rwStream ifNil: [self stream].
rwStream reset.
rwStream match: ww.
rwStream match: ww.
rwStream match: ' has '.
^ (rwStream upTo: Character lf) asNumber!
Item was changed:
----- Method: WordNet>>sensesFor: (in category 'as yet unclassified') -----
sensesFor: partOfSpeech
| ii strm |
parts ifNil: [self parts].
+ (ii := parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
+ strm := partStreams at: ii.
- (ii _ parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
- strm _ partStreams at: ii.
strm reset.
strm match: '"', word, '"'.
strm match: ' has '.
^ (strm upTo: Character lf) asNumber!
Item was changed:
----- Method: WordNet>>stream (in category 'as yet unclassified') -----
stream
+ rwStream := RWBinaryOrTextStream on: (String new: 1000).
- rwStream _ RWBinaryOrTextStream on: (String new: 1000).
rwStream nextPutAll: replyHTML; reset.
^ rwStream!
Item was changed:
----- Method: Workspace>>embeddedInMorphicWindowLabeled: (in category '*Etoys-Squeakland-accessing') -----
embeddedInMorphicWindowLabeled: labelString
| window |
+ window := (SystemWindow labelled: labelString) model: self.
- window _ (SystemWindow labelled: labelString) model: self.
window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
readSelection: nil menu: #codePaneMenu:shifted:)
frame: (0 at 0 corner: 1 at 1).
^ window!
Item was changed:
----- Method: WorldViewModel>>initialExtent: (in category 'as yet unclassified') -----
initialExtent: anExtent
+ initialExtent := anExtent!
- initialExtent _ anExtent!
Item was changed:
----- Method: WorldWindow class>>test1 (in category 'as yet unclassified') -----
test1
"WorldWindow test1."
| window world |
+ world := WiWPasteUpMorph newWorldForProject: nil.
+ window := (WorldWindow labelled: 'Inner World') model: world.
- world _ WiWPasteUpMorph newWorldForProject: nil.
- window _ (WorldWindow labelled: 'Inner World') model: world.
window addMorph: world.
world hostWindow: window.
window openInWorld
!
Item was changed:
----- Method: WorldWindow class>>test2 (in category 'as yet unclassified') -----
test2
"WorldWindow test2."
| window world scrollPane |
+ world := WiWPasteUpMorph newWorldForProject: nil.
+ window := (WorldWindow labelled: 'Scrollable World') model: world.
+ window addMorph: (scrollPane := TwoWayScrollPane new model: world)
- world _ WiWPasteUpMorph newWorldForProject: nil.
- window _ (WorldWindow labelled: 'Scrollable World') model: world.
- window addMorph: (scrollPane _ TwoWayScrollPane new model: world)
frame: (0 at 0 extent: 1.0 at 1.0).
scrollPane scroller addMorph: world.
world hostWindow: window.
window openInWorld
!
Item was changed:
----- Method: WorldWindow>>buildWindowMenu (in category 'menu') -----
buildWindowMenu
| aMenu |
+ aMenu := super buildWindowMenu.
- aMenu _ super buildWindowMenu.
{640 at 480. 800 at 600. 832 at 624. 1024 at 768} do: [ :each |
aMenu
add: each x printString,' x ',each y printString
target: self
selector: #extent:
argument: each + (0 at self labelHeight).
].
^aMenu!
Item was changed:
----- Method: ZoomMorph>>zoomFromMorph:toMorph:andThen: (in category 'as yet unclassified') -----
zoomFromMorph: m1 toMorph: m2 andThen: actionBlock
| nSteps topLeft r2 r1 extent ratio r mouthDeltas |
+ fromMorph := m1.
+ toMorph := m2.
+ r1 := fromMorph fullBounds.
+ r2 := toMorph fullBounds.
+ finalAction := actionBlock.
+ nSteps := 8.
+ boundsSeq := OrderedCollection new.
+ r := (1/nSteps) asFloat.
+ ratio := r.
+ r1 := 105 at 326 corner: 130 at 348.
+ mouthDeltas := {-7 at 24. -6 at 21. -6 at 18. -4 at 14. -4 at 10. -3 at 8. -3 at 3. 0 at 0}.
- fromMorph _ m1.
- toMorph _ m2.
- r1 _ fromMorph fullBounds.
- r2 _ toMorph fullBounds.
- finalAction _ actionBlock.
- nSteps _ 8.
- boundsSeq _ OrderedCollection new.
- r _ (1/nSteps) asFloat.
- ratio _ r.
- r1 _ 105 at 326 corner: 130 at 348.
- mouthDeltas _ {-7 at 24. -6 at 21. -6 at 18. -4 at 14. -4 at 10. -3 at 8. -3 at 3. 0 at 0}.
1 to: nSteps do:
+ [:i | topLeft := ((r2 topLeft - r1 topLeft) * ratio) asIntegerPoint + r1 topLeft.
+ extent := ((r2 extent - r1 extent) * ratio) asIntegerPoint + r1 extent.
- [:i | topLeft _ ((r2 topLeft - r1 topLeft) * ratio) asIntegerPoint + r1 topLeft.
- extent _ ((r2 extent - r1 extent) * ratio) asIntegerPoint + r1 extent.
boundsSeq addLast: (topLeft + (mouthDeltas at: i) extent: extent).
+ ratio := ratio + r].
- ratio _ ratio + r].
self addMorph: toMorph.
self step!
Item was changed:
----- Method: ZoomMorph>>zoomTo: (in category 'as yet unclassified') -----
zoomTo: newBounds
| scale |
self bounds: newBounds.
+ scale := newBounds extent / toMorph fullBounds extent.
- scale _ newBounds extent / toMorph fullBounds extent.
self setOffset: toMorph position - self position angle: 0.0 scale: scale!
More information about the Packages
mailing list