;;; -*- mode:lisp; package:(graph global 1000); base:10.; -*- ;;; ;;; This file contains code to implement a new user interface, ;;; radically different from the previous. ;;; **************************************************************** ;;; Necessary Loads, Constants, Declarations. ;;; **************************************************************** #+franz (declare (macros t)) ; Allow macros (defvar *the-real-world* nil) (defvar *the-world* nil) ;;; Something you can signal to leave the graph editor. (defflavor exit () (condition)) (defmethod (exit :report) (&rest ignore) nil) #+Symbolics (tv:add-select-key #\G 'graph-display-window "Graph World" nil) #+LMI (tv:add-system-key #\G 'graph-display-window "Graph World" nil) (defconst *node-menu* (tv:make-window 'tv:momentary-menu ':label '(:string "Select a node operation:" :font #-3600 fonts:tr18b #+3600 fonts:bigfnt) ':item-list '(("Add an arc" :value :add-arc-to-self :font fonts:tr12b :documentation "Add an arc with tail at selected node.") ("Add arc with automatic name" :value :automatic-add-arc-to-self :font fonts:tr12b :documentation "Add an arc, automatically select a name.") ("Move this node" :value :move-self :font fonts:tr12b :documentation "Select a new location for this node with mouse.") ("Edit attributes" :value :edit-attributes :font fonts:tr12b :documentation "Selects a choose-variable-values menu of node attributes") ("Swap node with another" :value :interactive-exchange-node :font fonts:tr12b :documentation "Select another node, and exchange positions of the two.") ("Delete this node" :value :delete-self :font fonts:tr12b :documentation "Remove this node, and any arcs touching it.")))) (defconst *arc-menu* (tv:make-window 'tv:momentary-menu ':label '(:string "Select an arc operation:" :font #-3600 fonts:tr18b #+3600 fonts:bigfnt) ':item-list '(("Edit attributes" :value :edit-attributes :font fonts:tr12b :documentation "Selects a choose-variable-values menu of arc attributes") ("Delete this arc" :value :delete-self :font fonts:tr12b :documentation "Remove this arc.") ("Add Inflection Point" :value :add-inflection-points :font fonts:tr12b :documentation "Add new intermediate points for this arc.")))) (defconst *window-menu* (tv:make-window 'tv:momentary-menu ':label '(:string "Select a window operation:" :font #-3600 fonts:tr18b #+3600 fonts:bigfnt) ;;; make node is new, might need better doc. ':item-list '(("Make node" :value :make-node :font fonts:tr12b :documentation "Make a new node.") ("Change view" :value :interactive-edit-view :font fonts:tr12b :documentation "Expose a global view where you can change the zooming and view.") ("Go home" :value :go-home :font fonts:tr12b :documentation "Return to normal zoom, origin") ("Save graph" :value :interactive-save-graph :font fonts:tr12b :documentation "Save this graph in a file for later retrieval") ("Retrieve graph" :value :interactive-retrieve-graph :font fonts:tr12b :documentation "Retrieve a graph from a file without deleting the current one.") ("Toggle grid" :value :toggle-grid :font fonts:tr12b :documentation "Turn the grid on or off.") ("Refresh screen" :value :redraw :font fonts:tr12b :documentation "Redraw everything") ("Delete Everything" :value :interactive-delete-everything :font fonts:tr12b :documentation "Delete all nodes and arcs, after asking for confirmation") ;("Inspect Form" :value :interactive-inspect-form :font fonts:tr12i :documentation ; "Reads a form from the terminal, and graph-inspects it.") ("Move Many Nodes" :value :move-many-nodes :font fonts:tr12b :documentation "Select and move many nodes. Position relative to first node.") ("Delete Many Nodes" :value :delete-many-nodes :font fonts:tr12b :documentation "Select several nodes for deletion") ("Edit Many Nodes" :value :edit-many-nodes :font fonts:tr12b :documentation "Select several nodes for editing.") ("Remember Many Nodes" :value :remember-many-nodes :font fonts:tr12b :documentation "Remember several nodes with a symbolic name") ("Delete Many Arcs" :value :delete-many-arcs :font fonts:tr12b :documentation "Select several arcs for deletion") ("Edit Many Arcs" :value :edit-many-arcs :font fonts:tr12b :documentation "Select several arcs for editing.") ("Remember Many Arcs" :value :remember-many-arcs :font fonts:tr12b :documentation "Remember several arcs with a symbolic name") ("Delete arc's Inflection Point" :value :user-delete-inflection :font fonts:tr12 :documentation "Select an inflection point in an arc to be deleted.") ("Gridify Whole Graph" :value :gridify-whole-graph :font fonts:tr12b :documentation "Move all nodes to grid points.") ("Improve Layout" :value :improve-layout-some-nodes :font fonts:hl12b :documentation "Exchange some nodes to remove crossing arcs.") ("Improve Layout to the Max" :value :improve-layout-some-nodes-to-the-max :font fonts:hl12b :documentation "Do the best possible untangling of arcs, constrained to seleected nodes.") ("Exit Graph Editor" :eval (signal 'exit) :font fonts:hl12bi :documentation "Quietly leave the graph editor.") ))) ;;; **************************************************************** ;;; User Accessible Code ;;; **************************************************************** ;;; The only reason we do a SETQ *THE-WORLD* is for debugging. The ;;; correct thing to do is (setup) (run). (defun setup () (let* ((world (tv:make-window 'graph-display-window ':font-map '(fonts:tr12b) ':save-bits t ;Save screen array when deexposed ':blinker-p nil ;No blinker for cursor. :process '(graph-process-toplevel) )) (infinite-window (tv:make-window 'infinite-window ':blinker-p nil ':edges-from world))) (setq *node-names* *original-node-names* *the-world* world) (send world ':set-node-blinker (tv:make-blinker world 'tv:rectangular-blinker ':visibility ':off)) (send world ':set-arc-blinker (tv:make-blinker world 'tv:wide-curve-blinker ':visibility ':off)) (send world ':set-point-blinker (tv:make-blinker world 'tv:circular-blinker ':visibility ':off ':radius *circular-blinker-radius*)) (send world ':set-infinite-blinker (tv:make-blinker infinite-window 'tv:box-blinker ':visibility nil)) (send world ':set-infinite-window infinite-window) (setq *the-real-world* world) (send world :activate))) (defun run () (send *the-real-world* :select) (tv:await-window-exposure)) (defun graph-set-window-label (window) (send window ':set-label (format nil "Graph world. ~D node~:P, ~D arc~:P, Zoom: ~D x ~D." (length (send window ':nodes)) (length (send window ':arcs)) (send window ':zoomx) (send window ':zoomy)))) (defmethod (graph-display-window :after :select) () (graph-set-window-label self)) (defun graph-process-toplevel (terminal-io) (let ((window terminal-io)) (loop doing (catch 'system-exit (CATCH-ERROR-RESTART ((SI:ABORT ERROR) "return to toplevel loop") (condition-case () (with-near-objects-highlighted (:arc :node :point) (with-mouse-documentation window *over-nothing-doc* ;; Let mouse-moves change the documentation provided above. Hack, hack. (let-globally ((*mouse-documented* nil)) (loop initially (send window ':expose) do (tv:await-window-exposure) (graph-set-window-label window) ;; While waiting for user to hit a key, get the mouse-documentation ;;correct, depending on what the mouse is over. do (send window ':select) for keystroke = (send window :any-tyi) until (eq keystroke #\end) ;; While running command, let user abort. do (condition-case () ;; Figure out what user wants to do. (send window ':handle-graph-keystroke keystroke) (sys:abort (beep) (beep) ;; Now, bury the trackable windows, just in case, ;; and select the main window. (send *interact-window* ':bury) (send *zmacs-window* ':bury) (send *cvv-window* ':bury) (send window ':select))) finally (send window :bury))))) (sys:abort (beep) (beep)) (exit (send window :bury) (send window :untyi (send window :any-tyi))))))))) ;;; Every kind of graph window must handle this in order to run properly. ;;; This is a method so you can override it with a different flavor of ;;; graph window. ;;; Keystroke is something from the keyboard or the mouse. If it is from ;;; the mouse, it includes all sorts of goodies. Look at the method for ;;; :mouse-click to see what. (defmethod (graph-display-mixin :handle-graph-keystroke) (keystroke) (cond ((memq keystroke '(#\page #\control-l #+Symbolics #\Refresh)) (send self :redraw)) ((atom keystroke) (beep)) (t (let ((object (sixth keystroke)) (key (understand keystroke))) (cond ;; If object is null, we are over "free" space ((null object) (selectq key (:left (send self ':user-add-node nil keystroke)) (:ctrl-left (send self ':user-add-node t keystroke)) (:meta-left (send self ':go-home)) (:super-left (send self ':interactive-inspect-form)) (:hyper-left (send self ':interactive-save-graph)) (:middle (send self ':interactive-edit-view)) (:ctrl-middle (send self ':redraw)) (:meta-middle (send self ':toggle-grid)) (:super-middle (send self ':interactive-delete-everything)) (:hyper-middle (send self ':interactive-retrieve-graph)) ((:right :ctrl-right :meta-right :super-right :hyper-right) (send self ':display-menu)) (otherwise (beep)))) ((typep object 'basic-node) (selectq key (:left (send self ':user-add-arc nil object)) ((:ctrl-left :super-left :hyper-left) (send self ':user-add-arc t object)) ((:middle :super-middle :hyper-middle) (send object ':edit-attributes)) (:ctrl-middle (send object ':move-self)) (:meta-left (send object ':interactive-exchange-node)) (:meta-middle (send object ':delete-self)) ((:right :ctrl-right :meta-right :super-right :hyper-right) (send object ':display-menu)) (otherwise (beep)))) ((typep object 'basic-arc) (selectq key (:left (send object ':add-inflection-points)) ((:middle :super-middle :hyper-middle :meta-middle) (send object ':edit-attributes)) (:ctrl-middle (send object ':delete-self)) ((:right :ctrl-right :meta-right :super-right :hyper-right) (send object ':display-menu)) (otherwise (beep)))) ((listp object) ;Must be an inflection-point ;; object is (:point ) (let ((arc (second object)) (x (third object)) (y (fourth object))) (selectq key (:left (send arc ':delete-inflection-point x y)) (:middle (send arc ':move-inflection-point x y)) (otherwise (beep))))) (t (beep))))))) ;;; Returns a keyword representing the mouse-click. Encodes whether or not ;;; the HYPER, SUPER, META, or CTRL keys are down. We don't care about the ;;; number of clicks. (defun understand (key) (let ((button (ldb %%kbd-mouse-button (second key)))) (intern (string-append (if (nth 6. key) "CTRL-" "") (if (nth 7. key) "META-" "") (if (nth 8. key) "SUPER-" "") (if (nth 9. key) "HYPER-" "") (selectq button (0 "LEFT") (1 "MIDDLE") (2 "RIGHT"))) :keyword))) ;;Change-documention-lines is called by a user who wishes to modify the documentation ;;lines. Works by using the key words graph-doc, node-doc, arc-doc and point-doc. (defun change-documentation-lines (&key graph-doc node-doc arc-doc point-doc) (if graph-doc (setq *over-nothing-doc* graph-doc)) (if node-doc (setq *over-node-doc* node-doc)) (if arc-doc (setq *over-arc-doc* arc-doc)) (if point-doc (setq *over-point-doc* point-doc))) ;;Append-item-list is called by the user to append items to the menus *window-menu*, ;;*node-menu*, or *arc-menu*. The items to be added should be passed in with the ;;keywords window-item-list, node-item-list, or arc-item-list. (defun append-item-list (&key window-item-list node-item-list arc-item-list) (if window-item-list (send *window-menu* ':set-item-list (append window-item-list (send *window-menu* ':item-list)))) (if node-item-list (send *node-menu* ':set-item-list (append node-item-list (send *node-menu* ':item-list)))) (if arc-item-list (send *arc-menu* ':set-item-list (append arc-item-list (send *arc-menu* ':item-list))))) ;;Set-item-list is called by the user to change the items in the menus *window-menu*, ;;*node-menu*, or *arc-menu*. The item-list to be used should be passed in with the ;;keywords window-item-list, node-item-list, or arc-item-list. (defun set-item-list (&key window-item-list node-item-list arc-item-list) (if window-item-list (send *window-menu* ':set-item-list window-item-list)) (if node-item-list (send *node-menu* ':set-item-list node-item-list)) (if arc-item-list (send *arc-menu* ':set-item-list arc-item-list))) ;;; **************************************************************** ;;; Display Menu methods for the various flavors. ;;; **************************************************************** (defmethod (basic-node :display-menu) () (let ((choice (send *node-menu* ':choose))) (setq-globally tv:mouse-window window) ;Fix minor bug. (send self ':send-if-handles choice))) (defmethod (basic-arc :display-menu) () (let ((choice (send *arc-menu* ':choose))) (setq-globally tv:mouse-window window) ;Fix minor bug. (send self ':send-if-handles choice))) (defmethod (graph-display-mixin :display-menu) () (let ((choice (send *window-menu* ':choose))) (setq-globally tv:mouse-window self) ;Fix minor bug. (send self ':send-if-handles choice)))