;;; -*- mode:lisp; package:(graph global 1000); base:10.; -*- ;;; ;;; ;;; This file contains code to implement ;;; **************** ;;; Comments about ARCS ;;; **************** ;;; Arcs are one of the primary objects of interest in the graph ;;; display system. You cannot add any arcs, though, until you have some ;;; nodes. Every arc has a head and a tail, although in general, there is ;;; no distinction placed on the difference. There are DIRECTED arcs for ;;; whom there is a distinction; directed arcs are drawn with an arrow-head ;;; to indicate their directed nature. ;;; $Log: /ct/lmcode/graph/arc.l,v $ ;;;Revision 1.3 84/08/03 09:22:12 linda ;;;fixed rel5-1 bug ;;; ;;;Revision 1.2 84/07/30 11:25:13 alfred ;;;Release 5.1 initial version. ;;; ;;;Revision 1.1 84/04/25 15:03:11 susan ;;;Initial revision ;;; ;;; **************************************************************** ;;; Necessary Loads, Constants, Declarations. ;;; **************************************************************** (defconst *display-types* '(:solid :dashed :dotted :spline :wide-spline) "The different ways of displaying an arc. These do not affect the direction of the arc, but merely how we draw it.") (defconst *arrow-angle* 0.700016 "This must be exactly this number or it won't work.") (defconst *arrow-size* 200. "This must not be exactly this number or it won't work.") (defconst *negative-infinity* -99999999) ;;; The amount you can be away from a line and still be near it. (defconst *near-qty* 2.) ;;; What percentage of the maximum segment length must a segment ;;; be to be considered long enough to label. (defconst *long-enough* 0.7) ;;; What slope is considered "gentle" enough for labelling a ;;; segment. Should be about 40 degrees. (defconst *gentle-slope* (// *pi* 6.0)) ;;; **************************************************************** ;;; Internal Macros, Structure Definitions, FLAVOR definitions. ;;; **************************************************************** ;;; Minimal arc is undirected. ;;;;;;;;;;;;;;; (defflavor basic-arc ;;;;;;;;;;;;;;; ((head nil) (tail nil) (shape ':solid) ;one of *display-types* (name (format nil "Node-~A-~D" (time:print-current-time nil) (time))) (label nil) (label-length 700.) (label-draw-type ':attached) (drawn-p nil) (window nil) (joint-points nil) ;Endpoints of line-segments (lengths nil) ;Lengths of line-segments. (head-arrow-p nil) (tail-arrow-p nil) (changed-p nil) ;have joint-points changed since ;last highlighted? (flash-blinker nil) ;blinker used for flashing. (informal-description "This arc has no description")) (editable-attributes-mixin) (:method-combination (:case :base-flavor-last :draw :erase)) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) (graph-putprop 'basic-arc 'head t ':read-only) (graph-putprop 'basic-arc 'head '(lambda (head) (format nil "The head points to a node of type ~A." (typep head))) ':pretty-print) (graph-putprop 'basic-arc 'tail t ':read-only) (graph-putprop 'basic-arc 'tail #'(lambda (tail) (format nil "The tail points to a node of type ~A." (typep tail))) ':pretty-print) (graph-putprop 'basic-arc 'label ':string ':type) (graph-putprop 'basic-arc 'label t ':printable) (graph-putprop 'basic-arc 'label-draw-type '(:attached :vector) ':type) (graph-putprop 'basic-arc 'label-draw-type t ':copyable) (graph-putprop 'basic-arc 'label-draw-type t ':printable) (graph-putprop 'basic-arc 'name t ':read-only) (graph-putprop 'basic-arc 'shape *display-types* ':type) (graph-putprop 'basic-arc 'shape t ':printable) (graph-putprop 'basic-arc 'shape t ':copyable) (graph-putprop 'basic-arc 'drawn-p t ':dont-edit) (graph-putprop 'basic-arc 'drawn-p t ':dont-print-to-file) (graph-putprop 'basic-arc 'window t ':dont-edit) (graph-putprop 'basic-arc 'window t ':dont-print-to-file) (graph-putprop 'basic-arc 'window nil ':dont-save-this-object-to-file) (graph-putprop 'basic-arc 'window nil ':dont-retrieve-this-object-from-file) (graph-putprop 'basic-arc 'changed-p t ':dont-edit) (graph-putprop 'basic-arc 'changed-p t ':dont-print-to-file) (graph-putprop 'basic-arc 'flash-blinker t ':dont-edit) (graph-putprop 'basic-arc 'flash-blinker t ':dont-print-to-file) (graph-putprop 'basic-arc 'joint-points t ':read-only) (graph-putprop 'basic-arc 'joint-points #'(lambda (joint-points) (format nil "Arc has ~D segment~:P." (1- (// (length joint-points) 2)))) ':pretty-print) (graph-putprop 'basic-arc 'lengths t ':dont-edit) (graph-putprop 'basic-arc 'head-arrow-p ':boolean ':type) (graph-putprop 'basic-arc 'head-arrow-p t :copyable) (graph-putprop 'basic-arc 'head-arrow-p t ':printable) (graph-putprop 'basic-arc 'tail-arrow-p ':boolean ':type) (graph-putprop 'basic-arc 'tail-arrow-p t :copyable) (graph-putprop 'basic-arc 'tail-arrow-p t ':printable) (graph-putprop 'basic-arc 'label-length ':numeric ':type) (graph-putprop 'basic-arc 'label-length t ':printable) (graph-putprop 'basic-arc 'informal-description ':edit ':type) ;;; **************************************************************** ;;; Internal Code ;;; **************************************************************** ;;; **************************************************************** ;;; Arc methods. ;;; **************************************************************** ;;; Before drawing an arc, check to see if it needs erasing. Afterwards, ;;; draw any head or tail arrows. ;;; Labels are done in an unusual manner. If there is only one segment, ;;; we draw the label attached to the middle of the segment, and send it ;;; in the "right" direction, depending on the slope of the segment. ;;; If there are multiple segments, we attach the label to the "middle" ;;; joint-point, and draw to the right, UNLESS either of the adjacent ;;; joint-points are above-and-to-the-right of the point under consideration, ;;; in which case we draw the label to the left. make sense?? (defwhopper (basic-arc :draw) (suboperation) (if drawn-p (erase self)) (setq drawn-p t) (continue-whopper suboperation) (if head-arrow-p (send self ':draw-head-arrow)) (if tail-arrow-p (send self ':draw-tail-arrow)) (when label (if (eq label-draw-type ':attached) (if (= (length joint-points) 4) ;If just one segment (let ((best-seg joint-points)) (multiple-value-bind (x y) (best-midpoint (first best-seg) (second best-seg) (third best-seg) (fourth best-seg)) (send window ':draw-underlined-graph-string label (horizontal-p best-seg) x y label-length (pos-slope-p (first best-seg) (second best-seg) (third best-seg) (fourth best-seg))))) (let ((midpoint (nthcdr (- (* 2 (// (length joint-points) 4.)) 2) joint-points))) (send window ':draw-underlined-graph-string label nil (third midpoint) (fourth midpoint) label-length (either-to-right-or-up (third midpoint) (fourth midpoint) (first midpoint) (second midpoint) (fifth midpoint) (sixth midpoint))))) (send self ':draw-vector-label)))) (defwhopper (basic-arc :erase) (suboperation) (if head-arrow-p (send self ':erase-head-arrow)) (if tail-arrow-p (send self ':erase-tail-arrow)) (continue-whopper suboperation) (when label (if (eq label-draw-type ':attached) (if (= (length joint-points) 4) ;If just one segment (let ((best-seg joint-points)) (multiple-value-bind (x y) (best-midpoint (first best-seg) (second best-seg) (third best-seg) (fourth best-seg)) (send window ':erase-underlined-graph-string label (horizontal-p best-seg) x y label-length (pos-slope-p (first best-seg) (second best-seg) (third best-seg) (fourth best-seg))))) (let ((midpoint (nthcdr (- (* 2 (// (length joint-points) 4.)) 2) joint-points))) (send window ':erase-underlined-graph-string label nil (third midpoint) (fourth midpoint) label-length (either-to-right-or-up (third midpoint) (fourth midpoint) (first midpoint) (second midpoint) (fifth midpoint) (sixth midpoint))))) (send self ':erase-vector-label))) (setq drawn-p nil)) ;;; Checks to see if pt2 or pt3 is to the right of or above pt1 (defun either-to-right-or-up (x1 y1 x2 y2 x3 y3) (or (and (> x2 x1) (< y2 y1)) (and (> x3 x1) (< y3 y1)))) ;;; Check to see if this arc is parallel to another. (defmethod (basic-arc :parallel-to-another-arc-p) () (loop for arc in (remq self (send head ':arcs)) for h = (send arc ':head) for tl = (send arc ':tail) if (or (and (eq head h) (eq tail tl)) (and (eq head tl) (eq tail h))) return t)) ;;; Rewritten to only recalculate the end points. (defmethod (basic-arc :compute-joint-points) () (let* ((cip (send self ':parallel-to-another-arc-p)) (head-arc-list (send head ':arcs)) (tail-arc-list (send tail ':arcs)) (len (length joint-points)) (head-nth (if cip (- (length head-arc-list) (find-position-in-list self head-arc-list)) 0)) (tail-nth (if cip (- (length tail-arc-list) (find-position-in-list self tail-arc-list)) 0)) (inflect-p (> len 4))) (multiple-value-bind (head-x head-y) (periphery-point head (if inflect-p (third joint-points) (send tail ':x)) (if inflect-p (fourth joint-points) (send tail ':y)) head-nth t) (multiple-value-bind (tail-x tail-y) (periphery-point tail (if inflect-p (nth (- len 4) joint-points) (send head ':x)) (if inflect-p (nth (- len 3) joint-points) (send head ':y)) tail-nth nil) (if (null joint-points) (setq joint-points (list head-x head-y tail-x tail-y)) (progn (setf (first joint-points) head-x) (setf (second joint-points) head-y) (setf (nth (- len 2) joint-points) tail-x) (setf (first (last joint-points)) tail-y))))))) (defmethod (basic-arc :after :compute-joint-points) () (send self ':compute-lengths)) ;;; After computing the endpoints of all the line segments, compute the ;;; lengths of each of the segments. These lengths are used in the NEAR ;;; calculations, and since highlighting requires NEAR, the lengths are needed ;;; thousands of times. Keeping a list of them will cut down drastically on ;;; computation required. (defmethod (basic-arc :compute-lengths) () (setq changed-p t) (setq lengths (loop for (x1 y1 x2 y2 . rest) on joint-points by 'cddr until (null x2) collect (dist x1 y1 x2 y2)))) ;;see whether this arc is viewable or not ;; Shouldn't need this. (defmethod (basic-arc :viewable-p) () (or (send head ':viewable-p) (send tail ':viewable-p))) ;;; **************************************************************** ;;; Drawing (and erasing) the body of an arc. ;;; **************************************************************** ;;; To draw an arc, you need to ask for the periphery points of ;;; each node to which the arc is attached. (defmethod (basic-arc :otherwise :draw) (ignore) (lexpr-send window ':draw-graph-lines joint-points)) ;;; don't erase if null arc. (defmethod (basic-arc :otherwise :erase) (ignore) (when (neq head tail) (lexpr-send window ':erase-graph-lines joint-points))) (defmethod (basic-arc :case :draw :dotted) () (lexpr-send window ':draw-dotted-graph-lines t joint-points)) (defmethod (basic-arc :case :erase :dotted) () (lexpr-send window ':draw-dotted-graph-lines nil joint-points)) (defmethod (basic-arc :case :draw :dashed) () (lexpr-send window ':draw-dashed-graph-lines t joint-points)) (defmethod (basic-arc :case :erase :dashed) () (lexpr-send window ':draw-dashed-graph-lines nil joint-points)) (defmethod (basic-arc :case :draw :spline) () (lexpr-send window ':draw-spline-graph-line t 1 joint-points)) (defmethod (basic-arc :case :erase :spline) () (lexpr-send window ':draw-spline-graph-line nil 1 joint-points)) (defmethod (basic-arc :case :draw :wide-spline) () (lexpr-send window ':draw-spline-graph-line t 3 joint-points)) (defmethod (basic-arc :case :erase :wide-spline) () (lexpr-send window ':draw-spline-graph-line nil 3 joint-points)) ;;; Returns a list of x y points that define the line(s) that make an arc. (defmethod (basic-arc :get-points) () joint-points) ;;; Returns T if the specified point is near the arc. This is easy, since ;;; all arcs are specified by a series of (one or more) line-segments. To ;;; check nearness to the arc, we just look at each of the line segments in ;;; succession. (defmethod (basic-arc :near-point) (x y) (loop for (x1 y1 x2 y2 . rest) on joint-points by 'cddr for length in lengths ;length of the line-segment defined ;by x1 y1 x2 y2. until (null x2) ; Don't cddr too far. if ( (+ (dist x y x1 y1) (dist x y x2 y2)) (+ *near-qty* (max length 150.))) return t)) ;;; Use this to save a arc. This produces code that make-instance should ;;; be pretty happy with, EXCEPT that the head and tail values return numbers. ;;; These numbers are the relative positions of the nodes in the total list ;;; of arcs. During restoration, we need to translate these back. (defmethod (basic-arc :display) (stream) (format stream "(graph:~S . ~S)~%" (typep self) (loop for iv in (si:flavor-all-instance-variables (get (typep self) 'si:flavor)) for uiv = (intern iv ':keyword) for val = (send self uiv) unless (graph-get (typep self) iv ':dont-print-to-file) collect uiv AND collect (cond ((eq uiv ':font) (zwei:font-name val)) ((memq uiv '(:head :tail)) (find-position-in-list val (send (send self ':window) ':nodes))) (t val))))) ;;; **************** ;;; Arc FLASHING ;;; **************** ;;; See also (in utils) macro with-object-flashing for an easy ;;; interface to this feature. (defmethod (basic-arc :flash) (status) ;; If there isn't a blinker yet, make one. (unless flash-blinker (setq flash-blinker (tv:make-blinker window 'tv:wide-curve-blinker))) ;; If turning on, set size and position (when status (send flash-blinker ':set-arc self) (send flash-blinker ':set-points window (send self ':get-points))) ;; Either start blinker blinking, or turn it off. (send flash-blinker ':set-visibility (if status ':blink))) ;;; **************** ;;; Stuff for menu operations ;;; **************** (defmethod (basic-arc :delete-self) () #+cadr (sys:%slide 50 2 200 1000000) (send window ':delete-arc self)) ;;; **************************************************************** ;;; Inflection points ;;; **************************************************************** ;;; This is mostly just for fun. ;;; ;;; This code allows a user to add new inflection points for the ;;; arc. They are not recomputed if the arc recomputes its joint-points. ;;; Thus, if either head or tail moves, the inflection points are lost. ;;; Use this to add new inflection points (defmethod (basic-arc :add-inflection-points) () (with-object-flashing self (with-object-flashing head (let ((points (send window ':get-many-positions))) (erase self) ;before we don't know how. (setf (cddr joint-points) (nconc points (cddr joint-points)))))) (send self ':compute-joint-points) (draw self)) (defmethod (basic-arc :delete-inflection-point) (x y) (erase self) (loop for ptr on joint-points by 'cddr until (null (cddddr ptr)) if (and (= x (third ptr)) (= y (fourth ptr))) return (setf (cddr ptr) (cddddr ptr))) (send self ':compute-joint-points) (draw self)) (defmethod (basic-arc :move-inflection-point) (x y) (with-point-flashing x y window (let ((new-pos (send window ':get-position))) (erase self) (loop for ptr on (cddr joint-points) by 'cddr until (null (cddr ptr)) if (and (= x (first ptr)) (= y (second ptr))) return (progn (setf (first ptr) (first new-pos)) (setf (second ptr) (second new-pos)))) (send self ':compute-joint-points) (draw self)))) ;;; **************************************************************** ;;; Arrow Arc methods. ;;; **************************************************************** ;;; The majority of the effort in drawing an arrow'ed arc is in computing ;;; the triangle that is the arrow-head. (defmethod (basic-arc :draw-head-arrow) () (when (neq head tail) (let* ((head-x (first joint-points)) (head-y (second joint-points)) (tail-x (third joint-points)) (tail-y (fourth joint-points)) (theta (safe-atan (- tail-y head-y) (- tail-x head-x))) (x1 (+ head-x (* (cos (+ theta *arrow-angle*)) *arrow-size*))) (y1 (+ head-y (* (sin (+ theta *arrow-angle*)) *arrow-size*))) (x2 (+ head-x (* (cos (- theta *arrow-angle*)) *arrow-size*))) (y2 (+ head-y (* (sin (- theta *arrow-angle*)) *arrow-size*)))) (send window ':draw-graph-triangle head-x head-y x1 y1 x2 y2)))) (defmethod (basic-arc :draw-tail-arrow) () (when (neq head tail) (let* ((fourth-tail (nthcdr (- (length joint-points) 4) joint-points)) (head-x (third fourth-tail)) (head-y (fourth fourth-tail)) (tail-x (first fourth-tail)) (tail-y (second fourth-tail)) (theta (safe-atan (- tail-y head-y) (- tail-x head-x))) (x1 (+ head-x (* (cos (+ theta *arrow-angle*)) *arrow-size*))) (y1 (+ head-y (* (sin (+ theta *arrow-angle*)) *arrow-size*))) (x2 (+ head-x (* (cos (- theta *arrow-angle*)) *arrow-size*))) (y2 (+ head-y (* (sin (- theta *arrow-angle*)) *arrow-size*)))) (send window ':draw-graph-triangle head-x head-y x1 y1 x2 y2)))) (defmethod (basic-arc :erase-head-arrow) () (when (neq head tail) (let* ((head-x (first joint-points)) (head-y (second joint-points)) (tail-x (third joint-points)) (tail-y (fourth joint-points)) (theta (safe-atan (- tail-y head-y) (- tail-x head-x))) (x1 (+ head-x (* (cos (+ theta *arrow-angle*)) *arrow-size*))) (y1 (+ head-y (* (sin (+ theta *arrow-angle*)) *arrow-size*))) (x2 (+ head-x (* (cos (- theta *arrow-angle*)) *arrow-size*))) (y2 (+ head-y (* (sin (- theta *arrow-angle*)) *arrow-size*)))) (send window ':erase-graph-triangle head-x head-y x1 y1 x2 y2)))) (defmethod (basic-arc :erase-tail-arrow) () (when (neq head tail) (let* ((fourth-tail (nthcdr (- (length joint-points) 4) joint-points)) (head-x (third fourth-tail)) (head-y (fourth fourth-tail)) (tail-x (first fourth-tail)) (tail-y (second fourth-tail)) (theta (safe-atan (- tail-y head-y) (- tail-x head-x))) (x1 (+ head-x (* (cos (+ theta *arrow-angle*)) *arrow-size*))) (y1 (+ head-y (* (sin (+ theta *arrow-angle*)) *arrow-size*))) (x2 (+ head-x (* (cos (- theta *arrow-angle*)) *arrow-size*))) (y2 (+ head-y (* (sin (- theta *arrow-angle*)) *arrow-size*)))) (send window ':erase-graph-triangle head-x head-y x1 y1 x2 y2)))) ;;; **************************************************************** ;;; Labels ;;; **************************************************************** (defmethod (basic-arc :draw-vector-label) () (let ((segment (nthcdr (* 2 (send self ':choose-best-segment)) joint-points))) (send window ':draw-vector-string (string-upcase label) (send window ':translate-x (first segment)) (- (send window ':translate-y (second segment)) 10.) (send window ':translate-x (third segment)) (- (send window ':translate-y (fourth segment)) 10.) ':wide 8. ':high 8. ':font ':standard))) (defmethod (basic-arc :erase-vector-label) () (let ((segment (nthcdr (* 2 (send self ':choose-best-segment)) joint-points))) (send window ':draw-vector-string (string-upcase label) (send window ':translate-x (first segment)) (- (send window ':translate-y (second segment)) 10.) (send window ':translate-x (third segment)) (- (send window ':translate-y (fourth segment)) 10.) ':wide 8. ':high 8. ':font ':standard ':alu tv:alu-andca))) ;;; +++++++ Consider replacing this with one that just returns ;;; +++++++ the longest segment, or just the first. ;;; ;;; This method locates the longest, most horizontal segment of all ;;; the segments. It returns the Nth pointer of the segment. ;;; ***** ;;; Actually, to prevent the need for sorting, etc., we use a simple ;;; algorithm: first compute the maximum length. Then, we look ;;; down the list of segments, considering those that are no less than ;;; 70% of the max length. If any segment has an angle of less than ;;; about 30degrees (these constants are defvar'ed at the beginning of ;;; this file), then it is returned. If none of the segments are thus ;;; chosen, we just return the longest segment. (defmethod (basic-arc :choose-best-segment) () (if (null (cdr lengths)) ;If only one segment (values 0 (apply 'vertical-slope-p joint-points)) ;return it. (let ((max (apply #'max lengths))) (loop for (x1 y1 x2 y2 . rest) on joint-points by 'cddr for length in lengths for i from 0 until (null x2) if (and (> (* *long-enough* length) max) (gentle-slope x1 y1 x2 y2 *gentle-slope*)) return i finally (return (loop for (x1 y1 x2 y2 . rest) on joint-points by 'cddr for length in lengths for i from 0 if (= max length) return (values i (vertical-slope-p x1 y1 x2 y2)))))))) ;;; Returns T if the slope of the line segment is "gentler" than ;;; that specified. (defun gentle-slope (x1 y1 x2 y2 slope) (cond ;; If the two y's are the same, the segment must be horizontal ;; so it is gentle, regardless of our slope. This is the quick ;; check. ((= y1 y2) t) ;; If not horizontal, we need to compare slopes. (t (let ((tani (safe-atan2 (- y2 y1) (- x2 x1)))) (or ( (abs tani) slope) ( (abs (- *pi* tani)) slope)))))) ;;; Returns T if the slope of the segment is close to vertical. ;;; Here, as a quick definition, we just see if the x is less than ;;; the y. (defun vertical-slope-p (x1 y1 x2 y2) (< (abs (- x1 x2)) (abs (- y1 y2)))) ;;; Accepts a list of four number, defining two points. Returns T if ;;; the segment is horizontal; that is if the Y coordinates are the same. (defun horizontal-p (segment) (= (second segment) (fourth segment))) (defun best-midpoint (x1 y1 x2 y2) (cond ((= y1 y2) (when (> x1 x2) (psetq x1 x2 x2 x1 y1 y2 y2 y1)) (values (+ x1 (// (- x2 x1) 4.)) (+ y1 (// (- y2 y1) 4.)))) (t (values (midpoint x1 x2) (midpoint y1 y2))))) ;;; Returns an integer 1/3 of the way from val1 to val2. (defun midpoint (val1 val2) (+ val1 (// (- val2 val1) 2.))) ;;; Returns T if the slope is positive. (defun pos-slope-p (x1 y1 x2 y2) (minusp (* (- y2 y1) (- x2 x1))))