;;; -*- MODE:lisp; package:(graph global 1000); base:10.; -*- ;;; ;;; ;;; Note that in the mode line, we create a new package, called ;;; GRAPH, inferior to GLOBAL, and with an initial size of 1000. ;;; The Graph package will be used for much graphics work. ;;; ;;; GRAPHD ;;; THIS CODE IS NOT IN THE LEAST FRANZ LISP COMPATIBLE, AND WILL ;;; NEVER BE. DON'T EVEN TRY TO RUN THIS IN FRANZ. ;;; This file contains code to implement a graph display system on ;;; the lisp machine. ;;; The Graph Display system will display graphs (directed or undirected) ;;; using user-defined nodes, and a variety of mechanisms for displaying ;;; arcs. Graphs are displayed on an infinite plane; the Lisp Machine ;;; window can zoom in or out to allow as much display as desired. The ;;; window can also pan left, right, up, and down. ;;; The Graph Display system is intended to become a component in other ;;; more interesting systems. Proposed systems include a Graphical Lisp ;;; inspector. ;;; A graph display window has a ZOOM, which is always an integer ;;; The lowest zoom is always 1. The term zoom ;;; is perhaps confusing, since as the number gets bigger, the ;;; objects displayed get smaller. The higher the zoom, the more ;;; objects can be visible in the window. ;;; A graph display window has a POSITION, broken into x and y components. ;;; The user may move the graph display around an infinite plane, looking ;;; at whatever. X and Y range among the integers, positive and negative. ;;; $Log: /ct/lmcode/graph/gwindow.l,v $ ;;;Revision 1.4 84/08/03 09:33:47 alfred ;;;Rel 5.1 bug fixes. ;;; ;;;Revision 1.3 84/07/30 11:25:40 alfred ;;;Release 5.1 initial version. ;;; ;;;Revision 1.2 84/07/27 13:54:03 linda ;;;changed some momentary menus to pop-up menus. ;;;"beefed up" various methods which generated OUTPUT HOLD ;;;in some situations. ;;;, ;;; ;;;Revision 1.1 84/04/25 15:06:13 susan ;;;Initial revision ;;; ;;; **************************************************************** ;;; Necessary Loads, Constants, Declarations. ;;; **************************************************************** (defconst *point-near-distance* 100. "How far away from a point you can be and still have it near.") (defvar *symbolic-things* nil "Symbol to hold properties which are symbolic names for lists of nodes.") (defvar *original-node-names* '("Foo" "Bar" "Baz" "Bletch" "Foobar" "Frog" "Moo" "Boo" "Susan" "Bill" "John" "Penny" "Alfred" "Alex" "Freep" "Frap" "Frep" "Rob" "Ostrich" "BigBird" "Kiwi" "Emu" "Dodo" "Maine" "New Hampshire" "Vermont" "Massachusetts" "Connecticut" "New York" "New Jersey" "Pennsylvania" "Delaware" "Maryland" "West Virginia" "Virginia" "North Carolina" "South Carolina" "Georgia" "Florida" "Texas" "Missouri" "Illinois" "Lee Blaine is in California" "Minnesota" "Stinking Detroit") "Names to use for 'gensymed' node names.") (defvar *node-names* *original-node-names*) ;;; Arrays used for drawing splines (defconst *spline-x-array* (make-array 5 ':fill-pointer 0)) (defconst *spline-y-array* (make-array 5 ':fill-pointer 0)) ;;; Used by with-near-objects-highlighted. Globally bound to a list ;;; of types of things to highlight. (defvar *near-objects* nil) (defvar *world-size* 100000.) (defflavor interact-window () (tv:tracking-mixin tv:window)) (defvar *interact-window* (tv:make-window 'interact-window ':width 500. ':height 200 ':deexposed-typeout-action ':permit ':save-bits t ':borders #+Symbolics '(tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border) #+LMI '(1 1 1 1) ':more-p nil ':label '(:string "The Window into which You Should Type" :font fonts:tr12b) ':font-map '(fonts:tr12b))) ;;; **************************************************************** ;;; Internal Macros, Structure Definitions, FLAVOR definitions. ;;; (Stuff that has to appear first.) ;;; **************************************************************** ;;; The major flavor that we will play with. You can mix this in ;;; to any kind of window in order to create a graph display window. ;;; ;;; A graph display window can have at most one graph displayed. ;;; The component flavors are rationalized as followed: ;;; LINE-TRUNCATING-MIXIN is required so we don't have to worry ;;; much about clipping. ;;; WINDOW is necessary to make this all work, of course!. ;;; For Rel 4.5: ;;; LIST-MOUSE-BUTTONS-MIXIN allows us to use ':tyi to get mouse blips. (defmacro with-near-objects-highlighted (object-types-to-highlight &body body) `(let-globally ((*near-objects* ',object-types-to-highlight)) ,@body)) (defflavor shift-key-mouse-documentation-mixin ((mouse-documentation '("Click all you want, turkey!!"))) () :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;;;;;;;;;;;;;;;;; (defflavor graph-display-mixin ;;;;;;;;;;;;;;;;;;; ((arcs nil) (nodes nil) (zoomx *default-mag*) (zoomy *default-mag*) (screen-x 0.) ;Current x position (screen-y 0.) ;Current y position (screen-width 0.) (screen-height 0.) (mouse-char 6.) (mouse-font fonts:mouse) (node-blinker nil) (arc-blinker nil) (point-blinker nil) (grid-on nil) ;default is to work with the grid on (grid-size 320.) ;this is a compromise number (highlighted-object nil) ;Object that mouse is highlighting. (infinite-window nil) (infinite-blinker nil) ) (shift-key-mouse-documentation-mixin tv:vector-character-mixin) :gettable-instance-variables :settable-instance-variables :initable-instance-variables (:required-flavors tv:line-truncating-mixin tv:window)) ;;; Instead of using the tv:list-mouse-buttons-mixin, we provide our own ;;; :mouse-click method that does the same as the list-mouse-buttons version, ;;; But IN ADDITION, returns the highlighted object at the time of the click. ;;; Since this happens at the same time that the keyclick goes in the input ;;; buffer (interrupt driven), it should avoid any timing problems between the ;;; various processes (user, mouse, keyboard) ;;; We also include in the key-click the state of the four shifting keys. (defmethod (graph-display-mixin :mouse-click) (button x y) (funcall-self ':force-kbd-input `(:mouse-button ,button ,self ,x ,y ,highlighted-object ,(key-state ':control) ,(key-state ':meta) ,(key-state ':super) ,(key-state ':hyper))) t) ;;;;;;;;;;;;;;;;;;;; (defflavor graph-display-window ;;;;;;;;;;;;;;;;;;;; () (graph-display-mixin tv:process-mixin tv:line-truncating-mixin tv:window)) ;;; Ordinary graph. These are the things you may want to manipulate. One ;;; can imagine a system having many graphs, and switching a graph display ;;; window from one graph to another. ;;; ;;; Mathematically, a graph is just a collection of arcs and nodes. For this ;;; system, it is possible to have nodes that know where they are displayed. (defflavor graph-window-pane () (graph-display-window tv:pane-mixin)) (defflavor infinite-window () (shift-key-mouse-documentation-mixin tv:window) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;; Types of arcs (display) straight-line, zig-zag, spline. ;;; Add a labelled arc mixin. ;;; You can only use this inside a defmethod where self is some ;;; instance of a graph window. (defmacro with-mouse-shape (shape &body body) `(unwind-protect (progn (send self ':set-mouse-cursor ,shape) ,@body ) (send self ':set-mouse-cursor 6. ))) ;an epsilon, but safer. ;;; Use these to test what button has been pressed (on the mouse). (defmacro double-left-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 0) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 1))) (defmacro single-left-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 0) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 0))) (defmacro left-button-p (button) `(eq (ldb %%kbd-mouse-button (second ,button)) 0)) (defmacro double-middle-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 1) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 1))) (defmacro single-middle-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 1) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 0))) (defmacro middle-button-p (button) `(eq (ldb %%kbd-mouse-button (second ,button)) 1)) (defmacro double-right-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 2) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 1))) (defmacro single-right-button-p (button) `(and (= (ldb %%kbd-mouse-button (second ,button)) 2) (= (ldb %%kbd-mouse-n-clicks (second ,button)) 0))) (defmacro right-button-p (button) `(eq (ldb %%kbd-mouse-button (second ,button)) 2)) ;;; Returns a number which is the smallest multiple of GRID-SIZE  NUMBER. (defmacro ceiling-grid (number grid-size) `(let ((my-number ,number) (my-grid-size ,grid-size)) (* (if (plusp my-number) (1+ (// (1- my-number) my-grid-size)) (// (1- my-number) my-grid-size)) my-grid-size))) ;;; **************************************************************** ;;; Graph Display Window methods, etc. ;;; **************************************************************** ;;; **************************************************************** ;;; Handle mouse documentation ;;; **************************************************************** ;;; Return the state of a key, T if it is depressed, NIL if it is not. ;;; This only works on new keyboards; on old keyboards it always returns NIL. ;;; A key is specified by either a number which is the ascii code of the ;;; key (the character you get when you type that key with no shifts), ;;; or a symbol which is the symbolic name of a shift key (see below). ;;; We have to redefine this to NOT ALLOW the keyboard main loop to run. (defun key-state (key &aux tem) ;;; (tv:kbd-process-main-loop-internal) (cond ((numberp key) (not (zerop (aref si:kbd-key-state-array key)))) ((setq tem (assq key #-3600 '((:shift #o100) (:left-shift #o0) (:right-shift #o40) (:greek #o101) (:left-greek #o1) (:right-greek #o41) (:top #o102) (:left-top #o2) (:right-top #o42) (:control #o104) (:left-control #o4) (:right-control #o44) (:meta #o105) (:left-meta #o5) (:right-meta #o45) (:super #o106) (:left-super #o6) (:right-super #o46) (:hyper #o107) (:left-hyper #o7) (:right-hyper #o47) (:caps-lock #o3) (:alt-lock #o10) (:mode-lock #o11) (:repeat #o12)) #+3600 '((:shift #o100) (:left-shift #o0) (:right-shift #o40) (:control #o101) (:left-control #o1) (:right-control #o41) (:meta #o102) (:left-meta #o2) (:right-meta #o42) (:super #o103) (:left-super #o3) (:right-super #o43) (:hyper #o104) (:left-hyper #o4) (:right-hyper #o44) (:symbol #o105) (:left-symbol #o5) (:right-symbol #o45) (:repeat #o6) (:caps-lock #o11) (:mode-lock #o12)) )) (tv:bit-test (lsh 1 (logand (setq tem (cadr tem)) #o37)) (cond ((< tem #o40) si:kbd-left-shifts) ((< tem #o100) si:kbd-right-shifts) (t (logior si:kbd-left-shifts si:kbd-right-shifts))))) (t (ferror nil "~s illegal key; must be character or symbol for shift key" key)))) ;;; This is called by the mouse process (defmethod (shift-key-mouse-documentation-mixin :who-line-documentation-string) () (cond ((key-state ':control) (or (second mouse-documentation) (first mouse-documentation))) ((key-state ':meta) (or (third mouse-documentation) (first mouse-documentation))) ((key-state ':super) (or (fourth mouse-documentation) (first mouse-documentation))) ((key-state ':hyper) (or (fifth mouse-documentation) (first mouse-documentation))) (t (first mouse-documentation)))) ;;; ****************************************************************** ;;; Manipulating Components ;;; ****************************************************************** ;;set up the screen's height and width (defmethod (graph-display-mixin :after :init) (ignore) (multiple-value-bind (width height) (send self ':inside-size) (setq screen-width (* zoomx width)) (setq screen-height (* zoomy height)))) (defmethod (graph-display-mixin :refresh) (&optional ignore) (send self :redraw)) ;;; Here is how to add a node to a graph. This particular method ;;; merely adds a basic node, which has no position. The node added ;;; will have no arcs attached to it. The node may be initialized with ;;; options. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (graph-display-mixin :add-node) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (new-node) (send new-node ':set-window self) (push new-node nodes) (send new-node ':guarantee-no-overlaps) (draw new-node) new-node) ;;; To delete a node, first arrange for all the arcs touching him to ;;; be deleted, then do the deletion, finally erase. (defmethod (graph-display-mixin :delete-node) (node) (loop for arc in (send node ':arcs) do (send self ':delete-arc arc)) (setq nodes (delq node nodes)) (erase node)) ;;; To add an arc, we do some checking. It is not legal to add an ;;; arc unless its head and tail point to nodes already part of the ;;; graph. The notion that there is a head and a tail does NOT imply ;;; that the arc is directed; we just need a convenient name for each ;;; end of the arc. Some flavors of nodes ARE directed, however. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (graph-display-mixin :add-arc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (head tail new-arc) (send new-arc ':set-head head) (send new-arc ':set-tail tail) (send new-arc ':set-window self) (push new-arc (send head ':arcs)) (push new-arc (send tail ':arcs)) (send new-arc ':compute-joint-points) (push new-arc arcs) (draw new-arc) new-arc) (defmethod (graph-display-mixin :delete-arc) (arc) (erase arc) (setf (send (send arc ':head) ':arcs) (delq arc (send (send arc ':head) ':arcs))) (setf (send (send arc ':tail) ':arcs) (delq arc (send (send arc ':tail) ':arcs))) (setq arcs (delq arc arcs))) ;;; Selecting an arc is somewhat harder. Need to look through the list ;;; of arcs, determining whether the specified point is within a 10% ;;; ellipse of the arc's line-segment. (defmethod (graph-display-mixin :select-arc) () (with-near-objects-highlighted (:arc) (with-mouse-shape #/l (loop for input = (send self :any-tyi) until (and (listp input) (eq (first input) ':mouse-button) (typep highlighted-object 'basic-arc)) do (beep)) highlighted-object))) ;;; To select a node, send this message to the window. ;;; Returns the node pointed, or nil if not over a node. (defmethod (graph-display-mixin :select-node) () (with-mouse-documentation self '("Click on the node you want ") (with-near-objects-highlighted (:node) (with-mouse-shape #/ (loop for input = (send self :any-tyi) until (and (listp input) (eq (first input) ':mouse-button) (typep highlighted-object 'basic-node)) do (beep)) highlighted-object)))) ;;; This is the same as :select-node except for the message ;;; displayed. It is used to prevent an arc from having its ;;; head and tail be connected to the same node. (defmethod (graph-display-mixin :select-a-different-node) () (with-mouse-documentation self '("Click on a different node, head and tail can't be the same ") (with-near-objects-highlighted (:node) (with-mouse-shape #/ (loop for input = (send self :any-tyi) until (and (listp input) (eq (first input) ':mouse-button) (typep highlighted-object 'basic-node)) do (beep)) highlighted-object)))) ;;; Returns a list (:point ) where x and y form a point ;;; in the list of joint-points. (defmethod (graph-display-mixin :select-inflection) () (with-mouse-documentation self '("Select an inflection point") (with-near-objects-highlighted (:point) (with-mouse-shape #/f (loop for input = (send self :any-tyi) until (and (listp input) (eq (first input) ':mouse-button) (listp (sixth input))) do (beep) finally (return (sixth input))))))) (defmethod (graph-display-mixin :get-position) () (with-mouse-documentation self '("Click left to select a location") (with-near-objects-highlighted () (with-mouse-shape #/a (let* ((input (loop for input = (send self :any-tyi) until (and (listp input) (eq (first input) ':mouse-button)) do (beep) finally (return input))) (x (fourth input)) (y (fifth input))) (setq x (send self ':untranslate-x x) y (send self ':untranslate-y y)) (list x y)))))) ;;; **************** ;;; Changing the view. ;;; **************** ;;; Here we set the zoom of the window. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (graph-display-mixin :adjust-zoom) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (new-x new-y &optional (refresh-p t)) (setq new-x (max 1. (fix new-x))) (setq new-y (max 1. (fix new-y))) ;; Select the correct font (send self ':set-font-map (list (cond ((< new-y 3) fonts:43vxms) ((< new-y 6) fonts:mets) ;;; used to be 25fr3 ((< new-y 9) fonts:tr18b) ((< new-y 12.) fonts:tr12b) ((< new-y 15.) fonts:tr10) ((< new-y 20.) fonts:tr8) (t fonts:hl7)))) (setq zoomx new-x zoomy new-y) ;; Tell the screen what its new size is. (multiple-value-bind (width height) (send self ':inside-size) (setq screen-width (* zoomx width)) (setq screen-height (* zoomy height))) (loop for arc in arcs do (send arc ':set-changed-p t)) ;; Most of the time, redraw everything. (if refresh-p (send self ':redraw))) ;;; return the top left and lower right coordinates of the graph-window. ;;; This corresponds with the methods that exist for nodes so that ;;; we can at times treat the screen as a large node (defmethod (graph-display-mixin :containing-rectangle) () (values screen-x screen-y (+ screen-x screen-width) (+ screen-y screen-height))) ;;; Here is how we redraw the display. ;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (graph-display-mixin :redraw) ;;;;;;;;;;;;;;;;;;;;;;;;;;; () ;; Clear the entire window. (send self ':clear-window) ;;if using a grid, draw it in (if grid-on (send self ':display-grid)) ;; Tell each arc it needs redrawing, (loop for arc in arcs do (send arc ':set-drawn-p nil)) ;;tell the nodes to redraw themselves (loop for node in nodes do (send node ':set-drawn-p nil) do (draw node))) (defmethod (graph-display-mixin :display-grid) () (let* ((first-grid-x (send self ':translate-x (ceiling-grid screen-x grid-size))) (first-grid-y (send self ':translate-y (ceiling-grid screen-y grid-size))) (effective-gridx (// grid-size zoomx)) (effective-gridy (// grid-size zoomy))) (multiple-value-bind (width height) (send self ':inside-size) (loop for i from 0 by 1 for x = (+ (fixr (* i effective-gridx)) first-grid-x) until (> x width) ;with arr = (send self ':screen-array) doing (loop for j from 0 by 1 for y = (+ (fixr (* j effective-gridy)) first-grid-y) until (> y height) doing ;(aset 1 arr x y)))))) (send self :draw-point x y tv:alu-seta 1)))))) (defmethod (graph-display-mixin :after :set-grid-on) (value) (if value (send self ':display-grid) (send self ':redraw))) ;;; Returns the panning display back to home. Useful if you can't ;;; find your bearings. ;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (graph-display-mixin :home) ;;;;;;;;;;;;;;;;;;;;;;;;; () (setq screen-x 0 screen-y 0) (send self ':redraw)) ;;; **************************************************************** ;;; Testing and demo code ;;; **************************************************************** ;;; Even newer interactive version. Used by the new user interface. ;;; Automatic-p indicates whether a name should be automatically generated ;;; or not. keystroke is the mouse-click (we hope) that caused this message ;;; to be sent. We examine the keystroke to get the position of the mouse. (defmethod (graph-display-mixin :user-add-node) (automatic-p keystroke) (let ((x (send self ':untranslate-x (fourth keystroke))) (y (send self ':untranslate-y (fifth keystroke)))) (send self ':add-node (make-instance 'basic-node ':x x ':y y ':label (if automatic-p (if *node-names* (pop *node-names*) (string (gensym))) nil))))) ;;; Similar in effect to user-add-node. ;;; ;;; Commented out for the moment: ;;; Orginally we allowed "up-and-over-arcs", that is, arcs which ;;; had head = tail. It has been redefined to NOT allow such an ;;; arc since it created such havoc in other methods. (defmethod (graph-display-mixin :user-add-arc) (automatic-p tail) (with-object-flashing tail (let ((head (send self :select-node))) ;; This is the code for the above comment: ;;; (loop for new_head = (send self ':select-a-different-node) ;;; until (neq new_head tail) ;;; do (beep) ;;; finally (return new_head)))) ;;; *** REMOVE THIS NEXT LINE WHEN IT'S LEGAL TO MAKE SELF ARCS *** (if (eq head tail) (signal 'sys:abort #+LMI "Self-referencing arc")) (send self ':add-arc head tail (make-instance (if (eq head tail) 'basic-arc ; This doesnt exist in source we have: ; 'up-and-over-arc 'basic-arc ) ':label (if automatic-p (if *node-names* (pop *node-names*) (string (gensym))) nil)))))) (defmethod (graph-display-mixin :make-node) (&optional keytap) (let* ((keystroke (if keytap keytap (with-mouse-documentation self '("Click L, M, or R where you want the node to be.") (with-near-objects-highlighted () (with-mouse-shape #/a (loop for input = (send self ':any-tyi) until (and (listp input) (eq (first input) ':mouse-button)) do (beep) finally (return input))))))) (x (send self ':untranslate-x (fourth keystroke))) (y (send self ':untranslate-y (fifth keystroke)))) (send self ':add-node (make-instance 'basic-node ':x x ':y y ':label nil)))) (defmethod (graph-display-mixin :user-delete-inflection) () (let* ((point (send self ':select-inflection)) (arc (second point)) (x (third point)) (y (fourth point))) (erase arc) (loop for ptr on (send arc ':joint-points) by 'cddr until (null (cddddr ptr)) if (and (= x (third ptr)) (= y (fourth ptr))) return (setf (cddr ptr) (cddddr ptr))) (send arc ':compute-lengths) (draw arc))) ;;; Adjust all nodes to be "on the grid," even if the grid isn't visible. (defmethod (graph-display-mixin :gridify-whole-graph) () (unless grid-on (send self ':set-grid-on t)) (loop for node in nodes do (erase node)) (loop for node in nodes do (send node ':guarantee-no-overlaps)) (loop for arc in arcs do (send arc ':compute-joint-points)) (loop for node in nodes do (draw node))) ;;; Sets the current mouse character. You supply a list of char., font. ;;; Also tells the window that this is the current mouse character. That ;;; makes the mouse become that character when it returns to the window ;;; from some other window. (defmethod (graph-display-mixin :set-mouse-cursor) (char) (tv:mouse-set-blinker-definition ':character 0 0 ':on ':set-character char 'fonts:mouse) (send self ':set-mouse-char char) ;;; Do we really need this????? ;;; (send self ':set-mouse-font fonts:mouse) ) (defmethod (graph-display-mixin :mouse-standard-blinker) (&rest ignore) (tv:mouse-set-blinker-definition ':character 0 0 ':on ':set-character mouse-char mouse-font)) (defmethod (graph-display-mixin :read-exp) (stream) (let* ((saved-list (read stream)) (saved-info (first saved-list)) (saved-nodes (second saved-list)) (saved-arcs (third saved-list)) (temp-node-list nil) (temp-arc-list nil)) (send self ':adjust-zoom (second (memq ':zoomx saved-info)) (second (memq ':zoomy saved-info)) nil) (setq screen-x (second (memq ':screen-x saved-info))) (setq screen-y (second (memq ':screen-y saved-info))) ;; First, set up the nodes, with no arcs. Adding arcs will fix ;; that quickly. For nodes that are of a flavor with the ;; dont-retrieve-this-object-from-file property on, insert a 'nil ;; into the position in the temp-node-list rather than an instance ;; of the node (setq temp-node-list (loop for node in saved-nodes for node-flavor = (first node) collect (if (graph-get node-flavor 'window ':dont-retrieve-this-object-from-file) nil (apply #'make-instance node)))) (loop for node in temp-node-list if node collect node into checked-nodes ;; Status of what to do about overlaps. ;; :query Ask what to do with this node. ;; :leave Leave this node where it says to be ;; :move Send this a :guarantee-no-overlaps message. with mode = ':query ;; Install window pointer if node do (send node ':set-window self) ;; Check for overlaps AND do (setq mode (send node ':maybe-overlap nodes checked-nodes mode))) ;; Now, set up the new arcs, ignoring their nodes. (setq temp-arc-list (loop for arc in saved-arcs for arc-flavor = (first arc) unless (graph-get arc-flavor 'window ':dont-retrieve-this-object-from-file) unless (non-existent-head-or-tail arc temp-node-list) collect (apply #'make-instance (transformed-arcs arc temp-node-list)))) (loop for arc in temp-arc-list do (send arc ':set-window self)) ;; Now, point the nodes and arcs to each other (loop for arc in temp-arc-list do (push arc (send (send arc ':head) ':arcs)) do (push arc (send (send arc ':tail) ':arcs))) ;; Recompute joint-points, since we may have moved some nodes. (loop for arc in temp-arc-list do (send arc ':compute-joint-points)) ;; Put the new arcs on the arc list. (setq arcs (nconc temp-arc-list arcs)) ;; Finally, put the new nodes on the node list. ;;first getting rid of any occurrences of 'nil in the list (setq nodes (nconc (delq nil temp-node-list) nodes)) (send self ':redraw))) ;;; returns 't if either the head or tail for this arc is a 'nil in the ;;; temp-node-list which implies that this node's flavor-type is currently ;;; not being entered into the graph world (defun non-existent-head-or-tail (arc temp-node-list) (let* ((arc-info (cdr arc)) (head (second (memq ':head arc-info))) (tail (second (memq ':tail arc-info)))) (not (and (nth head temp-node-list) (nth tail temp-node-list))))) (defun transformed-arcs (arc-descr node-list) (setf (second (memq ':head arc-descr)) (nth (second (memq ':head arc-descr)) node-list)) (setf (second (memq ':tail arc-descr)) (nth (second (memq ':tail arc-descr)) node-list)) arc-descr) ;;; Here we save everything. First write zoom, screen coordinates, ;;; then get the nodes and arcs to describe themselves. (defmethod (graph-display-mixin :DISPLAY) (stream) (format stream "((:zoomx ~D :zoomy ~D :screen-x ~D :screen-y ~D)" zoomx zoomy screen-x screen-y) (format stream "~%(") (loop for node in nodes unless (dont-save-node-to-file-p node) do (send node ':DISPLAY stream)) (format stream ")~%(") (loop for arc in arcs for arc-flavor = (typep arc) unless (or (graph-get arc-flavor 'window ':dont-save-this-object-to-file) (dont-save-node-to-file-p (send arc ':head)) (dont-save-node-to-file-p (send arc ':tail))) do (send arc ':DISPLAY stream)) (format stream "))")) ;;returns 't if this node should be saved in the file, 'nil otherwise (defun dont-save-node-to-file-p (node) (graph-get (typep node) 'window ':dont-save-this-object-to-file)) ;;; **************************************************************** ;;; Highlighting stuff. ;;; **************************************************************** ;;; Here is code to highlight nodes and arcs. Some of this is taken ;;; from Shelton's GED graphic editor. ;;; This code needs to be made MUCH quicker. ;;; One really KLUDGY thing going on in here is the mouse documentation. ;;; If we are over a node or an arc, we want to give a different documentation ;;; than we would if over free space. So, at the appropriate time, we ;;; SETQ the mouse-documentation to the right thing. The probelem ;;; is that some other routine may want to BIND the mouse documentation ;;; to something else, regardless of what the mouse is over. Thus, we have a ;;; special called *mouse-documented* which is T when someone else is using ;;; the mouse documentation. (It is bound with let-globally, since this ;;; method runs in a separate process.) ;;; New version of :mouse-moves. We want to see what is highlightable, and ;;; be certain to highlight only one thing at a time. Also, set the instance ;;; variable highlighted-object to the right thing. We can at present ;;; highlight arcs, nodes, and "points". To save time, we check arcs and ;;; points on the same pass, sort of, but look for points first. (defmethod (graph-display-mixin :after :mouse-moves) (px py) (prog outer () ;Name this so we can return. ;; Are we looking for arcs or points? (when (memq ':node *near-objects*) (loop with x = (send self ':untranslate-x px) with y = (send self ':untranslate-y py) for node in nodes if (send node ':viewable-p) do (when (send node ':contains-point x y) (multiple-value-bind (x1 y1 x2 y2) (send node ':containing-rectangle) (setq highlighted-object node) ;remember this object. (setq x1 (send self ':translate-x x1) y1 (send self ':translate-y y1) x2 (send self ':translate-x x2) y2 (send self ':translate-y y2)) (send node-blinker ':set-size-and-cursorpos (- x2 x1) (- y2 y1) x1 y1)) (send node-blinker ':set-visibility t) (send arc-blinker ':set-visibility nil) (send point-blinker ':set-visibility nil) (unless *mouse-documented* (setq mouse-documentation *over-node-doc*)) (return-from outer t)))) (when (or (memq ':point *near-objects*) (memq ':arc *near-objects*)) (loop with xx = (send self ':untranslate-x px) with yy = (send self ':untranslate-y py) for arc in arcs if (and (send arc ':viewable-p) (memq ':point *near-objects*)) do (loop for (x y z . rest) on (cddr (send arc ':joint-points)) by 'cddr until (null z) if ( (dist x y xx yy) *point-near-distance*) do (progn (send point-blinker ':set-cursorpos (send self ':translate-x x) (send self ':translate-y y)) (send point-blinker ':set-visibility t) (send node-blinker ':set-visibility nil) (send arc-blinker ':set-visibility nil) (unless *mouse-documented* (setq mouse-documentation *over-point-doc*)) (return-from outer (setq highlighted-object (list ':point arc x y))))) if (and (send arc ':viewable-p) (memq ':arc *near-objects*)) do (when (send arc ':near-point xx yy) (setq highlighted-object arc) (unless (and (eq arc (send arc-blinker ':arc)) (not (send arc ':changed-p))) (send arc-blinker ':set-arc arc) (send arc ':set-changed-p nil) (send arc-blinker ':set-points self (send arc ':get-points))) (send arc-blinker ':set-visibility t) (send node-blinker ':set-visibility nil) (send point-blinker ':set-visibility nil) (unless *mouse-documented* (setq mouse-documentation *over-arc-doc*)) (return-from outer t)))) ;; Nothing here, turn off all blinkers (setq highlighted-object nil) (unless *mouse-documented* (setq mouse-documentation *over-nothing-doc*)) (send node-blinker ':set-visibility nil) (send arc-blinker ':set-visibility nil) (send point-blinker ':set-visibility nil))) ;;; **************************************************************** ;;; Change the view, MENU OPERATIONS. ;;; **************************************************************** (defmethod (graph-display-mixin :go-home) () (send self ':adjust-zoom *default-mag* *default-mag* nil) (send self ':home)) (defmethod (graph-display-mixin :toggle-grid) () ;; Have to use SET- message to get after daemon. (send self ':set-grid-on (not grid-on))) (defmethod (graph-display-mixin :interactive-delete-everything) () (when (tv:menu-choose '(("Yes" t) ("No" nil)) "Really delete everything????") (setq arcs nil nodes nil) (send self ':redraw))) (defmethod (graph-display-mixin :interactive-retrieve-graph) () (let ((query-io *interact-window*)) (send *interact-window* ':clear-window) (format *interact-window* "~%File Name from which to read graph: ") (send *interact-window* ':expose-near '(:mouse)) (send *interact-window* ':select) (with-open-file (foo (readline *interact-window*) ':in) (send *interact-window* ':bury) (send self ':select) (send self ':read-exp foo)))) (defmethod (graph-display-mixin :interactive-save-graph) () (let ((query-io *interact-window*) (prinlevel) (prinlength)) (send *interact-window* ':clear-window) (format *interact-window* "~%File Name in which to save graph: ") (send *interact-window* ':expose-near '(:mouse)) (send *interact-window* ':select) (with-open-file (foo (readline *interact-window*) ':out) (send *interact-window* ':bury) (send self ':select) (send self ':DISPLAY foo)))) (defmethod (graph-display-mixin :interactive-inspect-form) () (let ((position (send self ':get-position))) (send *interact-window* ':clear-window) (format *interact-window* "~%Form to eval then inspect: ") (send *interact-window* ':expose-near '(:mouse)) (send *interact-window* ':select) (inspect-object (prog1 (eval (read *interact-window*)) (send *interact-window* ':bury) (send self ':select)) self (first position) (second position)))) (defmethod (graph-display-mixin :interactive-edit-view) (&aux (window-sizex tv:width) (window-sizey tv:height) (infinite-zoom (// (* 2 *world-size*) (min tv:width tv:height))) (sheet-x nil) (sheet-y nil)) (send self ':clear-window) (send infinite-window ':select) (multiple-value (sheet-x sheet-y) (tv:sheet-calculate-offsets infinite-window tv:main-screen)) (loop for node in nodes do (send infinite-window ':draw-rectangle 2 2 (// (- (send node ':x) (- *world-size*)) infinite-zoom) (// (- (send node ':y) (- *world-size*)) infinite-zoom) tv:alu-ior)) (tv:with-mouse-grabbed (with-mouse-documentation infinite-window '("Hold left button down to vary position. Middle to vary zoom. Right button exits.") (send infinite-blinker ':set-size-and-cursorpos (// (* window-sizex zoomx) infinite-zoom) (// (* window-sizey zoomy) infinite-zoom) (// (+ screen-x *world-size*) infinite-zoom) (// (+ screen-y *world-size*) infinite-zoom)) ;; First, expose the blinker. (send infinite-blinker ':set-visibility t) ;; Put the mouse where the blinker will be. (multiple-value-bind (xx yy) (send infinite-blinker ':read-cursorpos) (tv:mouse-warp (+ sheet-x xx) (+ sheet-y yy))) ;; Now, loop around, moving the blinker as necessary. (loop do (tv:mouse-wait) until (= tv:mouse-last-buttons 4) ;wait until user clicks right with (width height xpos ypos) do (multiple-value (width height) (send infinite-blinker ':size)) do (multiple-value (xpos ypos) (send infinite-blinker ':read-cursorpos)) do (cond ((= tv:mouse-last-buttons 1.) (send infinite-blinker ':set-cursorpos (- tv:mouse-x sheet-x (// width 2.)) (- tv:mouse-y sheet-y (// height 2.)))) ((= tv:mouse-last-buttons 2.) (let* ((x-diff (- tv:mouse-x sheet-x xpos (// width 2.))) (y-diff (- tv:mouse-y sheet-y ypos (// height 2.))) (new-width (abs (* x-diff 2.))) (new-height (abs (* y-diff 2.))) (new-xpos (- (+ xpos (// width 2.)) (// new-width 2.))) (new-ypos (- (+ ypos (// height 2.)) (// new-height 2.)))) (send infinite-blinker ':set-size-and-cursorpos new-width new-height new-xpos new-ypos))))))) ;; Finally, update the screen coordinates (multiple-value-bind (xx yy) (send infinite-blinker ':read-cursorpos) (setq screen-x (- (* infinite-zoom xx) *world-size*) screen-y (- (* infinite-zoom yy) *world-size*))) (send infinite-blinker ':set-visibility nil) (send self ':select) ;; and update the Zoom factor (multiple-value-bind (w h) (send infinite-blinker ':size) (send self ':adjust-zoom (fix (+ 0.5 (// (* infinite-zoom w) (float window-sizex)))) (fix (+ 0.5 (// (* infinite-zoom h) (float window-sizey)))))) ) ;;; **************************************************************** ;;; Select many nodes for an operation. ;;; **************************************************************** ;;; This is unusual code. Allows the user to select a number of nodes, ;;; then apply some operation to them. ;;; Here, we allow selection of N nodes. User selects with left button, ;;; and signals completion with right button. Middle button aborts. ;;; While selecting nodes, the ones selected are flashed. ;;; If the user clicks on one node multiple times, we only want ;;; to "collect" it once. ;;; +++++++++ Modify to allow "unselection" of nodes. (defmethod (graph-display-mixin :select-many-nodes) () (with-mouse-documentation self '("L: Select another node. L2: Add nodes from symbol. M: Abort. M2: Select all nodes. R: Use selected nodes.") (with-near-objects-highlighted (:node) (with-mouse-shape #/ (loop for input = (send self :any-tyi) with acc with abort = t until (and (listp input) (or (and (single-middle-button-p input) (progn (setq abort nil) (beep) t)) (right-button-p input))) ;; If user DOUBLE-LEFT clicks, let him/her select a symbolic ;; name for a collection of nodes. if (and (listp input) (double-left-button-p input)) append (setq acc (send self ':retrieve-many-nodes)) into collected-nodes AND do (loop for node in acc do (send node ':flash t)) ;; If user DOUBLE-MIDDLE clicks, select ALL nodes. if (and (listp input) (double-middle-button-p input)) do (setq collected-nodes nodes) AND do (loop for node in nodes do (send node ':flash t)) ;; If user SINGLE-LEFT clicks, select this node. if (and (listp input) (single-left-button-p input) (typep (sixth input) 'basic-node) (not (memq (sixth input) collected-nodes))) collect (sixth input) into collected-nodes AND do (send (sixth input) ':flash t) finally (progn (loop for node in collected-nodes do (send node ':flash nil)) (return (and abort collected-nodes)))))))) ;;; Allows user to specify several positions. Leaves a little X blinker ;;; wherever selected. Unwind-protect makes sure we turn off blinkers. (defmethod (graph-display-mixin :get-many-positions) (&aux (blinks nil)) (with-mouse-documentation self '("L: Select another point. M: Abort. R: Use selected points") (with-near-objects-highlighted () ;Don't highlight anything (with-mouse-shape #/a (unwind-protect (loop for input = (send self :any-tyi) if (and (listp input) (middle-button-p input)) do (progn (beep) (return nil)) until (and (listp input) (right-button-p input)) if (and (listp input) (left-button-p input)) collect (send self ':untranslate-x (fourth input)) AND collect (send self ':untranslate-y (fifth input)) AND do (push (tv:make-blinker self 'tv:character-blinker ':x-pos (fourth input) ':y-pos (fifth input) ':visibility ':blink ':font 'fonts:mouse ':char #/) blinks)) (loop for blink in blinks do (send blink ':set-visibility nil))))))) ;;; Same thing for arcs (defmethod (graph-display-mixin :select-many-arcs) () (with-mouse-documentation self '("L: Select another arc. L2: Add arcs from symbol. M: Abort. R: Use selected arcs.") (with-near-objects-highlighted (:arc) (with-mouse-shape #/l (loop for input = (send self :any-tyi) with acc with abort = t until (and (listp input) (or (and (middle-button-p input) (progn (setq abort nil) (beep) t)) (right-button-p input))) ;; If user DOUBLE-LEFT clicks, let him/her select a symbolic ;; name for a collection of arcs. if (and (listp input) (double-left-button-p input)) append (setq acc (send self ':retrieve-many-arcs)) into collected-arcs AND do (loop for arc in acc do (send arc ':flash t)) if (and (listp input) (left-button-p input) (typep (sixth input) 'basic-arc) (not (memq (sixth input) collected-arcs))) collect (sixth input) into collected-arcs AND do (send (sixth input) ':flash t) finally (progn (loop for arc in collected-arcs do (send arc ':flash nil)) (return (and abort collected-arcs)))))))) ;;; Move a whole bunch of nodes all at once. (defmethod (graph-display-mixin :move-many-nodes) () (let ((many (send self ':select-many-nodes))) (when many (with-object-flashing (first many) (let ((new-pos (send self ':get-position)) (first-x (send (first many) ':x)) (first-y (send (first many) ':y))) (loop for node in many do (send node ':move-relative (- (first new-pos) first-x) (- (second new-pos) first-y)))))))) (defmethod (graph-display-mixin :delete-many-nodes) () (loop for node in (send self ':select-many-nodes) do (send node ':delete-self))) (defmethod (graph-display-mixin :edit-many-nodes) (&aux instance-variables) (let ((many (send self ':select-many-nodes))) ;; Check to see if there are nodes. If so, edit the first one. ;; If user doesn't abort the edit, copy stuff. (when many (send (first many) ':edit-attributes t) (setq instance-variables (send (first many) ':select-ivs-for-copying "Select attributes you want copied:")) (loop for node in (cdr many) do (send node ':copy-attributes (first many) instance-variables))))) ;;delete a whole bunch of arcs at once (defmethod (graph-display-mixin :delete-many-arcs) () (loop for arc in (send self ':select-many-arcs) do (send arc ':delete-self))) ;;give a bunch of arcs the same characteristics (defmethod (graph-display-mixin :edit-many-arcs) (&aux instance-variables) (let ((many (send self ':select-many-arcs))) ;; Check to see if there are arcs. If so, edit the first one. ;; If user doesn't abort the edit, copy stuff. (when many (send (first many) ':edit-attributes t) (setq instance-variables (send (first many) ':select-ivs-for-copying "Select attributes you want copied:")) (loop for arc in (cdr many) do (send arc ':copy-attributes (first many)))))) ;;; Remember many nodes will let you select several nodes, ;;; and store them with a symbolic name. That name can then be ;;; used later for something. (defmethod (graph-display-mixin :remember-many-nodes) () (let ((many (send self ':select-many-nodes))) (send *interact-window* ':clear-window) (format *interact-window* "~%Symbol on which to remember these nodes: ") (send *interact-window* ':expose-near '(:mouse)) (send *interact-window* ':select) (putprop '*symbolic-things* many (read *interact-window*)) (send *interact-window* ':bury) (send self ':select))) ;;; Returns a list of nodes when the user selects a symbol. (defmethod (graph-display-mixin :retrieve-many-nodes) () (tv:menu-choose (loop for (ind val . rest) on (plist '*symbolic-things*) by 'cddr if (and (listp val) (typep (first val) 'basic-node)) collect (list (format nil "~A with ~D nodes" ind (length val)) ':value val ':documentation (format nil "Node labels:~{ ~A~}" (loop for node in val collect (or (send node ':label) "unnamed"))))) "Select a symbolic name to return many nodes:")) ;;same stuff as above for arcs (defmethod (graph-display-mixin :remember-many-arcs) () (let ((many (send self ':select-many-arcs))) (send *interact-window* ':clear-window) (format *interact-window* "~%Symbol on which to remember these arcs: ") (send *interact-window* ':expose-near '(:mouse)) (send *interact-window* ':select) (putprop '*symbolic-things* many (read *interact-window*)) (send *interact-window* ':bury) (send self ':select))) ;;; Returns a list of arcs when the user selects a symbol. (defmethod (graph-display-mixin :retrieve-many-arcs) () (tv:menu-choose (loop for (ind val . rest) on (plist '*symbolic-things*) by 'cddr if (and (listp val) (typep (first val) 'basic-arc)) collect (list (format nil "~A with ~D arcs" ind (length val)) ':value val ':documentation (format nil "Arcs labels:~{ ~A~}" (loop for arc in val collect (or (send arc ':label) "unnamed"))))) "Select a symbolic name to return many arcs:"))