'From Squeak3.1alpha of 28 February 2001 [latest update: #4207] on 21 July 2001 at 5:18:22 pm'! "Change Set: UniTile-tk Date: 18 July 2001 Author: Ted Kaehler Rename the preference #largeTiles to be #uniTilesClassic. [ ] default tile size is small. Remove size changing totally. Remove SizeScaleFactor. [ ] Only one drop target is highlighted. [ ] mouseEnter, mouseLeave do nothing unless the tile is in a script (not in viewer, not in tiles just laying on the desktop.) [ ] Translucent tiles when in hand actually work. Fix bug in flaps access."! !Preferences commentStamp: 'tk 7/18/2001 10:44' prior: 0! A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false. To open the control panel: Preferences openFactoredPanel To read how to use the panel (and how to make a preference be per-project): Preferences giveHelpWithPreferences All messages are on the class side. To query a a preference: Preferences logDebuggerStackToFile or some people prefer the more verbose Preferences valueOfFlag: #logDebuggerStackToFile You can make up a new preference any time. Do not define a new message in Preferences class. Accessor methods are compiled automatically when you add a preference as illustrated below: To add a preference (e.g. in the Postscript of a fileout): Preferences addPreference: #samplePreference categories: #(general browsing) default: true balloonHelp: 'This is an example of a preference added by a do-it'. To change a preference programatically: Preferences disable: #logDebuggerStackToFile. Or to turn it on, Preferences enable: #logDebuggerStackToFile. ! ]style[(220 29 81 35 751)f1,f1dPreferences openFactoredPanel;;,f1,f1dPreferences giveHelpWithPreferences;;,f1! !SyntaxMorph commentStamp: 'tk 7/19/2001 20:36' prior: 0! A single class of morph that holds any piece of Smalltalk, and allows it to be a tile. Tiles can be dragged in or out of a method. In the message list pane of a Browser, choose 'tile scriptor'. Bring up a second one to steal parts from. Clicking multiple times selects enclosing phrases of code. Dragging lets you take away a copy. Any tile may be replaced by dropping on it. Shift-click to edit the text of any tile. Change variable and message names, but do not change the part-of-speech (objects to selector). Each SyntaxMorph holds a ParseNode. After editing, the parseNode is only good as a part-of-speech indicator. Only the classes of the parseNodes are important. It's state is not kept up to date with the tile edits (but maybe it should be). The correspondence between SyntaxMorphs and parseNodes in the real parse tree is not one-to-one. Several extra levels of SyntaxMorph were added as aligners to make the horizontal and vertical layout right. These sometimes have nil for the parseNode. When accept the method, we pass over the tree of SyntaxMorphs, gathering their printStrings and inserting punctuation. See (SyntaxMorph>>printOn:indent:). We send the result to the compiler. (We do not use the parse tree we already have.) To turn on type checking: Preferences enable: #eToyFriendly or for testing: World project projectParameters at: #fullCheck put: true. Colors of tiles: Each tile has a current color (inst car color) and a deselectedColor (a property). The deselectedColor may be governed by the part of speech, or not. (translateColor: is only used when a tile is created, to set deselectedColor.) From deselectedColor (set by #setDeselectedColor), the color changes to: lightBrown when selected (not the submorphs) in #select translucent when held in the hand (allMorphs) in #lookTranslucent green when a drop target (allMorphs) (change the owners back) #dropColor, #trackDropZones deselectedColor is moderated by the darkness setting, #scaleColorByUserPref:. (as it is put into color in #color:)! !PasteUpMorph methodsFor: 'accessing' stamp: 'tk 7/17/2001 16:07'! flapTab | ww | self isFlap ifFalse:[^nil]. ww _ self world ifNil: [World]. ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]! ! !Preferences class methodsFor: 'initialization' stamp: 'tk 7/18/2001 11:04'! expungePreferenceNamed: aSymbol "Remove all memory of the given preference symbol in my various structures." | pref | pref _ self preferenceAt: aSymbol ifAbsent: [^ self]. pref localToProject ifTrue: [ Project allInstancesDo: [:proj | proj projectPreferenceFlagDictionary ifNotNil: [ proj projectPreferenceFlagDictionary removeKey: aSymbol ifAbsent: []]]]. DictionaryOfPreferences removeKey: aSymbol ifAbsent: []. self class removeSelector: aSymbol "Preferences expungePreferenceNamed: #tileToggleInBrowsers" ! ! !Preferences class methodsFor: 'reacting to change' stamp: 'tk 7/18/2001 16:02'! classicTilesSettingToggled "The current value of the largeTiles flag has changed; now react" Smalltalk isMorphic ifTrue: [Preferences universalTiles ifFalse: [self inform: 'note that this will only have a noticeable effect if the universalTiles preference is set to true, which it currently is not'] ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'tk 7/18/2001 16:03'! setNotificationParametersForStandardPreferences "Set up the notification parameters for the standard preferences that require need them. When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are: Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector: and Preference changeInformee:changeSelector:" "Preferences setNotificationParametersForStandardPreferences" | aPreference | #( (annotationPanes annotationPanesChanged) (eToyFriendly eToyFriendlyChanged) (infiniteUndo infiniteUndoChanged) (uniTilesClassic classicTilesSettingToggled) (optionalButtons optionalButtonsChanged) (roundedWindowCorners roundedWindowCornersChanged) (showProjectNavigator showProjectNavigatorChanged) (smartUpdating smartUpdatingChanged) (universalTiles universalTilesSettingToggled) (showSharedFlaps sharedFlapsSettingChanged)) do: [:pair | aPreference _ self preferenceAt: pair first. aPreference changeInformee: self changeSelector: pair second]! ! !SyntaxMorph methodsFor: 'accessing' stamp: 'tk 7/19/2001 20:04'! color: aColorOrSymbol | deselectedColor cc | aColorOrSymbol isColor ifTrue: [ self valueOfProperty: #deselectedColor ifAbsent: ["record my color the first time" self setProperty: #deselectedColor toValue: aColorOrSymbol. ^ super color: (self scaleColorByUserPref: aColorOrSymbol)]. ^ super color: aColorOrSymbol]. deselectedColor _ self valueOfProperty: #deselectedColor ifAbsent: [nil]. deselectedColor ifNotNil: [^ super color: (self scaleColorByUserPref: deselectedColor)]. aColorOrSymbol == #comment ifTrue: [^ self color: Color blue lighter]. SyntaxMorph noTileColor ifTrue: [ "override" ^ self color: Color transparent]. "Fix this to be real color!!" (cc _ self class translateColor: aColorOrSymbol) isColor ifTrue: [^ self color: cc] ifFalse: [Transcript show: aColorOrSymbol, ' needs to be handled in translateColor:'; cr. ^ self color: Color transparent]. "help!!"! ! !SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/19/2001 20:21'! mouseEnter: evt "Highlight this level as a potential grab target" "Transcript cr; print: self; show: ' enter'." self rootTile isMethodNode ifFalse: [^ self]. "not in a script" self unhighlightOwnerBorder. self highlightForGrab: evt. evt hand newKeyboardFocus: self. ! ! !SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/20/2001 17:42'! mouseEnterDragging: evt "Highlight this level as a potential drop target" "Transcript cr; print: self; show: ' enterDragging'." self rootTile isMethodNode ifFalse: [^ self]. "not in a script" evt hand hasSubmorphs ifFalse: [^ self]. "Don't react to empty hand" self unhighlightOwnerBorder. self isBlockNode ifFalse: [self highlightForDrop: evt. (self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m color = self dropColor]]) ifNotNilDo: [:m | m unhighlight]]. self isBlockNode ifTrue: [(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]]) ifNotNilDo: [:m | "Suspend outer block." m stopStepping; removeDropZones]. self startStepping] ! ! !SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/19/2001 20:21'! mouseLeave: evt "Move grab highlight back out a level" "Transcript cr; print: self; show: ' leave'." self rootTile isMethodNode ifFalse: [^ self]. "not in a script" self unhighlightBorder. (owner ~~ nil and: [owner isSyntaxMorph]) ifTrue: [owner highlightForGrab: evt]. ! ! !SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/20/2001 17:38'! mouseLeaveDragging: evt "Transcript cr; print: self; show: ' leaveDragging'." self rootTile isMethodNode ifFalse: [^ self]. "not in a script" self isBlockNode ifTrue: [self stopStepping; removeDropZones. (self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]]) ifNotNilDo: [:m | "Activate outer block." m startStepping]]. "Move drop highlight back out a level" self unhighlight. (owner ~~ nil and: [owner isSyntaxMorph]) ifTrue: [owner isBlockNode ifFalse: [owner highlightForDrop: evt]]. ! ! !SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/19/2001 19:26'! mouseMove: evt | dup selection | owner isSyntaxMorph ifFalse: [^ self]. self currentSelectionDo: [:innerMorph :mouseDownLoc :outerMorph | mouseDownLoc ifNotNil: [ (evt cursorPoint dist: mouseDownLoc) > 4 ifTrue: ["If drag 5 pixels, then tear off a copy of outer selection." selection _ outerMorph ifNil: [self]. selection deletePopup. evt hand attachMorph: (dup _ selection duplicate). Preferences tileTranslucentDrag ifTrue: [dup lookTranslucent] ifFalse: [dup align: dup topLeft with: evt hand position + self cursorBaseOffset]. self setSelection: nil. "Why doesn't this deselect?" (self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]]) ifNotNilDo: [:m | "Activate enclosing block." m startStepping]]]]. ! ! !SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 7/19/2001 19:04'! justDroppedInto: aMorph event: evt aMorph isSyntaxMorph ifFalse: [Preferences tileTranslucentDrag ifTrue: [self setDeselectedColor] ifFalse: [self align: self topLeft with: self topLeft - self cursorBaseOffset]]. self removeProperty: #beScript. ^ super justDroppedInto: aMorph event: evt! ! !SyntaxMorph methodsFor: 'drawing' stamp: 'tk 7/19/2001 20:14'! lookTranslucent self setDeselectedColor. super color: (self color alpha: 0.25). submorphs do: [:mm | (mm respondsTo: #lookTranslucent) ifTrue: [mm lookTranslucent] ifFalse: [mm color: color]]. ! ! !SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/19/2001 19:09'! stdBorderColor "put choices of how to do the border here" ^ self valueOfProperty: #deselectedBorderColor ifAbsent: [Color transparent]! ! !SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/19/2001 19:50'! unhighlight self setDeselectedColor. false ifTrue: [ self currentSelectionDo: [:innerMorph :mouseDownLoc :outerMorph | self color: ( false "(self == outerMorph or: [owner notNil and: [owner isSyntaxMorph not]])" ifTrue: [self valueOfProperty: #deselectedBorderColor ifAbsent: [#raised]] ifFalse: [self color: Color transparent] ) ]]. ! ! !SyntaxMorph methodsFor: 'selection' stamp: 'tk 7/19/2001 17:52'! setDeselectedColor "The normal color of the tile, stored with the tile" | deselectedColor deselectedBorderColor | deselectedColor _ self valueOfProperty: #deselectedColor ifAbsent: [nil]. deselectedBorderColor _ self valueOfProperty: #deselectedBorderColor ifAbsent: [nil]. deselectedColor ifNotNil: [ deselectedColor _ self scaleColorByUserPref: deselectedColor]. deselectedBorderColor ifNotNil: [ deselectedBorderColor _ self scaleColorByUserPref: deselectedBorderColor]. self color: (deselectedColor ifNil: [Color transparent]); borderColor: (deselectedBorderColor ifNil: [Color transparent])! ! !SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'tk 7/20/2001 17:44'! trackDropZones | hand i localPt insertion insHt ii prevBot nxtHt d c1 c2 ht2 spacer1 spacer2 wid ht1 | hand _ self primaryHand. (hand lastEvent redButtonPressed & hand hasSubmorphs and: [(self hasOwner: hand) not]) ifFalse: [^ self]. insertion _ hand firstSubmorph renderedMorph. insertion isSyntaxMorph ifFalse: [^ self]. insertion isNoun ifFalse: [^ self]. localPt _ self globalPointToLocal: hand position. insHt _ insertion height. "**just use standard line height here" self removeDropZones. "Maybe first check if in right place, then just tweak heights." i _ (ii _ self indexOfMorphAbove: localPt) min: submorphs size-1. prevBot _ i <= 0 ifTrue: [(self innerBounds) top] ifFalse: [(self submorphs at: i) bottom]. nxtHt _ (submorphs isEmpty ifTrue: [insertion] ifFalse: [self submorphs at: i+1]) height. d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"] ifFalse: [0 max: (localPt y - prevBot min: nxtHt)]. "Top and bottom spacer heights cause continuous motion..." c1 _ Color transparent. c2 _ Color transparent. ht2 _ d*insHt//nxtHt. ht1 _ insHt - ht2. wid _ self width - borderWidth - borderWidth "100 min: owner width - 10". (spacer1 _ BorderedMorph newBounds: (0@0 extent: wid@ht1) color: (ht1 > (insHt//2) ifTrue: [c1] ifFalse: [c2])) borderWidth: 1; borderColor: spacer1 color. self privateAddMorph: spacer1 atIndex: (i+1 max: 1). (spacer2 _ BorderedMorph newBounds: (0@0 extent: wid@ht2) color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2])) borderWidth: 1; borderColor: spacer2 color. spacer1 setProperty: #dropZone toValue: true. spacer2 setProperty: #dropZone toValue: true. self privateAddMorph: spacer2 atIndex: (i+3 min: submorphs size+1). self fullBounds. "Force layout prior to testing for cursor containment" "Maintain the drop target highlight -- highlight spacer if hand is in it." {spacer1. spacer2} do: [:spacer | (spacer containsPoint: localPt) ifTrue: [spacer color: self dropColor. "Ignore border color. Maybe do it later. self borderColor = self dropColor ifTrue: [self borderColor: self stdBorderColor]"]]. "If no submorph (incl spacers) highlighted, then re-highlight the block." "Ignore border color. Maybe do it later. ((self wantsDroppedMorph: insertion event: hand lastEvent) and: [(self submorphs anySatisfy: [:m | m containsPoint: localPt]) not]) ifTrue: [self borderColor: self dropColor]. " ! ! !SyntaxMorph methodsFor: 'menus' stamp: 'tk 7/18/2001 16:34'! finalAppearanceTweaks | deletes | SizeScaleFactor ifNil: [SizeScaleFactor _ 0.15]. SizeScaleFactor _ 0.0. "disable this feature. Default was for giant tiles" self usingClassicTiles ifTrue: [ self allMorphsDo: [:each | (each isKindOf: SyntaxMorph) ifTrue: [each lookClassic] ]. ^self ]. deletes _ OrderedCollection new. self allMorphsDo: [ :each | (each respondsTo: #setDeselectedColor) ifTrue: [each setDeselectedColor]. "(each hasProperty: #variableInsetSize) ifTrue: [ each layoutInset: ((each valueOfProperty: #variableInsetSize) * SizeScaleFactor) rounded. ]." (each isKindOf: SyntaxMorph) ifTrue: [ each layoutInset: (6 * SizeScaleFactor) rounded. ]. ]. deletes do: [ :each | each delete]. ! ! !SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/18/2001 16:33'! addTemporaryControls | row stdSize | stdSize _ 8@8. row _ AlignmentMorph newRow color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self addMorph: row. { Morph new extent: stdSize; setBalloonText: 'Change the contrast'; on: #mouseUp send: #controlContrast2: to: self; on: #mouseMove send: #controlContrast2: to: self; on: #mouseDown send: #controlContrast2: to: self. "Removed because it's default is giant tiles, which no one wants. --tk Morph new extent: stdSize; color: Color green; setBalloonText: 'Change basic spacing'; on: #mouseUp send: #controlSpacing2: to: self; on: #mouseMove send: #controlSpacing2: to: self; on: #mouseDown send: #controlSpacing2: to: self. " Morph new extent: stdSize; color: Color red; setBalloonText: 'Change basic style'; on: #mouseUp send: #changeBasicStyle to: self. } do: [ :each | row addMorphBack: each. row addMorphBack: (self transparentSpacerOfSize: stdSize). ]. ! ! !SyntaxMorph methodsFor: 'formatting options' stamp: 'tk 7/18/2001 16:00'! usingClassicTiles ^ Preferences uniTilesClassic! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 7/19/2001 20:06'! translateColor: aColorOrSymbol aColorOrSymbol isColor ifTrue: [^ aColorOrSymbol]. aColorOrSymbol == #comment ifTrue: [^ Color blue lighter]. aColorOrSymbol == #block ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903]. aColorOrSymbol == #method ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903]. aColorOrSymbol == #text ifTrue: [^ Color r: 0.9 g: 0.9 b: 0.9]. self noTileColor ifTrue: [^ Color r: 1.0 g: 0.839 b: 0.613]. "override" aColorOrSymbol == #assignment ifTrue: [^ Color paleGreen]. aColorOrSymbol == #keyword1 ifTrue: [^ Color paleBuff]. "binary" aColorOrSymbol == #keyword2 ifTrue: [^ Color paleBuff lighter]. "multipart" aColorOrSymbol == #cascade ifTrue: [^ Color paleYellow darker]. "has receiver" aColorOrSymbol == #cascade2 ifTrue: [^ Color paleOrange]. "one send in the cascade" aColorOrSymbol == #literal ifTrue: [^ Color paleMagenta]. aColorOrSymbol == #message ifTrue: [^ Color paleYellow]. aColorOrSymbol == #method ifTrue: [^ Color white]. aColorOrSymbol == #error ifTrue: [^ Color red]. aColorOrSymbol == #return ifTrue: [^ Color lightGray]. aColorOrSymbol == #variable ifTrue: [^ Color paleTan]. aColorOrSymbol == #brace ifTrue: [^ Color paleOrange]. aColorOrSymbol == #tempVariable ifTrue: [^ Color paleYellow mixed: 0.75 with: Color paleGreen "Color yellow lighter lighter"]. aColorOrSymbol == #blockarg2 ifTrue: [ ^ Color paleYellow mixed: 0.75 with: Color paleGreen]. "arg itself" aColorOrSymbol == #blockarg1 ifTrue: [^ Color paleRed]. "container" "yellow mixed: 0.5 with: Color white" ^ Color tan "has to be something!!"! ! !TheWorldMenu methodsFor: 'action' stamp: 'tk 7/18/2001 16:06'! uniTilesClassicString ^ (myProject parameterAt: #uniTilesClassic ifAbsent: [false]) ifTrue: ['classic tiles'] ifFalse: ['classic tiles']! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'tk 7/19/2001 19:28'! lookTranslucent "keep the text the same color (black)"! ! TheWorldMenu removeSelector: #largeTilesString! SyntaxMorph removeSelector: #colorShowing! SyntaxMorph removeSelector: #lookOpaque! Preferences class removeSelector: #largeTiles! "Postscript: Create a new preference, uniTilesClassic, and remove largeTiles. " Preferences addPreference: #uniTilesClassic categories: #(scripting) default: true balloonHelp: 'Governs whether universal tiles should appear and act like classic tiles when scripting in this project.' projectLocal: true changeInformee: nil changeSelector: nil. "copy values over" Project allInstancesDo: [:proj | (proj projectPreferenceAt: #largeTiles) ifFalse: [ proj projectPreferenceFlagDictionary at: #uniTilesClassic put: false]]. "delete old" Preferences expungePreferenceNamed: #largeTiles. "set notification" Preferences setNotificationParametersForStandardPreferences.!