;;; -*- mode:lisp; package:(graph global 1000); base:10.; -*- ;;;

;;;

;;; This file contains code to implement


;;; ****************
;;; Comments about Nodes
;;; ****************

;;; Nodes are one of the primary objects of interest in the graph
;;; display system.  You must have nodes before you can add any
;;; arcs.  The graph display system imposes the restriction that nodes
;;; may not overlap as displayed

;;; There are several flavors of graph nodes that you can use, and you
;;; may define others to suit your needs.  An anticipated application
;;; (soon to be built) will build nodes to represent conses.

;;;  &&&&  Changes on 10-Feb-84.

;;;  We talked about this for a while, and decided that it is REALLY
;;; IMPORTANT to allow the user to dynamically change the shape of nodes.
;;; The way we are going to do this is to let each node have a SHAPE
;;; instance variable, and dispatch on the shape when doing certain
;;; shape-critical operations, like :DRAW or :ERASE.

;;;  To handle the dispatching, we are using a relatively new addition to the 
;;; flavor system, CASE method combination.  This allows a second level
;;; of dispatch, where you send a message with a PRIMARY method name, and
;;; a secondary method name.  For more details, see the GREEN lisp machine
;;; manual, or the Slymebolics Release 4.0 release notes.
;;;
;;; To further aid in this, we define several MACROS for shape-critical
;;; operations.  They work like this:
;;;
;;;  (draw <obj>)  ==>  (send <obj> ':draw (send <obj> ':shape))
;;;  
;;;  This should make it very easy for users to use, and avoids the 
;;; problems of having :draw have to have a big Selectq.

;;;  &&&&  More 10-Feb-84 CHanges.

;;;  Instance variables that should not be printed to a file should
;;; have a ':dont-print-to-file property.



;;;  ****************************************************************
;;;  Necessary Loads, Constants, Declarations. 
;;;  ****************************************************************

;;; A constant which controls the separation of parallel arcs.
(defconst *delta-separation* 4. "The separation between adjacent parallel arcs")

