(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10)
(FILECREATED "14-Oct-88 12:09:13" {QV}<NOTECARDS>1.3MNEXT>GRAPHERPATCH.;2 22306
previous date%: "10-Oct-88 16:44:36" {QV}<NOTECARDS>1.3MNEXT>GRAPHERPATCH.;1)
(* "
Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT GRAPHERPATCHCOMS)
(RPAQQ GRAPHERPATCHCOMS
(
(* ;;; "RG 1/28/87 From Dave Newman's DVNPATCH003 for NoteCards. Adds MoveRegion and MoveSubtree facilities.")
(* ;;; "pmi 4/8/88: Added change to EDITADDNODE which allows a position to be specified for the node being added.")
[DECLARE%: DONTEVAL@LOAD FIRST (P (NC.LoadFileFromDirectories 'GRAPHER 'LISPUSERSDIRECTORIES]
(FNS EDITMOVEREGION EDITMOVESUBTREE NOT.TRACKCURSOR RECURSIVE.COLLECTDESCENDENTS
MOVEDESCENDENTS COLLECT.CHILD.NODES CREATE.NEW.NODEPOSITION
GETBOXPOSITION.FROMINITIALREGION INIT/NODES/FOR/LAYOUT NODECREATE EDITADDNODE
COLLECTDESCENDENTS)
(DECLARE%: DONTEVAL@LOAD (P (DREMOVE (SASSOC "Move Node" EDITGRAPHMENUCOMMANDS)
EDITGRAPHMENUCOMMANDS)
(ADDTOVAR EDITGRAPHMENUCOMMANDS
(Move% Node 'MOVENODE
"Moves a single node in the graph."
(SUBITEMS (|Move Single Node| 'MOVENODE
"Moves a single node in the graph."
)
(|Move Node and Subtree| (EDITMOVESUBTREE
GRAPHWINDOW)
"Moves a subtree of nodes relative to the movement of their root."
)
(Move% Region (EDITMOVEREGION GRAPHWINDOW
)
"Moves a group of nodes within a specified region to another region."
))))
(SETQ EDITGRAPHMENU NIL)))
(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
GRAPHERPATCH)))
(* ;;;
"RG 1/28/87 From Dave Newman's DVNPATCH003 for NoteCards. Adds MoveRegion and MoveSubtree facilities."
)
(* ;;;
"pmi 4/8/88: Added change to EDITADDNODE which allows a position to be specified for the node being added."
)
(DECLARE%: DONTEVAL@LOAD FIRST
(NC.LoadFileFromDirectories 'GRAPHER 'LISPUSERSDIRECTORIES)
)
(DEFINEQ
(EDITMOVEREGION
(LAMBDA (Window) (* Newman "27-Jan-87 11:08")
(* * This function moves all the nodes within a selected region to another
region of similar shape and size.)
(if (NOT (WINDOWP Window))
then (ERROR Window " not a window.")
else (PROMPTPRINT " Select the region containing the nodes you wish to move.")
(PROG* ((DisplayStream (WINDOWPROP Window 'DSP))
(Region (GETWREGION Window))
(Graph (WINDOWPROP Window 'GRAPH))
(NodeList (for Node in (fetch (GRAPH GRAPHNODES) of Graph)
when (OR (INTERSECTREGIONS Region (NODEREGION Node))
(SUBREGIONP Region (NODEREGION Node))) collect Node)))
(if (NULL Graph)
then (ERROR Window " not a graph window.")
elseif (NULL NodeList)
then (PROMPTPRINT "No nodes in the region selected."))
(for Node in NodeList do (FLIPNODE Node DisplayStream))
(bind OldPos (NewRegionPosition ← (GETBOXPOSITION.FROMINITIALREGION Window Region
DisplayStream)) for SelectedNode
in NodeList eachtime (SETQ OldPos (fetch (GRAPHNODE NODEPOSITION) of
SelectedNode
))
do (MOVENODE SelectedNode OldPos (CREATE.NEW.NODEPOSITION
SelectedNode
(DIFFERENCE (fetch (POSITION XCOORD)
of NewRegionPosition)
(fetch (REGION LEFT) of Region))
(DIFFERENCE (fetch (POSITION YCOORD)
of NewRegionPosition)
(fetch (REGION BOTTOM) of Region)))
Graph DisplayStream)
(EXTENDEXTENT (WFROMDS DisplayStream)
(NODEREGION SelectedNode))
(* extent the graph extent because the node may be outside the old extent.)
(FLIPNODE SelectedNode DisplayStream))))))
(EDITMOVESUBTREE
(LAMBDA (WINDOW) (* Newman "27-Jan-87 11:10")
(* * Code derived from EDITMOVENODE by Richard Burton.
Changes to prompt strings, and changes the to TRACKCURSOR to a call to
NOT.TRACKCURSOR)
(* hilite nodes until the cursor goes down then move it)
(PROG ((DS (WINDOWPROP WINDOW 'DSP))
(REG (WINDOWPROP WINDOW 'REGION))
(GRAPH (WINDOWPROP WINDOW 'GRAPH))
OLDPOS NOW NEAR NODELST)
(COND
(GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH)))
(T (RETURN)))
(printout PROMPTWINDOW T "Move the cursor to the node " "that is the common root of "
"the subtree you want to move " "and press any button.")
(SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS))))
FLIP
(AND NOW (FLIPNODE NOW DS))
(AND NEAR (FLIPNODE NEAR DS))
(SETQ NOW NEAR)
LP (GETMOUSESTATE)
(COND
((LASTMOUSESTATE (NOT UP)) (* button up, process it.)
(AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.)
)
((EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS))))
(GO LP))
(T (GO FLIP)))
(printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position"
"and release the button.")
(NOT.TRACKCURSOR NOW DS GRAPH)
(printout PROMPTWINDOW T "Done."))))
(NOT.TRACKCURSOR
[LAMBDA (Node DisplayStream Graph) (* ; "Edited 3-Aug-88 14:50 by pmi")
(* ;; "Gets an old, and a new region from the user, and uses these to calculate all the new positions for all the children of Node.")
(* ;;
"rht 4/28/87: Changed from APPLY of UNIONREGIONS to for loop doing successive UNIONREGIONS calls.")
(* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.")
(if (NULL Node)
then (PROMPTPRINT "No node selected.")
else (PROG* ((Children (COLLECTDESCENDENTS Node Graph))
(OldRegion (for EachNode in (CONS Node Children) bind (TotalRegion ← (NODEREGION
Node))
do (FLIPNODE EachNode DisplayStream)
(SETQ TotalRegion (UNIONREGIONS TotalRegion (NODEREGION EachNode)
)) finally (RETURN TotalRegion)))
(NewRegionPosition (GETBOXPOSITION.FROMINITIALREGION (WFROMDS DisplayStream)
OldRegion DisplayStream))
(deltaX (DIFFERENCE (fetch (POSITION XCOORD) of NewRegionPosition)
(fetch (REGION LEFT) of OldRegion)))
(deltaY (DIFFERENCE (fetch (POSITION YCOORD) of NewRegionPosition)
(fetch (REGION BOTTOM) of OldRegion)))
(OldPos (fetch (GRAPHNODE NODEPOSITION) of Node))
(NewPos (CREATE.NEW.NODEPOSITION Node deltaX deltaY)))
[if (NOT (EQUAL OldPos NewPos))
then (MOVENODE Node OldPos NewPos Graph DisplayStream)
(EXTENDEXTENT (WFROMDS DisplayStream)
(NODEREGION Node))
(CALL.MOVENODEFN Node OldPos Graph (WFROMDS DisplayStream)
NewPos)
(if Children
then (PROG [(MovedNodes (LIST (fetch (GRAPHNODE NODEID) of Node]
(MOVEDESCENDENTS Graph Node DisplayStream deltaX deltaY]
(for EachNode in (CONS Node Children) do (FLIPNODE EachNode DisplayStream])
(RECURSIVE.COLLECTDESCENDENTS
[LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 16:06 by pmi")
(* ;; "Collect all descendents of Node in Graph.")
(* ;;
"pmi 8/2/88: Changed to break infinite recursion on circular graphs. Now marks nodes as visited.")
(* ;; "pmi 8/5/88: FIxes bug introduced by previous fix.")
(LET (NodeId)
(* ;; "Node's NODEID may be a list if it is a virtual node. ")
(if (LISTP (SETQ NodeId (fetch (GRAPHNODE NODEID) of Node)))
then (SETQ NodeId (CAR NodeId)))
(NC.GraphNodeIDPutProp NodeId 'Visited T)
(for ChildNode in (COLLECT.CHILD.NODES Node Graph) bind ChildNodeID
when [PROGN (SETQ ChildNodeID (fetch (GRAPHNODE NODEID) of ChildNode))
(* ;; "This node has not been visited, and it is not a virtual node.")
(NOT (NC.GraphNodeIDGetProp (if (LISTP ChildNodeID)
then (CAR ChildNodeID)
else ChildNodeID)
'Visited] join (CONS ChildNode (RECURSIVE.COLLECTDESCENDENTS
ChildNode Graph])
(MOVEDESCENDENTS
[LAMBDA (Graph Node DisplayStream deltaX deltaY) (* ; "Edited 3-Aug-88 14:51 by pmi")
(* ;; "Moves Node and all Children of Node by deltaX and deltaY.")
(* ;; "first, finds all descendents of Node. For each of these, create a new position based on the old and the deltas. Then, if the child has not been moved yet, we add it to the list of moved nodes, move the node, and call the MOVENODEFN,")
(* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.")
(bind (MovedNodes ← (LIST Node))
NewPos for Child in (COLLECTDESCENDENTS Node Graph) eachtime (SETQ NewPos
(CREATE.NEW.NODEPOSITION
Child deltaX deltaY))
unless (MEMBER (fetch (GRAPHNODE NODEID) of Child)
MovedNodes) do (SETQ MovedNodes (CONS (fetch (GRAPHNODE NODEID) of Child)
MovedNodes))
(MOVENODE Child (fetch NODEPOSITION of Child)
NewPos Graph DisplayStream)
(EXTENDEXTENT (WFROMDS DisplayStream)
(NODEREGION Child))
(* ;; "we must call EXTENDEXTENT to extend the graph extent in case we have moved a node outside the previous extent.")
(CALL.MOVENODEFN Child NewPos Graph (WFROMDS DisplayStream)
(fetch NODEPOSITION of Child])
(COLLECT.CHILD.NODES
(LAMBDA (Node Graph) (* Newman "27-Jan-87 11:16")
(* * collect all immediate children (only one generation) of Node in Graph.)
(bind (GraphNodes ← (fetch (GRAPH GRAPHNODES) of Graph)) for NodeID
in (fetch (GRAPHNODE TONODES) of Node) collect (* ??? (ASSOC (if (AND
(LISTP NodeID) (EQUAL
(CAR NodeID) (QUOTE Link% Parameters)))
then (* Special case where the second
item in the list is the NodeID)
(CADR NodeID) else NodeID) GraphNodes))
(GETNODEFROMID NodeID GraphNodes))))
(CREATE.NEW.NODEPOSITION
(LAMBDA (Node deltaX deltaY) (* Newman "27-Jan-87 11:06")
(* * Creates a new position for Node by adding deltaX and deltaY to the
appropriate coordinates.)
(PROG ((OldPos (fetch (GRAPHNODE NODEPOSITION) of Node)))
(RETURN (create POSITION
XCOORD ← (PLUS deltaX (fetch (POSITION XCOORD) of OldPos))
YCOORD ← (PLUS deltaY (fetch (POSITION YCOORD) of OldPos)))))))
(GETBOXPOSITION.FROMINITIALREGION
(LAMBDA (Window Region DisplayStream) (* Newman "26-Jan-87 11:38")
(* * This function obtains a new region from the user, and it prompts the user
using the region passed in as Region. DisplayStream is the displaystream of
Window, and Region is considered to be a region within Window.
This function was written to be called from EDITMOVEREGION.)
(* All of the garbage below to calculate the third and fourth arguments to
GETBOXPOSITION exists to put the ghost box prompting the user in exactly the
same place as the region passed in.)
(GETBOXPOSITION (fetch (REGION WIDTH) of Region)
(fetch (REGION HEIGHT) of Region)
(DIFFERENCE (PLUS (fetch (REGION LEFT) of Region)
(fetch (REGION LEFT) of (WINDOWPROP Window 'REGION))
(WINDOWPROP Window 'BORDER))
(fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL DisplayStream)))
(DIFFERENCE (PLUS (fetch (REGION BOTTOM) of Region)
(fetch (REGION BOTTOM) of (WINDOWPROP Window 'REGION))
(WINDOWPROP Window 'BORDER))
(fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL DisplayStream)))
Window "Select new region for nodes.")))
(INIT/NODES/FOR/LAYOUT
(LAMBDA (NS FORMAT ROOTIDS FONT) (* Randy.Gobbel " 8-May-87 16:22")
(for GN in NS do (replace (GRAPHNODE NODEPOSITION) of GN
with (NOT (NOT (FMEMB (fetch (GRAPHNODE NODEID) of GN)
ROOTIDS))))
(* T Used to indicate prior visitation. Roots are already visited)
(OR (IMAGEOBJP (fetch (GRAPHNODE NODELABEL) of GN))
(fetch (GRAPHNODE NODEFONT) of GN)
(replace (GRAPHNODE NODEFONT) of GN with FONT)))
(for R in ROOTIDS do (COND
((EQMEMB 'LATTICE FORMAT)
(LATTICE/BREAK/CYCLES (GETNODEFROMID R NODELST)
NIL))
(T (FOREST/BREAK/CYCLES (GETNODEFROMID R NODELST)))))
(for GN in NODELST do (replace (GRAPHNODE NODEPOSITION) of GN with NIL)
(SET/LABEL/SIZE GN))))
(NODECREATE
(LAMBDA (ID LABEL POS TONODEIDS FROMNODEIDS FONT BORDER LABELSHADE)
(* Randy.Gobbel "13-May-87 12:04")
(* creates a node for a grapher.)
(create GRAPHNODE
NODEID ← ID
NODEPOSITION ← POS
NODELABEL ← LABEL
NODEFONT ← (COND
(FONT)
((IMAGEOBJP LABEL)
NIL)
(DEFAULT.GRAPH.NODEFONT)
(T (FONTNAMELIST DEFAULTFONT)))
TONODES ← TONODEIDS
FROMNODES ← FROMNODEIDS
NODEBORDER ← BORDER
NODELABELSHADE ← LABELSHADE)))
(EDITADDNODE
[LAMBDA (W NewPosition) (* ; "Edited 8-Apr-88 17:36 by pmi")
(* ;
"adds a node to the graph in the window W and displays it.")
(* ;; "pmi 4/8/88: Added NewPosition argument so that the new position for a node may be specified programatically.")
(DECLARE (GLOBALVARS PROMPTWINDOW))
(PROG [NODE ORIGPOS NEWPOS (GRAPH (WINDOWPROP W 'GRAPH))
(Stream (WINDOWPROP W 'DSP]
(OR (SETQ NODE (GRAPHADDNODE GRAPH W))
(RETURN))
(MEASUREGRAPHNODE NODE)
(if (POSITIONP NewPosition)
then (SETQ ORIGPOS (create POSITION using (fetch NODEPOSITION of NODE)))
(MOVENODE NODE ORIGPOS NewPosition GRAPH Stream)
(FLIPNODE NODE Stream)
(EXTENDEXTENT (WFROMDS Stream)
(NODEREGION NODE))
(CALL.MOVENODEFN NODE NewPosition GRAPH (WFROMDS Stream)
ORIGPOS)
else (printout PROMPTWINDOW T "Position node " (DISPLAY/NAME NODE))
(PRINTDISPLAYNODE NODE (CONSTANT (create POSITION
XCOORD ← 0
YCOORD ← 0))
W
(DSPCLIPPINGREGION NIL W))
(TRACKCURSOR NODE Stream GRAPH))
(RETURN NODE])
(COLLECTDESCENDENTS
[LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 15:40 by pmi")
(* ;; "pmi 8/3/88: Created to wrap RESETLST around call to RECURSIVE.COLLECTDESCENDENTS. Prevents infinite looping on circular graph structures by marking where we have been.")
(* ;; "Clean up the Visited markers placed on the nodes traversed.")
(* ;; "pmi 8/5/88: Now also cleans up Visited marker on Node.")
(LET (NodeID Descendents)
(RESETLST
[RESETSAVE NIL
'(PROGN (for VisitedNode in (CONS Node Descendents) bind VisitedNodeID
do (NC.GraphNodeIDPutProp (if (LISTP (SETQ VisitedNodeID
(fetch (GRAPHNODE NODEID)
of VisitedNode)))
then (CAR VisitedNodeID)
else VisitedNodeID)
'Visited NIL]
(SETQ Descendents (RECURSIVE.COLLECTDESCENDENTS Node Graph)))])
)
(DECLARE%: DONTEVAL@LOAD
(DREMOVE (SASSOC "Move Node" EDITGRAPHMENUCOMMANDS)
EDITGRAPHMENUCOMMANDS)
(ADDTOVAR EDITGRAPHMENUCOMMANDS (Move% Node 'MOVENODE "Moves a single node in the graph."
(SUBITEMS (|Move Single Node| 'MOVENODE
"Moves a single node in the graph.")
(|Move Node and Subtree| (EDITMOVESUBTREE
GRAPHWINDOW)
"Moves a subtree of nodes relative to the movement of their root."
)
(Move% Region (EDITMOVEREGION GRAPHWINDOW)
"Moves a group of nodes within a specified region to another region."
))))
(SETQ EDITGRAPHMENU NIL)
)
(PUTPROPS GRAPHERPATCH FILETYPE :TCOMPL)
(PUTPROPS GRAPHERPATCH MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10))
(PUTPROPS GRAPHERPATCH COPYRIGHT ("Xerox Corporation" 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3021 20930 (EDITMOVEREGION 3031 . 5788) (EDITMOVESUBTREE 5790 . 7445) (NOT.TRACKCURSOR
7447 . 9991) (RECURSIVE.COLLECTDESCENDENTS 9993 . 11383) (MOVEDESCENDENTS 11385 . 13173) (
COLLECT.CHILD.NODES 13175 . 14144) (CREATE.NEW.NODEPOSITION 14146 . 14693) (
GETBOXPOSITION.FROMINITIALREGION 14695 . 16173) (INIT/NODES/FOR/LAYOUT 16175 . 17299) (NODECREATE
17301 . 18066) (EDITADDNODE 18068 . 19679) (COLLECTDESCENDENTS 19681 . 20928)))))
STOP