;;; -*- mode:lisp; package: graph; base:10.;; Fonts: CPTFONT -*- ;;; ;;; ;;; This file contains code to implement ;;; $Log: /ct/lmcode/graph/utils.l,v $ ;;;Revision 1.6 84/08/03 09:26:50 linda ;;;fixed rel5-1 bug ;;; ;;;Revision 1.5 84/07/30 15:13:36 alfred ;;;5.1 bug fix. ;;; ;;;Revision 1.4 84/07/30 14:20:45 alfred ;;;5.1 bug fix. ;;; ;;;Revision 1.2 84/07/06 14:43:50 linda ;;;corrected an apparent typo in with-window-mouse-shape ;;; ;;;Revision 1.1 84/04/25 15:18:16 susan ;;;Initial revision ;;; ;;; **************************************************************** ;;; Necessary Loads, Constants, Declarations. ;;; **************************************************************** ;;; Seem to use this a lot. (defconst *pi* 3.14159265358979323) ;;; The size of circular-blinkers (defconst *circular-blinker-radius* 8.) ;; The default magnification (defconst *default-mag* 10.) (defconst *line-highlight-width* 6. "Width of line used to highlight arcs here and there.") ;;strings used for mouse documentation choices ;;These should correspond to how your :HANDLE-GRAPH-KEYSTROKE method deals ;; with mouse clicks. These values are just the defaults. (defconst *over-nothing-doc* '("UNSHIFTED: L: Make node. M: Edit view. R: Graph menu." "CTRL: L: Make node with name. M: Refresh screen. R: Graph menu." "META: L: Go home. M: Toggle grid. R: Graph menu." "SUPER: L: Inspect form. M: Delete everything. R: Graph menu." "HYPER: L: Save graph. M: Retrieve graph. R: Graph menu.")) (defconst *over-node-doc* '("UNSHIFTED: L: Make arc. M: Edit node. R: Node menu." "CTRL: L: Make arc with name. M: Move node. R: Node menu." "META: L: Swap node with other. M: Delete node. R: Node menu." "SUPER: L: Make arc. M: Edit node. R: Node menu." "HYPER: L: Make arc. M: Edit node. R: Node menu.")) (defconst *over-arc-doc* '("UNSHIFTED: L: Add inflection pts. M: Edit this arc. R: Arc menu." "CTRL: L: Beep. M: Delete this arc. R: Arc menu." "META: L: Beep. M: Edit this arc. R: Arc menu." "SUPER: L: Beep. M: Edit this arc. R: Arc menu." "HYPER: L: Beep. M: Edit this arc. R: Arc menu.")) (defconst *over-point-doc* '("UNSHIFTED: L: Delete this infl pt. M: Move this infl pt. R: Beep." "CTRL: L: Beep. M: Beep. R: Beep." "META: L: Beep. M: Beep. R: Beep." "SUPER: L: Beep. M: Beep. R: Beep." "HYPER: L: Beep. M: Beep. R: Beep.")) ;;; A special to keep around the node being editted. (defvar *current-node* nil) (defvar *current-window* nil) ;;; A special symbol used in the edit attributes facility. (defvar *zmacs-edit* nil) (defflavor editing-window () (tv:tracking-mixin zwei:standalone-editor-window tv:temporary-window-mixin)) ;;; Keep around just one window for editing, to save time. (defvar *zmacs-window* #-LMI (tv:make-window 'editing-window ':borders #+Symbolics '(tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border) #+LMI '(1 1 1 1) ':width 600. ':height 400. ':label "Type the key when done") #+LMI ;; this gets an error during loading. figure out why later #'(lambda (&rest ignored) nil) ) (defflavor trackable-temporary-choose-variable-values-window () (tv:tracking-mixin tv:temporary-choose-variable-values-window)) ;;; Why not just have one of these windows? This puts in a restriction ;;; that you can only use this one-at-a-time, but that isn't too onerous. ;;; It saves the trouble of having to make new ones, and set the font ;;; maps each time. You can't just supply a :FONT-MAP init option to ;;; make-window, since the :after :init method munges the filemap ;;; based on the xxx-font init options. (defvar *cvv-window* (tv:make-window 'trackable-temporary-choose-variable-values-window ':borders '(tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border tv:draw-gray-border) ':superior tv:mouse-sheet ':string-font fonts:tr12i ':name-font fonts:tr12 ':value-font fonts:tr12b ':unselected-choice-font fonts:tr10 ':selected-choice-font fonts:tr10b)) (defvar *drawing-inhibited* nil "Bind to T to prevent draw messages.") (defvar *mouse-documented* nil "Bind to T if you have specific mouse documentation that should not be overridden.") ;;; **************************************************************** ;;; Internal Macros, Structure Definitions, FLAVOR definitions. ;;; **************************************************************** ;;; Computes integer distance between two points (defmacro dist (x1 y1 x2 y2) `(isqrt (+ (sq (- ,x2 ,x1)) (sq (- ,y2 ,y1))))) (defflavor editable-attributes-mixin () () (:required-instance-variables drawn-p)) ;;square of a number (defmacro sq (x) `(* ,x ,x)) ;;; **************** ;;; to inhibit drawing ;;; **************** (defwrapper (editable-attributes-mixin :draw) (() . body) `(unless *drawing-inhibited* ,@body)) (defwrapper (editable-attributes-mixin :erase) (() . body) `(unless *drawing-inhibited* ,@body)) (defmacro with-drawing-inhibited (&body body) `(let ((*drawing-inhibited* t)) ,@body)) ;;; The following three macros were installed because we decided to make ;;; shape a component of the node or arc. The shape message is of type ;;; ':CASE, which means it dispatches on a sub-operation, which happens ;;; to be the shape of the object. These macros make it easy to send ;;; messages, since they ask the object for its shape for you. (defmacro draw (object) `(send ,object ':draw (send ,object ':shape))) (defmacro erase (object) `(send ,object ':erase (send ,object ':shape))) (defun periphery-point (object remote-x remote-y &optional delta headp) (send object ':periphery-point (send object ':shape) remote-x remote-y delta headp)) ;;; This is a total kludge. The old definition didn't work because ;;; the normal who-line documentation definitions don't work correctly ;;; when the mouse is grabbed. (defmacro with-mouse-documentation (window string-list &body body) `(let ((old-doc (send ,window ':mouse-documentation))) (let-globally ((tv:mouse-window ,window) (*mouse-documented* t)) (unwind-protect (progn (send ,window ':set-mouse-documentation ,string-list) ,@body) (send ,window ':set-mouse-documentation old-doc) )))) ;;; A simple way to flash an arc or node. (defmacro with-object-flashing (object &body body) `(unwind-protect (progn (send ,object ':flash t) ,@body) (send ,object ':flash nil))) (defmacro with-point-flashing (x y window &body body) `(let ((blink (tv:make-blinker ,window 'tv:circular-blinker ':x-pos (send ,window ':translate-x ,x) ':y-pos (send ,window ':translate-y ,y) ':radius *circular-blinker-radius* ':visibility ':blink))) (unwind-protect (progn ,@body) (send blink ':set-visibility nil)))) ;;; **************************************************************** ;;; Internal Code ;;; **************************************************************** ;;; What a kludge!! This started out to be something pretty simple. It ;;; really still is, but it is straining. With the EDIT-ATTRIBUTES message, ;;; you can modify any instance variable, as long as it is programmed correctly. ;;; :Edit-Attributes will not let you modify a pair of instance variables ;;; as a unit. To get the right editing, put properties on the names of the ;;; instance variables: ;;; ;;; :READ-ONLY The instance variable value is displayed, but can't be modified. ;;; :DONT-EDIT The iv is not displayed. ;;; :TYPE The instance variable can be edited. The type property should ;;; be one of the following: ;;; :STRING -- The value can be a string or nil. ;;; :NUMERIC -- The value can be a number. ;;; :EDIT -- The value is a string edited using ZMACS ;;; :WIDTH -- Exclusively for editing width of nodes using mouse. ;;; :HEIGHT -- Exclusively for editing height of nodes using mouse. ;;; :BOOLEAN -- The value is T or NIL ;;; (ch1 ch2 ...) -- The value is one of the choices. ;;; :PRETTY-PRINT Used when :READ-ONLY to format the IV nicely. ;;; These properties must be installed with graph-putprop. See NODE for some ;;; examples. If you make a new flavor of node or arc, you should use ;;; the flavor name for the secondary-indicator to graph-put. (defmethod (editable-attributes-mixin :edit-attributes) (&optional (copyable-attributes-only nil)) (let* ((gensym-list nil) (flavor (typep self)) (cvv-label (if copyable-attributes-only (format nil "Editing object ~A AND OTHER OBJECTS" (or (send self ':send-if-handles ':label) "")) (format nil "Editing object ~A, of flavor ~A" (or (send self ':send-if-handles ':label) "") (typep self)))) (iv-list (loop for iv in (si:flavor-all-instance-variables (get (typep self) 'si:flavor)) for gs = (gensym) unless (graph-get flavor iv ':dont-edit) collect iv and do (set gs (send self (intern iv :keyword))) and collect gs into temp-list finally (setq gensym-list temp-list))) (menu-list (append (list "Changeable Attributes:") (loop for gensym in gensym-list for iv in iv-list unless (or (and copyable-attributes-only (not (graph-get flavor iv ':copyable))) (graph-get flavor iv ':read-only)) collect (generate-menu-item gensym iv flavor)) (list "" "Non-changeable Attributes: ") (loop for iv in iv-list if (or (and copyable-attributes-only (not (graph-get flavor iv ':copyable))) (graph-get flavor iv ':read-only)) collect (format nil "~A: ~A" (string iv) (let ((fn (graph-get flavor iv ':pretty-print))) (if fn (funcall fn (send self (intern iv :keyword))) (send self (intern iv :keyword))))))))) ;; The catch is here for the ABORT ;; menu choice that does a *throw with a value of NIL. (when (*catch 'tvcvv ;; Bind up object and window to allow some kludges in editing. (let ((*current-node* self) (*current-window* (send self ':window))) (improved-choose-variable-values menu-list cvv-label)) t) ;; Check to see if any of the ':printable instance variables ;; have changed. ONLY if one of these changes do we actually erase ;; and print. (let ((p-i-c (loop for iv in iv-list for gs in gensym-list if (and (graph-get flavor iv ':printable) (not (let ((alphabetic-case-affects-string-comparison t)) (equal (symeval gs) (send self (intern iv :keyword)))))) return t)) ;; Collect a list which has T if an instance variable has not ;; changed, or NIL if it has. We have to do this, because later ;; when we send all the SET- messages, there may be side-effects ;; that cause other instance variables to change, and thus thes ;; saved values that we have in the gensyms will APPEAR to be ;; different. If we had a kind of "parallel" loop down below, ;; it wouldn't be a problem. (ivs (loop for iv in iv-list for gs in gensym-list collect (equal (symeval gs) (send self (intern iv :keyword)))))) ;; If printable instance changed, clear. (if p-i-c (erase self)) ;; Don't draw or erase anything while we munge the instance variables. (with-drawing-inhibited (loop for gensym in gensym-list for iv in iv-list for same in ivs unless (or (graph-get flavor iv ':read-only) same) do (send self (intern (format nil "SET-~A" iv) :keyword) (symeval gensym)))) ;; If printable instance changed, redraw. (if p-i-c (draw self)) ;; Return T to indicate we did edit successfully t)))) ;;; Generate the item descriptions for CHOOSE-VARIABLE-VALUES. Perhaps we ;;; should have used better names, but it is too late now. (defun generate-menu-item (gensym iv flavor) (let ((item-type (graph-get flavor iv ':type))) (selectq item-type (:numeric (list gensym (string iv) ':number)) (:string (list gensym (string iv) ':string-or-nil)) ;; Note the special care that went into these three options. They ;; are set up so that if you click, the CVV menu goes away for a while ;; while some other editing operation happens. (:edit (list gensym (string iv) ':assoc '(("Click here to use ZMACS to edit this." . :edit-this-variable)))) (:height ; (list gensym (format nil "Current height: ~D." (symeval gensym)) ; ':assoc '(("Click here to modify with mouse." . :change-the-height)))) (list gensym "Current height" :positive-number)) (:width ; (list gensym (format nil "Current width: ~D." (symeval gensym)) ; ':assoc '(("Click here to modify with mouse" . :change-the-width)))) (list gensym "Current width" :positive-number)) (:boolean (list gensym (string iv) ':boolean)) (otherwise (list gensym (string iv) ':choose item-type))))) ;;; Allows you to edit a string. Pops up a ZMACS window, allows editing ;;; until the user hits the END key, then returns to the CVV menu. (defun edit-string (string) (send *zmacs-window* ':set-interval-string string) (send *zmacs-window* ':expose-near '(:mouse)) (send *zmacs-window* ':select) (send *zmacs-window* ':edit) (prog1 (send *zmacs-window* ':interval-string) (send *zmacs-window* ':bury))) ;;; This is similar to the with-mouse-shape macro in gwindow but uses the current ;;; window instead of self (defmacro with-window-mouse-shape (shape &body body) `(unwind-protect (progn (send *current-window* ':set-mouse-cursor ,shape) ,@body ) (send *current-window* ':set-mouse-cursor 6.))) ;;; #/ ))) ;;; Edits the width of a node. You get to hold down the mouse button, and ;;; move the mouse around. The distance from the center of the node to the ;;; mouse is the new half-width. A rubber-band rectangle shows the new ;;; containing rectangle for the node. We use the NODE BLINKER that the window ;;; already knows about, since it is the right type. (defun edit-width (node) (let* ((zoomx (send *current-window* ':zoomx)) (zoomy (send *current-window* ':zoomy)) (width (// (send node ':width) zoomx)) (height (// (send node ':height) zoomy)) (x (send *current-window* ':translate-x (send node ':x))) (y (send *current-window* ':translate-y (send node ':y))) (sheet-x nil) (blinker (send *current-window* ':node-blinker))) (multiple-value (sheet-x nil) (tv:sheet-calculate-offsets *current-window* tv:main-screen)) ;; Adjust the size and position of the blinker to correspond to the ;; node's present size and location. (send blinker ':set-size-and-cursorpos width height (- x (// width 2)) (- y (// height 2))) (tv:with-mouse-grabbed (with-mouse-documentation *current-window* '("Hold left button down to change the width") (with-window-mouse-shape 5. ;;; #/ ;; Turn on the blinker (send blinker ':set-visibility t) ;; Wait for user to hold down left button (loop do (tv:mouse-wait) until (= tv:mouse-last-buttons 1.)) ;; Keep updating the size of the blinker until the user ;; lets go of the left button. (loop do (tv:mouse-wait) for xx = (abs (- x tv:mouse-x)) ;Distance from center of node to mouse. do (send blinker ':set-size-and-cursorpos (* xx 2.) height (- x xx) (- y (// height 2))) until (= tv:mouse-last-buttons 0.)) ;; Turn the blinker back off. (send blinker ':set-visibility nil)))) (setq width (send blinker ':size)) ;; (let ((*drawing-inhibited* nil)) ;Temporarily allow drawing. ;; (send node ':set-width (* zoomx width))) (* zoomx width))) ;;; Works just like edit-width, above. (defun edit-height (node) (let* ((zoomx (send *current-window* ':zoomx)) (zoomy (send *current-window* ':zoomy)) (width (// (send node ':width) zoomx)) (height (// (send node ':height) zoomy)) (x (send *current-window* ':translate-x (send node ':x))) (y (send *current-window* ':translate-y (send node ':y))) (sheet-y nil) (blinker (send *current-window* ':node-blinker))) (multiple-value (nil sheet-y) (tv:sheet-calculate-offsets *current-window* tv:main-screen)) ;; Adjust the size and position of the blinker to correspond to the ;; node's present size and location. (send blinker ':set-size-and-cursorpos width height (- x (// width 2)) (- y (// height 2))) (tv:with-mouse-grabbed (with-mouse-documentation *current-window* '("Hold left button down to change the height") (with-window-mouse-shape 4. ;;; #/ ;; Turn on the blinker (send blinker ':set-visibility t) ;; Wait for user to hold down left button (loop do (tv:mouse-wait) until (= tv:mouse-last-buttons 1.)) ;; Keep updating the size of the blinker until the user ;; lets go of the left button. (loop do (tv:mouse-wait) for yy = (abs (- y (- tv:mouse-y sheet-y))) do (send blinker ':set-size-and-cursorpos width (* yy 2) (- x (// width 2)) (- y yy)) until (= tv:mouse-last-buttons 0.)) ;; Turn the blinker back off. (send blinker ':set-visibility nil)))) (multiple-value (nil height) (send blinker ':size)) ;; (let ((*drawing-inhibited* nil)) ;Temporarily allow drawing. ;; (send node ':set-height (* zoomy height))) (* zoomy height))) ;;; This function runs each time the user makes some selection in the ;;; Choose-Variable-Values menu. It checks for specific selections which ;;; indicate some other editing operation should occur. (See GENERATE-MENU-ITEM ;;; for more details.) (defun after-choice (window var old new) (cond ((eq new ':edit-this-variable) (send window ':bury) (set var (edit-string old)) (send window ':select)) ((eq new ':change-the-height) (send window ':bury) (set var (edit-height *current-node*)) (send window ':select)) ((eq new ':change-the-width) (send window ':bury) (set var (edit-width *current-node*)) (send window ':select)))) ;;; Our version of choose-variable values. It has margin choices including ;;; ABORT which leaves without ;;; making any changes (does this via *throw). Finally, this automatically ;;; calls the AFTER-CHOICE function each time the user changes anything. #+LMI (defun improved-choose-variable-values (menu-list label) (tv:choose-variable-values menu-list :label label :margin-choices '("Make changes" ("ABORT, ignore changes" (*throw 'tvcvv nil))))) #+Symbolics (defun improved-choose-variable-values (menu-list label) (let ((width nil) (osw nil) ;old selected window (margin-choices ;; This is a "pre-compiled" version of the margin-choices. If you look ;; at the code for tv:c-v-v, you will see it does a mapcar over the list ;; users are expected to provide. Here, we go ahead and supply it, to ;; save time and consing. '(("Make Changes" nil tv:choose-variable-values-choice-box-handler nil nil nil) ("ABORT, ignore changes" nil tv:choose-variable-values-choice-box-handler nil nil (*throw 'tvcvv nil))))) ;;Make sure all variables are bound, while in caller's environment (dolist (elem menu-list) (if (listp elem) (setq elem (car elem))) (cond ((symbolp elem) (symeval elem)) ((eq (data-type elem) 'locative) (setq elem (car elem))) ;force compiler ((stringp elem)) (t (ferror nil "~s is a ~s bad data type for variable" elem (data-type elem))))) (funcall *cvv-window* ':setup menu-list label #'after-choice margin-choices) (setq width (funcall *cvv-window* ':appropriate-width 10.)) (funcall *cvv-window* ':adjust-geometry-for-new-variables width) (setq osw tv:selected-window) (unwind-protect ; (let ((iob (funcall *cvv-window* ':io-buffer))) (tv:io-buffer-clear iob) (tv:delaying-screen-management (tv:expose-window-near *cvv-window* '(:mouse)) (funcall *cvv-window* ':select) (send *cvv-window* ':select)) ;for who-line (let-globally ((tv:mouse-window *cvv-window*)) (do () (nil) (process-wait "Do something!!" #'(lambda (iob) (not (tv:io-buffer-empty-p iob))) iob) (and (tv:choose-variable-values-process-message *cvv-window* (funcall *cvv-window* ':any-tyi)) (return nil))))) (tv:delaying-screen-management (funcall *cvv-window* ':deactivate) ;formerly ':Deactivate (and osw (funcall osw ':select nil)))))) ;;; Improved way of printing strings. If the string is nil, print lots ;;; of spaces to make it easy to mouse. ;;; ******* ;;; Fix this redefinition by binding fs:inhibit-fdefine-warnings or something like it. (defun tv:print-string-or-nil (string stream) (if string (send stream ':string-out string) (send stream ':string-out " "))) ;;; Send this to an arc to copy instance variables from another arc. You can optionally ;;; supply a list of instance variables over which to copy instead of the copyable ones. (defmethod (editable-attributes-mixin :copy-attributes) (source-object &optional (iv-list nil supplied-p)) (loop for iv in (if supplied-p iv-list (si:flavor-all-instance-variables (get (typep self) 'si:flavor))) if (or supplied-p (graph-get (typep self) iv ':copyable)) do (send self (intern (format nil "SET-~A" iv) :keyword) (send source-object (intern iv :keyword)))) (send self ':set-drawn-p nil) (draw self)) ;;; Returns a list of instance variables. The user gets to select them from a multiple ;;; choice menu. (defmethod (editable-attributes-mixin :select-ivs-for-copying) (&optional (label "Select instance variables:")) (let* ((items (loop for iv in (si:flavor-all-instance-variables (get (typep self) 'si:flavor)) if (graph-get (typep self) iv ':copyable) collect (cons (format nil "~A, with value ~A" iv (send self (intern iv :keyword))) iv))) (menu (tv:make-window 'tv:multiple-menu ':font-map '(fonts:tr12b fonts:hl12i) ':label label ':item-list items ':highlighted-items items ))) (send menu ':expose-near '(:mouse)) (prog1 (send menu ':choose) (send menu ':bury) (send (send self ':window) ':select)))) ;;; **************************************************************** ;;; Arithmetic Stuff ;;; **************************************************************** ;;; I suppose we could have put in a condition handler, but this ;;; seems straitforward enough. ;;; We need to protect ATAN and ATAN2 from getting bad input. (defun safe-atan (y x) (if (and (zerop y) (zerop x)) 0 (atan y x))) (defun safe-atan2 (y x) (if (and (zerop y) (zerop x)) 0 (atan2 y x))) ;;; **************************************************************** ;;; Graph versions of putprop and get ;;; **************************************************************** ;;; The location of all graph properties. There must be a better ;;; way to do this simply. CLEARLY, Lisp needs a primitive for ;;; multiple indexing into a property list, or something like that. (defvar *graph-properties-list* nil) (defvar *list-of-three* (list t nil t)) (defun graph-putprop (flavor iv-name value indicator) (push value (si:flavor-plist (get flavor 'si:flavor))) (push (cons iv-name indicator) (si:flavor-plist (get flavor 'si:flavor)))) (defun graph-get (flavor iv-name indicator) (loop for parent in (si:flavor-depends-on-all (get flavor 'si:flavor)) do (multiple-value-bind (value not-found) (search-plist iv-name indicator (si:flavor-plist (get parent 'si:flavor))) (unless not-found (return value))) finally (return nil))) ;;; Get a flavor object from an object ;;;(get (typep ) 'si:flavor) ;;; Searches a flavor property list for one of our special two-indicator ;;;properties. Does this without consing. If not found, returns a second ;;; value of T. (defun search-plist (ind1 ind2 plist) (loop for (indicator value . rest) on plist by 'cddr if (and (not (atom indicator)) ;kludge since CONSP not present. (eq ind1 (car indicator)) (eq ind2 (cdr indicator))) return value finally (return (values nil t))))