;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(TVFONT TR10B TR10I) -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.  Where functionality implemented herein replicates
;;; similarly named functionality on Symbolics machines, this code was
;;; developed solely from the interface specification in the documentation
;;; or through guesswork, never by examination of Symbolics source code.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.
;;; **********************************************************************

#|
Flavor definition for graph window

2S*ee the documentation for basic-x-y-scrolling-window2, and maybe the examples
at the end of this file.

Interesting initable instance variables.

 from essential-graph-mixin 
   :orientation - which can be :horizontal or :vertical. It conrols how a graph is drawn (using the :draw-graph method)
                  The default is :horizontal
   :generation-spacing - # of pixels between a parent and a child
   :sibling-spacing - # of pixels between two siblings

 plus all those from basic-x-y-scrolling-window.

Has methods :draw-graph
               :generate-graph
               :add-vertex
               :add-edge
               :delete-vertex
               :delete-edge

Vertices have a default mouse-sensitive-type of :vertex, edges of :edge.
Thus, if you want mouse sensitivity you should put these types on your
item-type-alist.  The edit-*graph-2display-mixin to *basic-2graph-mixin will handle mouse-m
and mouse-m-2 blips if the blip is over a vertex*.
2Mouse-m will make the vertex follow (move to) the mouse until
the button is released (ie. you drag the vertex.)  Mouse-m-2 will drag
subtrees. You, the programmer are required to advertise this drag
capability in the who-line.  For example, your item-type-alist could
have the entry (:vertex display-vertex
                     *"2L: display, M: hold down to drag vertex, Sh-M: hold down to drag subtree, R: menu*"
2                  (*"2some op*"2 :value some-op)
                  (*"2some other op*"2))

