neil@comp.lancs.ac.uk (Neil Haddley) (02/09/88)
Dear All, It seems rather odd posting code on the net . Especially stuff which is not actually a finished appliction as such . But I think it might be interesting , if not useful, for a few of yourselves . If I don't get any response, by mail or whatever, I promise I'll not waste any more net resources again . Still that said here goes : The following code is part of a system being developed in a Pro- totype manner at Lancaster, which aims to support the design pro- cess, and so aid software reuse . Papers describing the project will shortly be avaliable on request . The interface for the designer's notepad is being developed in Smalltalk, for obvious reasons, and will then be re-implemented in 'C', to tie up with the rest of the system . It's still very early days interface-wise, so the code given below will almost all be thrown away, but it may help anyone just starting in Smalltalk to get going . (See Editor/Editor/Author/author) . The code does not alter any Standard System code, and should create no loading problems, (I've even changed 'Model's to 'Ob- ject') . Lastly any comments are welcome, but please remember I've not been using the system long so go easy . Neil Haddley (9th Febuary 1988) ------------------------------Cut Here------------------------------ Object subclass: #SymbolGenerator instanceVariableNames: 'baseString counter ' classVariableNames: '' poolDictionaries: '' category: 'Useful'! !SymbolGenerator methodsFor: 'accessing'! next | temp | temp _ (baseString , (counter storeStringRadix: 10)) asSymbol. counter _ counter + 1. ^temp! ! !SymbolGenerator methodsFor: 'private'! baseString: aString counter _ 1. baseString _ aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SymbolGenerator class instanceVariableNames: ''! !SymbolGenerator class methodsFor: 'instance creation'! baseString: aString ^super new baseString: aString! !Line subclass: #DirectedArc instanceVariableNames: 'type arrowHeadLength ' classVariableNames: '' poolDictionaries: '' category: 'Directed-Arc'! !DirectedArc methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger mask: aForm "Draws a directed arc, made up of three lines ." | start finish arrowHeadPoint angle point grad xDis yDis pos | collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points']. start _ self beginPoint. finish _ self endPoint. type = #centered ifTrue: [arrowHeadPoint _ start + (finish - start / 2)] ifFalse: [arrowHeadPoint _ finish]. aDisplayMedium drawLine: self form from: start + aPoint to: finish + aPoint clippingBox: clipRect rule: anInteger mask: aForm. angle _ 2.75. point _ arrowHeadPoint - start. point x = 0 ifTrue: [grad _ 0] ifFalse: [grad _ point y / point x]. xDis _ arrowHeadLength * (angle - grad arcTan) cos. yDis _ arrowHeadLength * (angle - grad arcTan) sin. point x > 0 ifTrue: [pos _ point x + xDis @ (point y - yDis)] ifFalse: [pos _ point x - xDis @ (point y + yDis)]. aDisplayMedium drawLine: self form from: arrowHeadPoint + aPoint to: start + aPoint + pos clippingBox: clipRect rule: anInteger mask: aForm. xDis _ arrowHeadLength * (angle + grad arcTan) cos. yDis _ arrowHeadLength * (angle + grad arcTan) sin. point x > 0 ifTrue: [pos _ point x + xDis @ (point y + yDis)] ifFalse: [pos _ point x - xDis @ (point y - yDis)]. aDisplayMedium drawLine: self form from: arrowHeadPoint + aPoint to: start + aPoint + pos clippingBox: clipRect rule: anInteger mask: aForm! ! !DirectedArc methodsFor: 'private'! initialize self type: #normal. self arrowHeadLength: 10! ! !DirectedArc methodsFor: 'accessing'! arrowHeadLength: aNumber arrowHeadLength _ aNumber! type: aType type _ aType! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DirectedArc class instanceVariableNames: ''! !DirectedArc class methodsFor: 'examples'! example "DirectedArc example" | aForm anArc | aForm _ Form new extent: 2 @ 2. aForm black. anArc _ DirectedArc new. "anArc type: #centered." anArc form: aForm. anArc beginPoint: Sensor waitButton. Sensor waitNoButton. aForm displayOn: Display at: anArc beginPoint. anArc endPoint: Sensor waitButton. anArc displayOn: Display! ! !DirectedArc class methodsFor: 'instance creation'! new ^super new initialize! !View subclass: #WorkspaceView instanceVariableNames: 'points ' classVariableNames: '' poolDictionaries: '' category: 'Editor'! !WorkspaceView methodsFor: 'displaying'! displayView | temp | temp _ model elementNames. temp do: [:key | self singleElementDisplay: key]. temp _ model linkNames. temp do: [:key | self singleLinkDisplay: key].! getArrowForForm: aForm at: aPoint toForm: anotherForm at: anotherPoint | startFormExtent endFormExtent temp anArrow startPoint endPoint | startFormExtent _ aForm extent. startPoint _ self displayTransform: aPoint. endFormExtent _ anotherForm extent. endPoint _ self displayTransform: anotherPoint. startPoint x < (endPoint x + (endFormExtent x / 2)) ifTrue: [startPoint x + (startFormExtent x / 2) < endPoint x ifTrue: [startPoint x: startPoint x + startFormExtent x]] ifFalse: [endPoint x < (startPoint x + (startFormExtent x / 2)) ifTrue: [endPoint x: endPoint x + endFormExtent x]]. startPoint y + (startFormExtent y / 2) > (endPoint y + (endFormExtent y / 2)) ifTrue: [endPoint y: endPoint y + endFormExtent y] ifFalse: [startPoint y: startPoint y + startFormExtent y]. anArrow _ self getArrowFromPoint: startPoint to: endPoint. ^anArrow! getArrowForForm: aForm at: aPoint toPoint: anotherPoint | startFormExtent startPoint endPoint temp anArrow | startFormExtent _ aForm extent. startPoint _ self displayTransform: aPoint. endPoint _ self displayTransform: anotherPoint. startPoint x < endPoint x ifTrue: [startPoint x + (startFormExtent x / 2) < endPoint x ifTrue: [startPoint x: startPoint x + startFormExtent x]]. startPoint y + (startFormExtent y / 2) > endPoint y ifFalse: [startPoint y: startPoint y + startFormExtent y]. anArrow _ self getArrowFromPoint: startPoint to: endPoint. ^anArrow! getArrowFromPoint: aPoint to: anotherPoint | temp anArrow | temp _ Form new extent: 3 @ 3. temp darkGray. anArrow _ DirectedArc new. "anArrow type: #centered." anArrow form: temp. anArrow beginPoint: aPoint. anArrow endPoint: anotherPoint. ^anArrow! singleElementDisplay: aSymbol | element form pos | element _model element: aSymbol. form _ element form. pos _ model pointFor: aSymbol. form displayOn: Display at: (self displayTransform: pos) clippingBox: (self displayTransform: self boundingBox) rule: Form over mask: Form black! singleLinkDisplay: aSymbol | link startElementName endElementName arrow | link _ model link: aSymbol. startElementName _ link startElement. endElementName _ link endElement. arrow _ self getArrowForForm: (model element: startElementName) form at: (model pointFor: startElementName) toForm: (model element: endElementName) form at: (model pointFor: endElementName). arrow displayOn: Display! update: aParameter aParameter = nil ifTrue: [self display] ifFalse: [('Element*' match: aParameter asString) ifTrue: [self singleElementDisplay: aParameter] ifFalse: [('Link*' match: aParameter asString) ifTrue: [self singleLinkDisplay: aParameter]]]! ! !WorkspaceView methodsFor: 'controller access'! defaultControlerClass ^NoController! ! !WorkspaceView methodsFor: 'model access'! addElement: anElement ^self model addElement: anElement at: (self inverseDisplayTransform: Sensor cursorPoint)! ! Object subclass: #Element instanceVariableNames: 'text form aNote subWorkspace reuseFlag ' classVariableNames: 'FlagForm ' poolDictionaries: '' category: 'Editor'! !Element methodsFor: 'accessing'! clearReuseFlag reuseFlag _ false. self form: text! form ^form! openNote StringHolderView open: aNote label: self text! openSubWorkspace Editor openOnWorkspace: subWorkspace label: text! reuseFlag ^reuseFlag! setReuseFlag reuseFlag _ true. self form: text! text ^text! toggle reuseFlag _ reuseFlag not. self form: text. ^reuseFlag! ! !Element methodsFor: 'private'! form: aString | temp textSize flagSize newSize shape figure tidySize tidyForm | temp _ Text fromString: aString. "temp allBold." temp _ temp asDisplayText textStyle: (TextStyle styleNamed: #default). textSize _ temp extent. reuseFlag ifTrue: [textSize _ temp extent. flagSize _ FlagForm extent. newSize _ textSize. newSize y: newSize y + flagSize y. tidySize _ ((newSize x) - (flagSize x)) @ (flagSize y). tidyForm _ Form extent: tidySize. tidyForm white. shape _ Form extent: newSize. shape black. figure _ shape deepCopy. FlagForm displayOn: figure at: 0 @ 0. tidyForm displayOn: figure at: (flagSize x) @ 0. temp displayOn: figure at: 0 @ flagSize y. form _ OpaqueForm figure: figure shape: shape] ifFalse: [shape _ Form extent: textSize. shape black. figure _ shape deepCopy. temp displayOn: figure at: 0 @ 0. form _ OpaqueForm figure: figure shape: shape]! initialize: aString reuseFlag _ false. self text: aString. aNote _ StringHolder new. subWorkspace _ Workspace new.! text: aString | temp shape figure | text _ aString. self form: aString.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Element class instanceVariableNames: ''! !Element class methodsFor: 'instance creation'! new ^super new initialize: 'Untitled'! text: aString ^super new initialize: aString! ! !Element class methodsFor: 'class initialization'! initialize "Element initialize" FlagForm _ Form extent: 7@8 fromArray: #(65024 43520 54784 43520 54784 43520 54784 65024 ) offset: 0@0.! ! Element initialize! TextView subclass: #TextualView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Editor'! !TextualView methodsFor: 'accept'! accept: sometext from: aController ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextualView class instanceVariableNames: ''! !TextualView class methodsFor: 'instance creation'! on: anObject "Create an instance viewing anObject. See super method in TextView for full explanation." ^super on: anObject aspect: #text change: #newText: menu: #textMenu! ! MouseMenuController subclass: #Editor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Editor'! !Editor methodsFor: 'Author'! author "Please Note that this code is at a very very early stage in its development, and is therefore of little use in itself . It would however have been useful to myself when I first started learning Smalltalk, (not that I could claim to have mastered it yet), and in that spirit I have place it onto UserNet . If anyone would like further details of what we're trying to do here at Lancaster, or has any comments relating to how this code could be improved, please contact me : Neil Haddley Department of Computer Science, University of Lancaster, Lancaster, England . email (neil@uk.ac.lancs.comp) or whatever . Neil (9th Febuary 1988) ."! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Editor class instanceVariableNames: ''! !Editor class methodsFor: 'instance creation'! createOnWorkspace: aWorkspace label: aString | workspaceView workspaceEditor topView textView textEditor | workspaceView _ WorkspaceView new model: aWorkspace. workspaceView window: (0@0 extent: 100@100). workspaceView insideColor: Form white. workspaceView borderWidth: 2. workspaceEditor _ WorkspaceController new. workspaceView controller: workspaceEditor. textView _ TextualView on: aWorkspace . textView borderWidth: 2. "textView _ TextualView new model: aWorkspace. textView window: (0@0 extent: 100@100). textView insideColor: Form white. textView borderWidth: 2. textEditor _ NoController new. textView controller: textEditor." topView _ StandardSystemView new. topView window: (0@0 extent: 100@100). topView insideColor: Form darkGray. topView model: aWorkspace. topView addSubView: workspaceView viewport: (5@5 extent: 90@70). topView addSubView: textView viewport: (5@75 extent: 90@20). topView label: aString. topView borderWidth: 2. topView minimumSize: 200@200. ^topView! open "Editor open" | topView | topView _ self createOnWorkspace: Workspace new label: 'Designer''s Notepad'. topView controller open! openOnWorkspace: aWorkspace | topView | topView _ self createOnWorkspace: aWorkspace label: 'Designer''s Notepad'. topView controller open! openOnWorkspace: aWorkspace label: aString "Create and schedule an instance of me on the workspace aWorkspace." | topView | topView _ self createOnWorkspace: aWorkspace label: aString. topView controller open! ! Object variableSubclass: #Workspace instanceVariableNames: 'elementSymbolGenerator linkSymbolGenerator elements links points text ' classVariableNames: '' poolDictionaries: '' category: 'Editor'! !Workspace methodsFor: 'accessing'! addElement: anElement at: aPoint | temp | temp _ elementSymbolGenerator next. elements at: temp put: anElement. points at: temp put: aPoint. self changed: temp. self changed: #text! addElementLink: aLink | temp | temp _ linkSymbolGenerator next. links at: temp put: aLink. self changed: temp. self changed: #text! element: elementName ^elements at: elementName! elementLabeled: aString | temp result element | temp _ self elementNames. result _ nil. temp do: [:key | element _ (elements at: key). (aString = element text) ifTrue: [result _ element]]. ^result! elementNames ^elements keys! form: elementName ^(elements at: elementName) form! link: linkName ^links at: linkName! linkLabeled: aString | temp result link | temp _ self linkNames. result _ nil. temp do: [:key | link _ (links at: key). (aString = link text) ifTrue: [result _ link]]. ^result! linkNames ^links keys! nearestElementTo: aPoint | maximumDistance nearest dist temp pos newDist | maximumDistance _ 1000. nearest _ nil. dist _ maximumDistance. temp _ self elementNames. temp do: [:key | pos _ (self pointFor: key). newDist _ (pos dist: aPoint) . newDist < dist ifTrue: [dist_ newDist. nearest _ key]]. dist = maximumDistance ifTrue: [self error: 'point selected is too far away from any node'] ifFalse: [^nearest]! pointFor: aSymbol ^points at: aSymbol ifAbsent: [points at: aSymbol put: 50@50. ^50@50]! setPointFor: aSymbol to: aPoint points at: aSymbol put: aPoint. self changed! toggleReuseFlag: elementName | element | element _ self element: elementName. element toggle. self changed! ! !Workspace methodsFor: 'private'! initialize elementSymbolGenerator _ SymbolGenerator baseString: 'Element'. linkSymbolGenerator _ SymbolGenerator baseString: 'Link'. elements _ Dictionary new. links _ Dictionary new. points _ Dictionary new. text _ Text fromString: ''.! ! !Workspace methodsFor: 'text'! addIfNoElementLabeled: aString | present | present _ false. self elementNames do: [:key | ((self element: key) label = aString) ifTrue: [present _ true]]. present ifFalse: [self addElement: (Element text: aString) at: 50@50 ]! newText: someText | pointer nextCR nextName | self error: 'here I am'. text _ someText. pointer _ 0. [nextCR _ text findString: ('\' withCRs) startingAt: pointer. nextName _ text copyFrom: pointer to: (nextCR -1). self addIfNoElementLabeled: nextName. pointer _ nextCR + 1] whileTrue: [(pointer < text size)].! reCreateText | string temp link | string _ '{ '. temp _ self elementNames. temp do: [:key | string _ string , (self element: key) text storeString , ' ']. string _ string , '}\{ ' withCRs. temp _ self linkNames. temp do: [:key | link _ self link: key. string _ string , '( ' , link text storeString , ' ' , (self element: link startElement) text storeString , ' ' , (self element: link endElement) text storeString , ' ) ']. string _ string , '}'. text _ Text fromString: string! text self reCreateText. ^text! textMenu ^ActionMenu labels: 'copy\cut\paste\accept\cancel\format' withCRs lines: #(3 5 ) selectors: #(copySelection cut paste accept cancel format )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Workspace class instanceVariableNames: ''! !Workspace class methodsFor: 'instance creation'! new ^super new initialize! ! MouseMenuController subclass: #WorkspaceController instanceVariableNames: '' classVariableNames: 'YellowButtonMenu YellowButtonMessages ' poolDictionaries: '' category: 'Editor'! !WorkspaceController methodsFor: 'initialize-release'! initialize super initialize. self yellowButtonMenu: YellowButtonMenu yellowButtonMessages: YellowButtonMessages! ! !WorkspaceController methodsFor: 'control defaults'! isControlActive ^(view containsPoint: sensor cursorPoint) & sensor blueButtonPressed not! ! !WorkspaceController methodsFor: 'menu messages'! addLink | temp startElementName startElementForm startElementPos endElementName link | Sensor waitNoButton. Cursor crossHair showWhile: [Sensor waitButton]. temp _ Sensor cursorPoint. startElementName _ model nearestElementTo: (view inverseDisplayTransform: temp). startElementForm _ model form: startElementName. startElementPos _ model pointFor: startElementName. Cursor blank showWhile: [ temp _ self rubberBandForm: startElementForm at: startElementPos until: [sensor noButtonPressed]]. endElementName _ model nearestElementTo: (view inverseDisplayTransform: temp). endElementName = startElementName ifFalse: [link _ ElementLink startElement: startElementName endElement: endElementName. model addElementLink: link]! addText | text element form | text _ FillInTheBlank request: 'Please Enter Label' initialAnswer: 'Untitled'. text = '' ifFalse: [element _ Element text: text. form _ element form. Cursor blank showWhile: [form follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]. view addElement: element]! inspectNote | temp element elementName | Sensor waitNoButton. Cursor crossHair showWhile: [Sensor waitButton]. temp _ Sensor cursorPoint. elementName _ model nearestElementTo: (view inverseDisplayTransform: temp). element _ (model element: elementName). element openNote! inspectSubWorkspace | temp element elementName | Sensor waitNoButton. Cursor crossHair showWhile: [Sensor waitButton]. temp _ Sensor cursorPoint. elementName _ model nearestElementTo: (view inverseDisplayTransform: temp). element _ (model element: elementName). element openSubWorkspace! moveText | temp elementName elementForm elementPos form | Sensor waitNoButton. Cursor crossHair showWhile: [Sensor waitButton]. temp _ Sensor cursorPoint. elementName _ model nearestElementTo: (view inverseDisplayTransform: temp). elementForm _ (model element: elementName) form. elementPos _ model pointFor: elementName. form _ Form extent: elementForm extent. form white. form displayOn: Display at: (self view displayTransform: elementPos) clippingBox: (self view displayTransform: self view boundingBox) rule: Form over mask: Form black. Sensor cursorPoint: (self view displayTransform: elementPos). Cursor hand showWhile: [elementForm follow: [Sensor cursorPoint] while: [Sensor anyButtonPressed]]. model setPointFor: elementName to: (view inverseDisplayTransform: Sensor cursorPoint).! toggleReuseFlag | temp element elementForm elementPos form elementName | Sensor waitNoButton. Cursor crossHair showWhile: [Sensor waitButton]. temp _ Sensor cursorPoint. elementName _ model nearestElementTo: (view inverseDisplayTransform: temp). model toggleReuseFlag: elementName! ! !WorkspaceController methodsFor: 'private'! rubberBandForm: startElementForm at: startElementPos until: aBlock | arrow endPoint oldEndPoint | arrow _ view getArrowForForm: startElementForm at: startElementPos toPoint: startElementPos. arrow displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. oldEndPoint _ startElementPos. endPoint _ oldEndPoint. [aBlock value] whileFalse: [(endPoint _ (self view inverseDisplayTransform: (Sensor cursorPoint))) = oldEndPoint ifFalse: [oldEndPoint _ endPoint. arrow displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. arrow _ view getArrowForForm: startElementForm at: startElementPos toPoint: endPoint. arrow displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil]]. arrow displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse mask: nil. ^self view displayTransform: endPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorkspaceController class instanceVariableNames: ''! !WorkspaceController class methodsFor: 'class initialization'! initialize "WorkspaceController initialize" YellowButtonMenu _ PopUpMenu labels: 'add text\add link\move text\inspect note\inspect subWorkspace\toggle reuseFlag' withCRs lines: #(2 3 5). YellowButtonMessages _ #(addText addLink moveText inspectNote inspectSubWorkspace toggleReuseFlag)! ! WorkspaceController initialize! Object subclass: #ElementLink instanceVariableNames: 'startElement endElement text ' classVariableNames: '' poolDictionaries: '' category: 'Editor'! !ElementLink methodsFor: 'accessing'! endElement ^endElement! startElement ^startElement! text ^text! ! !ElementLink methodsFor: 'private'! startElement: aSymbol endElement: anotherSymbol label: aLabel startElement _ aSymbol. endElement _ anotherSymbol. text _ aLabel.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ElementLink class instanceVariableNames: ''! !ElementLink class methodsFor: 'instance creation'! startElement: aSymbol endElement: anotherSymbol ^super new startElement: aSymbol endElement: anotherSymbol label: 'is-related-to'! startElement: aSymbol endElement: anotherSymbol label: aLabel ^super new startElement: aSymbol endElement: anotherSymbol label: aLabel! !-- EMAIL: neil@comp.lancs.ac.uk | Post: University of Lancaster, UUCP: ...!mcvax!ukc!dcl-cs!neil | Department of Computing, | Bailrigg, Lancaster, UK.