'From Squeak3.1alpha of 28 February 2001 [latest update: #3862] on 17 March 2001 at 7:47:41 pm'! "Change Set: ValueParam-ar Date: 17 March 2001 Author: Andreas Raab The change set modifies the event handler to pass any extra value parameter as the first argument (rather than the last argument). This is a preparation for a future change of passing both, event and source morph only if requested. The value parameter, if provided, is never optional in the current implementation so it makes sense to pass any extra arguments provided as the first args and append the optional arguments (such as event and source morph) only if requested by the client."! !CRDictionaryBrowser methodsFor: 'view hooks' stamp: 'ar 3/17/2001 14:16'! charKeyMorph: anObject requestor: aPluggableTextMorph "A view calls this method to obtain the morph that represents the index (key) of the currently displayed character" | morph string | anObject isNil ifTrue: [^ StringMorph contents: 'Empty']. morph _ AlignmentMorph new color: aPluggableTextMorph color lighter lighter lighter. morph hResizing: #shrinkWrap. string _ anObject headerString. morph _ morph addMorph: (StringMorph contents: string). morph on: #mouseDown send: #renameCharAction:event:sourceMorph: to: self withValue: aPluggableTextMorph. morph setBalloonText: 'Click to edit or inspect'. ^ morph.! ! !CRDictionaryBrowser methodsFor: 'view hooks' stamp: 'ar 3/17/2001 14:16'! renameCharAction: aPluggableTextMorph event: evt sourceMorph: aMorph "Called by a view to rename the current character" | oldChar newChar newString | (self changeCharRequestRequestor: aPluggableTextMorph) ifFalse: [^ self]. oldChar _ aPluggableTextMorph currentKey. newString _ FillInTheBlankMorphWithCharMenu request: 'Edit character' initialAnswer: oldChar string. newString isEmptyOrNil ifFalse: [newChar _ CRChar string: newString. newChar ~= oldChar ifTrue: [self appModel renameChar: oldChar to: newChar. aPluggableTextMorph setKey: newChar]]. ! ! !CategoryViewer methodsFor: 'entries' stamp: 'ar 3/17/2001 14:20'! phraseForSlot: slotSpec "Return a PhraseTileMorph representing a variable belonging to the player" "The slot spec if a tuple with the following structure: 1 #slot 2 slot name 3 balloon help 4 slot type 5 #readOnly,# readWrite, or #writeOnly 6 getter receiver indicator 7 getter selector 8 setter receiver indicator 9 setter selector NB: all are symbols except #3, which is a string" | r anArrow slotName getterButton ut cover inner | r _ ViewerRow newRow color: self color; beSticky; elementSymbol: (slotName _ slotSpec second); wrapCentering: #center; cellPositioning: #leftCenter. r addMorphBack: (self slotHeaderFor: slotName). r addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" r addMorphBack: (self infoButtonFor: slotName). r addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" ut _ scriptedPlayer isUniversalTiles. ut ifTrue: [inner _ self newTilesFor: scriptedPlayer getter: slotSpec. cover _ (Morph new) color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #newMakeGetter:event:from: to: self withValue: slotSpec] ifFalse: [r addMorphBack: self tileForSelf bePossessive. r addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" getterButton _ self getterButtonFor: slotName type: slotSpec fourth]. r addMorphBack: getterButton. getterButton setBalloonText: slotSpec third. (slotName == #isOverColor) ifTrue: [ self addIsOverColorDetailTo: r. ^ r ]. (slotName == #touchesA) ifTrue: [ self addTouchesADetailTo: r. ^ r ]. r addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (slotSpec fifth == #readOnly) ifFalse: [r addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ ut ifTrue: [self arrowSetterButton: #newMakeSetter:event:from: args: slotSpec] ifFalse: [self arrowSetterButton: #makeSetter:event:from: args: (Array with: slotName with: slotSpec fourth)]. r addMorphBack: anArrow. ]. (#(colorSees playerSeeingColor copy touchesA) includes: slotName) ifFalse: [r addMorphBack: (self readoutFor: slotName type: slotSpec fourth readOnly: slotSpec fifth getSelector: slotSpec seventh putSelector: slotSpec ninth)]. anArrow ifNotNil: [anArrow step]. ^ r! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:19'! arrowSetterButtonFor: partName type: partType | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.'. m on: #mouseDown send: #makeSetter:event:from: to: self withValue: (Array with: partName with: partType). ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:20'! getterButtonFor: partName type: partType | m | m _ TileMorph new setOperator: partName. m typeColor: (ScriptingSystem colorForType: partType). m on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: partName with: partType). ^ m! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:20'! makeGetter: args event: evt from: aMorph | m selfTile selector aType firstArg | (aType _ args last) == #unknown ifTrue: [^ self beep]. (#(colorSees isOverColor touchesA) includes: (firstArg _ args first)) ifFalse: [m _ PhraseTileMorph new setSlotRefOperator: args first asSymbol type: aType] ifTrue: [(firstArg == #colorSees) ifTrue: [m _ self colorSeesPhrase]. (firstArg == #isOverColor) ifTrue: [m _ self seesColorPhrase]. (firstArg == #touchesA) ifTrue: [m _ self touchesAPhrase]. ]. selfTile _ self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. selector _ m submorphs at: 2. (aType == #number) ifTrue: [selector addSuffixArrow]. selector updateLiteralLabel. m enforceTileColorPolicy. owner ifNotNil: [self primaryHand attachMorph: m] ifNil: [^ m]. ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:17'! makeSetter: args event: evt from: aMorph | argType m argTile selfTile argValue | argType _ args last. m _ PhraseTileMorph new setAssignmentRoot: args first asSymbol type: #command rcvrType: #player argType: argType. argValue _ self scriptedPlayer perform: (ScriptingSystem getterSelectorFor: args first asSymbol). (argValue isKindOf: Player) ifTrue: [argTile _ argValue tileReferringToSelf] ifFalse: [argTile _ scriptedPlayer tileForArgType: argType inViewer: self. 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. owner ifNotNil: [self primaryHand attachMorph: m] ifNil: [^ m]. ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:20'! newMakeGetter: aSpec event: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newTilesFor: scriptedPlayer getter: aSpec. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m]. ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:17'! newMakeSetter: aSpec event: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newTilesFor: scriptedPlayer setter: aSpec. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m]. ! ! !EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:24'! addCurves "Add the polyLine corresponding to the currently selected envelope, and possibly all the others, too." | verts aLine | sound envelopes do: [:env | (showAllEnvelopes or: [env == envelope]) ifTrue: [verts _ env points collect: [:p | (self xFromMs: p x) @ (self yFromValue: p y)]. aLine _ EnvelopeLineMorph basicNew vertices: verts borderWidth: 1 borderColor: (self colorForEnvelope: env). env == envelope ifTrue: [aLine borderWidth: 2. line _ aLine] ifFalse: [aLine on: #mouseUp send: #clickOn:evt:from: to: self withValue: env. self addMorph: aLine]]]. self addMorph: line "add the active one last (in front)"! ! !EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:25'! addHandlesIn: frame | handle | handle := PolygonMorph vertices: (Array with: 0@0 with: 8@0 with: 4@8) color: Color orange borderWidth: 1 borderColor: Color black. handle addMorph: ((RectangleMorph newBounds: ((self handleOffset: handle)-(2@0) extent: 1@(graphArea height-2)) color: Color orange) borderWidth: 0). limitHandles _ Array with: handle with: handle veryDeepCopy with: handle veryDeepCopy. 1 to: limitHandles size do: [:i | handle _ limitHandles at: i. handle on: #mouseDown send: #limitHandleMove:event:from: to: self withValue: i. handle on: #mouseMove send: #limitHandleMove:event:from: to: self withValue: i. self addMorph: handle. handle position: ((self xFromMs: (envelope points at: (limits at: i)) x) @ (graphArea top)) - (self handleOffset: handle)]! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'! clickOn: env evt: anEvent from: aLine self editEnvelope: env! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'! limitHandleMove: index event: evt from: handle "index is the handle index = 1, 2 or 3" | ix p ms x points limIx | ix _ limits at: index. "index of corresponding vertex" p _ evt cursorPoint adhereTo: graphArea bounds. ms _ self msFromX: p x + (self handleOffset: handle) x. "Constrain move to adjacent points on ALL envelopes" sound envelopes do: [:env | limIx _ env perform: (#(loopStartIndex loopEndIndex decayEndIndex) at: index). ms _ self constrain: ms adjacentTo: limIx in: env points]. "Update the handle, the vertex and the line being edited" x _ self xFromMs: ms. handle position: (x @ graphArea top) - (self handleOffset: handle). line verticesAt: ix put: x @ (line vertices at: ix) y. sound envelopes do: [:env | limIx _ env perform: (#(loopStartIndex loopEndIndex decayEndIndex) at: index). points _ env points. points at: limIx put: ms @ (points at: limIx) y. env setPoints: points loopStart: env loopStartIndex loopEnd: env loopEndIndex].! ! !EventHandler methodsFor: 'events' stamp: 'ar 3/17/2001 14:34'! send: selector to: recipient withEvent: event fromMorph: sourceMorph | arity | recipient ifNil: [^ self]. arity _ selector numArgs. arity = 0 ifTrue: [^ recipient perform: selector]. arity = 1 ifTrue: [^ recipient perform: selector with: event]. arity = 2 ifTrue: [^ recipient perform: selector with: event with: sourceMorph]. arity = 3 ifTrue: [^ recipient perform: selector with: valueParameter with: event with: sourceMorph]. self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! ! !HtmlArea methodsFor: 'formatting' stamp: 'ar 3/17/2001 14:25'! linkMorphForMap: map andBrowser: browser | m | (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! ! !HtmlInput methodsFor: 'formatting' stamp: 'ar 3/17/2001 14:26'! addImageButtonToFormatter: formatter "is it a submit button?" | formData imageUrl morph | (imageUrl _ self getAttribute: 'src') ifNil: [^self]. formatter baseUrl ifNotNil: [imageUrl _ imageUrl asUrlRelativeTo: formatter baseUrl]. morph _ DownloadingImageMorph new. morph defaultExtent: self imageExtent. morph altText: self alt. morph url: imageUrl. value _ self getAttribute: 'name' default: 'Submit'. formData _ formatter currentFormData. morph on: #mouseUp send: #mouseUpFormData:event:linkMorph: to: self withValue: formData. formatter addIncompleteMorph: morph ! ! !HtmlInput methodsFor: 'morphic' stamp: 'ar 3/17/2001 14:26'! mouseUpFormData: formData event: event linkMorph: linkMorph | aPoint | 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! ! !HtmlMap methodsFor: 'morphic' stamp: 'ar 3/17/2001 14:25'! 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 jumpToUrl: url! ! !PhraseTileMorph methodsFor: 'tiles from method' stamp: 'ar 3/17/2001 14:37'! tilesFrom: msgNode in: aScriptor "Construct a single line of tiles from a MessageNode of a parse tree. For a single message send." | tile pm sel instVar suff argNode selType | self flag: #noteToTed. "Ted: this is your code from 8/6/99, which is now broken before it could ever get used. The method #scriptInfoFor: which it formerly called is gone; I've included its old content at the end in comments as a pointer. sw 9/8/2000 09:44" "latter-day note: sw 10/10/2000 11:25 - this is now reached by the from a menu item in the Scriptor menu, so this is where the capability needs to be revived" true ifTrue: [^ self inform: 'Under Construction!! Not yet released!!. (sorry)']. sel _ msgNode selector key. (sel beginsWith: 'assign') ifTrue: [ "assignment" instVar _ msgNode arguments first literalValue. instVar _ (instVar copyFrom: 4 to: instVar size) withFirstCharacterDownshifted. pm _ (CategoryViewer new) scriptedPlayer: aScriptor playerScripted; makeSetter: (Array with: instVar with: #number) event: nil from: aScriptor playerScripted costume. "makes a new Phrase" suff _ (sel findTokens: ':') first. suff _ (suff copyFrom: 7 to: suff size-6), ':'. ": Incr: Decr: Mult:" pm submorphs second setAssignmentSuffix: suff. pm submorphs third delete. tile _ TilePadMorph new tilesFrom: msgNode arguments last in: aScriptor. pm addMorphBack: tile. ^ pm]. (sel beginsWith: 'get') ifTrue: [ "getter" instVar _ (sel copyFrom: 4 to: sel size) withFirstCharacterDownshifted. pm _ (CategoryViewer new) scriptedPlayer: aScriptor playerScripted; makeGetter: (Array with: instVar with: #number) event: nil from: aScriptor playerScripted costume. "makes a new Phrase" ^ pm]. (#(ifTrue:ifFalse: ifFalse: ifTrue:) includes: sel) ifTrue: [ ^ CompoundTileMorph new tilesFrom: msgNode in: aScriptor]. self addMorphBack: (TilePadMorph new tilesFrom: msgNode receiver in: aScriptor). self addMorphBack: (TileMorph new selectorTile: msgNode in: aScriptor). "selector" (aScriptor playerScripted elementTypeFor: sel) == #systemScript ifTrue: [ selType _ (aScriptor playerScripted phraseSpecFor: (Array with: #command with: sel)) last]. msgNode arguments size > 0 ifTrue: [ argNode _ msgNode arguments last. tile _ TileMorph new tilesFrom: argNode type: selType in: aScriptor. self addMorphBack: tile]. "Old code from Player, now superseded by an entirely new mechanism... phraseSpecFor: aPair | info prefix | info _ (prefix _ aPair first) == #slot ifTrue: [ScriptingSystem slotInfoFor: aPair second] ifFalse: [ScriptingSystem scriptInfoFor: aPair second]. ^ (Array with: prefix), info" ! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:30'! buildKeyboard | wtWid bkWid keyRect octavePt nWhite nBlack | self removeAllMorphs. wtWid _ 8. bkWid _ 5. self extent: 10@10. 1 to: nOctaves+1 do: [:i | i <= nOctaves ifTrue: [nWhite _ 7. nBlack _ 5] ifFalse: [nWhite _ 1. nBlack _ 0 "High C"]. octavePt _ self innerBounds topLeft + ((7*wtWid*(i-1)-1)@-1). 1 to: nWhite do: [:j | keyRect _ octavePt + (j-1*wtWid@0) extent: (wtWid+1)@36. self addMorph: ((RectangleMorph newBounds: keyRect color: whiteKeyColor) borderWidth: 1; on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self withValue: i-1*12 + (#(1 3 5 6 8 10 12) at: j))]. 1 to: nBlack do: [:j | keyRect _ octavePt + ((#(6 15 29 38 47) at: j)@1) extent: bkWid@21. self addMorph: ((Morph newBounds: keyRect color: blackKeyColor) on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self withValue: i-1*12 + (#(2 4 7 9 11) at: j))]]. self submorphsDo: [:m | m on: #mouseMove send: #mouseMovePitch:event:noteMorph: to: self; on: #mouseUp send: #mouseUpPitch:event:noteMorph: to: self; on: #mouseEnterDragging send: #mouseDownPitch:event:noteMorph: to: self; on: #mouseLeaveDragging send: #mouseUpPitch:event:noteMorph: to: self]. self extent: (self fullBounds extent + borderWidth - 1)! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:27'! mouseDownPitch: midiKey event: event noteMorph: noteMorph | pitch | event hand hasSubmorphs ifTrue: [^ self "no response if drag something over me"]. event hand mouseFocus ifNil: ["If dragged into me, then establish focus so I'll see moves" event hand newMouseFocus: noteMorph event: event]. noteMorph color: playingKeyColor. pitch _ AbstractSound pitchForMIDIKey: midiKey + 23. soundPlaying ifNotNil: [soundPlaying stopGracefully]. soundPlaying _ soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3. SoundPlayer resumePlaying: soundPlaying quickStart: true. ! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:28'! mouseMovePitch: pitch event: event noteMorph: noteMorph (noteMorph containsPoint: event cursorPoint) ifFalse: ["If drag out of me, zap focus so other morphs can see drag in." event hand releaseMouseFocus: noteMorph] ! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:29'! mouseUpPitch: pitch event: event noteMorph: noteMorph noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). soundPlaying ifNotNil: [soundPlaying stopGracefully]. ! ! !KeyboardMorphForInput methodsFor: 'events' stamp: 'ar 3/17/2001 14:27'! mouseDownPitch: midiKey event: event noteMorph: keyMorph | sel noteEvent | event hand hasSubmorphs ifTrue: [^ self "no response if drag something over me"]. keyMorph color: playingKeyColor. (sel _ pianoRoll selection) ifNil: [^ self]. insertMode ifTrue: [sel _ pianoRoll selectionForInsertion. insertMode _ false]. sel = prevSelection ifFalse: ["This is a new selection -- need to determine start time" sel third = 0 ifTrue: [startOfNextNote _ 0] ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first) at: sel third) endTime. startOfNextNote _ startOfNextNote + self fullDuration - 1 truncateTo: self fullDuration]]. noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration; key: midiKey + 23 velocity: self velocity channel: 1. pianoRoll appendEvent: noteEvent fullDuration: self fullDuration. soundPlaying ifNotNil: [soundPlaying stopGracefully]. (soundPlaying _ self soundForEvent: noteEvent inTrack: sel first) play. prevSelection _ pianoRoll selection. startOfNextNote _ startOfNextNote + self fullDuration.! ! !KeyboardMorphForInput methodsFor: 'events' stamp: 'ar 3/17/2001 14:28'! mouseUpPitch: pitch event: event noteMorph: noteMorph noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). ! ! !MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:40'! mouseDownPitch: midiKey event: event noteMorph: noteMorph midiPort ifNil: [^ super mouseDownPitch: midiKey-1 event: event noteMorph: noteMorph]. noteMorph color: playingKeyColor. soundPlaying ifNil: [midiPort ensureOpen] ifNotNil: [self turnOffNote]. self turnOnNote: midiKey + 23. ! ! !MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:41'! mouseUpPitch: midiKey event: event noteMorph: noteMorph midiPort ifNil: [ ^ super mouseUpPitch: midiKey event: event noteMorph: noteMorph]. noteMorph color: ((#(0 1 3 5 6 8 10) includes: midiKey \\ 12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). soundPlaying ifNotNil: [self turnOffNote]. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:32'! addHandles | handle newVert tri | self removeHandles. handles _ OrderedCollection new. tri _ Array with: 0@-4 with: 4@3 with: -3@3. vertices withIndexDo: [:vertPt :vertIndex | handle _ EllipseMorph newBounds: (Rectangle center: vertPt extent: 8@8) color: Color yellow. handle on: #mouseMove send: #dragVertex:event:fromHandle: to: self withValue: vertIndex. handle on: #mouseUp send: #dropVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: handle. handles addLast: handle. (closed or: [vertIndex < vertices size]) ifTrue: [newVert _ PolygonMorph vertices: (tri collect: [:p | p + (vertPt + (vertices atWrap: vertIndex+1) // 2)]) color: Color green borderWidth: 1 borderColor: Color black. newVert on: #mouseDown send: #newVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: newVert. handles addLast: newVert]]. smoothCurve ifTrue: [self updateHandles; layoutChanged]. self changed! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:30'! dragVertex: ix event: evt fromHandle: handle | p | p _ self isCurve ifTrue: [evt cursorPoint] ifFalse: [self griddedPoint: evt cursorPoint]. handle position: p - (handle extent//2). self verticesAt: ix put: p. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:31'! dropVertex: ix event: evt fromHandle: handle | p | p _ vertices at: ix. (((vertices atWrap: ix-1) dist: p) < 3 or: [((vertices atWrap: ix+1) dist: p) < 3]) ifTrue: ["Drag a vertex onto its neighbor means delete" self setVertices: (vertices copyReplaceFrom: ix to: ix with: Array new)]. evt shiftPressed ifTrue: [self removeHandles] ifFalse: [self addHandles "remove then add to recreate"]! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:32'! newVertex: ix event: evt fromHandle: handle "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events." | pt | pt _ evt cursorPoint. self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)). evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1). ! ! !EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:38'! dragVertex: ix event: evt fromHandle: handle | p | super dragVertex: ix event: evt fromHandle: handle. p _ owner acceptGraphPoint: evt cursorPoint at: ix. self verticesAt: ix put: p. ! ! !EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:31'! dropVertex: ix event: evt fromHandle: handle | oldVerts | oldVerts _ vertices. super dropVertex: ix event: evt fromHandle: handle. vertices = oldVerts ifFalse: [owner deletePoint: ix "deleted a vertex"]! ! !EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:39'! newVertex: ix event: evt fromHandle: handle "Install a new vertex if there is room." (owner insertPointAfter: ix) ifFalse: [^ self "not enough room"]. super newVertex: ix event: evt fromHandle: handle. self verticesAt: ix+1 put: (owner acceptGraphPoint: evt cursorPoint at: ix+1). ! ! !Preferences class methodsFor: 'pref buttons' stamp: 'ar 3/17/2001 14:32'! buttonRepresenting: prefSymbol wording: aString color: aColor inPanel: aPreferencesPanel "Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place" | outerButton aButton str aHelp miniWrapper | ((FlagDictionary includesKey: prefSymbol) or: [self flagsHeldByProjects includesKey: prefSymbol]) ifFalse: [self error: 'Unknown preference: ', prefSymbol printString]. outerButton _ AlignmentMorph newRow height: 24. outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]). outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]). outerButton vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #togglePreference:; arguments: (Array with: prefSymbol); target: Preferences; getSelector: prefSymbol. outerButton addTransparentSpacerOfSize: (2 @ 0). str _ StringMorph contents: aString font: (StrikeFont familyName: 'NewYork' size: 12). (self isProjectPreference: prefSymbol) ifTrue: [str emphasis: 1]. miniWrapper _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. miniWrapper beTransparent addMorphBack: str lock. aPreferencesPanel ifNotNil: [miniWrapper on: #mouseDown send: #prefMenu:event:rcvr: to: aPreferencesPanel withValue: prefSymbol]. outerButton addMorphBack: miniWrapper. aButton setBalloonText: (aHelp _ Preferences helpMessageForPreference: prefSymbol). miniWrapper setBalloonText: aHelp; setProperty: #balloonTarget toValue: aButton. ^ outerButton "self currentHand attachMorph: (Preferences buttonRepresenting: #balloonHelpEnabled wording: 'Balloon Help' color: Color red muchLighter inPanel: nil) " ! ! !PreferencesPanel methodsFor: 'initialization' stamp: 'ar 3/17/2001 14:32'! prefMenu: prefSymbol event: anEvent rcvr: aMorph "the user clicked on a preference name. put up a menu" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: prefSymbol. (Preferences okayToChangeProjectLocalnessOf: prefSymbol) ifTrue: [aMenu addUpdating: #isProjectLocalString: enablementSelector: nil target: Preferences selector: #toggleProjectLocalnessOf: argumentList: {prefSymbol}]. aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project'. aMenu add: 'browse senders' target: Smalltalk selector: #browseAllCallsOn: argument: prefSymbol. aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', prefSymbol, '".'. aMenu add: 'show category...' target: self selector: #findCategoryFromPreference: argument: prefSymbol. aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. Smalltalk isMorphic ifTrue: [aMenu add: 'hand me a button for this preference' target: self selector: #tearOfButtonFor: argument: prefSymbol. aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish']. aMenu add: 'copy this name to clipboard' target: self selector: #copyNameOf: argument: prefSymbol. aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. aMenu popUpInWorld! ! !StarMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:33'! addHandles | center | self removeHandles. center _ vertices sum // vertices size. "Average vertices to get the center" handles _ {center. vertices second} with: {#center. #outside} collect: [:p :which | (EllipseMorph newBounds: (Rectangle center: p extent: 8@8) color: Color yellow) on: #mouseDown send: #dragVertex:event:fromHandle: to: self withValue: which; on: #mouseMove send: #dragVertex:event:fromHandle: to: self withValue: which]. self addAllMorphs: handles. self changed! ! !StarMorph methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 14:30'! dragVertex: label event: evt fromHandle: handle | ext oldR pt center | label == #center ifTrue: [self position: self position + (evt cursorPoint - handle center)]. label == #outside ifTrue: [center _ handles first center. pt _ center - evt cursorPoint. ext _ pt r. oldR _ ext. vertices _ (0 to: 359 by: (360//vertices size)) collect: [:angle | (Point r: (oldR _ oldR = ext ifTrue: [ext*5//12] ifFalse: [ext]) degrees: angle + pt degrees) + center]. handle align: handle center with: evt cursorPoint]. self computeBounds. ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ar 3/17/2001 19:39'! upDown: delta event: evt arrow: arrowMorph | st aList index now want instVar | st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self]. (self nodeClassIs: LiteralNode) ifTrue: [ "+/- 1" st contents: (self decompile asNumber + delta) printString. ^ self acceptSilently. "maybe set parseNode's key"]. (self nodeClassIs: VariableNode) ifTrue: [ "true/false" st contents: (self decompile asString = 'true') not printString. ^ self acceptSilently. "maybe set parseNode's key"]. (self nodeClassIs: SelectorNode) ifTrue: [ aList _ #(+ - * / // \\ min: max:). index _ aList indexOf: self decompile asString. index > 0 ifTrue: [ ^ self setSelector: (aList atWrap: index + delta) in: st]. aList _ #(= ~= > >= isDivisibleBy: < <=). index _ aList indexOf: self decompile asString. index > 0 ifTrue: [ ^ self setSelector: (aList atWrap: index + delta) in: st]. aList _ #(== ~~). index _ aList indexOf: self decompile asString. index > 0 ifTrue: [ ^ self setSelector: (aList atWrap: index + delta) in: st]. 'beep:' = self decompile asString ifTrue: ["replace sound arg" self changeSound: delta. ^ self acceptSilently]. ]. (self nodeClassIs: SelectorNode) ifTrue: ["kinds of assignment" ((now _ self decompile asString) beginsWith: 'set') ifTrue: ["a setX: 3" want _ 1+delta. instVar _ (now allButFirst: 3) allButLast]. (now endsWith: 'IncreaseBy:') ifTrue: ["a xIncreaseBy: 3 a setX: (a getX +3)." want _ 2+delta. instVar _ now allButLast: 11]. (now endsWith: 'DecreaseBy:') ifTrue: ["a xDecreaseBy: 3 a setX: (a getX -3)." want _ 3+delta. instVar _ now allButLast: 11]. (now endsWith: 'MultiplyBy:') ifTrue: ["a xMultiplyBy: 3 a setX: (a getX *3)." want _ 4+delta. instVar _ now allButLast: 11]. want ifNil: [^ self]. instVar _ instVar asLowercase. want _ #(1 2 3 4) atWrap: want. want = 1 ifTrue: [^ self setSelector: ('set', instVar capitalized, ':') in: st]. "setter method is present" want = 2 ifTrue: [^ self setSelector: instVar, 'IncreaseBy:' in: st]. "notUnderstood will create the method if needed" want = 3 ifTrue: [^ self setSelector: instVar, 'DecreaseBy:' in: st]. "notUnderstood will create the method if needed" want = 4 ifTrue: [^ self setSelector: instVar, 'MultiplyBy:' in: st]. "notUnderstood will create the method if needed" ]. ! ! !SyntaxMorph methodsFor: 'pop ups' stamp: 'ar 3/17/2001 14:33'! upDownArrows "Return an array of two up/down arrow buttons. It replaces the selector or arg with a new one. I am a number or boolean or a selector (beep:, +,-,*,//,\\, or setX: incX: decX: for any X." | patch sel any ok | any _ (self nodeClassIs: LiteralNode) and: [parseNode key isNumber]. any _ any or: [(self nodeClassIs: VariableNode) and: [(#('true' 'false') includes: self decompile asString)]]. any _ any or: [(self nodeClassIs: SelectorNode) and: [ok _ #(beep: + - * // \\) includes: (sel _ parseNode key). ok _ ok or: [(sel beginsWith: 'set') and: [(sel atWrap: 4) isUppercase]]. ok _ ok or: [sel size > 11 and: [#('IncreaseBy:' 'DecreaseBy:' 'MultiplyBy:') includes: (sel last: 11)]]. ok]]. any _ any or: [(self nodeClassIs: SelectorNode) and: [ok _ #(= ~= == ~~) includes: (sel _ parseNode key). ok]]. any ifFalse: [^ nil]. patch _ {(ImageMorph new image: TileMorph upPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: 1. (ImageMorph new image: TileMorph downPicture) on: #mouseDown send: #upDown:event:arrow: to: self withValue: -1}. ^ patch! ! SyntaxMorph removeSelector: #event:arrow:upDown:! StarMorph removeSelector: #dragVertex:fromHandle:vertIndex:! PreferencesPanel removeSelector: #prefMenu:rcvr:pref:! EnvelopeLineMorph removeSelector: #dragVertex:fromHandle:vertIndex:! EnvelopeLineMorph removeSelector: #dropVertex:fromHandle:vertIndex:! EnvelopeLineMorph removeSelector: #newVertex:fromHandle:afterVert:! PolygonMorph removeSelector: #dragVertex:fromHandle:vertIndex:! PolygonMorph removeSelector: #dropVertex:fromHandle:vertIndex:! PolygonMorph removeSelector: #newVertex:fromHandle:afterVert:! MIDIPianoKeyboardMorph removeSelector: #mouseDownEvent:noteMorph:pitch:! MIDIPianoKeyboardMorph removeSelector: #mouseUpEvent:noteMorph:pitch:! KeyboardMorphForInput removeSelector: #mouseDownEvent:noteMorph:pitch:! KeyboardMorphForInput removeSelector: #mouseUpEvent:noteMorph:pitch:! PianoKeyboardMorph removeSelector: #mouseDownEvent:noteMorph:pitch:! PianoKeyboardMorph removeSelector: #mouseMoveEvent:noteMorph:pitch:! PianoKeyboardMorph removeSelector: #mouseUpEvent:noteMorph:pitch:! HtmlMap removeSelector: #mouseUpEvent:linkMorph:browserAndUrl:! HtmlInput removeSelector: #mouseUpEvent:linkMorph:formData:! EnvelopeEditorMorph removeSelector: #clickOnLine:evt:envelope:! EnvelopeEditorMorph removeSelector: #limitHandleMoveEvent:from:index:! CategoryViewer removeSelector: #makeGetter:from:forPart:! CategoryViewer removeSelector: #makeSetter:from:forPart:! CategoryViewer removeSelector: #newMakeGetter:from:forPart:! CategoryViewer removeSelector: #newMakeSetter:from:forPart:! CRDictionaryBrowser removeSelector: #renameCharAction:sourceMorph:requestor:!