\ Conceptual Entity Relationship Diagrammer \ Used to help ones thinking about a subject \ Larry Daniel \ larry@larrybrucedaniel.com \ find the latest version at http://www.larrybrucedaniel.com/forth \ October 9, 2005 anew -workfile \ \ L i n k e d L i s t \ variable listHead 0 listHead ! variable listHeadRel 0 listHeadRel ! : getFirstNode ( -- nodea ) listHead @ ; : getNextNode ( nodea -- nodea ) dup 1 > if @ then ; : getFirstRel ( -- nodea ) listHeadRel @ ; : getNextRel ( nodea -- nodea ) dup 1 > if @ then ; : getFirstSeg { rela -- nodea } rela 6 cells + @ ; \ \ Insert Entity Node at head \ : addNode { nodea -- } listHead @ nodea ! \ Link to previous head nodea listHead ! \ Link the new head ; \ \ Insert Relationship Node at head \ : addRelNode { nodea -- } listHeadRel @ nodea ! \ Link to previous head nodea listHeadRel ! \ Link the new head ; \ \ Insert LIne Segement into Relationship \ : addSegmentNode { sega rela } rela 6 cells + @ sega ! \ Link to previous head sega rela 6 cells + ! \ Link the new head ; \ \ r e m o v e N o d e \ variable lastone : removeNode { nodea } getFirstNode ?dup 0= if exit then dup nodea = if drop nodea @ listHead ! exit then dup lastone ! begin >r r@ nodea = if nodea 3 cells + @ free nodea @ lastone @ ! exit then r@ lastone ! r> getNextNode ?dup 0= until ; \ r e m o v e R e l \ : removeRel { nodea } getFirstRel ?dup 0= if exit then dup nodea = if drop nodea @ listHeadRel ! exit then dup lastone ! begin >r r@ nodea = if nodea 3 cells + @ free \ Free the name memory nodea @ lastone @ ! exit then r@ lastone ! r> getNextRel ?dup 0= until ; \ \ C l e a r N o d e s \ : clearNodes GetFirstNode begin dup removeNode GetNextNode ?dup 0= until 0 listHead ! ; \ \ c l e a r R e l s \ : clearRels GetFirstRel begin dup removeRel GetNextRel ?dup 0= until 0 listHeadRel ! ; \ \ Current Entity \ variable currentEntity variable currentRel variable currentSegment \ \ m a k e R e l a t i o n s h i p \ : makeRelationship { from tto addr len -- address } here 0 , \ 0 Linked List Pointer from , \ 1 From Entity ID tto , \ 2 To Entity ID addr , \ 3 Addr of Name len , \ 4 Len of Name NextID , \ 5 Unique Identification 0 , \ 6 Line Segment List Head ; \ \ m a k e R e l a t i o n s h i p I d \ : makeRelationshipId { from tto id addr len -- address } here 0 , \ Linked List Pointer from , tto , addr , len , id , 0 , ; \ \ m a k e S e g m e n t \ : makeSegment { x y -- address } here 0 , \ Next Segment x , y , ; \ \ m a k e E n t i t y \ : makeEntity { x y addr len -- address } here 0 , \ Linked List Pointer x , \ X position y , \ Y position addr , \ Address of name len , \ length of name NextID , ; \ \ m a k e E n t i t y I d \ : makeEntityId { x y id addr len -- address } here 0 , \ Linked List Pointer x , \ X position y , \ Y position addr , \ Address of name len , \ length of name id , ; \ \ E n t i t y @ \ : Entity@ { addr -- name len x y id } addr 3 cells + @ addr 4 cells + @ addr 1 cells + @ addr 2 cells + @ addr 5 cells + @ ; : getCurrentName ( -- name ) currentEntity @ ?dup 0= if exit then 3 cells + @ ; : getCurrentLen ( -- len ) currentEntity @ ?dup 0= if exit then 4 cells + @ ; : setCurrentLen ( len -- ) currentEntity @ ?dup 0= if exit then 4 cells + ! ; : getCurrentX ( -- x ) currentEntity @ ?dup 0= if exit then 1 cells + @ ; : getCurrentY ( -- y ) currentEntity @ ?dup 0= if exit then 2 cells + @ ; : .Entity ( addr -- ) Entity@ . . . type ; : SetEntityPos { addr x y } x addr 1 cells + ! y addr 2 cells + ! ; : getId ( addr --- id ) 5 cells + @ ; \ \ g e t E n t i t y B y I d \ : getEntityById { id -- addr } GetFirstNode begin dup getId id = if exit then GetNextNode ?dup 0= until ; \ \ g e t S e g C o o r d i n a t e s \ : getSegCoordinates { seg -- x y } seg 0= if 0 0 exit then seg 1 cells + @ seg 2 cells + @ ; \ \ L i s t E n t i t i e s \ : ListEntities cr GetFirstNode begin dup .Entity cr GetNextNode ?dup 0= until ; : .relationship { addr } addr 1 cells + @ . addr 2 cells + @ . addr 3 cells + @ addr 4 cells + @ type addr 5 cells + @ space . ; \ \ L i s t R e l a t i o n s h i p s \ : ListRelationships cr GetFirstRel begin dup .relationship cr GetNextRel ?dup 0= until ; \ \ File I/O \ 0 value fileHandle : write-number s>d <# # # # # #> fileHandle write-file drop ; : write-delimiter S" ," fileHandle write-file drop ; : write-string fileHandle write-file drop ; : write-eol S" " fileHandle write-line drop ; : write-end-of-model S" MODEL END" fileHandle write-line drop ; defer getFileName variable fileName variable fileNameCount : write-era getFileName 2dup fileNameCount ! fileName ! dup 0= if 2drop exit then 2dup w/o open-file if drop w/o create-file if S" File Open Error" errorbox exit then to fileHandle else to fileHandle 2drop then GetFirstNode begin S" E " write-string dup 1 cells + @ write-number write-delimiter dup 2 cells + @ write-number write-delimiter dup 3 cells + @ >r dup 4 cells + @ r> swap write-string write-delimiter dup 5 cells + @ write-number write-eol GetNextNode dup 0= until drop GetFirstRel ?dup 0<> if begin S" R " write-string dup 1 cells + @ write-number write-delimiter dup 2 cells + @ write-number write-delimiter dup 3 cells + @ >r dup 4 cells + @ r> swap write-string write-delimiter dup 5 cells + @ write-number write-eol dup getFirstSeg ?dup 0<> if begin S" S " write-string dup getSegCoordinates swap write-number write-delimiter write-number write-eol getNextNode ?dup 0= until then GetNextRel dup 0= until drop then write-end-of-model fileHandle close-file drop ; \ \ Read and Parse from File \ defer GetOpenName variable saveaddr variable savelen variable entity_x variable entity_Y variable entity_id variable entity_name 10 allot : parse-line { addr len } addr c@ ascii E = if 0 0 addr 2 + len >number savelen ! saveaddr ! d>s entity_x ! 2drop 0 0 saveaddr @ 1+ savelen @ >number savelen ! saveaddr ! d>s entity_y ! entity_name 10 32 fill 2drop entity_name >r saveaddr @ 1+ begin dup c@ ascii , <> while dup c@ r@ c! 1+ r> 1+ >r repeat r> drop saveaddr ! 0 0 saveaddr @ 1+ savelen @ >number savelen ! saveaddr ! d>s entity_id ! 2drop entity_name 9 malloc dup >r 9 cmove entity_x @ entity_Y @ entity_id @ r> 9 makeEntityId addNode else addr c@ ascii R = if 0 0 addr 2 + len >number savelen ! saveaddr ! d>s entity_x ! 2drop 0 0 saveaddr @ 1+ savelen @ >number savelen ! saveaddr ! d>s entity_y ! entity_name 10 32 fill 2drop entity_name >r saveaddr @ 1+ begin dup c@ ascii , <> while dup c@ r@ c! 1+ r> 1+ >r repeat r> drop saveaddr ! 0 0 saveaddr @ 1+ savelen @ >number savelen ! saveaddr ! d>s entity_id ! 2drop entity_name 9 malloc dup >r 9 cmove entity_x @ entity_Y @ entity_id @ r> 9 makeRelationshipId dup addRelNode currentRel ! else addr c@ ascii S = if 0 0 addr 2 + len >number savelen ! saveaddr ! d>s entity_x ! 2drop 0 0 saveaddr @ 1+ savelen @ >number savelen ! saveaddr ! d>s entity_y ! entity_x @ entity_y @ makeSegment currentRel @ addSegmentNode then then then ; : read-era GetOpenName ?dup 0= if exit then r/o open-file if exit then to fileHandle ClearNodes ClearRels begin pad 128 fileHandle read-line drop drop dup 0> while pad 9 S" MODEL END" compare 0= if filehandle close-file exit then pad swap parse-line repeat fileHandle close-file drop ; \ \ w i t h i n E n t i t y \ : withinEntity { addr x y } addr Entity@ drop 2swap 2drop dup y < swap 60 + y > and swap dup x < swap 84 + x > and and ; \ \ w i t h i n T e x t \ : withinText { addr x y } addr Entity@ drop 2swap 2drop dup y < swap 29 + y > and swap dup x < swap 75 + x > and and ; \ \ i n E n t i t y \ : inEntity { x y -- f } GetFirstNode begin dup x y withinEntity if currentEntity ! true then GetNextNode dup 1 < until ; \ \ i n T e x t \ : inText { x y -- f } listHead @ 0= if exit then GetFirstNode begin dup x y withinText if currentEntity ! true then GetNextNode dup 1 < until ; \ \ Defer mouse words \ defer _clicker defer _doubleclicker defer _unclicker defer _tracker \ \ E d i t i n g \ 0 value editing? 0 value cursor 10 value maxlen 0 value selectionStart 0 value selectionEnd false value ctrl_key? 0 value selected1 0 value selected2 : extendSelection ( x y -- ) drop getCurrentX - 8 / to selectionEnd ; : cursorback cursor 1- dup -1 > if to cursor then ; : cursorforward cursor 1+ dup maxlen < if to cursor then ; : delete selectionStart selectionEnd = if getCurrentLen cursor > if getCurrentName cursor 1+ + dup 1- getCurrentLen cursor - cmove getCurrentLen 1- setCurrentLen then else selectionStart selectionEnd > if getCurrentName selectionStart + getCurrentName selectionEnd + selectionStart selectionEnd - dup >r cmove selectionEnd to cursor else getCurrentName selectionStart + getCurrentName selectionEnd + selectionEnd selectionStart - dup >r cmove> selectionStart to cursor then getCurrentLen r> - setCurrentLen cursor to selectionStart cursor to selectionEnd then ; : backspace cursorback delete ; : character selectionStart selectionEnd = if cursor maxlen < if getCurrentName cursor + c! cursorforward cursor getCurrentLen > if cursor setCurrentLen then then else delete recurse then ; \ \ C r e a t e E n t i t y \ : CreateEntity 50 50 9 malloc 0 makeEntity addNode ; \ \ C r e a t e R e l a t i o n s h i p \ : CreateRelationship selected1 selected2 and if selected1 selected2 9 malloc 0 makeRelationship addRelNode then ; \ \ R e m o v e R e l s W i t h I d \ : RemoveRelsWithId { id } GetFirstRel dup 0= if exit then begin >r r@ 1 cells + @ id = r@ 2 cells + @ id = or if r@ removeRel then r> GetNextRel ?dup 0= until ; \ \ D e l e t e R e l \ : DeleteRel { id1 id2 } GetFirstRel ?dup 0= if exit then begin >r r@ 1 cells + @ dup id1 = swap id2 = or r@ 2 cells + @ dup id1 = swap id2 = or and if r@ removeRel then r> GetNextRel ?dup 0= until ; defer deselect \ \ D e l e t e E n t i t y \ : DeleteEntity selected1 0<> if selected1 removeRelsWithId selected1 GetEntityById removeNode deselect then ; \ \ D e l e t e R e l a t i o n s h i p \ : DeleteRelationship selected1 0<> selected2 0<> and if selected1 selected2 DeleteRel deselect then ; \ \ Deferred Functions for Menu \ Defer Repaint Defer CloseWindow Defer PrintDiagram \ \ M e n u \ MENUBAR workmenu POPUP "&File" MENUITEM "&New" ClearRels ClearNodes repaint ; MENUITEM "&Open" read-era repaint ; MENUITEM "&Save" write-era ; MENUITEM "&Print" PrintDiagram ; MENUITEM "E&xit" CloseWindow ; POPUP "&Model" MenuItem "Add &Entity" CreateEntity repaint ; :MenuItem armenu "Add &Relationship" CreateRelationship repaint ; :MenuItem demenu "Delete Entity" DeleteEntity repaint ; :MenuItem drmenu "Delete Relationship" DeleteRelationship repaint ; ENDBAR \ \ D r a w i n g \ Windc DrawDc \ \ S c a l e O p e r a t o r \ 100 value screenDPI ( Adjust this to fit printer paper) screenDPI value DPI : s* DPI screenDPI */ ; \ \ c e n t e r O f E n t i t y \ : centerOfEntity { entity } entity 0= if 0 0 exit then entity 1 cells + @ s* 40 s* + entity 2 cells + @ s* 30 s* + ; \ \ m a t c h S e g m e nt \ : matchSegment { sega x y -- f } sega 0= if false exit then sega 1 cells + @ dup 10 + x > swap 10 - x < and sega 2 cells + @ dup 10 + y > swap 10 - y < and and ; \ \ f i n d S e g m e n t \ : findSegment { rel x y -- f } rel getFirstSeg begin dup x y matchSegment if currentSegment ! true then GetNextNode dup 1 < until ; \ \ w i t h i n R e l \ : withinRel { addr x y -- f } addr getFirstSeg 0= if addr 1 cells + @ getEntityById centerOfEntity addr 2 cells + @ getEntityById centerOfEntity rot + 2/ dup 5 + y > swap 5 - y < and rot rot + 2/ dup 5 + x > swap 5 - x < and and else addr x y findSegment then ; \ \ i n R e l \ : inRel { x y -- f } listHeadRel @ 0= if false exit then GetFirstRel begin dup x y withinRel if currentRel ! true then GetNextNode dup 1 < until ; \ \ s p l i t R e l \ : splitRel { x y -- } currentRel @ ?dup 0= if exit then x y findSegment 0= if x y makeSegment currentRel @ addSegmentNode then ; \ \ m o v e R e l C e n t e r \ : moveRelCenter { x y -- } currentRel @ x y findSegment if currentSegment @ dup 1 cells + x swap ! 2 cells + y swap ! then repaint ; \ \ \ D r a w E n t i t y \ : DrawEntity { name len x y id } black brushcolor: drawdc x s* 2 s* + y s* 2 s* + x s* 86 s* + y s* 62 s* + 20 s* 20 s* roundrect: drawdc white brushcolor: drawdc x s* y s* x s* 84 s* + y s* 60 s* + 20 s* 20 s* roundrect: drawdc x s* y s* 30 s* + moveto: drawdc x s* 84 s* + y s* 30 s* + lineto: drawdc x s* 5 s* + y s* 5 s* + name len textout: drawdc ; \ \ D r a w R e l \ : DrawRel { rel } rel 0<> if rel 1 cells + @ getEntityById centerOfEntity ( 2dup ) moveto: drawdc rel getFirstSeg ?dup 0<> if begin dup getSegCoordinates s* swap s* swap lineto: drawdc getNextNode ?dup 0= until then rel 2 cells + @ getEntityById centerOfEntity ( 2dup ) lineto: drawdc ( rot + 2/ rot rot + 2/ 5 - swap 5 - 2dup ) ( 10 + swap 10 + swap 3 3 roundrect: drawdc ) then ; \ \ O b j e c t W o r k \ :Object Work if dup 1 cells + @ 5 + cursor 8 * + swap 2 cells + @ 5 + gray pencolor: dc 2dup moveto: dc 18 + lineto: dc then ;M :M PushKey: \ dup . dup case 131076 of cursorback endof 131077 of cursorforward endof VK_BACK of backspace endof 131075 of delete endof endcase dup dup 32 >= swap ascii ~ < and if character else drop then Paint: self ;M :M TextEditingChanges: true ;M :M editEntityName: DrawTextCursor: self begin TextEditingChanges: self until ;M :M On_Paint: Gethandle: dc PutHandle: drawdc black pencolor: dc SYSTEM_FIXED_FONT SelectStockObject: dc drop screenDPI to dpi listHead @ 0<> if GetFirstRel begin dup DrawRel: self GetNextRel ?dup 0= until GetFirstNode begin dup dup 0<> if dup getid selected1 = swap dup getid selected2 = rot or if Entity@ DrawHighlightedEntity: self else Entity@ DrawEntity: self then GetNextNode ?dup 0= then until editing? if DrawTextCursor: self DrawSelection: self then then ;M :M WM_LBUTTONDOWN ( h m w l -- res ) set-mousexy _clicker 0 ;M :M WM_LBUTTONUP ( h m w l -- res ) set-mousexy _unclicker 0 ;M :M WM_MOUSEMOVE ( h m w l -- res ) set-mousexy _tracker 0 ;M :M On_Init: On_Init: super workmenu SetMenubar: self deselect ;M :M On_Done: bye On_Done: super ;M ;Object \ \ M e n u F u n c t i o n s \ :noname Paint: Work ; is Repaint :noname close: Work ( bye ) ; is CloseWindow \ \ Dialogs \ :Object myfsd if GetFirstRel begin dup DrawRel GetNextRel ?dup 0= until GetFirstNode begin dup Entity@ DrawEntity GetNextNode ?dup 0= until then print-end ; ' PrintDiagramNow is PrintDiagram \ \ E n t i t y A p p \ : entityapp Start: work ; ' entityapp turnkey entity