'From etoys2.2 of 24 September 2007 [latest update: #1680] on 3 October 2007 at 1:20:31 am'! "Change Set: distanceAndBearing-sw Date: 3 October 2007 Author: Scott Wallace Finally adds the long-expected numeric-valued slots, each with a player-valued argument, to,the viewer, to assist in simulations: distanceTo: and, bearingTo:. These would be very happy to support watchers and readouts-in-viewers, but that will need to wait for another time."! !Morph class methodsFor: 'scripting' stamp: 'sw 10/3/2007 01:12'! additionsToViewerCategoryObservation "Answer viewer additions for the 'observations' category" ^#( observation ( (slot colorUnder 'The color under the center of the object' Color readOnly Player getColorUnder unused unused ) (slot brightnessUnder 'The brightness under the center of the object' Number readOnly Player getBrightnessUnder unused unused) (slot luminanceUnder 'The luminance under the center of the object' Number readOnly Player getLuminanceUnder unused unused) (slot saturationUnder 'The saturation under the center of the object' Number readOnly Player getSaturationUnder unused unused) (slot distanceToPlayer 'The distance to another object' Number readOnly Player distanceToPlayer: unused unused) (slot bearingTo 'The heading I would need to have to face directly toward another object' Number readOnly Player bearingTo: unused unused) " (slot bearingFrom 'The heading another object would need to have in order to face directly toward me' Number readOnly Player bearingFrom: unused unused)" )) ! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 9/29/2007 02:18'! typeForSlotWithGetter: aGetter "Answer the data type for values of the instance variable of the given name" | getter inherentSelector | (#(color:sees: seesColor: touchesA: overlaps: overlapsAny:) includes: aGetter) ifTrue: [^ #Boolean]. (#(distanceToPlayer: bearingTo: bearingFrom:) includes: aGetter) ifTrue: [^ #Number]. (#(+ * - /) includes: aGetter) ifTrue: [^ #Player]. "weird vector stuff" "Annoying special cases" inherentSelector _ Utilities inherentSelectorForGetter: aGetter. (self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type]. getter _ (aGetter beginsWith: 'get') ifTrue: [aGetter] ifFalse: [Utilities getterSelectorFor: aGetter]. ^ (Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aGetter]) resultType! ! !Player methodsFor: 'special numeric slots' stamp: 'sw 10/3/2007 01:02'! bearingFrom: aPlayer "Answer the bearing to the receiver from another player" ^ aPlayer costume positionInWorld bearingToPoint: costume positionInWorld! ! !Player methodsFor: 'special numeric slots' stamp: 'sw 10/3/2007 01:02'! bearingTo: aPlayer "Answer the bearing from the receiver to another player" ^ costume positionInWorld bearingToPoint: aPlayer costume positionInWorld! ! !Player methodsFor: 'special numeric slots' stamp: 'sw 10/3/2007 00:58'! distanceToPlayer: aPlayer "Simplified distance... simply answer the distance between the centers of the two objects." ^ costume positionInWorld dist: aPlayer costume positionInWorld ! ! !StandardScriptingSystem methodsFor: '*WS-Sound-Override' stamp: 'sw 10/2/2007 03:18'! wordingForOperator: aString "Answer the wording to be seen by the user for the given operator symbol/string" | toTest | toTest _ aString asString. #( (append: 'include at end') (arrowheadsOnAllPens 'arrowheads on all pens') (bearingTo 'bearing to') (bearingFrom 'bearing from') (beep: 'make sound') (bounce: 'bounce') (clearTurtleTrails 'clear pen trails') (clearOwnersPenTrails 'clear all pen trails') (colorSees 'color sees') (color:sees: 'color sees') (distanceToPlayer 'distance to') (distanceTo: 'distance to') (doMenuItem: 'do menu item') (doScript: 'do') (forward: 'forward by') (goToRightOf: 'align after') (includeAtCursor: 'include at cursor') (isDivisibleBy: 'is divisible by') (liftAllPens 'lift all pens') (lowerAllPens 'lower all pens') (makeNewDrawingIn: 'start painting in') (max: 'max') (min: 'min') (moveToward: 'move toward') (noArrowheadsOnAllPens 'no arrowheads on pens') (overlapsAny 'overlaps any') (pauseAll: 'pause all') (pauseScript: 'pause script') (playButtonHit 'play') (prepend: 'include at beginning') (recordButtonHit 'start recording') (seesColor: 'is over color') (startAll: 'start all') (startScript: 'start script') (stopButtonHit 'stop') (stopProgramatically 'stop') (stopAll: 'stop all') (stopScript: 'stop script') (tellAllSiblings: 'tell all siblings') (tellSelfAndAllSiblings: 'send to all') (turn: 'turn by') (turnToward: 'turn toward') (wearCostumeOf: 'look like') (dial: 'dial to') (dialNumber 'dial number') (playSound: 'play frequency of') (stopSound 'stop sound') (soundPitch 'sound pitch') (soundLevel 'sound level') (soundListening 'listening') (passOver 'pass over') (passUnder 'pass under') (appendVertex 'add a vertex at end') (insertVertexAtCursor 'insert a vertex at cursor') (prependVertex 'add a vertex at beginning') (removeAllButCursor 'remove all vertices but cursor') (removeVertexAtCursor 'remove the vertex at cursor') (shuffleVertices 'shuffle vertices') (lineCurved 'line is curved') (lineOpened 'line is opened') (showingHandles 'showing handle') (vertexCursor 'vertex cursor') (verticesCount 'vertices count') (xAtCursor 'x at cursor') (yAtCursor 'y at cursor') ) do: [:pair | toTest = pair first ifTrue: [^ pair second]]. ^ toTest "StandardScriptingSystem initialize" ! ! !Viewer methodsFor: 'special phrases' stamp: 'sw 9/29/2007 02:45'! bearingFromPhrase "Answer a bearing-from phrase to hand to the user." ^ self conjuredUpPhraseWithOperator: #bearingFrom: type: #Number! ! !Viewer methodsFor: 'special phrases' stamp: 'sw 9/29/2007 02:44'! bearingToPhrase "Answer a bearing-to phrase to hand to the user." ^ self conjuredUpPhraseWithOperator: #bearingTo: type: #Number! ! !Viewer methodsFor: 'special phrases' stamp: 'sw 10/2/2007 03:14'! conjuredUpPhraseWithOperator: anOperator type: aType "Answer a PhraseTileMorph carefully constructed for overlaps, overlaps-any, and touches-a, distance to, bearing to, bearing from -- all pseudo-slots which take a player-valued argument." | outerPhrase aTile | outerPhrase := PhraseTileMorph new setOperator: #+ type: aType rcvrType: #Player argType: #Player. "temp dummy" (outerPhrase submorphs second) delete. "operator" aTile := TileMorph new. aTile setOperator: anOperator andUseWording: (ScriptingSystem wordingForOperator: anOperator). outerPhrase addMorphBack: aTile. Smalltalk at: #AA put: aTile. aTile addCaretsAsAppropriate: false. (outerPhrase submorphs second) goBehind. "Make it third" outerPhrase submorphs last addMorph: self presenter standardPlayer tileToRefer. ^ outerPhrase! ! !Viewer methodsFor: 'special phrases' stamp: 'sw 9/29/2007 02:45'! distanceToPlayerPhrase "Answer a distance-to phrase to hand to the user." ^ self conjuredUpPhraseWithOperator: #distanceToPlayer: type: #Number! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 10/3/2007 00:37'! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton aRow doc setter hotTileForSelf spacer | Preferences universalTiles ifTrue: [^ self universalTilesPhraseForVariableFrom: aMethodInterface]. 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. hotTileForSelf _ self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer _ Morph new color: self color; extent: 0@0). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType. 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: [getterButton setBalloonText: doc]. (slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #color:sees:) ifTrue: [self addColorSeesDetailTo: aRow. ^ aRow]. (#(touchesA: overlaps: overlapsAny: distanceToPlayer: bearingTo: bearingFrom:) includes: slotName) ifTrue: [self addPlayerArgumentTo: aRow. ^ aRow]. aRow addMorphBack: VariableSpacer new. (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType). anArrow beTransparent. anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. aRow addMorphBack: anArrow]. (#(color:sees: copy touchesA: overlaps: overlapsAny: getTurtleAt: getTurtleOf:) includes: slotName) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 10/2/2007 21:07'! 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); 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. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. 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: [getterButton setBalloonText: doc]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface. anArrow beTransparent. aRow addMorphBack: anArrow]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 10/3/2007 00:58'! 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 == #systemScript) ifTrue: [^ false]. ((elementType == #systemSlot) and: [#(color:sees: touchesA: overlaps: overlapsAny: distanceToPlayer: bearingTo: bearingFrom:) includes: aSymbol]) ifTrue: [^ false]. ^ true! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 10/2/2007 03:17'! getterTilesFor: getterSelector type: aType "Answer classic getter for the given name/type" "aPhrase _ nil, assumed" | selfTile selector aPhrase | (#(#color:sees: #colorSees) includes: getterSelector) ifTrue: [aPhrase := self colorSeesPhrase]. (#(#getPatchValueIn:) includes: getterSelector) ifTrue: [aPhrase _ self patchValuePhrase]. (#(#getRedComponentIn:) includes: getterSelector) ifTrue: [aPhrase _ self colorComponentPhraseFor: #red]. (#(#getGreenComponentIn:) includes: getterSelector) ifTrue: [aPhrase _ self colorComponentPhraseFor: #green]. (#(#getBlueComponentIn:) includes: getterSelector) ifTrue: [aPhrase _ self colorComponentPhraseFor: #blue]. (#(#getUphillIn:) includes: getterSelector) ifTrue: [aPhrase _ self patchUphillPhrase]. (#(#bounceOn:) includes: getterSelector) ifTrue: [aPhrase _ self bounceOnPhrase]. " (#(#bounceOn:color: #bounceOnColor:) includes: getterSelector) ifTrue: [aPhrase _ self bounceOnColorPhrase]." (getterSelector = #getDistanceTo:) ifTrue: [aPhrase _ self distanceToPhrase]. (getterSelector = #getAngleTo:) ifTrue: [aPhrase _ self angleToPhrase]. (getterSelector = #getTurtleOf:) ifTrue: [aPhrase _ self turtleOfPhrase]. (getterSelector = #distanceToPlayer:) ifTrue: [aPhrase _ self distanceToPlayerPhrase]. (getterSelector = #bearingTo:) ifTrue: [aPhrase _ self bearingToPhrase]. (getterSelector = #bearingFrom:) 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! ! !ViewerLine methodsFor: 'slot' stamp: 'sw 10/2/2007 03:29'! 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@-1)) corner: (endMorph bottomRight + (2@-1))). aMorph height:(submorphs third height + 1). aMorph beTransparent; borderWidth: 2; borderColor: (Color r: 1.0 g: 0.355 b: 0.839); lock. ActiveWorld addHighlightMorph: aMorph for: nil. " Color fromUser (Color r: 1.0 g: 0.355 b: 0.839) "! ! !Vocabulary class methodsFor: 'eToy vocabularies' stamp: 'sw 9/29/2007 02:26'! gettersForbiddenFromWatchers "Answer getters that should not have watchers launched to them" ^ #(colorSees copy isOverColor: seesColor: newClone getNewClone color:sees: touchesA: overlaps: overlapsAny: distanceToPlayer: bearingTo: bearingFrom:)! !