'From Squeak3.2alpha of 4 October 2001 [latest update: #4418] on 4 October 2001 at 6:29:49 pm'! "Change Set: TTrailsArrows-tk Date: 4 October 2001 Author: Ted Kaeher Adds a new item in every Viewer. In the 'pen use' category, there are tiles for (penArrowheads <- false). Setting this to true will make an arrowhead at the end of each new turtle trail. (Turtle trails must be enabled.) This works correctly with 'batch turtle trails' either on or off. Adds new items to the pen category of a viewer on a World -- to put arrowheads on trials of all players, or stop doing that. The old preference-driven arrowheads are removed. Additional feature: Any plain old Pen can have an arrowhead by sending it the message #arrowHead. (Only works when the Pen was moved with go: instead of goto:. It needs to know its direction.)"! Object subclass: #ActorState instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary penArrowheads ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting Support'! !PasteUpMorph commentStamp: 'tk 10/4/2001 17:56' prior: 0! A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph. Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. presenter A Presenter in charge of stopButton stepButton and goButton, mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled. model cursor ?? padding ?? backgroundMorph A Form that covers the background. turtleTrailsForm Moving submorphs may leave trails on this form. turtlePen Draws the trails. lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn only once each step cycle. The point is the start of the current stroke. isPartsBin If true, every object dragged out is copied. autoLineLayout ?? indicateCursor ?? resizeToFit ?? wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo. worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. griddingOn If true, submorphs are on a grid ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:42'! getPenArrowheads ^ penArrowheads == true! ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:43'! setPenArrowheads: aBoolean penArrowheads _ aBoolean! ! !Morph class methodsFor: 'scripting' stamp: 'tk 10/4/2001 17:27'! additionsToViewerCategoryPenUse "Answer viewer additions for the 'pen use' category" ^#( #'pen use' ( (slot penColor 'the color of ink used by the pen' Color readWrite Player getPenColor Player setPenColor:) (slot penSize 'the width of the pen' Number readWrite Player getPenSize Player setPenSize:) (slot penDown 'whether the pen is currently down' Boolean readWrite Player getPenDown Player setPenDown:) (slot penArrowheads 'whether to show arrowheads at the ends of pen strokes' Boolean readWrite Player getPenArrowheads Player setPenArrowheads:) (command clearOwnersPenTrails 'clear all pen trails in my containing playfield') ) ) ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'! arrowheadsOnAllPens submorphs do: [:m | m assuredPlayer setPenArrowheads: true] ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 16:40'! drawPenTrailFor: aMorph from: oldPoint to: targetPoint "Draw a pen trail for aMorph, using its pen state (the pen is assumed to be down)." "The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared." | origin mPenSize offset turtleTrailsDelta newPoint | turtleTrailsDelta _ self valueOfProperty: #turtleTrailsDelta ifAbsent:[0@0]. newPoint _ targetPoint - turtleTrailsDelta. oldPoint = newPoint ifTrue: [^ self]. self createOrResizeTrailsForm. origin _ self topLeft. mPenSize _ aMorph getPenSize. turtlePen sourceForm width ~= mPenSize ifTrue: [turtlePen squareNib: mPenSize]. offset _ (mPenSize // 2)@(mPenSize // 2). turtlePen color: aMorph getPenColor. turtlePen drawFrom: (oldPoint - origin - offset) asIntegerPoint to: (newPoint - origin - offset) asIntegerPoint. aMorph player getPenArrowheads ifTrue: [ turtlePen arrowHeadFrom: (oldPoint - origin - offset) to: (newPoint - origin - offset)]. self invalidRect: ((oldPoint rect: newPoint) expandBy: mPenSize) ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'! noArrowheadsOnAllPens submorphs do: [:m | m assuredPlayer setPenArrowheads: false] ! ! !PasteUpMorph class methodsFor: 'scripting' stamp: 'tk 10/4/2001 18:01'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ # ( (playfield ( (command initiatePainting 'Initiate painting of a new object in the standard playfield.') (slot mouseX 'The x coordinate of the mouse pointer' Number readWrite Player getMouseX unused unused) (slot mouseY 'The y coordinate of the mouse pointer' Number readWrite Player getMouseY unused unused) (command roundUpStrays 'Bring all out-of-container subparts back into view.') (slot NumberAtCursor 'the Number at the cursor' Number readWrite Player getNumberAtCursor Player setNumberAtCursor: ) (slot playerAtCursor 'the object currently at the cursor' Player readWrite Player getValueAtCursor unused unused) (slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly Player getGraphicAtCursor unused unused) (command unhideHiddenObjects 'Unhide all hidden objects.'))) (collections ( (slot cursor 'The index of the chosen element' Number readWrite Player getCursor Player setCursorWrapped:) (slot playerAtCursor 'the object currently at the cursor' Player readWrite Player getValueAtCursor unused unused) (slot firstElement 'The first object in my contents' Player readWrite Player getFirstElement Player setFirstElement:) (slot NumberAtCursor 'the number at the cursor' Number readWrite Player getNumberAtCursor Player setNumberAtCursor: ) (slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly Player getGraphicAtCursor unused unused) (command removeAll 'Remove all elements from the playfield') (command shuffleContents 'Shuffle the contents of the playfield') (command append: 'Add the object to my content' Player))) (#'stack navigation' ( (command goToNextCardInStack 'Go to the next card') (command goToPreviousCardInStack 'Go to the previous card') (command goToFirstCardInBackground 'Go to the first card of the current background') (command goToFirstCardOfStack 'Go to the first card of the entire stack') (command goToLastCardInBackground 'Go to the last card of the current background') (command goToLastCardOfStack 'Go to the last card of the entire stack') (command deleteCard 'Delete the current card') (command insertCard 'Create a new card'))) (viewing ( (slot viewingNormally 'whether contents are viewed normally' Boolean readWrite Player getViewingByIcon Player setViewingByIcon: ))) (#'pen trails' ( (command liftAllPens 'Lift the pens on all the objects in my interior.') (command lowerAllPens 'Lower the pens on all the objects in my interior.') (command arrowheadsOnAllPens 'Put arrowheads on the ends of strokes of pens on all objects.') (command noArrowheadsOnAllPens 'Stop putting arrowheads on the ends of strokes of pens on all objects.') (command clearTurtleTrails 'Clear all the pen trails in the interior.')))) ! ! !Pen methodsFor: 'operations' stamp: 'tk 10/4/2001 17:03'! arrowHead "Put an arrowhead on the previous pen stroke" " | pen | pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHead]." penDown ifTrue: [ self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location to: location]. ! ! !Pen methodsFor: 'operations' stamp: 'tk 10/4/2001 16:19'! arrowHeadFrom: prevPt to: newPt "Put an arrowhead on the pen stroke from oldPt to newPt" " | pen | pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHead]." | pm af myColor finalPt delta | myColor _ self color. delta _ newPt - prevPt. finalPt _ newPt + (Point r: sourceForm width degrees: delta degrees). "in same direction" pm _ PolygonMorph vertices: (Array with: prevPt asIntegerPoint with: finalPt asIntegerPoint) color: myColor "not used" borderWidth: sourceForm width borderColor: myColor. pm makeOpen; makeForwardArrow. af _ pm arrowForms first. "render it onto the destForm" (FormCanvas on: destForm "Display") stencil: af at: af offset + (1@1) color: myColor. ! ! !Pen methodsFor: 'operations'! up "Set the state of the receiver's pen to up (no drawing)." penDown _ false! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:16'! arrowheadsOnAllPens "Only for the Player of a World" self costume arrowheadsOnAllPens! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:47'! getPenArrowheads "Answer a boolean indicating whether the receiver's pen will draw an arrowhead at the end of a stroke" ^ self actorState getPenArrowheads! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:14'! noArrowheadsOnAllPens "Only for the Player of a Playfield" self costume noArrowheadsOnAllPens! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:48'! setPenArrowheads: penDown "Set whether the pen will draw arrowheads on the ends of strokes" self actorState setPenArrowheads: penDown. ! ! !Player methodsFor: 'slots-kernel' stamp: 'tk 10/4/2001 18:16'! usableMethodInterfacesIn: methodInterfaceList "Filter the list given by methodInterfaceList, to remove items inappropriate to the receiver" self hasCostumeThatIsAWorld ifTrue: [^ methodInterfaceList select: [:anInterface | #(append: beep: clearTurtleTrails doScript: getColor "color" getCursor "cursor" deleteCard doMenuItem emptyScript firstPage goToFirstCardInBackground goToFirstCardOfStack goToLastCardInBackground goToLastCardOfStack goToNextCardInStack goToPreviousCardInStack initiatePainting insertCard liftAllPens lowerAllPens arrowheadsOnAllPens noArrowheadsOnAllPens getMouseX getMouseY "mouseX mouseY" pauseScript: reverse roundUpStrays shuffleContents startScript: stopScript: unhideHiddenObjects getValueAtCursor "valueAtCursor" startAll: pauseAll: stopAll:) includes: anInterface selector]]. self hasAnyBorderedCostumes ifTrue: [^ methodInterfaceList]. ^ self hasOnlySketchCostumes ifTrue: [methodInterfaceList select: [:anInterface | (#(getColor getBorderColor getBorderWidth) includes: anInterface selector) not]] ifFalse: [methodInterfaceList select: [:anInterface | (#(getBorderColor getBorderWidth) includes: anInterface selector) not]]! ! !Player methodsFor: 'slots-kernel' stamp: 'tk 10/4/2001 18:23'! usablePhraseSpecsIn: aListOfTuples "Filter the list given by aListOfTuples, to remove items inappropriate to the receiver" self hasCostumeThatIsAWorld ifTrue: [^ aListOfTuples select: [:tuple | #(beep doMenuItem color doScript: startScript: stopScript: pauseScript: liftAllPens lowerAllPens arrowheadsOnAllPens noArrowheadsOnAllPens clearTurtleTrails initiatePainting cursor valueAtCursor mouseX mouseY roundUpStrays unhideHiddenObjects startAll: pauseAll: stopAll:) includes: tuple second]]. self hasAnyBorderedCostumes ifTrue: [^ aListOfTuples]. ^ self hasOnlySketchCostumes ifTrue: [aListOfTuples select: [:tuple | (#(color borderColor borderWidth) includes: tuple second) not]] ifFalse: [aListOfTuples select: [:tuple | (#(borderColor borderWidth) includes: tuple second) not]] ! ! !Point methodsFor: 'private' stamp: 'tk 10/4/2001 16:16'! setR: rho degrees: degrees | radians | radians _ degrees asFloat degreesToRadians. x _ rho asFloat * radians cos. y _ rho asFloat * radians sin.! ! !Point class methodsFor: 'instance creation' stamp: 'tk 10/4/2001 16:17'! r: rho degrees: degrees "Answer an instance of me with polar coordinates rho and theta." ^self new setR: rho degrees: degrees! ! !StandardScriptingSystem methodsFor: 'utilities' stamp: 'tk 10/4/2001 18:19'! wordingForOperator: aString "Answer the wording to be seen by the user for the given operator symbol/string" | toTest | "StandardScriptingSystem initialize" toTest _ aString asString. #( (append: 'append') (beep: 'make sound') (bounce: 'bounce') (clearTurtleTrails 'clear pen trails') (clearOwnersPenTrails 'clear all pen trails') (doMenuItem: 'do menu item') (doScript: 'do') (forward: 'forward by') (moveToward: 'move toward') (goToRightOf: 'align after') (isDivisibleBy: 'is divisible by') (liftAllPens 'lift all pens') (lowerAllPens 'lower all pens') (arrowheadsOnAllPens 'arrowheads on all pens') (noArrowheadsOnAllPens 'no arrowheads on pens') (pauseScript: 'pause script') (max: 'max') (min: 'min') (seesColor: 'is over color') (makeNewDrawingIn: 'start painting in') (startScript: 'start script') (stopProgramatically 'stop') (stopScript: 'stop script') (turn: 'turn by') (wearCostumeOf: 'look like')) do: [:pair | toTest = pair first ifTrue: [^ pair second]]. ^ toTest! ! !Player reorganize! ('card/stack commands' deleteCard firstPage getRoundedCorners goToCard: goToFirstCardInBackground goToFirstCardOfStack goToLastCardInBackground goToLastCardOfStack goToNextCardInStack goToPreviousCardInStack goto: insertCard lastPage nextPage previousPage setRoundedCorners:) ('copying' copyUniClassWith: initializeCostumesFrom: veryDeepFixupWith: veryDeepInner:) ('costume' availableCostumeNames availableCostumesForArrows clearOwnersPenTrails clearPenTrails costume costume: costumeRespondingTo: costumes costumesDo: forgetOtherCostumes getValueFromCostume: hasAnyBorderedCostumes hasCostumeThatIsAWorld hasOnlySketchCostumes knownSketchCostumeWithSameFormAs: newCostume rawCostume: recaptureUniqueCostumes rememberCostume: renderedCostume: renderedCostume:remember: resetCostumeList sendMessageToCostume: sendMessageToCostume:with: setCostumeSlot:toValue: stamp stampAndErase tearOffButtonToFireScriptForSelector: wearCostumeOf: wearCostumeOfClass: wearCostumeOfName:) ('heading' headDown headLeft headRight headUp) ('name' externalName knownName renameTo: tryToRenameTo: uniqueNameForReference) ('pen' addPlayerMenuItemsTo:hand: arrowheadsOnAllPens choosePenColor: choosePenSize clearTurtleTrails colorUnder defaultPenColor defaultPenSize getPenArrowheads getPenColor getPenDown getPenSize liftAllPens liftPen lowerAllPens lowerPen noArrowheadsOnAllPens penColor: setPenArrowheads: setPenColor: setPenDown: setPenSize:) ('slots-kernel' categories categoriesForVocabulary: categoriesForWorld methodInterfacesForInstanceVariablesCategoryIn: methodInterfacesForScriptsCategoryIn: slotInfo slotNames typeForSlot: typeForSlot:vocabulary: typeForSlotWithGetter: usableMethodInterfacesIn: usablePhraseSpecsIn:) ('slot getters/setters' cameraPoint cameraPoint: getActWhen getAllButFirstCharacter getAmount getAngle getBorderColor getBorderWidth getBottom getBrightnessUnder getCameraPoint getCharacters getColor getColorUnder getConePosition getCostume getCostumeAtCursor getCursor getCursorWrapped getDescending getDistance getFirstCharacter getFirstElement getGetListSelector getGraphic getGraphicAtCursor getHeading getHeadingUnrounded getHeight getHolder getIndexInOwner getIsUnderMouse getKnobColor getLabel getLastValue getLeft getLeftRight getLuminanceUnder getMaxVal getMinVal getMouseX getMouseY getName getNewClone getNumberAtCursor getNumericValue getOffsetX getOffsetY getPlayerAtCursor getRight getRotationStyle getSampleAtCursor getSaturationUnder getScale getScaleFactor getSpeed getTheta getTop getTruncate getUpDown getValueAtCursor getViewingByIcon getWidth getX getY handTheUserACopy setActWhen: setAllButFirstCharacter: setBorderColor: setBorderWidth: setBottom: setCameraPoint: setCharacters: setColor: setColorUnder: setConePosition: setCostume: setCursor: setCursorWrapped: setDescending: setDistance: setFirstCharacter: setFirstElement: setGetListSelector: setGraphic: setHeading: setHeight: setIndexInOwner: setKnobColor: setLabel: setLastValue: setLeft: setMaxVal: setMinVal: setName: setNumberAtCursor: setNumericValue: setOffsetX: setOffsetY: setRight: setRotationStyle: setSampleAtCursor: setScale: setScaleFactor: setTheta: setTop: setTruncate: setValueAtCursor: setViewingByIcon: setWidth: setX: setY:) ('slots-user' addInstanceVariable addInstanceVariableNamed:type:value: addSpecialSetter: chooseSlotTypeFor: chooseUserSlot compileInstVarAccessorsFor: doesNotUnderstand: hasUserDefinedScripts hasUserDefinedSlots initialTypeForSlotNamed: initialValueForSlotOfType: offerGetterTiles: removeSlotNamed: renameSlot: renameSlot:newSlotName: setPrecisionFor: slotInfoAt: slotInfoAt:ifAbsent: slotInfoForGetter: slotNamesOfType: tearOffFancyWatcherFor: tearOffWatcherFor: valueOfType:from:) ('slots-assignment' assignDecrGetter:setter:amt: assignGetter:setter:amt: assignIncrGetter:setter:amt: assignMultGetter:setter:amt:) ('scripts-kernel' acceptScript:for: allScriptEditors editDescriptionForSelector: elementTypeFor:vocabulary: emptyScript existingScriptInstantiationForSelector: expungeEmptyScripts expungeEmptyUnRenamedScripts hasScriptInvoking:ofPlayer: hasScriptReferencing:ofPlayer: infoFor:inViewer: instantiatedUserScriptsDo: isEmptyTileScript: isExpendableScript: isUniversalTiles makeIsolatedCodePaneForSelector: methodInterfaceForEmptyScript newScriptorAround: newTextualScriptorFor: noteRenameOf:to:inPlayer: okayToDestroyScriptNamed: okayToRemoveSlotNamed: pacifyScript: removeScript:fromWorld: removeScriptWithSelector: removeScriptWithoutUpdatingViewers: removeScriptWithoutUpdatingViewers:fromWorld: renameScript: renameScript:newSelector: runScript: scriptEditorFor: scriptEvaluatorFor:phrase: scriptInstantiationForSelector: scriptorsForSelector:inWorld: slotInfoButtonHitFor:inViewer: sourceCodeFor: tileScriptCommands tilesToCall: universalTilesForInterface:) ('scripts-execution' assureEventHandlerRepresentsStatus fireOnce prepareToBeRunning runAllClosingScripts runAllOpeningScripts runAllTickingScripts: scriptPerformer scriptingError: startRunning startRunningScripts step stepAt: stopProgramatically stopRunning wantsSteps) ('scripts-standard' append: assignStatus:toAllFor: bounce: changeScript:toStatus: clear contents contents: doButtonAction doMenuItem: doScript: fire followPath forward: getObtrudes goToRightOf: hide initiatePainting loadSineWave loadSound: makeNewDrawingIn: menuItemAfter: menuItemBefore: moveToward: pauseAll: pauseScript: play removeAll reverse show shuffleContents startAll: startScript: stopAll: stopScript: tellAllSiblings: turn: wrap) ('scripts-vector' * + - / asPoint decr: dividedBy: incr: multBy:) ('misc' actorState allOpenViewers allOpenViewersOnReceiverAndSiblings assureUniClass basicType beNotZero: belongsToUniClass browseEToyVocabulary browsePlayerClass categoriesForViewer: color color:sees: defaultFloatPrecisionFor: defaultLabelForInspector dummy erase getIsOverColor: grabPlayerIn: grabScriptorForSelector:in: graphicForViewerTab indicateLocationOnScreen isPlayerLike makeBounceSound: nameForViewer noteDeletionOf:fromWorld: offerAlternateViewerMenuFor:event: offerViewerMenuFor:event: openSearchingVocabularyBrowser openUnderlyingScriptorFor: ordinalNumber presenter printOn: revealPlayerIn: revertToUnscriptedPlayerIfAppropriate roundUpStrays seesColor: stack stringForReadout tearOffTileForSelf thumbnailMenuEvt:forMorph: tileReferringToSelf tileToRefer touchesA: unhideHiddenObjects uninstallFrom: unusedScriptName updateAllViewers updateAllViewersAndForceToShow: viewerFlapTab width) ('object fileIn') ('fileIn/Out' comeFullyUpOnReload: releaseCachedState storeDataOn:) ('slots-wonderland' getFogColor getFogDensity getFogRangeEnd getFogRangeStart getFogType setFogColor: setFogDensity: setFogRangeEnd: setFogRangeStart: setFogType:) ! Pen removeSelector: #arrowHeads:! PasteUpMorph removeSelector: #arrowHeads!