|*#
(export '(graph-window))

(1defvar* *item-resource* nil
"A resource of items of different flavors."
)

(1defvar* 2*Inhibit-Draw-Operations** Nil
"When true, drawing is inhibited."
)

;-------------------------------------------------------------------------------

(defflavor linked-grapher-mixin
	   ((linked-to nil))
	   ()
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables
)

(defmethod (2Linked-Grapher-Mixin* :Perform-All-Link-Actions-For)
	   (old-item new-item)
  (1loop* for (other-window . type-specs) in linked-to
	do (1send* self :Perform-Link-Actions-For old-item new-item type-specs)
  )
)

(defmethod (2Linked-Grapher-Mixin* :Perform-Link-Actions-For)
	   (old-item new-item type-specs)
  (1loop* for (type message-to-old-item-and-args message-to-other-and-args)
	in type-specs
	when (1typep* new-item type)
	do (1if* (1consp* message-to-old-item-and-args)
	       (1lexpr-send* old-item message-to-old-item-and-args)
	       nil
	   )
	   (1if* (1consp* message-to-other-and-args)
	       (1lexpr-send* new-item message-to-other-and-args)
	       nil
	   )
  )
)

(1defwhopper* (2Linked-Grapher-Mixin* :Scrollable-Item) (&rest args)
  (1let* ((item (1lexpr-continue-whopper* args)))
       (without-recursion
	 (1loop* for (other-window . type-specs) in linked-to
	       for new-item = (1lexpr-send* other-window :Scrollable-Item args)
	       do (1send* item :Add-Linked-To new-item)
	          (1send* self :Perform-Link-Actions-For item new-item type-specs)
	 )
       )
       item
  )
)

(1defwhopper* (2Linked-Grapher-Mixin* :Turn-On-Vertex-Dragging)
	      (2Vertex* &optional (warp-p t))
  (1continue-whopper* 2Vertex* warp-p)
  (without-recursion
    (1loop* for (other-window . type-specs) in linked-to
	  do (1send* other-window :Turn-On-Vertex-Dragging 2Vertex* nil)
    )
  )
)

(1defwhopper* (2Linked-Grapher-Mixin* :Turn-Off-Vertex-Dragging) ()
  (1continue-whopper*)
  (without-recursion
    (1loop* for (other-window . type-specs) in linked-to
	  do (1send* other-window :Turn-Off-Vertex-Dragging)
    )
  )
)

(1defwhopper* (2Linked-Grapher-Mixin* :Turn-On-Subtree-Dragging)
	      (2Vertex* &optional (warp-p t))
  (1continue-whopper* 2Vertex* warp-p)
  (without-recursion
    (1loop* for (other-window . type-specs) in linked-to
	  do (1send* other-window :Turn-On-Subtree-Dragging 2Vertex* nil)
    )
  )
)

(1defwhopper* (2Linked-Grapher-Mixin* :Turn-Off-Subtree-Dragging) ()
  (1continue-whopper*)
  (without-recursion
    (1loop* for (other-window . type-specs) in linked-to
	  do (1send* other-window :Turn-Off-Subtree-Dragging)
    )
  )
)

;-------------------------------------------------------------------------------

(defflavor basic-graph-mixin ()
	   (2tv-colon-graphics-mixin-rendering-mixin*
	    rendering-mixin
	    2Essential-Graph-Mixin*
	    2Edit-Graph-Display-Mixin*
	   )
)

(defflavor graph-window ()
	   (2Linked-Grapher-Mixin* basic-graph-mixin basic-x-y-scrolling-window)
)

(1defvar* 2*Resourcify-Items** Nil
"When true keeps old items in a resource."
)

(1defmethod* (2Basic-Graph-Mixin* :Before :Clear-Window) (&rest ignore)
"Keep a resource of the items."
  (1if* 2*Resourcify-Items**
      (1Loop* for item in (1send* self :Item-List)
	    for bin = (1or* (1assoc* (1type-of* item) 2*Item-Resource**)
			  (1progn* (1push* (1list* (1type-of* item)) 2*Item-Resource**)
				  (1assoc* (1type-of* item) 2*Item-Resource**)
			  )
		      )
	    Do (1setf* (1rest* bin) (1cons* item (1rest* bin)))
      )
      nil
  )
)

;;; Optimise draw-dashed line so that it only tries to draw the dashed
;;; line over the possible bounds.  This speeds things up enormously.
;;; The following copied and modified from
;;;    (:method tv:graphics-mixin :draw-line)
;;; to do the right clipping.
(1defwhopper* (2Basic-Graph-Mixin* :Draw-Dashed-Line)
	      (from-x from-y to-x to-y &OPTIONAL (ALU CHAR-ALUF)
		      (DASH-SPACING 20) SPACE-LITERALLY-P (OFFSET 0)
		      (DASH-LENGTH (FLOOR DASH-SPACING 2))
		      (color (sheet-foreground-color self)))
  (1if* (1send* self :Physical-Line-On-Screen-P from-x from-y to-x to-y)
      (1if* 2*Dont-Clip-P**
	  (1continue-whopper* from-x from-y to-x to-y alu dash-spacing
			        space-literally-p offset dash-length color)
	 (1Progn*
	  (SETQ FROM-X (+ FROM-X (SHEET-INSIDE-LEFT))
		FROM-Y (+ FROM-Y (SHEET-INSIDE-TOP))
		TO-X (+ TO-X (SHEET-INSIDE-LEFT))
		TO-Y (+ TO-Y (SHEET-INSIDE-TOP)))
	  (IF nil ;(mac-window-p self)
	      ;;; I think we can make this optimisation
	      ;;; for the mX too.
	      (1continue-whopper* from-x from-y to-x to-y alu dash-spacing
				   space-literally-p offset dash-length color)
	    ;1; else...*
	      (DO ((FROM-VISIBILITY (DRAW-LINE-CLIP-VISIBILITY FROM-X FROM-Y)
				    (DRAW-LINE-CLIP-VISIBILITY FROM-X FROM-Y))
		   (TO-VISIBILITY (DRAW-LINE-CLIP-VISIBILITY TO-X TO-Y))
		   (EXCHANGED NIL))
		  ;1;When completely visible, draw the line*
		  ((AND (ZEROP FROM-VISIBILITY) (ZEROP TO-VISIBILITY))
		   (AND EXCHANGED (PSETQ FROM-X TO-X TO-X FROM-X FROM-Y TO-Y
					 TO-Y FROM-Y))
		   (1continue-whopper*
		     (1-* from-x (SHEET-INSIDE-LEFT))
		     (1-* from-y (SHEET-INSIDE-TOP))
		     (1-* to-x (SHEET-INSIDE-LEFT)) (1-* to-y (SHEET-INSIDE-TOP))
		      alu dash-spacing space-literally-p
		      offset dash-length color)
		  )
		;1; If all off the screen, dont draw anything.*
		(OR (ZEROP (LOGAND FROM-VISIBILITY TO-VISIBILITY)) (RETURN NIL))
		;1; Exchange points to try to make to point visible.*
		(AND (ZEROP FROM-VISIBILITY)
		     (PSETQ FROM-X TO-X TO-X FROM-X FROM-Y TO-Y TO-Y FROM-Y
			    FROM-VISIBILITY TO-VISIBILITY TO-VISIBILITY
			    FROM-VISIBILITY
			    EXCHANGED (NOT EXCHANGED)))
		;1; If TO-X = FROM-X then FROM-VISIBILITY = 0, 4 or 8*
		;; 1so there is no*
		;1; danger of divide by zero in the next "Push".*
		(COND ((LDB-TEST (BYTE 1 0) FROM-VISIBILITY)
		       ;1Push toward left edge*
		       (SETQ FROM-Y	(+ FROM-Y
					   (TRUNCATE (* (- TO-Y FROM-Y)
							(- (SHEET-INSIDE-LEFT)
							   FROM-X))
						     (- TO-X FROM-X)))
			     FROM-X (SHEET-INSIDE-LEFT)))
		      ((LDB-TEST (BYTE 1 1) FROM-VISIBILITY)
		       ;1Push toward right edge*
		       (SETQ FROM-Y	(+ FROM-Y
					   (TRUNCATE (* (- TO-Y FROM-Y)
							(- (SHEET-INSIDE-RIGHT)
							   FROM-X 1))
						     (- TO-X FROM-X)))
			     FROM-X (1- (SHEET-INSIDE-RIGHT)))))
		(COND ((LDB-TEST (BYTE 1 2) FROM-VISIBILITY)
		       ;;1Push toward top*
		       ;1; It is possible that TO-Y = FROM-Y at this point*
		       ;; 1because of*
		       ;1; the effects of the last "Push", but in that case*
		       ;; 1TO-X is*
		       ;1; probably equal to FROM-X as well (or at least*
		       ;; 1close to it)*
		       ;1; so we needn't draw anything:*
		       (AND (= TO-Y FROM-Y) (RETURN NIL))
		       (SETQ FROM-X (+ FROM-X (TRUNCATE (* (- TO-X FROM-X)
							   (- (SHEET-INSIDE-TOP)
							      FROM-Y))
							(- TO-Y FROM-Y)))
			     FROM-Y (SHEET-INSIDE-TOP)))
		      ((LDB-TEST (BYTE 1 3) FROM-VISIBILITY)
		       ;1Push toward bottom*
		       ;1; Same:*
		       (AND (= TO-Y FROM-Y) (RETURN NIL))
		       (SETQ FROM-X (+ FROM-X
				       (TRUNCATE (* (- TO-X FROM-X)
						    (- (SHEET-INSIDE-BOTTOM)
						       FROM-Y 1))
						 (- TO-Y FROM-Y)))
			     FROM-Y (1- (SHEET-INSIDE-BOTTOM)))))))
	 )
      )
      nil
  )
)

(Defflavor essential-graph-mixin ((generation-spacing 60)
				2   *(sibling-spacing 10)
				2   *(orientation :horizontal))
	   ()
2   *:initable-instance-variables
2   *:gettable-instance-variables
2   *:settable-instance-variables)


1;;;Edited by HASTINGS   30 Apr 87  15:34
;;;Edited by Reed Hastings         30 Sep 87  20:13
;;;Edited by Reed Hastings         30 Sep 87  22:53*
(defmethod (essential-graph-mixin :draw-graph) (vertices edges &optional root (logical-x 0) (logical-y 0) (scroll-to-node nil))
  "2Draws a directed, possibly cyclic, possibly unconnected, graph.*
   2Doesn't handle reflexive edges very well.*
  2 *Vertices is a list of vertices.  Each vertex can be either a vertex-instance or a string, symbol or
   a list of the form 2(symbol-or-string* . options). Options 2are not evaluated and *include :mouse-sensitive-type
   :pre-print-item-modify-function 2:font*........ .
   Edges is list of edges. Each edges can be either an edge-instance or a list of the form
   (vertex-a vertex-b . options) where vertex-a or b can be strings or instances, and options2 are* 2not*
   2evaluated *and2 *include :item :arrowhead-p :label :label-font :mouse-sensitive-type :undirected-p
   :dashed-p (which can be 1, 2, 3 or t for three different2 *dashing styles).
 2   *Note that if you supply strings then
   #'equal will be used to judge uniqueness of vertices (ie. we're Case sensitive).
   Root can be a string or a vertex-instance.
   Logical-x and y are the upper-left corner of the smallest rectangle covering the graph."

 (1let* ((old-item-list (send self :item-list)))
       ;;; Remember the old item list so that we can avoid the remove duplicates
       ;;; below if posible because it it O(n**2).
  ;; make all vertices into instances
  (setq vertices
	(mapcar #'(lambda (vertex)
		    (etypecase vertex
		      (basic-vertex vertex)
		      (symbol (make-instance 'vertex :item vertex
					     :window self
					     :pre-print-item-modify-function #'symbol-name))
		      (string (make-instance 'vertex :item vertex :window self))
		      (list (assert (or (symbolp (first vertex))
					(stringp (first vertex))))
			    (apply #'make-instance 'vertex :item (car vertex)
				   :window self
				   ;;if they supplies a :pre-print... then use it, else use ours
				   (if (member :pre-print-item-modify-function (cdr vertex))
				       (cdr vertex)
				       (list* 
					 :pre-print-item-modify-function
					 (etypecase (first vertex)
					   (string #'identity)
					   (symbol #'symbol-name))
					 (cdr vertex)))))))	;1options*
		vertices))
  ;; make all edges into instances
  (setq edges
	(mapcar #'(lambda (edge)
		    (etypecase edge
		      (basic-edge edge)
		      (list (apply
			      #'make-instance 'edge
			      :window self
			      ;1; leave the user to set this if he wants* :item (list (first edge) (second edge))
			      :from-vertex
			      (etypecase (car edge)
				(basic-vertex (car edge))
				;;if its a symbol find the vertex with that symbol as the item
				((or string symbol) (cond ((find (car edge) vertices
								 :test #'equal
								 :key #'(lambda (v) (send v :item))))
							  (t (error "there is not vertex instance for the vertex ~
                                                        , ~a, in the edge, ~a" (car edge) edge)))))
			      :to-vertex
			      (etypecase (second edge)
				(basic-vertex (second edge))
				;;if its a symbol 1or string *find the vertex with that symbol1 or string* as the item
				((or string symbol) (cond ((find (second edge) vertices
								 :test #'equal
								 :key #'(lambda (v) (send v :item))))
							  (t (error "there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~a" (second edge) edge)))))
			      (cddr edge))))) ;;any user supplied options
		edges)) ;; arg for lambda above.
  ;; make sure the vertices know about their edges
  (dolist (edge edges)
    (send (send edge :to-vertex) :add-to-parent-edges edge)
    (send (send edge :from-vertex) :add-to-child-edges edge))
  ;; pick the root if necessary 
  (cond ((not root) ;1;easy case first, user didn't give us one.*
	 (setq root (pick-root vertices)))
	(t (setq root ;1;find the correct instance*
		 (etypecase root
		   (vertex root) ;1;fine, do nothing*
		   ((or string symbol) ;;1find the vertex with the item equal to root.*
		    (cond ((find root vertices
				 :test #'equal
				 :key #'(lambda (v) (send v :item))))
			  (t (error "there is not vertex instance for the root ~
                                        , ~a, " root))))))))
  ;1;get the vertices ready for postioning by declaring them all not positioned*
  (loop for vertex in vertices do (send vertex :set-positioned-p nil))
  
  ;; layout the graph1 by laying out its connected components*
  (1let* ((2*Inhibit-Draw-Operations** t))
    (ecase orientation
      (:Horizontal
       (loop with vertices-not-positioned = vertices and y-pos = logical-y
	     while vertices-not-positioned
	     for current-root = root then (pick-root vertices-not-positioned)
	     do
	     ;1; :position-self-n-descendents returns two values: the connected graph height and width.*
	     (incf y-pos (+ (send current-root :Position-Self-N-Descendents
				  logical-x y-pos)
			    sibling-spacing))
	     (1setq* vertices-not-positioned
		   (1loop* for vert in vertices-not-positioned
			 unless (1send* vert :Positioned-P)
			 collect vert))))
      (:vertical
       ;;; Copy-list so that we get to delq below.
       (loop with vertices-not-positioned = (1copy-list* vertices) and x-pos = logical-x
	     while vertices-not-positioned
	     for current-root = root then (pick-root vertices-not-positioned)
	     do
	     ;1; :position-self-n-descendents returns two values: the connected graph height and width.*
	     (incf x-pos
		   (+ (second (multiple-value-list (send current-root :position-self-n-descendents x-pos logical-y)))
		      sibling-spacing))
	     (1setq* vertices-not-positioned
		   (1loop* for vert in vertices-not-positioned
			 unless (1send* vert :Positioned-P)
			 collect vert))))))
  ;1;since we're all done positioning we won't use the positioned-p flag anymore,*
  ;1;so for good measure we set it back to nil.  Probably not nec.*
  (loop for vertex in vertices do (send vertex :set-positioned-p nil))
  ;; maybe scroll to the node.
  (1multiple-value-bind* (x y)
      (1send* self :Find-Good-Place-To-Scroll-A-Vertex-To scroll-to-node)
    (1setf* (1symeval-in-instance* self 'x-pl-offset) x)
    (1setf* (1symeval-in-instance* self 'y-pl-offset) y)
  )
  ;1; draw the graph*
  (loop for item in edges
	do
	(send item :maybe-draw-self))
  (loop for item in vertices
	do
	(send item :maybe-draw-self))

  ;; tell the window about the new items
  (send self :Set-Item-List
	(1if* old-item-list
	    ;;; This used to be a remove-duplicates.  Changed by JPR because
	    ;;; this is performance critical.  I'm still uneasy about this
	    ;;; call since it's quadratic time and this is generally a
	    ;;; large list.
	    (remove-list-duplicates-eq (append old-item-list edges vertices))
	    (append edges vertices)))
  (send self :Maybe-Show-Overview)
  (1send* self :item-list)))
  

(1defmethod* (2Essential-Graph-Mixin* :Find-Good-Place-To-Scroll-A-Vertex-To)
	     (2Vertex*)
  (1declare* (1values* x y))
  (1if* vertex
      (1let* ((ideal-x-point
	      (1floor* (1-* (sheet-inside-width self)
			 (1-* (1send* vertex :Msr-Right)
			    (1send* vertex :Msr-Left)
			 )
		     )
		     2
	      )
	    )
	    (ideal-y-point
	      (1floor* (1-* (sheet-inside-height self)
			 (1-* (1send* vertex :Msr-Bottom)
			    (1send* vertex :Msr-Top)
			 )
		     )
		     2
	      )
	    )
	   )
	   (values (1if* (1<* (1send* vertex :Msr-Left) ideal-x-point)
		       (1-* (sheet-inside-left self))
		       (1-* (1send* vertex :Msr-Left) ideal-x-point
			   (sheet-inside-left self)
		       )
		   )
		   (1if* (1<* (1send* vertex :Msr-Top) ideal-y-point)
		       (1-* (sheet-inside-top self))
		       (1-* (1send* vertex :Msr-Top) ideal-y-point
			   (sheet-inside-top self)
		       )
		   )
	   )
      )
      (1values* 0 0)
  )
)

(1defun* remove-list-duplicates-eq (1list*)
  "Removes duplicates from a list using the Eq test.  Much faster than the sys
defined one."
  (let ((result nil))
       (1loop* for element in list
	     unless (1member* element result :Test #'1eq*)
	     do (1push* element result)
       )
       result
  )
)

(defun pick-root (vertices)
  "2First looks for a vertex with no parent edges and some child edges,
   if that fails, for a vertex with no parent edges,
   if that fails, pick any vertex*"
  (let ((root (dolist (v vertices)
		(if (and (not (send v :parent-edges))
			 (send v :child-edges))
		    (return v)))))
    (unless root (setq root (dolist (v vertices)
		   (if (not (send v :parent-edges))
		       (return v)))))
    (unless root (setq root (car vertices)))
    root)) ;1return this*

(defmethod (essential-graph-mixin :generate-graph) (root generator &optional (draw-p t) edge-options vertex-options)
  "2Uses the generator function to generate all the descendents of root, and draw if draw-p.
    Returns the generated graph as a 2 element list: vertices edges. Edge-options and vertex-options are lists
    of :option value that are applied to each edge or vertex. These options are not evaluated.*"
  (let ((vertices (list `(,root ,@vertex-options)))
	(edges nil))
    (do ((parents (list root) next-generation)
	 (next-generation nil nil))		 
	((null parents))
      (dolist (parent parents)
	(dolist (child (funcall generator  parent))
	  (cond ((1loop* for v in vertices
		       when (1eq* child (1first* v))
		       ;must be a cycle so do nothing more
		       return t
		       finally (return nil)))
		(t (push `(,child ,@vertex-options) vertices)
		   (push `(,parent ,child2 *,@edge-options) edges)
		   (push child next-generation))))))
    (if draw-p (send self :draw-graph vertices edges root))
    (unless vertex-options
      ;1;change vertices from  ((a) (b) (c)) to (a b c)*
      (do ((l vertices (cdr vertices)))
	  ((null l))
	(rplaca l (caar l))))
    (list vertices edges)))


(defmethod (essential-graph-mixin :add-edge) (edge)
  "2edge can be an edge instance or a list of vertex-instances, strings, or symbols*"
  ;1; make edge into an instance*
  (setq edge
	(etypecase edge
	  (basic-edge edge)
	  (list (apply
		  #'make-instance 'edge
		  :window self
		 ;1; leave the user to set this if he wants* :item (list (first edge) (second edge))
		  :from-vertex
		  (etypecase (car edge)
		    (vertex (car edge))
		    ;;if its a symbol find the vertex with that symbol as the item
		    ((or string symbol) (cond ((find (car edge) (send self :item-list)
						     :test #'equal
						     :key #'(lambda (v) (send v :item))))
					      (t (error "there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~a" (car edge) edge))))
		    )
		  :to-vertex
		  (etypecase (second edge)
		    (vertex (second edge))
		    ;;if its a symbol find the vertex with that symbol as the item
		    ((or string symbol) (cond ((find (second edge) (send self :item-list)
						     :test #'equal
						     :key #'(lambda (v) (send v :item))))
					      (t (error "there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~a" (second edge) edge)))))
		  (cddr edge))))) ;1user options*
  ;1;tell the other vertices about the edge*
  (send (send edge :from-vertex) :add-to-child-edges edge)
  (send (send edge :to-vertex) :add-to-parent-edges edge)
  ;1;tell the window about the new edge*
  (send self :set-item-list (nconc (send self :item-list) (list edge)))
  ;1;send the edge off on it's own.*
  (send edge :calculate-your-position)
  (send edge :maybe-draw-self))

(defmethod (essential-graph-mixin :add-vertex) (vertex)
  "2vertex can be a vertex-instance or a symbol or a string or
   a list whose car is a string or a symbol and cdr is options*"
  (setq vertex
	(etypecase vertex
	  (basic-vertex vertex)
	  (symbol (make-instance 'vertex :item vertex
				 :window self
				 :pre-print-item-modify-function #'symbol-name))
	  (string (make-instance 'vertex :item vertex :window self))
	  (list (assert (or (symbolp (first vertex))
			    (stringp (first vertex))))
		(apply #'make-instance 'vertex :item (car vertex)
			                               :window self
						       :pre-print-item-modify-function (etypecase (first vertex)
											 (string #'identity)
											 (symbol #'symbol-name))
						       (cdr vertex))))) ;1user supplied options*
  ;1;tell the window*
  (send self :set-item-list (nconc (send self :item-list) (list vertex)))
  (send vertex :maybe-draw-self)) ;1probably at 0,0*


(defmethod (essential-graph-mixin :delete-edge) (edge)
  "2edge can be an edge instance or a list of vertex-instances, strings, or symbols.
    In the latter case we first look for an edge instance with* edge2 as its :item, and
    failing that look for an edge whose from-vertex's :item is the car of edge, and
   whose to-vertex's :item is the cadr of edge.*"
  (let ((edge-instance
	  (etypecase edge
	    (basic-edge edge)
	    (list
	     (cond ((find edge (send self :item-list)
			 :test #'(lambda (edge item) (equal edge (send item :item)))))
		   ((etypecase (first edge)
		      (vertex (find edge (send self :item-list)
				    :test #'(lambda (edge item)
					      (and (eql (first edge) (send item :send-if-handles :from-vertex))
						   (eql (second edge) (send item :send-if-handles :to-vertex))))))
		      ((or string symbol)
		       (find edge (send self :item-list)
			     :test #'(lambda (edge item)
				       (and (typep item 'edge)
					    (equal (first edge)
						   (send (send item :from-vertex) :item))
					    (equal (second edge)
						   (send (send item :to-vertex) :item)))))))))))))
    (cond (edge-instance
	   (send edge-instance :delete-self))
	  (t (cerror "Ignore delete-edge request"
		     "The edge, ~a, is not on the item-list of the window" edge)))))

(defmethod (essential-graph-mixin :delete-vertex) (vertex)
  "2vertex can be an instance or a string or a symbol.  Also deletes any edges to or from vertex*"
  (let ((vertex-instance
	  (etypecase vertex
	    (vertex vertex)
	    ((or string symbol)
	     (find vertex (send self :item-list)
		   :test #'(lambda (vertex item)
			     (equal (send item :item) vertex)))))))
    (cond (vertex-instance
	   (send vertex-instance :delete-self))
	  (t (cerror "Ignore delete vertex request"
		     "The vertex, ~a, is not on the item-list of the window" vertex)))))


;;--------------------------- edit-graph-display-mixin ----------------------

;;; this sets up vertex and subtree dragging.
;;; The programmer must find a way to tell the user that holding down
;;; mouse-m will drag the vertex, and c-mouse-m (same as mouse-m-2)
;;; will drag the subtree.  I suggust the :documentation option to 
;;; the item-type-alist instance var.

;;a better way to do dragging would have been to turn dragging on locally,
;;send self :handle-mouse, and turn off dragging when the button went up or 
;;; the :handle-mouse method returned.

(defflavor edit-graph-display-mixin ((vertex-being-dragged nil)
				     (subtree-being-dragged nil)
				     ;;1we use these temp vars as caches of window varaibles*
				     ;1; that we are going to temporarily change*
				     (mouse-sensitive-types-temp-var nil)
				     (char-aluf-temp-var )
				     (erase-aluf-temp-var ))
	   ()
  (:required-instance-variables currently-boxed-item
				x-pl-offset y-pl-offset))

(defmethod (edit-graph-display-mixin :after :init) (&rest ignore)
  (setq char-aluf-temp-var (send self :char-aluf)
	erase-aluf-temp-var (send self :erase-aluf)))

(defmethod (edit-graph-display-mixin :after :handle-mouse) (&rest ignore)
  "if the mouse wanders far, don't take the vertex with it!"
  (1send* self :turn-off-vertex-dragging)
  (1send* self :turn-off-subtree-dragging))

(1defmethod* drag-scrollable-item ((item t))
  nil
)

(defmethod (edit-graph-display-mixin :mouse-click) (button ignore ignore)
  "If the user clicked on a vertex with a mouse-m or mouse-m-2 then
   initiate the dragging."
  ;;just to be safe
  (and vertex-being-dragged (1send* self :turn-off-vertex-dragging))
  (and subtree-being-dragged (1send* self :turn-off-subtree-dragging))
  (when (drag-scrollable-item currently-boxed-item)
    (case button
       (#\mouse-m (1send* self :turn-on-vertex-dragging currently-boxed-item) t)
       (#\mouse-m-2
	(1send* self :turn-on-subtree-dragging currently-boxed-item) t))))

(1defmethod* (edit-graph-display-mixin :Turn-On-Vertex-Dragging)
	     (2Vertex* &optional (warp-mouse-p t))
  (turn-on-xor)
  (turn-off-mouse-sensitivity)
  (1if* warp-mouse-p (move-mouse-to-upper-corner vertex) nil)
  (if vertex-being-dragged
      (format self "trouble: initiating vertex dragging but something ~
              is already being dragged.  In :turn-on-vertex-dragging"))
  (setq vertex-being-dragged  vertex))

(1defmethod* (edit-graph-display-mixin :Turn-Off-Vertex-Dragging) ()
  (turn-off-xor)
  (setq vertex-being-dragged  nil)
  (restore-mouse-sensitivity))

(defmethod (edit-graph-display-mixin :Turn-On-Subtree-Dragging)
	   (vertex &optional (warp-mouse-p t))
    (turn-on-xor)
  (turn-off-mouse-sensitivity)
  (1if* warp-mouse-p (move-mouse-to-upper-corner vertex) nil)
  (if subtree-being-dragged
      (format self "trouble: initiating subtree dragging but something ~
              is already being dragged.  In :turn-on-subtree-dragging"))
  (setq subtree-being-dragged  vertex))

(defmethod (edit-graph-display-mixin :Turn-Off-Subtree-Dragging) ()
    (turn-off-xor)
  (restore-mouse-sensitivity)
  (setq subtree-being-dragged  nil))

(defun-method turn-off-mouse-sensitivity edit-graph-display-mixin ()
  (setq mouse-sensitive-types-temp-var (send self :mouse-sensitive-types))
  (send self :set-mouse-sensitive-types nil))

(defun-method restore-mouse-sensitivity edit-graph-display-mixin ()
  (unless (send self :mouse-sensitive-types)
    (send self :set-mouse-sensitive-types mouse-sensitive-types-temp-var)))

(defun-method turn-on-xor edit-graph-display-mixin ()
  (setq char-aluf-temp-var (send self :char-aluf)
	erase-aluf-temp-var (send self :erase-aluf))
  (with-xor-type-alus (self) (1send* self :Refresh))
  (send self :set-char-aluf  alu-xor)
  (send self :set-erase-aluf alu-xor)
)

(defun-method turn-off-xor edit-graph-display-mixin ()
  (1if* (1and* (1equal* (send self :char-aluf) char-aluf-temp-var)
	    (1equal* (send self :erase-aluf) erase-aluf-temp-var)
      )
      nil
      (progn (send self :set-char-aluf char-aluf-temp-var)
	     (send self :set-erase-aluf erase-aluf-temp-var)
	     (1send* self :Refresh)
      )
  )
)

(defun-method move-mouse-to-upper-corner edit-graph-display-mixin (vertex)
  ;;messy because we go from logical to physical to outside  coordinates   
  (send self :mouse-warp
	(+ (sheet-inside-left self) (- (send vertex :logical-x) (send self :x-pl-offset)))
	(+ (sheet-inside-top self) (- (send vertex :logical-y) (send self :y-pl-offset)))))


(defmethod (edit-graph-display-mixin :after :mouse-moves) (x y)
  "This actually does the dragging"
  ;;It will never happen that (and vertex-being-dragged subtree-being-dragged) is true. 
  (when (or vertex-being-dragged subtree-being-dragged)
     (if ;; middle button still down
      (= (mouse-buttons) 2)
      (let ((logical-mouse-x (- (+ x x-pl-offset) (sheet-inside-left self)))
	    (logical-mouse-y (- (+ y y-pl-offset) (sheet-inside-top self))))
	(and vertex-being-dragged
	     (send vertex-being-dragged :move-to logical-mouse-x logical-mouse-y))
	(and subtree-being-dragged
	     (send subtree-being-dragged :move-self-n-descendents  logical-mouse-x logical-mouse-y)))
      ;;else
      (progn (1send* self :turn-off-vertex-dragging)
	     (1send* self :turn-off-subtree-dragging)))))

(defun reshape-item (item)
  (send (send item :Window) :Reshape-Item item)
)

(defmethod (edit-graph-display-mixin :Reshape-Item) (item)
  (unwind-protect
      (progn (turn-on-xor)
	     (turn-off-mouse-sensitivity)
	     (reshape-item-1 item)
      )
    (turn-off-xor)
    (restore-mouse-sensitivity)
    (send self :Refresh)
  )
)

(defun reshape-item-1 (item)
  (let ((sheet (send item :Window)))
       (with-xor-type-alus (sheet)
	 (send item :Set-Visible-P t)
	 (multiple-value-bind
	   (ignore ignore radius-point-x radius-point-y)
	     (send item :Stretch-Point)
	   (with-mouse-grabbed-on-sheet (sheet)
	     (unwind-protect
	       (progn
		(mouse-warp radius-point-x radius-point-y)
		(mouse-set-blinker-definition
		  :character 0 5 :On :Set-Character #o3
		)
		(process-wait "Release Button"
			      #'(lambda () (zerop mouse-last-buttons))
		)
		(process-wait
		  "Button"
		  #'(lambda () (not (zerop mouse-last-buttons)))
		)
		(Loop until (zerop mouse-last-buttons)
		      do (send item :Set-Stretch-Point
			       mouse-x mouse-y :Physical
			 )
		)
	       )
	       (mouse-standard-blinker)
	     )
	   )
	 )
       )
  )
  (let ((*Track-Movement-On-Overview-Window-P* t))
       (Send item :Draw-Self)
  )
)

;;; ------------------ vertex and edge definitions -------------------------

(defflavor basic-vertex ((child-edges nil)
		   (parent-edges nil)
		   (left-anchor '(0 0))
		   (right-anchor '(0 0))
		   (top-anchor '(0 0))
		   (bottom-anchor '(0 0))
		   (being-positioned-p nil) ;1to avoid getting trapped in drawing or positioning a cycle*
		   (being-drawn-p nil)      ;1we set these flags (using the macro with-positioning-flag-set)*
		   (being-moved-p nil) 	    ;1while drawing or positioning* or 1moving.*
		   (getting-descendents-p nil)

		   (positioned-p nil))		;1also need this which is set once and for all*
						;1so that diags don't cause us to move this vertex*
						;1to a new position. *
	   (Vertex-Node-Mixin basic-node-item)               
  (:default-init-plist :mouse-sensitive-type :vertex) ;1put vertex in keyword package cause it sure don't belong in tv.*
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

(1defmethod* drag-scrollable-item ((item 2Basic-Vertex*))
  t
)

1;;;Edited by Reed Hastings         10 Jul 87  17:29*
(1defun* 2Vertexp* (x)
  (1typep* x '2Basic-Vertex*)
)

(1defmethod* (2Basic-Vertex* :On-Screen-P) ()
  (1or* 2*Force-On-Screen-P**
       (1send* window :vertex-on-screen-p msr-left msr-top msr-right msr-bottom)
  )
)

(1defmethod* (2Graph-Window* :vertex-on-screen-p) (left top right bottom)
  (1setq* left (1+* (Sheet-inside-left) (1-* left x-pl-offset)))
  (1setq* right (1+* (Sheet-inside-left) (1-* right x-pl-offset)))
  (1setq* top (1+* (Sheet-inside-top) (1-* top y-pl-offset)))
  (1setq* bottom (1+* (Sheet-inside-top) (1-* bottom y-pl-offset)))
  (1let* ((top-left-visibility (draw-line-clip-visibility left top))
	(bottom-right-visibility (draw-line-clip-visibility right bottom))
       )
       (1if* (1or* (1zerop* top-left-visibility) (1zerop* bottom-right-visibility))
	   t
	   (1if* (1zerop* (logand top-left-visibility bottom-right-visibility))
	       t ;;; Then this crosses the window.
	       ;;; Then this diagonal is not visible.
	       (1let* ((top-right-visibility
		       (draw-line-clip-visibility right top)
		     )
		     (bottom-left-visibility
		       (draw-line-clip-visibility left bottom)
		     )
		    )
		    (1or* (1zerop* top-right-visibility)
			 (1zerop* bottom-left-visibility)
			 (1zerop* (logand top-right-visibility
					 bottom-left-visibility
				 )
			)
		    )
	       )
	   )
       )
  )
)

(1defmethod* (2Graph-Window* :edge-on-screen-p) (from-x from-y to-x to-y)
  (1setq* from-x (1+* (sheet-inside-left) (1-* from-x x-pl-offset)))
  (1setq* to-x   (1+* (Sheet-inside-left) (1-* to-x   x-pl-offset)))
  (1setq* from-y (1+* (Sheet-inside-top)  (1-* from-y y-pl-offset)))
  (1setq* to-y   (1+* (Sheet-inside-top)  (1-* to-y   y-pl-offset)))
  (1let* ((from-visibility (draw-line-clip-visibility from-x from-y))
	(to-visibility   (draw-line-clip-visibility to-x to-y))
       )
       (1or* (1zerop* from-visibility) (1zerop* to-visibility)
	   (1zerop* (logand from-visibility to-visibility))
       )
  )
)

(1defmethod* (2Graph-Window* :Physical-Line-On-Screen-P)
	     (from-x from-y to-x to-y)
  (1setq* from-x (1+* (sheet-inside-left) from-x))
  (1setq* to-x   (1+* (Sheet-inside-left) to-x))
  (1setq* from-y (1+* (Sheet-inside-top)  from-y))
  (1setq* to-y   (1+* (Sheet-inside-top)  to-y))
  (1let* ((from-visibility (draw-line-clip-visibility from-x from-y))
	(to-visibility   (draw-line-clip-visibility to-x to-y))
       )
       (1or* (1zerop* from-visibility) (1zerop* to-visibility)
	   (1zerop* (logand from-visibility to-visibility))
       )
  )
)

(1defmethod (basic-vertex* :Make-Me-And-My-Children-Invisible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visibility nil)
       (1send* window :Refresh)
  )
)

(1defmethod (basic-vertex* :Make-Me-And-My-Children-Visible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visibility t)
       (1send* window :Refresh)
  )
)

(1defmethod (basic-vertex* :Make-Children-Invisible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1loop* for child in child-edges
	     do (1send* child :Set-Visibility nil)
       )
       (1send* window :Refresh)
  )
)

(1defmethod (basic-vertex* :Make-Children-Visible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1loop* for child in child-edges
	     do (1send* child :Set-Visibility t)
       )
       (1send* window :Refresh)
  )
)

(1defmethod (basic-vertex* :Set-Visibility) (to)
  (1declare* (1special* *passed-these-nodes*))
  (1if* (1not* (1member* self *passed-these-nodes*))
      (1progn* (1push* self *passed-these-nodes*)
	      (1setq* visible-p to)
	      (1loop* for child in child-edges
		    do (1send* child :Set-Visibility to)
	      )
	      (1loop* for parent in parent-edges
		    do (1send* parent :Set-Visible-p to)
	      )
      )
      nil
  )
)

(defmethod (basic-vertex :Make-Me-Visible) ()
  "Make this vertex (and links directly connected to it) be Visible, but 
leave all other nodes alone."
  (let ((*passed-these-nodes* nil))
       (declare (special *passed-these-nodes*))
       (send self :Set-Visibility-Dont-Descend t)
       (send window :Refresh)))

;;; By Jamie Zawinski
(defmethod (basic-vertex :Make-Me-Invisible) ()
  "Make this vertex (and links directly connected to it) be invisible, but 
leave all other nodes alone."
  (let ((*passed-these-nodes* nil))
       (declare (special *passed-these-nodes*))
       (send self :Set-Visibility-Dont-Descend nil)
       (send window :Refresh)))

;;; By Jamie Zawinski
(defmethod (basic-vertex :Set-Visibility-Dont-Descend) (to)
  "Make this vertex (and links directly connected to it) be invisible, but 
leave all other nodes alone."
  (declare (special *passed-these-nodes*))
  (if (not (member self *passed-these-nodes*))
      (progn (push self *passed-these-nodes*)
	      (setq visible-p to)
	      (loop for child in child-edges
		    do (send child :Set-Visible-p to))
	      (loop for parent in parent-edges
		    do (send parent :Set-Visible-p to))
	      )
      nil))


(defconstant anchor-space 4 "how many pixels away from a word to put it's anchor. The anchor is where the
                             edge attaches to the vertex")

(defmethod (basic-vertex :after :init) (&rest ignore)
  (send self :set-anchors))

(defmethod (basic-vertex :set-anchors) ()
  (setq right-anchor (list (+ right-edge anchor-space) (truncate (+ top-edge bottom-edge) 2))
        left-anchor (list (- left-edge anchor-space) (truncate (+ top-edge bottom-edge) 2))
        top-anchor (list (truncate (+ left-edge right-edge) 2) (- top-edge anchor-space))
        bottom-anchor (list (truncate (+ left-edge right-edge) 2) (+ bottom-edge anchor-space))))

(defmethod (basic-vertex :after :move-to) (x y &optional inhibit-redraw-p)
  (ignore x y)
  (send self :set-anchors)
  (dolist (edge (append child-edges parent-edges))
    (send edge :calculate-your-position)
    (unless  inhibit-redraw-p
      (send edge :maybe-draw-self))))

(defmethod (basic-vertex :after :delete-self) (&rest ignore)
  "2After deleting a vertex, delete all the edges to or from the vertex*"
  (dolist (edge (append parent-edges child-edges))
    (send edge :delete-self)))

(defmethod (basic-vertex :add-to-child-edges) (edge)
  (unless (find edge child-edges) (push edge child-edges)))

(defmethod (basic-vertex :add-to-parent-edges) (edge)
  (unless (find edge parent-edges) (push edge parent-edges)))

(defmethod (basic-vertex :delete-from-parent-edges) (edge)
  (setq parent-edges (delete edge (1the* list parent-edges) :Test #'eq)))

(defmethod (basic-vertex :delete-from-child-edges) (edge)
  (setq child-edges (delete edge (1the* list child-edges) :Test #'eq)))

(defmethod (basic-vertex :draw-self-n-descendents) ()
  (send self :maybe-draw-self)
  (with-drawing-flag-set  ;1protects against getting lost in cycles*
    (loop for edge in child-edges do
	  (send edge  :draw-self-n-descendents))))

(defmethod (basic-vertex :move-self-n-descendents) (x y)
  (let ((relative-x (- x logical-x))
	(relative-y (- y logical-y)))
    (with-moving-flag-set
      (send self :move-self-n-descendents-relative relative-x relative-y))))

(defmethod (basic-vertex :move-self-relative) (x y &optional inhibit-redraw-p)
  (send self :move-to (+ x logical-x) (+ y logical-y)  inhibit-redraw-p))

(defmethod (basic-vertex :move-self-n-descendents-relative) (x y &optional inhibit-redraw-p)
  (send self :move-self-relative x y inhibit-redraw-p)
  (dolist (edge child-edges)
    (send edge  :move-self-n-descendents-relative x y inhibit-redraw-p)))

(defmethod (basic-vertex :position-self-n-descendents) (at-x at-y)
  "Positions the graph so that the upper left edge is at-x at-y."
  (ecase (send window :orientation)
    (:horizontal
     (let* ((longest-subtree 0)
	    (this-vertex-length (- (send self :right-edge) (send self :left-edge)))
	    (this-vertex-height (- (send self :bottom-edge) (send self :top-edge)))
	    (child-at-x (+ at-x this-vertex-length (send window :generation-spacing)))
	    (child-at-y at-y))
       (with-positioning-flag-set
	 (loop for edge in child-edges do
	       (multiple-value-bind (subtree-height subtree-length)
		   (send edge  :position-self-n-descendents child-at-x child-at-y)
		 (incf child-at-y (+ subtree-height (send window :sibling-spacing)))
		 (setq longest-subtree (max longest-subtree subtree-length)))
	       finally (decf child-at-y
			     (send window :sibling-spacing))))	;this because we only want to increment child-at-y 
						;by :sibling-spacing n-1 times
						;but we've incf'd n times.  n = # of edges.
       (let ((tree-height (max this-vertex-height (- child-at-y at-y)))
	     (tree-length (+ this-vertex-length (send window :generation-spacing) longest-subtree)))
	 (send self :move-to at-x (+ at-y (truncate (- tree-height this-vertex-height) 2)) t)
	 ;1;let everyone else now that we're positioned and probably shouldn't be re-positioned.*
	 ;1;this is stronger that the being-positioned-p flag which is only set while we're positioning*
	 ;1;our children, and basically is just cycle protection.*
	 (setq positioned-p t)
	 (loop for edge in child-edges do
	       (send edge :calculate-your-position))
	 (loop for edge in parent-edges do
	       (send edge :calculate-your-position))
	 (values tree-height tree-length))))
    (:vertical ;1parallel/inverse to above.*
     (let* ((deepest-subtree 0)
	    (this-vertex-width (- (send self :right-edge) (send self :left-edge)))
	    (this-vertex-height (- (send self :bottom-edge) (send self :top-edge)))
	    (child-at-x at-x)
	    (child-at-y (+ at-y this-vertex-height (send window :generation-spacing))))
       (with-positioning-flag-set
	 (loop for edge in child-edges do
	       (multiple-value-bind (subtree-height subtree-width)
		   (send edge  :position-self-n-descendents child-at-x child-at-y)
		 (incf child-at-x (+ subtree-width (send window :sibling-spacing)))
		 (setq deepest-subtree (max deepest-subtree subtree-height)))
	       finally (decf child-at-x
			     (send window :sibling-spacing))))	;this because we only want to increment child-at-1x* 
						;by :sibling-spacing n-1 times
						;but we've incf'd n times.  n = # of edges.
       (let ((tree-height (+ this-vertex-height (send window :generation-spacing) deepest-subtree))
	     (tree-width (max this-vertex-width (- child-at-x at-x))))
	 (send self :move-to (+ at-x (truncate (- tree-width this-vertex-width) 2)) at-y t)
	 ;1;let everyone else now that we're positioned and probably shouldn't be re-positioned.*
	 ;1;this is stronger that the being-positioned-p flag which is only set while we're positioning*
	 ;1;our children, and basically is just cycle protection.*
	 (setq positioned-p t)
	 (loop for edge in child-edges do
	       (send edge :calculate-your-position))
	 (loop for edge in parent-edges do
	       (send edge :calculate-your-position))
	 (values tree-height tree-width))))))

(defmethod (basic-vertex :get-self-n-descendents) ()
  (with-getting-descendents-flag-set  ;1; protects agianst cycles*
    (cons self (mapcan #'(lambda (child) (send child :get-self-n-descendents))
		       child-edges))))

(1defmethod* (2Basic-Vertex* :Join-Items-With-An-Edge)
       (to &optional (edge-item nil) (edge-flavor 'edge) &rest init-options)
  (check-type to basic-vertex)
  (let ((edge
	  (apply 'make-instance edge-flavor
		 :Window window
		 :From-Vertex self
		 :To-Vertex to
		 :Item edge-item
		 :Unique-Key (gensym)
		 :Dynamic-Anchors-P t
		 init-options 
	  )
	)
       )
       (push edge (symeval-in-instance window 'item-list))
       (send self :Add-To-Child-Edges edge)
       (send to   :Add-To-Parent-Edges edge)
       (send self :Set-Anchors)
       (send to   :Set-Anchors)
       (send edge :Calculate-Your-Position)
       (send edge :Maybe-Draw-Self)
       (send window :Refresh)
       2edge*
  )
)

(1defflavor* 2Vertex*
	   ()
	   (scrollable-text-item 2Basic-Vertex*)
)

(1defflavor* 2Invisible-Vertex* () (2Vertex*) (:Default-Init-Plist :Visible-P nil))

(1defmethod* (2Invisible-Vertex* :Before :Maybe-Draw-Self) (&rest ignore)
  (1setq* visible-p nil)
  (1loop* for 2Edge* in child-edges do
	(1setf* (1symeval-in-instance* 2Edge* 'visible-p) nil)
  )
)

;;;-------------------- boxed vertex -----------------------------


(defflavor abstract-boxing-thing
	   ()
	   (basic-vertex)
  :Abstract-Flavor
)

(defmethod (abstract-boxing-thing :calculate-coords)
	   (top bottom left right x-offset y-offset)
  (let ((
x (if x-offset (- x-offset (send window :x-pl-offset)) 0))
	(
y (if y-offset (- y-offset (send window :y-pl-offset)) 0))
       )
       (1if* 2*Dont-Clip-P**
	   (1values* (+ 
y top) (+ 
y bottom) (+ 
x left) (+ 
x right))
	   (Let ((tp (max (+ 
y top) 0))
		 (b  (min (+ 
y bottom)
			  (+ (send window :inside-height) -1)
		     )
		 )
		 (l  (max (+ 
x left) 0))
		 (r  (min (+ 
x right)
			  (+ (send window :inside-width) -1)
		     )
		 )
		)
		(values tp b l r)
	   )
       )
  )
)


(defmethod (abstract-boxing-thing :draw-a-filled-rectangle)
	   (top bottom left right)
  (multiple-value-bind (tp b l r)
      (send self :calculate-coords
	   top bottom left right nil nil
      )
    (send window :draw-rectangle (- r l) (- b tp) l tp (draw-alu))
  )
)

(defmethod (abstract-boxing-thing :flash-whole-box) ()
  (multiple-value-bind (top bottom left right)
      (send self :box-coords)
    (send self :draw-a-filled-rectangle
	  top bottom left right
    )
  )
)

(defmethod (abstract-boxing-thing :box-coords) ()
  (values
    (+ 1 (- msr-top (send window :y-pl-offset))
    )
    (+ -2 (- msr-bottom (send window :y-pl-offset))
    )
    (+ 1 (- msr-left (send window :x-pl-offset))
    )
    (+ -2 (- msr-right (send window :x-pl-offset))
    )
  )
)

(defun draw-a-box (l r tp b alu window)
  (1let* ((dashed-p (1if* (1numberp* (1send* self :Dashed-P))
		      (1min* (1send* self :Dashed-P) 3)
		      (1if* (1send* self :Dashed-P)
			  3
			  nil
		      )
		  )
	)
       )
       (1if* dashed-p
	   (1progn* (send window :draw-dashed-line l tp r tp alu
			 (dashed-line-spacing dashed-p) nil 0
			 (dashed-line-length dashed-p)
		   )
		   (send window :draw-dashed-line l b  r b  alu
			 (dashed-line-spacing dashed-p) nil 0
			 (dashed-line-length dashed-p)
		   )
		   (send window :draw-dashed-line l tp l b  alu
			 (dashed-line-spacing dashed-p) nil 0
			 (dashed-line-length dashed-p)
		   )
		   (send window :draw-dashed-line r tp r b  alu
			 (dashed-line-spacing dashed-p) nil 0
			 (dashed-line-length dashed-p)
		   )
	   )
	   (1progn* (send window :draw-line l tp r tp alu)
		   (send window :draw-line l b  r b  alu)
		   (send window :draw-line l tp l b  alu)
		   (send window :draw-line r tp r b  alu)
	   )
       )
  )
)

(defun draw-a-rectangle (l r tp b alu window)
  (send window :draw-rectangle (- r l) (- b tp) l tp alu)
)

(defmethod (abstract-boxing-thing :undraw-self-this-way)
 (do-method undo-method partial-undo-method pred current partial alu-on alu-off)
  (ignore do-method alu-on)
  (if (1and* (1equal* 2*Rendering-Type** :Explorer) pred)
      ;; Undraw in old place.
      (if current
	  (if partial
	      (lexpr-send self partial-undo-method current)
	      (send self undo-method alu-off)
	  )
	  nil
      )
      nil
  )
)

(defmethod (abstract-boxing-thing :draw-self-this-way)
 (do-method undo-method partial-undo-method pred current partial alu-on alu-off)
  (ignore undo-method partial-undo-method pred current partial alu-off)
  (if pred
      (send self do-method alu-on)
      nil
  )
)

(defmethod (abstract-boxing-thing :do-something-to-a-rectangle)
  (function current partial set-current set-partial top bottom
   left right x-offset y-offset alu-on alu-off)
  (ignore current partial)
  (multiple-value-bind (tp b l r)
      (send self :calculate-coords
	   top bottom left right x-offset y-offset
      )
    (if (and (> b tp) (> r l))
	(1progn* ;prepare-sheet (window)
	  (funcall function l r tp b alu-on window)
	  (send self set-current
		(list tp b l r (send window :x-pl-offset)
		      (send window :y-pl-offset) alu-off
		)
	  )
	  (send self set-partial
		(not (and (= top tp) (= bottom b)
			  (= left l) (= right r)
		     )
		)
	  )
	)
	(send self set-current nil)
    )
  )
)

;-------------------------------------------------------------------------------

(defflavor basic-boxed-vertex
	   ((box-myself-p t)
	    (currently-boxed nil)
	    (partially-boxed nil)
	    (dashed-p nil)
	   )
	   (abstract-boxing-thing)
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables
)

(defmethod (basic-boxed-vertex :after :refreshed) ()
  (setq currently-boxed nil)
  (setq partially-boxed nil)
)

(defmethod (basic-boxed-vertex :before :draw-self) (&rest ignore)
  (1if* (1equal* 2*Rendering-Type** :Explorer)
      (Send self :undraw-self-this-way :draw-box :draw-box :draw-a-rectangle
	    box-myself-p currently-boxed partially-boxed (draw-alu) (erase-alu)
      )
      (send self :draw-self-this-way :draw-box :draw-box :draw-a-rectangle
	    box-myself-p currently-boxed partially-boxed (draw-alu) (erase-alu)
      )
  )
)

(defmethod (basic-boxed-vertex :after :draw-self) (&rest ignore)
  (1if* (1equal* 2*Rendering-Type** :Explorer)
      (send self :draw-self-this-way :draw-box :draw-box :draw-a-rectangle
	    box-myself-p currently-boxed partially-boxed (draw-alu) (erase-alu)
      )
      nil
  )
)

(defmethod (basic-boxed-vertex :draw-a-rectangle)
  (top bottom left right &optional (x-offset nil) (y-offset nil)
   (draw-alu (draw-alu)) (erase-alu (erase-alu)))
  (send self :do-something-to-a-rectangle 'draw-a-box :currently-boxed
	:partially-boxed :set-currently-boxed :set-partially-boxed
	top bottom left right x-offset y-offset draw-alu erase-alu
  )
)

(defmethod (basic-boxed-vertex :before :set-dashed-p) (ignore)
  (1send* self :Maybe-erase-self)
)

(defmethod (basic-boxed-vertex :after :set-dashed-p) (ignore)
  (1send* self :maybe-draw-Self)
)

(defmethod (basic-boxed-vertex :after :set-box-myself-p) (ignore)
  (with-xor-type-alus (window)
    (if box-myself-p
	(send self :draw-box (erase-alu))
	(send self :draw-box (draw-alu))
    )
  )
)

(defmethod (basic-boxed-vertex :draw-box) (&optional (alu (draw-alu)))
  (multiple-value-bind (top bottom left right)
      (send self :box-coords)
    (send self :draw-a-rectangle
	  top bottom left right nil nil alu
    )
  )
)

(defmethod (basic-boxed-vertex :after :erase-self) ()
  (if (and box-myself-p currently-boxed)
      (progn (lexpr-send self :draw-a-rectangle
			 currently-boxed
	     )
	     (setq currently-boxed nil)
      )
      nil
  )
)

(1defparameter* 2*Number-Of-Times-To-Flash-Vertices** 10)

(defmethod (basic-boxed-vertex :flash) ()
  (1loop* for i from 1 to 2*Number-Of-Times-To-Flash-Vertices** Do
	(1send* self :Set-Box-Myself-P (1not* Box-Myself-P))
	(1sleep* 0.1)
  )
)

(1defflavor* 2Boxed-Vertex*
	   ()
	   (2Basic-Boxed-Vertex* 2Vertex*)
)

;-------------------------------------------------------------------------------

(defflavor basic-filled-vertex
	   ((fill-myself-p t)
	    (currently-filled nil)
	    (partially-filled nil)
	   )
	   (abstract-boxing-thing)
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables
)

(defmethod (basic-filled-vertex :after :refreshed) ()
  (setq currently-filled nil)
  (setq partially-filled nil)
)

(defmethod (basic-filled-vertex :draw-a-filled-rectangle)
  (top bottom left right &optional (x-offset nil) (y-offset nil)
   (alu (draw-alu))
  )
  (send self :do-something-to-a-rectangle 'draw-a-rectangle
	:currently-filled :partially-filled :set-currently-filled
	:set-partially-filled top bottom left right
	x-offset y-offset alu alu
  )
)

(1defwhopper* (2Basic-Filled-Vertex* :Draw-Self) (&rest args)
  (1if* (1or* (1equal* 2*Rendering-Type** :Explorer) (1not* fill-myself-p))
      (1lexpr-continue-whopper* args)
      (1let* ((2*Paint-In-White-P** t))
	   (1lexpr-continue-whopper* args)
      )
  )
)

(Defmethod (basic-filled-vertex :before :draw-self) (&rest ignore)
  (1if* (1equal* 2*Rendering-Type** :Explorer)
      (send self :undraw-self-this-way :draw-block :draw-block
	    :draw-a-filled-rectangle
	    fill-myself-p currently-filled partially-filled
	    (draw-alu) (draw-alu)
      )
      (with-xor-type-alus (window)
	(send self :draw-self-this-way :draw-block :draw-block
	      :draw-a-filled-rectangle
	      fill-myself-p currently-filled partially-filled
	      (draw-alu) (draw-alu)
	)
      )
  )
)

(defmethod (basic-filled-vertex :after :draw-self) (&rest ignore)
  (1if* (1equal* 2*Rendering-Type** :Explorer)
      (with-xor-type-alus (window)
	(send self :draw-self-this-way :draw-block :draw-block
	      :draw-a-filled-rectangle
	      fill-myself-p currently-filled partially-filled
	      (draw-alu) (draw-alu)
	)
      )
      nil
  )
)

(defmethod (basic-filled-vertex :after :set-fill-myself-p) (ignore)
  (with-xor-type-alus (window) 
    (if fill-myself-p
	(send self :draw-block (draw-alu))
	(send self :draw-block (erase-alu))
    )
  )
)

(defmethod (basic-filled-vertex :draw-block) (&optional (alu (draw-alu)))
  (multiple-value-bind (top bottom left right)
      (send self :box-coords)
    (send self :draw-a-filled-rectangle
	  top bottom left right nil nil alu
    )
  )
)

(defmethod (basic-filled-vertex :after :erase-self) ()
  (if (and fill-myself-p currently-filled)
      (progn (lexpr-send self :draw-a-filled-rectangle
			 currently-filled
	     )
	     (setq currently-filled nil)
      )
      nil
  )
)

(defmethod (basic-filled-vertex :flash) ()
  (1loop* for i from 1 to 2*Number-Of-Times-To-Flash-Vertices** Do
	(1send* self :Set-Fill-Myself-P (1not* Fill-Myself-P))
	(1sleep* 0.1)
  )
)

(1defflavor* 2Filled-Vertex*
	   ()
	   (2Basic-Filled-Vertex* 2Vertex*)
)

;-------------------------------------------------------------------------------

(defflavor basic-boxed-filled-vertex
	   ()
	   (basic-filled-vertex basic-boxed-vertex)
  (:default-init-plist :fill-myself-p nil)
)

(defmethod (basic-boxed-filled-vertex :toggle) ()
  (if box-myself-p
      (send self :set-fill-myself-p t)
      (send self :set-box-myself-p  t)
  )
)

(defmethod (basic-boxed-filled-vertex :flash) ()
  (1let* ((old-box  Box-Myself-P)
        (old-fill Fill-myself-p)
	(*already-toggling* t)
       )
       (declare (special *already-toggling*))
       (1if* old-box  (1send* self :Set-Box-Myself-P  nil))
       (1if* old-fill (1send* self :Set-Fill-Myself-P nil))
       (1loop* for i from 1 to (1truncate* *number-of-times-to-flash-vertices* 4)
	     do (1send* self :Set-Box-Myself-P t)
	        (1sleep* 0.1)
		(1send* self :Set-Box-Myself-P nil)
	        (1sleep* 0.1)
		(1send* self :Set-Fill-Myself-P t)
		(1sleep* 0.1)
		(1send* self :Set-Fill-Myself-P nil)
		(1sleep* 0.1)
       )
       (1if* old-box  (1send* self :Set-Box-Myself-P  old-box))
       (1if* old-fill (1send* self :Set-Fill-Myself-P old-fill))
  )
)

(defmethod (basic-boxed-filled-vertex :before :set-fill-myself-p) (to)
  (declare (special *already-toggling*))
  (if (and (boundp '*already-toggling*) *already-toggling*)
      nil
      (let ((*already-toggling* t))
	   (declare (special *already-toggling*))
	   (if to
	       (send self :set-box-myself-p nil)
	       nil
	   )
      )
  )
)

(defmethod (basic-boxed-filled-vertex :before :set-box-myself-p) (to)
  (declare (special *already-toggling*))
  (if (and (boundp '*already-toggling*) *already-toggling*)
      nil
      (let ((*already-toggling* t))
	   (declare (special *already-toggling*))
	   (if to
	       (send self :set-fill-myself-p nil)
	       nil
	   )
      )
  )
)

(1defflavor* 2boxed-filled-vertex*
	   ()
	   (basic-boxed-filled-vertex 2Vertex*)
)

;;----------------------- Graphics vertices ---------------------

(1defflavor* graphics-vertex
	   ()
	   (scrollable-graphics-item 2Basic-Vertex*)
  ;; Just ignore these in plot-a-graph.
  (:Init-Keywords :Font 3:Pre-Print-Item-Modify-Function*)
)

(1defflavor* boxed-graphics-vertex
	   ()
	   (2Basic-Boxed-Vertex* scrollable-graphics-item)
  ;; Just ignore these in plot-a-graph.
  (:Init-Keywords :Font 3:Pre-Print-Item-Modify-Function*)
)

(1defflavor* filled-graphics-vertex
	   ()
	   (2Basic-Filled-Vertex* scrollable-graphics-item)
  ;; Just ignore these in plot-a-graph.
  (:Init-Keywords :Font 3:Pre-Print-Item-Modify-Function*)
)

(1defflavor* boxed-filled-graphics-vertex
	   ()
	   (2Basic-Boxed-Filled-Vertex* scrollable-graphics-item)
  ;; Just ignore these in plot-a-graph.
  (:Init-Keywords :Font 3:Pre-Print-Item-Modify-Function*)
)

(defun Display-Bitmap-From-File
   (grapher-sheet pathname
    &optional (x 0)
              (y 0)
	      (mouse-sensitive-type :Vertex)
	      (flavor 'graphics-vertex)
   )
  (let ((bitmap (w:read-bit-array-file pathname)))
       (send grapher-sheet :Scrollable-Item bitmap flavor
	     :X (1or* x (1floor* (1-* (sheet-inside-width grapher-sheet)
				(1array-dimension* bitmap 1)
			      )
			      2
		       )
		)
	     :Y (1or* y (1floor* (1-* (sheet-inside-height grapher-sheet)
				 (1array-dimension* bitmap 1)
			     )
			     2
		       )
		)
	     :Unique-Key (gensym) :Mouse-Sensitive-Type mouse-sensitive-type
       )
  )
)

(1defun* move-to-front-of-item-list (item)
  (1let* ((window (1send* item :Window)))
       (1let* ((item-list (1send* window :Item-List)))
	    (1assert* (1member* item item-list) () "Item is not in window.")
	    (1send* window :Set-Item-List
		   (1cons* item (1delete* item item-list :Test #'1eq*))
	    )
	    (1send* window :Refresh)
       )
  )
)

;;----------------------- edge ----------------------------------

(defflavor basic-edge (from-vertex to-vertex)
	   (scrollable-line-item)
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables
  (:default-init-plist :mouse-sensitive-type :edge))

(1defmethod* (2Basic-Edge* :Print-Self) (1stream* ignore ignore)
  (1if* (1catch-error*
        (1if* (1and* (1boundp-in-instance* self 'from-vertex)
		  (1boundp-in-instance* self 'to-vertex)
	    )
	    (1if* (1and* (1boundp-in-instance* self 'item) item)
		(1progn*
		  (1format* stream "#<~ ~ "
			  (1list* (1type-of* self) nil (1type-of* self))
			  (1list* item t item)
		  )
		  (1format* stream ":~  ~ "
			    (1list* from-vertex t (1send* from-vertex :Item))
			    (1list*   to-vertex t (1send*   to-vertex :Item))
		  )
		  (2Print-Pointer-To* self stream)
		  (1format* stream ">")
		  t
		)
		(1progn*
		  (1format* stream "#<~ "
			  (1list* (1type-of* self) nil (1type-of* self))
		  )
		  (1format* stream "~  ~ "
			    (1list* from-vertex t (1send* from-vertex :Item))
			    (1list*   to-vertex t (1send*   to-vertex :Item))
		  )
		  (2Print-Pointer-To* self stream)
		  (1format* stream ">")
		  t
		)
	    )
	    (1progn*
	      (1format* stream "#<~ "
		      (1list* (1type-of* self) nil (1type-of* self))
	      )
	      (2Print-Pointer-To* self stream)
	      (1format* stream ">")
	      t
	    )
	)
	nil
      )
      self
      (1format* stream "Error printing...")
  )
)

(1defmethod* (2Basic-Edge* :On-Screen-P) ()
  (1or* 2*Force-On-Screen-P**
       (1Send* window :edge-on-screen-p from-x from-y to-x to-y)
  )
)

(1defmethod* (2Basic-Edge* :Set-Visibility) (to)
  (1declare* (1special* *passed-these-nodes*))
  (1if* (1not* (1member* self *passed-these-nodes*))
      (1progn* (1push* self *passed-these-nodes*)
	      (1setq* visible-p to)
	      (1send* to-vertex :Set-Visibility to)
      )
      nil
  )
)

(1defmethod* (2Basic-Edge* :Make-Me-And-My-Children-Invisible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visibility nil)
       (1send* window :Refresh)
  )
)

(1defmethod* (2Basic-Edge* :Make-Me-Visible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visible-P t)
       (1send* window :Refresh)
  )
)

(1defmethod* (2Basic-Edge* :Make-Me-Invisible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visible-P nil)
       (1send* window :Refresh)
  )
)

(1defmethod* (2Basic-Edge* :Make-Me-And-My-Children-Visible) ()
  (1let* ((*passed-these-nodes* nil))
       (1declare* (1special* *passed-these-nodes*))
       (1send* self :Set-Visibility t)
       (1send* window :Refresh)
  )
)

(defmethod (basic-edge :after :delete-self) (&rest ignore)
  "2after deleting the edge, remove self from their parent and child lists*"
  (send to-vertex :delete-from-parent-edges self)
  (send from-vertex :delete-from-child-edges self))

(defmethod (basic-edge  :position-self-n-descendents) (at-x at-y)
  (if (and  (not (send to-vertex :being-positioned-p)) ;1watch out for cycles*
	    (not (send to-vertex :positioned-p)))  ;1watch our for diags*
      (send to-vertex :position-self-n-descendents at-x at-y)
      (values 0 0)) ;1this else handles cycles.*
  ;;we can't calculate from-x and from-y yet because from-vertex is
  ;;not positoned yet.  We depond upon from-vertex to send us a 
  ;; :calculate-your-position message when it has finished positioning itself
  )

(defmethod (basic-edge :draw-self-n-descendents) ()
  (send self :maybe-draw-self)
  (unless (send to-vertex :being-drawn-p)  ;1this to handle cycles*
  (send to-vertex  :draw-self-n-descendents)))

(defmethod (basic-edge :move-self-n-descendents-relative) (x y &optional inhibit-redraw-p)
  (unless (send to-vertex :being-moved-p)   ;1this to handle cycles*
    (send to-vertex :move-self-n-descendents-relative x y inhibit-redraw-p)))

(defmethod (basic-edge :get-self-n-descendents) ()
  (unless (send to-vertex :getting-descendents-p) (send to-vertex :get-self-n-descendents)))

(defmethod (basic-edge :calculate-your-position) ()
  (ecase (send window :orientation)
    (:horizontal
     (send self :move-to
	   (first (send from-vertex :right-anchor))
	   (second (send from-vertex :right-anchor))
	   (first (send to-vertex :left-anchor))
	   (second (send to-vertex :left-anchor))
	   'inhibit-redisplay))
    (:vertical
     (send self :move-to
	   (first (send from-vertex :bottom-anchor))
	   (second (send from-vertex :bottom-anchor))
	   (first (send to-vertex :top-anchor))
	   (second (send to-vertex :top-anchor))
	   'inhibit-redisplay))))


(defmethod (basic-edge :draw-boxing-maybe) (logical-mouse-x logical-mouse-y)
  (1if* (send self :boxing-appropriate-p logical-mouse-x logical-mouse-y)
      ;;then get the window's item blinker, and turn it on
     (let ((blinker (send window :edge-following-blinker)))
	  (4blinker-set-cursorpos*
	    blinker (1-* logical-mouse-x (send window :x-pl-offset))
	    (- logical-mouse-y (send window :y-pl-offset))
	  )
	  (4set-following-arrow-blinker-origin*
	    4blinker* (1-* to-x (send window :x-pl-offset))
	    (- to-y (send window :y-pl-offset))
	  )
	  ;; Turn the blinker on.
	  (blinker-set-visibility blinker T)
	  t
      )
      nil
  )
)

(defmethod (basic-edge :erase-boxing) ()
  "Turn the blinker off"
  (blinker-set-visibility (send window :edge-following-blinker) nil))


(1defvar* *edge-arrow-mouse-blinker-position-error-margin* 0.05 "=5%")

(defun safe/ (x y)
  "Divides x by y giving 0 if y = 0."
  (if (1=* y 0)
      0
      (1/* x y)
  )
)

(defmethod (basic-edge :boxing-appropriate-p) (logical-mouse-x logical-mouse-y)
  "In order to qualify for boxing the item must be of a
   current-mouse-sensitive-type, and the mouse has to be over the msr
   (mouse sensitive region) of the item."
  (and visible-p
       (1>=* logical-mouse-x (1min* from-x to-x))
       (1<=* logical-mouse-x (1m*ax from-x to-x))
       (1>=* logical-mouse-y (1min* from-y to-y))
       (1<=* logical-mouse-y (1m*ax from-y to-y))
       (send window :current-mouse-sensitve-type-p mouse-sensitive-type)
       (1let* ((normalised-x-target (1-* to-x from-x))
	    (normalised-y-target (1-* to-y from-y))
	    (normalised-x-mouse (1-* logical-mouse-x from-x))
	    (normalised-y-mouse (1-* logical-mouse-y from-y))
	   )
	   (1let* ((gradient-of-edge
		   (safe1/* normalised-y-target normalised-x-target)
		 )
		(gradient-of-mouse
		  (safe1/* normalised-y-mouse normalised-x-mouse)
		)
	       )
	       (1or* (1and* (1zerop* gradient-of-edge)
			 (1zerop* gradient-of-mouse)
		   )
		   (1<* (safe1/* (1abs* (- gradient-of-edge gradient-of-mouse))
			 (max (1abs* gradient-of-edge) (1abs* gradient-of-mouse))
		      )
		      *edge-arrow-mouse-blinker-position-error-margin*
		   )
	       )
	   )
       )
  )
)

;-------------------------------------------------------------------------------

(defflavor edge ()
	   (undirected-possibly-mixin
	    dashed-line-mixin
	    arrowhead-mixin
	    edge-label-mixin
	    basic-edge))

;-------------------------------------------------------------------------------

(1defflavor* 2Invisible-Edge* () (2Edge*) (:Default-Init-Plist :Visible-P nil))

(1defmethod* (2Invisible-Edge* :Before :Maybe-Draw-Self) (&rest ignore)
  (1setq* visible-p nil)
)

;-------------------------------------------------------------------------------

(defflavor edge-label-mixin ((label nil)
			     (label-font nil)
			     (label-offset 2)
			     (label-position))
	   ()
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables
  (:required-instance-variables  window item from-x from-y to-x to-y))

(defmethod (edge-label-mixin :after :init) (&rest ignore)
  (unless label-font (setq label-font (send window :current-font)))
  ;1;error checking*
  (when label
    (etypecase label
      (string) ;1fine, do nothing*
      (symbol ;1;help out the silly user.*
         (setq label (string-downcase (symbol-name label)))))))

(defmethod (edge-label-mixin :after :draw-self) (&rest ignore)
  (when label 
    (condition-case ()				;trap divide-by-zero errors generated from lines of no length
	(let* ((slope (condition-case ()	;positive slope is downhill cause of window coords
			  (/ (- from-y to-y)
			     (- from-x to-x))
			(sys:divide-by-zero 100000)))
	       (middle-x (truncate (+ to-x from-x) 2))
	       (middle-y (truncate (+ to-y from-y) 2))
	       (ratio (/ label-offset (sqrt (+ (* (- to-y from-y)(- to-y from-y))
					       (* (- to-x from-x)(- to-x from-x))))))
	       (label-anchor1 (rotate (list (+ middle-x (* ratio (- from-x to-x)))
					    (+ middle-y (* ratio (- from-y to-y))))
				      (list middle-x middle-y) 90 :degrees))
	       (label-anchor2 (rotate (list (+ middle-x (* ratio (- from-x to-x)))
					    (+ middle-y (* ratio (- from-y to-y))))
				      (list middle-x middle-y) -90 :degrees)))
	  ;1;choose the anchor pos to the right.  if they are close choose the "right" one*
	  (setq label-position
		(cond ((> 3 (abs (- (first label-anchor1) (first label-anchor2))))	;1close?*
		       ;1; if the line is going downhill from left to right (Slope pos.) then choose the higher anchor (whose y is less)*
		       (cond ((>= slope 0)
			      (setq label-position (if (>= (second label-anchor1) (second label-anchor2))
						       label-anchor2
						       label-anchor1)))
			     (t			;1else choose the lower (whose y is greater) anchor*
			      (setq label-position (if (>= (second label-anchor1) (second label-anchor2))
						       label-anchor1
						       label-anchor2)))))
		      
		      (t			;1else choose the anchor to the right*
		       (if (> (first label-anchor1) (first label-anchor2))
			   label-anchor1
			   label-anchor2))))
	  (setf label-font
		(typecase label-font
		  (font label-font)
		  (symbol (symbol-value label-font))
		  (otherwise label-font)))
	  ;1;if the line is downhill then give room for the font height*
	  (if (> slope 0)
	      (decf (second label-position) (font-char-height label-font)))
	  ;1;send outside coords*
	  (send window :string-out-explicit-within-region
		label
		(+ (sheet-inside-left window)
		   (- (first label-position) (send window :x-pl-offset)))
		(+ (sheet-inside-top window)
		   (- (second label-position) (send window :y-pl-offset)))
		label-font
		(draw-alu)))
      (sys:divide-by-zero))))


(defmethod (edge-label-mixin :after :erase-self) (&rest ignore)
  (when label-position 
    (send window :string-out-explicit-within-region
	  label
	  (+ (sheet-inside-left window)
	     (- (first label-position) (send window :x-pl-offset)))
	  (+ (sheet-inside-top window)
	     (- (second label-position) (send window :y-pl-offset)))
	  label-font
	  (erase-alu))))


(defconstant deg-to-rads-const (/ pi 180))
(defconstant pi/2 (/ pi 2))

(defun rotate (point center theta &optional (theta-type :degrees))
  "2Rotates *point2 *theta 2around *center. 2 Counter-clockwise is positive.
   Point and center should be two element lists. Theta-type can be
  :degrees or :radians*"
  (ecase theta-type
     (:degrees (setq theta (* deg-to-rads-const theta)))
     (:radians))
;  (let ((rotation-matrix (list (cos theta) (cos (+ theta pi/2))
;			       (sin theta) (sin (+ theta pi/2)))))
  (let ((rotation-matrix
;	  (1let* ((cos-theta (1cos* theta))
;	        (sin-theta (1sin* theta)))
	  (1multiple-value-bind* (sin-theta cos-theta)
	      (2Fast-Sin-And-Cos* theta)
	    (list cos-theta (1-* sin-theta)
		  sin-theta cos-theta))))
     ;1; translate to 0,0 ,rotate, then translate back.*
    (L+ center (matrix-multiply rotation-matrix (L- point center)))))

(defun matrix-multiply (matrix vector)
  "2matrix must be a four element list (a b c d), vector a two element list (x y)
  Returns integers*"
  (list (round (+ (* (first matrix) (first vector))
		  (* (second matrix) (second vector))))
	(round (+ (* (third matrix) (first vector))
		  (* (fourth matrix) (second vector))))))

(defun L+ (x y)
  (list (+ (first x)
	   (first y))
	(+ (second x)
	   (second y))))

(defun L- (x y)
  (list (- (first x)
	   (first y))
	(- (second x)
	   (second y))))

(defflavor arrowhead-mixin ((arrowhead-p t)
			    (reverse-arrowhead-p nil)
			    (tip1-x nil) (tip1-y nil)
			    (tip2-x nil) (tip2-y nil))
	   ()
  (:initable-instance-variables arrowhead-p reverse-arrowhead-p)
  (:settable-instance-variables arrowhead-p reverse-arrowhead-p)
  (:required-instance-variables from-x from-y to-x to-y window))

(defconstant *arrowhead-length* 10)
(defconstant *arrowhead-angle* 24)

(defmethod (arrowhead-mixin :after :draw-self) (&rest ignore)
  (if arrowhead-p (send self :draw-arrowhead)))

(defmethod (arrowhead-mixin :after :erase-self) (&rest ignore)
  (if arrowhead-p (send self :erase-arrowhead)))

(defmethod (arrowhead-mixin :after :refreshed) ()
  (1setq* tip1-x nil)
)

(defun-method draw-arrowhead arrowhead-mixin ()
  (if tip1-x (send self :erase-arrowhead))	;this so we don't leave do-do's in random places.
  (let* ((my-from-x (1if* reverse-arrowhead-p to-x from-x))
        (my-from-y (1if* reverse-arrowhead-p to-y from-y))
	(my-to-x   (1if* reverse-arrowhead-p from-x to-x))
	(my-to-y   (1if* reverse-arrowhead-p from-y to-y))
	(slope (/ (- my-from-y my-to-y) ;positive slope is downhill cause of window coords
		   (- my-from-x my-to-x)))
	 (shaft-length (sqrt (+ (* (- my-to-y my-from-y)(- my-to-y my-from-y))
				(* (- my-to-x my-from-x)(- my-to-x my-from-x)))))
	 (ratio (/ *arrowhead-length* shaft-length))
	 (head-x (- my-to-x (* ratio (- my-to-x my-from-x))))
	 (head-y (- my-to-y (* slope (* ratio (- my-to-x my-from-x)))))
	 ;;                              \
	 ;;                                \
	 ;;      ------------------------h--->      ; the h is at (head-x, head-y)
	 ;;                                /
	 ;;                              /
	 
	 (tip-1 (rotate (list head-x head-y) (list my-to-x my-to-y) *arrowhead-angle*))
	 (tip-2 (rotate (list head-x head-y) (list my-to-x my-to-y) (- *arrowhead-angle*))))
   ; (format window "~a ~a ~a ~a ~a ~a~&" tip-1 tip-2 my-to-x my-to-y (truncate head-x) (truncate head-y))
    (setq tip1-x (first tip-1)
	  tip1-y (second tip-1)
	  tip2-x (first tip-2)
	  tip2-y (second tip-2))
    ;;convert to physical coordinates, and draw.
    (send self :draw-maybe-dashed-line
	  (- my-to-x (send window :x-pl-offset))
	  (- my-to-y (send window :y-pl-offset))
	  (- tip1-x (send window :x-pl-offset))
	  (- tip1-y (send window :y-pl-offset))
	  (draw-alu))
    (send self :draw-maybe-dashed-line
	  (- my-to-x (send window :x-pl-offset))
	  (- my-to-y (send window :y-pl-offset))
	  (- tip2-x (send window :x-pl-offset))
	  (- tip2-y (send window :y-pl-offset))
	  (draw-alu))))


(defmethod (arrowhead-mixin :draw-arrowhead) ()
  ;; can't draw the arrowhead for a veritical shaft. big deal.
  (condition-case ()
      (draw-arrowhead)
    (sys:divide-by-zero nil)))

(defmethod (arrowhead-mixin :erase-arrowhead) ()
  (when (and tip2-y tip2-x tip1-y tip1-x)
    (let ((physical-to-x (- to-x (send window :x-pl-offset)))
	  (physical-to-y (- to-y (send window :y-pl-offset)))
	  (physical-tip1-x (- tip1-x (send window :x-pl-offset)))
	  (physical-tip1-y (- tip1-y (send window :y-pl-offset)))
	  (physical-tip2-x (- tip2-x (send window :x-pl-offset)))
	  (physical-tip2-y (- tip2-y (send window :y-pl-offset))))
      (send self :draw-maybe-dashed-line
	    physical-to-x physical-to-y
	    physical-tip2-x physical-tip2-y
	    (erase-alu))
      (send self :draw-maybe-dashed-line
	    physical-to-x physical-to-y
	    physical-tip1-x physical-tip1-y
	    (erase-alu))
      (setq tip2-y nil
	    tip2-x nil
	    tip1-y nil
	    tip1-x nil))))

;1;;--------------- dashed line mixin -----------------------------------*

(defflavor dashed-line-mixin ((dashed-p))
	   ()
  :initable-instance-variables
  :settable-instance-variables
  :gettable-instance-variables
  (:required-flavors scrollable-line-item)
  (:documentation "Set dashed-p to 1, 2, or 3 for three different dashing styles. "))

(1defmethod* (2Dashed-Line-Mixin* :draw-maybe-dashed-line) (x1 y1 x2 y2 alu)
  (1if* dashed-p
      (1send* window :draw-dashed-line x1 y1 x2 y2 alu
	     (dashed-line-spacing (1case* dashed-p (1 1) (2 2) (otherwise 3)))
	     nil 0
	     (dashed-line-length  (1case* dashed-p (1 1) (2 2) (otherwise 3)))
      )
      (1send* window :Draw-Line x1 y1 x2 y2 alu)
  )
)

(defmethod (dashed-line-mixin :after :draw-self) (&rest ignore)
  "2if Dashed-p, erase the solid line, and draw ours in*"
  (when dashed-p
    ;1;first convert to physical coordinates*
    (let ((p-from-x (- from-x (send window :x-pl-offset)))
	  (p-from-y (- from-y (send window :y-pl-offset)))
	  (p-to-x (- to-x (send window :x-pl-offset)))
	  (p-to-y (- to-y (send window :y-pl-offset))))
    (send window :draw-line p-from-x p-from-y p-to-x p-to-y (erase-alu))
    (case dashed-p
       (1 (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		(draw-alu) (dashed-line-spacing 1) nil 0 (dashed-line-length 1)))
       (2 (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		(draw-alu) (dashed-line-spacing 2) nil 0 (dashed-line-length 2)))
       (otherwise
	   (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
	      (draw-alu) (dashed-line-spacing 3) nil 0 (dashed-line-length 3)))))))

(defmethod (dashed-line-mixin :after :erase-self) (&rest ignore)
  "2if Dashed-p, we better clean up after ourselves*"
  (when dashed-p
    ;1;first convert to physical coordinates*
    (let ((p-from-x (- from-x (send window :x-pl-offset)))
	  (p-from-y (- from-y (send window :y-pl-offset)))
	  (p-to-x (- to-x (send window :x-pl-offset)))
	  (p-to-y (- to-y (send window :y-pl-offset))))
      (send window :draw-line p-from-x p-from-y p-to-x p-to-y (erase-alu))
      (case dashed-p
	(1 (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		 (erase-alu) (dashed-line-spacing 1) nil 0 (dashed-line-length 1)))
	(2 (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		 (erase-alu) (dashed-line-spacing 2) nil 0 (dashed-line-length 2)))
	(otherwise
	 (send window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
	       (erase-alu) (dashed-line-spacing 3) nil 0 (dashed-line-length 3)))))))

(defun dashed-line-spacing (type)
  (ecase type
    (1 10)
    (2 20)
    (3 30)))

(defun dashed-line-length (type)
  (ecase type
    (1 5)
    (2 5)
    (3 20)))


;;;---------------- undirected-possibl1y*-mixin ----------------------

(defflavor 2Undirected-Possibly-Mixin*
	   ((undirected-p nil)
	    (dynamic-anchors-p nil)
	   )
	    ()
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables
  (:required-flavors basic-edge))

(defmethod (undirected-possibly-mixin :after :init) (&rest ignore)
  (and undirected-p 
       (send self :set-arrowhead-p nil)))

(defmethod (undirected-possibly-mixin :calculate-your-position) ()
  "2If we're an undirected edge, then use the closest pair of anchors, ie. not always left to right*"
  (if (1or* dynamic-anchors-p undirected-p)
    (ecase (send window :orientation)
      (:horizontal
       ;1; best is the line with the least delta-x*
       (let* ((possibilities (list (list (send from-vertex :right-anchor)
					 (send to-vertex :right-anchor))
				   (list (send from-vertex :right-anchor)
					 (send to-vertex :left-anchor))
				   (list (send from-vertex :left-anchor)
					 (send to-vertex :right-anchor))
				   (list (send from-vertex :left-anchor)
					 (send to-vertex :left-anchor))))
	      (best (first (sort possibilities #'<
				 :key  #'(lambda (p) (abs (- (caar p) (caadr p))))))))
	 (send self :move-to
	       (first (first best))
	       (second (first best))
	       (first (second best))
	       (second (second best))
	       'inhibit-redisplay)))
      (:vertical
       ;1; best is the line with the least delta-y*
       (let* ((possibilities (list (list (send from-vertex :bottom-anchor)
					 (send to-vertex :bottom-anchor))
				   (list (send from-vertex :bottom-anchor)
					 (send to-vertex :top-anchor))
				   (list (send from-vertex :top-anchor)
					 (send to-vertex :bottom-anchor))
				   (list (send from-vertex :top-anchor)
					 (send to-vertex :top-anchor))))
	      (best (first (sort possibilities #'<
				 :key  #'(lambda (p) (abs (- (cadar p) (cadadr p))))))))
	 (send self :move-to
	       (first (first best))
	       (second (first best))
	       (first (second best))
	       (second (second best))
	       'inhibit-redisplay))))
    ;1;else do the normal thing*
    (ecase (send window :orientation)
    (:horizontal
     (send self :move-to
	   (first (send from-vertex :right-anchor))
	   (second (send from-vertex :right-anchor))
	   (first (send to-vertex :left-anchor))
	   (second (send to-vertex :left-anchor))
	   'inhibit-redisplay))
    (:vertical
     (send self :move-to
	   (first (send from-vertex :bottom-anchor))
	   (second (send from-vertex :bottom-anchor))
	   (first (send to-vertex :top-anchor))
	   (second (send to-vertex :top-anchor))
	   'inhibit-redisplay)))))

;-------------------------------------------------------------------------------

;;; Optimisations.

;;; Copied and modified from sys:sin-cos-float-aux by JPR.
(defun fast-sin-and-cos (angle)
  (1declare* (1values* sin-of-angle cos-of-angle))
  (1declare* (optimize (speed 3) (safety 0)))
  (LET (eps c1 c2 rc pi-inv)
    (ETYPECASE angle
      (single-float
       (SETQ eps 2.44f-4
	     c1	3.140625f0
	     c2 -9.676535898f-4
	     rc '(0.2601903036f-5 -0.1980741872f-3
				  0.8333025139f-2
				  -0.1666665668f+0)
	     pi-inv 0.31830988618379067154f0))
      (short-float
       (SETQ eps 0.0027s0
	     c1 3.140625s0
	     c2 -9.676535898s-4
	     rc '(0.2601903036S-5 -0.1980741872S-3
				  0.8333025139S-2
				  -0.1666665668S+0)
	     pi-inv 0.31830988618379067154s0))
      (double-float
       (SETQ eps 1.05d-8
	     c1 3.1416015625d0
	     c2 8.908910206761537356617d-6
	     rc '(0.27204790957888846175d-14 -0.76429178068910467734d-12
					     0.16058936490371589114d-9
					     -0.25052106798274584544d-7
					     0.27557319210152756119d-5
					     -0.19841269841201840457d-3
					     0.83333333333331650314d-2
					     -0.16666666666666665052d0)
	     pi-inv 0.31830988618379067154d0)))
    (multiple-value-bind (n r) (ROUND (* angle pi-inv))
      (multiple-value-bind (x1 x2) (FLOOR angle)
        (1values*
	  (let* ((xn n)
		 (f (+ (- x1 (* xn c1)) x2 (* xn c2)))
		 (res
		   (IF (< (ABS f) eps)
		       f
		       (LET* ((g (sys:sqr f)))
			 (+ f (* f g (sys:poly g rc)))))))
	    (IF (ODDP n) (- res) res))
	  (1progn*
	    (when (not (minusp r)) (incf n))
	    (let* ((xn (- n (float 0.5s0 angle)))
		   (f (+ (- x1 (* xn c1)) x2 (* xn c2)))
		   (res
		     (IF (< (ABS f) eps)
			 f
			 (LET* ((g (sys:sqr f)))
			   (+ f (* f g (sys:poly g rc)))))))
	      (IF (ODDP n) (- res) res))))))))

;-------------------------------------------------------------------------------

#|


(send w :draw-graph
      (list "ver1" "ver2" "ver3" "ver31" "ver311" "ver32" "ver21" "ver22" "ver221" "ver2211" "ver22111"
	    "ver22112" "ver22113" "2ver1" "2ver2" "2ver3" "3ver1" "3ver2" "4ver1")
      (list (list "ver1" "ver2")
	    (list "ver1" "ver3" :dashed-p 1)
	    (list "ver3" "ver31" :dashed-p t)
	    (list "ver3" "ver32" :dashed-p 2)
	    (list "ver3" "ver1")
	    (list "ver31" "ver311")
	    (list "ver2" "ver21")
	    (list "ver2" "ver22")
	    (list "ver22" "ver221")
	    (list "ver221" "ver2211")
	    (list "ver2211" "ver22111")
	    (list "ver2211" "ver22112")
	    (list "ver2211" "ver22113")
	    (list "2ver1" "2ver2")
	    (list "2ver1" "2ver3")
	    (list "3ver1" "3ver2")))
	    





(progn
  (send w :set-label (format nil
			     "AKO links:   solid line ~&~
                              IS-A links:  short dashes ~&~
                              HATES links: long dashes"))
  (send w :draw-graph
	'((rover :FONT fonts:tr10i)  (jasmine :font fonts:tr10i) (sleepy :font fonts:tr10i)
	  cat dog pig domesticated-animal animal)
	`((rover dog :dashed-p 1 :label "note!")
	  (jasmine dog :dashed-p 1)
	  (sleepy cat :dashed-p 1)
	  (dog domesticated-animal)
	  (cat domesticated-animal)
	  (domesticated-animal animal)
	  (pig animal)
	  (cat dog :dashed-p 3))))


(send w :draw-graph '(a b c d e f g h i j k l m n o p)
      '((a b)
	(a c)
	(a d)
	(b e :label "from b to e" :label-font fonts:hl12b)
	(b f :undirected-p t :label "undirected")
	(b g :arrowhead-p nil :label "directed")
	(c h :item '(c j))
	(c i :mouse-sensitive-type 'foo-edge)
	(d j :dashed-p 1)
	(d k :dashed-p 2)
	(d l :dashed-p 3)
	(d m :dashed-p t)
	(n o :undirected-p t)
	(o p :undirected-p t)))
(send w :set-item-type-alist '((:vertex foo "foo" (foo foo2)) (:edge bar "bar" (bar bar2))))
(send w :set-orientation :vertical)


(progn (setq w (make-instance 'tv:graph-window :edges '(0 0 600 400)))
       (send w :draw-graph '(a b c d e f g h i j k l m n o p)
	     '((a b)
	       (a c)
	       (a d)
	       (b e :label "from b to e" :label-font fonts:hl12b)
	       (b f :undirected-p t :label "undirected")
	       (b g :arrowhead-p nil :label "directed")
	       (c h :item '(c j))
	       (c i :mouse-sensitive-type 'foo-edge)
	       (d j :dashed-p 1)
	       (d k :dashed-p 2)
	       (d l :dashed-p 3)
	       (d m :dashed-p t)
	       (n o :undirected-p t)
	       (o p :undirected-p t)
	       (p j)))
       (send w :expose)
       (send w :set-item-type-alist '((:vertex foo "foo" (foo foo2)))))	
|#