;;;  The nearness to the screen factor for determining whether
;;; a node is visable. 
(defvar *chocolate-fudge* 500. "How far the center of a node may be from the
 screen and still be considered viewable.")





;;;  ****************************************************************
;;;  Internal Macros, Structure Definitions, FLAVOR definitions. 
;;;  ****************************************************************

;;;  Rounds NUMBER to the nearest GRID-SIZE.  Works equally well for negative
;;; numbers.  E.g. (round-grid -14 10) --> -10, while (round-grid -15 10) --> -20. 
(defmacro round-grid (number grid-size)
  `(let ((my-number ,number)
	 (my-grid-size ,grid-size))
     (* (// (+ (abs my-number) (// my-grid-size 2.)) my-grid-size)
	my-grid-size
	(signum my-number))))


;;;  A basic node encompasses the concepts of a mathematical node, plus
;;; it knows where it is, and has a (possibly null) label that can be
;;; displayed.

	   ;;;;;;;;;;
(defflavor basic-node
	   ;;;;;;;;;;

	((arcs nil)		       ;;;What arcs touch this node
	 (x 50.)				;These positions are Not critical. 
	 (y 50.)
	 (width 900.)
	 (height 600.)
	 (label ':unlabelled)
	 (name (format nil "Node-~A-~D" (time:print-current-time nil) (time)))
	 (drawn-p nil)
	 (shape ':rectangle)	       ;; Default shape to draw this.
	 (flash-blinker nil)			; Blinker to use for flashing
	 (window nil)			;pointer back to instance of
						;graph-display-mixin
	 )
	(editable-attributes-mixin)
  (:method-combination (:case :base-flavor-last :draw :erase :periphery-point))
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)
(graph-putprop 'basic-node 'arcs t ':read-only)
(graph-putprop 'basic-node 'arcs '(lambda (arcs)
			       (format nil "This node has ~D arc~:P." (length arcs)))
	       ':pretty-print)
(graph-putprop 'basic-node 'arcs t ':dont-print-to-file)
(graph-putprop 'basic-node 'x t ':read-only)
(graph-putprop 'basic-node 'y t ':read-only)
(graph-putprop 'basic-node 'width ':width ':type)
(graph-putprop 'basic-node 'width t ':printable)
(graph-putprop 'basic-node 'width t ':copyable)
(graph-putprop 'basic-node 'height ':height ':type)
(graph-putprop 'basic-node 'height t ':printable)
(graph-putprop 'basic-node 'height t ':copyable)
(graph-putprop 'basic-node 'label ':string ':type)
(graph-putprop 'basic-node 'label t ':printable)
(graph-putprop 'basic-node 'name t ':read-only)
(graph-putprop 'basic-node 'name t ':printable)
(graph-putprop 'basic-node 'drawn-p t ':dont-edit)
(graph-putprop 'basic-node 'drawn-p t ':dont-print-to-file)
(graph-putprop 'basic-node 'flash-blinker t ':dont-edit)
(graph-putprop 'basic-node 'flash-blinker t ':dont-print-to-file)
(graph-putprop 'basic-node 'window t ':dont-edit)
(graph-putprop 'basic-node 'window t ':dont-print-to-file)
(graph-putprop 'basic-node 'window nil ':dont-save-this-object-to-file)
(graph-putprop 'basic-node 'window nil ':dont-retrieve-this-object-from-file)
(graph-putprop 'basic-node 'shape
	       '(:rectangle :parallelogram :diamond :ellipse :sausage) ':type)
(graph-putprop 'basic-node 'shape t ':printable)	
(graph-putprop 'basic-node 'shape t ':copyable)



;;;  ****************************************************************
;;;  Internal Code
;;;  ****************************************************************

;;;  Make the node have a label.  If you supply one, it will override
;;; whatever damage this method might cause.
(defmethod (basic-node :before :init)
    (&rest ignore)
    (if (eq label ':unlabelled) (setq label name)))   ; Copy the name over to the label.

;;;  ****************
;;;  General graph node stuff. 
;;;  More specific node types follow. 
;;;  ****************

;;; Send this message to a node to find the point on its periphery
;;; to which you would draw an arc.  This could be a midpoint of some
;;; closest side, or whatever.  You need to supply the centerpoint 
;;; of the node of the originating arc, so the node to which this
;;; message is sent can tell the direction of the arc. 
;;;  This default message just returns the center of the node.  Most
;;; of the time we can do MUCH better. 
;;;

;;;  To position a node. 
	    ;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :set-position)
	    ;;;;;;;;;;;;;;;;;;;;;;;;
	   (new-x new-y)
  (erase self)
  (setq x new-x  y new-y)
  (send self ':guarantee-no-overlaps)
  ;; Tell the arcs to recompute their positions. 
  (loop for arc in arcs do (send arc ':compute-joint-points))
  (draw self))

(defmethod (basic-node :before :set-width)
	   (ignore)
  (erase self))

(defmethod (basic-node :after :set-width)
	   (new-width)
  (setq width new-width)
  (send self ':guarantee-no-overlaps)
  ;; Tell the arcs to recompute their positions. 
  (loop for arc in arcs do (send arc ':compute-joint-points))
  (draw self))

(defmethod (basic-node :before :set-height)
	   (ignore)
  (erase self))

(defmethod (basic-node :after :set-height)
	   (new-height)
  (setq height new-height)
  (send self ':guarantee-no-overlaps)
  ;; Tell the arcs to recompute their positions. 
  (loop for arc in arcs do (send arc ':compute-joint-points))
  (draw self))


(defmethod (basic-node :before :set-shape)
	   (ignore)
  (erase self))

(defmethod (basic-node :after :set-shape)
	   (ignore)
  (loop for arc in arcs do (send arc ':compute-joint-points))
  (draw self))

;;;  Here is a tough one.  To guarantee a node doesn't overlap, we
;;; need to compare it with all other nodes.  We also compensate for
;;;the grid size in this method by rounding each coordinate to the
;;;nearest grid point.  The :before daemon snaps the x and y
;;;coordinates to the nearest grid point if the grid is
;;;being used on the window.
(defmethod (basic-node :before :guarantee-no-overlaps)
	   (&optional ignore)
  (let ((grid-size (send window ':grid-size)))
    (when (send window ':grid-on)
      (setq y (round-grid y grid-size))
      (setq x (round-grid x grid-size)))))

(defmethod (basic-node :guarantee-no-overlaps)
	   (&optional other-nodes)
  (loop for node in (send window ':nodes)
	unless (eq self node)
	if (send node ':overlap-p self)
	return (progn
		 ;; Move over about half the width of the node in a crude
		 ;; attempt to find a better place for it. 
		 (setq x (+ x (// width 2)))
		 (send self ':guarantee-no-overlaps other-nodes)))
  (loop for node in other-nodes
	unless (eq self node)
	if (send node ':overlap-p self)
	return (progn
		 ;; Move over about half the width of the node in a crude
		 ;; attempt to find a better place for it. 
		 (setq x (+ x (// width 2)))
		 (send self ':guarantee-no-overlaps other-nodes))))


;;;  Special feature used by :read message in graph-editor windows.
;;;  This will check to see if the node overlaps any of the other nodes
;;; presented in a list.  If it does overlap, it will take a MODE dependent
;;; action, and return a new MODE.  If no overlap, just returns the current
;;; mode.  This thing interacts with the user via a menu.
(defmethod (basic-node :maybe-overlap)
	   (node-list other-node-list mode)
  (cond ((or (loop for node in other-node-list
		   if (send self ':overlap-p node) return t finally nil)
	     (loop for node in node-list
		   if (send self ':overlap-p node)
		   return t
		   finally nil))
	 (selectq mode
	   (:query
	    (let ((action (tv:menu-choose
			    '(("Move this node" :move)
			      ("Let node stay" :leave)
			      ("Move this and all other overlapping nodes" :move-all)
			      ("Let this and all other overlapping nodes stay" :leave-all))
			    (format nil "This node, ~A, overlaps another." name))))
	      (selectq action
		(:move (send self ':guarantee-no-overlaps other-node-list)
		       :query)
		(:leave :query)
		(:move-all (send self ':guarantee-no-overlaps other-node-list)
		           :move)
		(:leave-all :leave)
		(otherwise :query))))
	   (:leave ':leave)
	   (:move (send self :guarantee-no-overlaps other-node-list)
	          :move)))
	(t mode)))

;;; Check to see if a node is viewable before we attempt to draw 
;;; or erase it. 
(defwrapper (basic-node :draw) (() . body)
  `(when (send self ':viewable-p) ,@body))

(defwrapper (basic-node :erase) (() . body)
  `(when (send self ':viewable-p) ,@body))


;;;  Before drawing any node, check to see if it is already on the screen,
;;; and if so, erase it first.

(defwhopper (basic-node :draw)
	    (suboperation)
  (if drawn-p (erase self))
  (continue-whopper suboperation)
  (setq drawn-p t)
  (loop for arc in arcs
	if (not (send arc ':drawn-p))
	 do (draw arc)))

;;;  After erasing a node, let it know it is no longer on the screen.

(defwhopper (basic-node :erase)
	    (suboperation)
  (continue-whopper suboperation)
  (setq drawn-p nil)
  (loop for arc in arcs do (erase arc)))

;;;  See if this node overlaps another. 
(defmethod (basic-node :overlap-p)
	   (node)
  (multiple-value-bind  (ulx1 uly1 lrx1 lry1)
      (send self ':containing-rectangle)
    (multiple-value-bind  (ulx2 uly2 lrx2 lry2)
	(send node ':containing-rectangle)
      (overlapping-boxes-p ulx1 uly1 lrx1 lry1 ulx2 uly2 lrx2 lry2))))

(defun overlapping-boxes-p (ulx1 uly1 lrx1 lry1 ulx2 uly2 lrx2 lry2)
      (and
	;; First, see if the x's overlap
	(or ( ulx1 ulx2 lrx1)
	    ( ulx1 lrx2 lrx1)
	    ( ulx2 ulx1 lrx2)
	    ( ulx2 lrx1 lrx2))
	;; Now, see if the y's overlap.  Both x and y must overlap for the
	;; rectangles to overlap. 
	(or ( uly1 uly2 lry1)
	    ( uly1 lry2 lry1)
	    ( uly2 uly1 lry2)
	    ( uly2 lry1 lry2))))

;;;return when this graph-node is currently viewable on the screen
;;;return t if is, nil otherwise.  This is a VERY simple algorithm
;;; that is only approximate.  If the node's center is NEAR the screen
;;; it is considered viewable. 
(defmethod (basic-node :viewable-p)
	   ()
  ;; Get the screen's coordinates. 
    (multiple-value-bind (sulx suly slrx slry)
	(send window ':containing-rectangle)
      (and ( (- sulx *chocolate-fudge*) x (+ slrx *chocolate-fudge*))
	   ( (- suly *chocolate-fudge*) y (+ slry *chocolate-fudge*)))))

;;;  Returns T if the node "contains" the specified point. 
(defmethod (basic-node :contains-point)
	   (w z)
  (multiple-value-bind (ulx uly lrx lry)
      (send self ':containing-rectangle)
    (and ( ulx w lrx) ( uly z lry))))


(defmethod (basic-node :containing-rectangle)
	   ()
  (let ((hh (// height 2))
	(hw (// width 2)))
    (values (- x hw) (- y hh) (+ x hw) (+ y hh))))


;;; Default; just wipes out the entire containing rectangle
(defmethod (basic-node :otherwise :erase)
	   (ignore)
  (multiple-value-bind (ulx uly nil nil)
      (send self ':containing-rectangle)
    (send window ':draw-white-box  ulx uly width height)))

;;; Use this to save a node.  This produces code that make-instance should
;;; be pretty happy with, EXCEPT that the :ARC value returns a list of numbers. 
;;; These numbers are the relative positions of the arcs in the total list
;;; of arcs.  During restoration, we need to translate these back. 
(defmethod (basic-node :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))
			      (t val)))))


;;;  ****************
;;;  Node FLASHING
;;;  ****************

;;;  See also (in utils) the macro with-object-flashing for an easy interface to this.

(defmethod (basic-node :flash)
	   (status)
  ;; If there isn't a blinker yet, make one.
  (unless flash-blinker
    (setq flash-blinker (tv:make-blinker window 'tv:rectangular-blinker)))
  ;; If turning on, set size and position
  (when status
    (let ((wid (// width (send window ':zoomx)))
	  (hei (// height (send window ':zoomy))))
      (send flash-blinker ':set-size-and-cursorpos
	    wid hei	  
	    (- (send window ':translate-x x) (// wid 2))
	    (- (send window ':translate-y y) (// hei 2)))))
  ;; Either start blinker blinking, or turn it off.
  (send flash-blinker ':set-visibility (if status ':blink)))

;;;  ****************
;;;  Stuff for interactive menus.
;;;  ****************

;;;  
(defmethod (basic-node :add-arc-to-self)
	   ()
  (send window ':user-add-arc nil self))

(defmethod (basic-node :automatic-add-arc-to-self)
	   ()
  (send window ':user-add-arc t self))

(defmethod (basic-node :move-self)
	   ()
  (with-object-flashing self
    (let ((new-pos (send window ':get-position)))
      (send self ':set-position (first new-pos) (second new-pos)))))

(defmethod (basic-node :move-relative)
	   (deltax deltay)
  (send self ':set-position (+ x deltax) (+ y deltay)))

;;;  This code moved to the editable-attributes-mixin.
;;;;  Send this to a node to copy instance variables from another node.
;(defmethod (basic-node :copy-attributes)
;	   (source-node)
;  (loop for iv in (si:flavor-all-instance-variables (get (typep self) 'si:flavor))
;	if (graph-get (typep self) iv ':copyable)
;	do (send self (intern (format nil "SET-~A" iv) :keyword)
;		 (send source-node (intern iv :keyword ))))
;  (setq drawn-p nil)
;  (draw self))

(defmethod (basic-node :delete-self)
	   ()
#+cadr  (sys:%slide 50 2 200 1000000)
  (send window ':delete-node self))

;;;  ****************
;;;  Rectangle nodes. 
;;;  ****************


;;;  Drawing a rectangle node is one of the simplest things. 
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :draw :rectangle)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (&aux (hw (// width 2)))
    (send window ':draw-graph-rectangle
	  (- x hw)  (- y (// height 2)) width height)
    (if label (send window ':draw-centered-graph-string
		    label (- x hw) (+ x hw) (- y (// height 4)))))


;;;  To erase a rectangle node, just draw a white box in the
;;; right place. 
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :erase :rectangle)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   ()
  (when drawn-p
    (send window ':draw-white-box
	  (- x (// width 2))  (- y (// height 2)) width height)))

;;;  Returns a point on the edge of the rectangle that is
;;; on a line from the remote point to the center of the
;;; rectangle. 
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :periphery-point :rectangle)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (remote-x remote-y &optional (delta 0) ignore)
  (setq delta (* (expt -1 delta) delta *delta-separation* *default-mag*))
  (let* ((lratan (safe-atan height width))
	 (ulatan (+ *pi* lratan))
	 (llatan (safe-atan height (- width)))
	 (uratan (+ *pi* llatan))
	 (remote-atan (safe-atan (- remote-y y) (- remote-x x))))
  (cond
    (( lratan remote-atan llatan)
     (values (+ delta x) (+ y (// height 2))))
    (( llatan remote-atan ulatan)
     (values (- x (// width 2)) (+ delta y)))
    (( ulatan remote-atan uratan)
     (values (+ delta x) (- y (// height 2))))
    (t
     (values (+ x (// width 2)) (+ delta y))))))


;;;  ****************
;;;  Parallelogram nodes. 
;;;  ****************

(defconst *parallelogramslant* 1.2 "Slant used for parallelograms")
(defconst *cos-parallelogramslant* (cos *parallelogramslant*))
(defconst *sin-parallelogramslant* (sin *parallelogramslant*))
;;; Draw a parallelogram

	    ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :draw :parallelogram)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (&aux (inside (- (// width 2.)
			    (fixr (// (* height *cos-parallelogramslant*)
				      *sin-parallelogramslant*)))))
    (send window ':draw-graph-parallelogram x y width height *parallelogramslant*)
    (if label (send window ':draw-centered-graph-string
		    label (- x inside) (+ x inside) (- y (// height 4)))))


;;; Erase a parallelogram

	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :erase :parallelogram)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   ()
  (when drawn-p
    (send window ':erase-graph-parallelogram x y width height *parallelogramslant*)))

;;;  Returns a point on the edge of the parallelogram that is
;;; on a line from the remote point to the center of the
;;; parallelogram. 
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod (basic-node :case :periphery-point :parallelogram)
	   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (remote-x remote-y &optional (delta 0) ignore)
  (setq delta (* (expt -1 delta) delta *delta-separation* *default-mag*))
  (let* ((uratan (safe-atan height width))
	 (llatan (+ *pi* uratan))
	 (ulatan (safe-atan height (- width)))
	 (lratan (+ *pi* ulatan))
	 (remote-atan (safe-atan (- y remote-y) (- remote-x x)))
	 (offset (fixr (// (* height *cos-parallelogramslant*) *sin-parallelogramslant*)))
	 (width2 (// width 2.))
	 (height2 (// height 2.))
	 (upper (- y height2))
	 (lower (+ y height2))
	 (xleft (- x width2))
	 (xmidleft (+ xleft offset))
	 (xright (+ x width2))
	 (xmidright (- xright offset)))
    (cond
      (( uratan remote-atan ulatan)
       (values (+ delta (// (+ xmidleft xright) 2.)) upper))
      (( ulatan remote-atan llatan)
       (values (fixr (- (// (+ xleft xmidleft) 2.) (* delta *cos-parallelogramslant*)))
	       (fixr (+ y (* delta *sin-parallelogramslant*)))))
      (( llatan remote-atan lratan)
       (values (+ delta (// (+ xleft xmidright) 2.)) lower))
      (t
       (values (fixr (- (// (+ xmidright xright) 2.) (* delta *cos-parallelogramslant*)))
	       (fixr (+ y (* delta *sin-parallelogramslant*))))))))


;;;  ****************
;;;  Ellipse nodes
;;;  ****************

(defmethod (basic-node :case :draw :ellipse)
	   (&aux (x-radius (// width 2)) (y-radius (// height 2)))
  (send window ':draw-graph-ellipse x y x-radius y-radius)
  (if label (send window ':draw-centered-graph-string
		  label (- x x-radius) (+ x x-radius) y)))

(defmethod (basic-node :case :erase :ellipse)
	   (&aux (x-radius (// width 2)) (y-radius (// height 2)))
  (when drawn-p
    (send window ':erase-graph-ellipse x y x-radius y-radius)))

;;; Compute the periphery point of an ellipse node. This is the intersection of the
;;; line from (remote-x, remote-y) to (x, y) with  the perimeter of the ellipse.
;;; Four major cases are possible. First we check that every thing looks "good". If 
;;; not then we break. Two more cases are occur if the line is perfectly vertical
;;; or horizantal. The interesting case occurs when we really have to do the
;;; intersection computation. This is done by substituting the equation for the line
;;; (y = mx +q) into the equation for the ellipse (ax^2 + by^2 = r^2). This results
;;; in another equation (c1x^2 + c2x + c3 = 0) which we solve with the quadratic
;;; formula.

(defmethod (basic-node :case :periphery-point :ellipse)
       (remote-x remote-y &optional ignore ignore)
  (let* ((dx (- x remote-x))
	 (dy (- y remote-y))
	 (w2  (// width 2.0))
	 (h2 (// height 2.0))
	 (maxr (max w2 h2))
	 m q a b r c1 c2 c3 b2m4ac rp rm)
;    (format t "~%x=~d y=~d remote-x=~d remote-y=~d~%" x y remote-x remote-y)
    (cond ((and (equal dx 0.) (equal dy 0.)) (break))	;should also check for inside node
	  ((equal dx 0.)
	   (if (> remote-y y) (values x (fix (+ y h2))) (values x (fix (- y h2)))))
	  ((equal dy 0.)
	   (if (> remote-x x) (values (fixr (+ x w2)) y) (values (fixr (- x w2)) y)))
	  (t
	   (setq m (// (float dy) (float dx))
		 q (- y (* m x)))
	   (if (equal width height)
	       (setq a 1.
		     b 1.
		     r w2)
	       (setq a (quotient (* maxr maxr) (* w2 w2))
		     b (quotient (* maxr maxr) (* h2 h2))
		     r maxr))
;	  (format t "~%m=~d, q=~d, a= ~d, b=~d, r=~d~%" m q a b r)
	  (setq c1 (+ a (* b m m))
		c2 (* 2. (- (* b m q) (* b m y) (* a x)))
		c3 (- (+ (* a x x) (* b q q) (* b y y)) (* 2. b q y) (* r r)))
	  (setq b2m4ac (- (* c2 c2) (* 4. c1 c3)))
;	  (format t "~%c1=~d c2=~d c3=~d b2m4ac=~d~%" c1 c2 c3 b2m4ac)
	  (if (< b2m4ac 0.) (break))
	  (setq rp (// (- (sqrt b2m4ac) c2) 2.0 c1)
		rm (// (+ (sqrt b2m4ac) c2) -2.0 c1))
;	  (format t "rp=~d rm=~d" rp rm)
	  (if (< (abs (- remote-x rp)) (abs (- remote-x rm)))
	      (values (fixr rp) (fixr (+ (* m rp) q)))
	      (values (fixr rm) (fixr (+ (* m rm) q))))))))


;;;  ****************
;;;  Diamond nodes
;;;  ****************


(defmethod (basic-node :case :draw :diamond)
	   ()
  (let ((hw (// width 2.))
	(hh (// height 2.)))
    (send window ':draw-graph-lines
	  (- x hw) y
	  x (- y hh)
	  (+ x hw) y
	  x (+ y hh)
	  (- x hw) y)
    (if label (send window ':draw-centered-graph-string
		    label (- x hw) (+ x hw) (- y 5.)))))

;;;  We don't need an erase method; just blat out the rectangle.


;;;  Almost identical to rectangle nodes.
(defmethod (basic-node :case :periphery-point :diamond)
	    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   (remote-x remote-y &optional ignore ignore)
  (let* ((lratan (safe-atan height width))
	 (ulatan (+ *pi* lratan))
	 (llatan (safe-atan height (- width)))
	 (uratan (+ *pi* llatan))
	 (remote-atan (safe-atan (- remote-y y) (- remote-x x))))
  (cond
    (( lratan remote-atan llatan)
     (values x (+ y (// height 2))))
    (( llatan remote-atan ulatan)
     (values (- x (// width 2)) y))
    (( ulatan remote-atan uratan)
     (values x (- y (// height 2))))
    (t
     (values (+ x (// width 2)) y)))))


;;;  ****************************************************************
;;;  "Sausages"  (left-half-circle, parallel-lines, right-half-circle)
;;;  ****************************************************************

(defmethod (basic-node :case :draw :sausage)
	   (&aux (hw (// width 2)))
  (send window ':draw-graph-sausage x y (// height 2) hw)
  (if label (send window ':draw-centered-graph-string
		  label (- x hw) (+ x hw) (- y 5))))

;;; Don't need erase; use the default erase.

(defmethod (basic-node :case :periphery-point :sausage)
	   (remote-x remote-y &optional ignore ignore)
  (let* ((lratan (safe-atan height width))
	 (ulatan (+ *pi* lratan))
	 (llatan (safe-atan height (- width)))
	 (uratan (+ *pi* llatan))
	 (remote-atan (safe-atan (- remote-y y) (- remote-x x))))
  (cond
    (( lratan remote-atan llatan)
     (values x (+ y (// height 2))))
    (( llatan remote-atan ulatan)
     (values (- x (// width 2)) y))
    (( ulatan remote-atan uratan)
     (values x (- y (// height 2))))
    (t
     (values (+ x (// width 2)) y)))))