;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB)Ï1; Ï*Patch-File: T -*-

;Ï1;;                     RESTRICTED RIGHTS LEGEND          Ï*
;Ï1;; Use, duplication, or disclosure by the Government is subject toÏ*
;Ï1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights inÏ*
;Ï1;; Technical Data and Computer Software clause at 52.227-7013.Ï*
;Ï1;;                   TEXAS INSTRUMENTS INCORPORATED.Ï*
;Ï1;;                            P.O. BOX 149149Ï*
;Ï1;;                         AUSTIN, TEXAS 78714-9149Ï*
;Ï1;;                             MS 2151Ï*
;Ï1;; Copyright (C) 1986,1987, 1988, 1989 Texas Instruments Incorporated. All rights reserved.Ï*

#|
Ï3Flavor definition for graph window

See the documentation for basic-x-y-scrolling-window, 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  Ï*	Ï3:draw-graph
              Ï*	Ï3:generate-graph
                Ï*	Ï3:add-vertex
             Ï*	Ï3:add-edge
             Ï*	Ï3:delete-vertex
             Ï*	Ï3: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-display-mixin to basic-graph-mixin will handle mouse-m and mouse-m-2 blips 
if the blip is over a vertex.
Mouse-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Ï*
	Ï3 "L: display, M: hold down to drag vertex, Sh-M: hold down to drag subtree, R: menu"Ï*
	Ï3 ("some op" :value some-op)Ï*
	Ï3 ("some other op"))Ï*

|#

(EXPORT '(graph-window))

(DEFFLAVOR Ï4graph-windowÏ* ()
	   (basic-graph-mixin basic-x-y-scrolling-window))

(DEFFLAVOR Ï4basic-graph-mixinÏ* ()
	   (essential-graph-mixin edit-graph-display-mixin))

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

(DEFMETHOD Ï4(essential-graph-mixin :draw-graphÏ*) (vertices edges &optional root (logical-x 0) (logical-y 0))
  "Ï2Draws a directed, possibly cyclic, possibly unconnected, graph.
   Doesn't handle reflexive edges very well.
   Vertices is a list of vertices.  Each vertex can be either a vertex-instance or a string, symbol or
   a list of the form (symbol-or-string . options). Options are not evaluated and include :mouse-sensitive-type
   :pre-print-item-modify-function :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 options are not
   evaluated and include :item :arrowhead-p :label :label-font :mouse-sensitive-type :undirected-p
   :dashed-p (which can be 1, 2, 3 or t for three different dashing styles).
    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.Ï*"
  
  ;Ï1; make all vertices into instancesÏ*
  (SETQ vertices
	(MAPCAR #'(lambda (vertex)
		    (ETYPECASE vertex
		      (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
				   ;Ï1; 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)))))))	;Ï1; optionsÏ*
		vertices))

  ;Ï1; make all edges into instancesÏ*
  (SETQ edges
	(MAPCAR #'(lambda (edge)
		    (ETYPECASE edge
		      (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))
				;Ï1; 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 "Ï3there is not vertex instance for the vertex ~
                                                        , ~a, in the edge, ~aÏ*" (CAR edge) edge)))))
			      :to-vertex
			      (ETYPECASE (SECOND edge)
				(vertex (SECOND edge))
				;Ï1; if its a symbol or string find the vertex with that symbol or string as the itemÏ*
				((OR string symbol) (COND ((FIND (SECOND edge) vertices
								 :test #'EQUAL
								 :key #'(lambda (v) (SEND v :item))))
							  (t (ERROR "Ï3there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~aÏ*" (SECOND edge) edge)))))
			      (CDDR edge))))) ;Ï1;any user supplied optionsÏ*
		edges)) ;Ï1; arg for lambda above.Ï*

  ;Ï1; 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))

  ;Ï1; 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) ;Ï1; find the vertex with the item equal to root.Ï*
		    (COND ((FIND root vertices
				 :test #'EQUAL
				 :key #'(lambda (v) (SEND v :item))))
			  (t (ERROR "Ï3there 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))
  
  ;Ï1; layout the graph by laying out its connected componentsÏ*
  (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))
	   (SETQ vertices-not-positioned	;Ï1; remove the newly positioned verticesÏ*
		 (SET-DIFFERENCE vertices-not-positioned
				 (SEND current-root :get-self-n-descendents)))))
    (:vertical
     (LOOP with vertices-not-positioned = 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))
	   (SETQ vertices-not-positioned	;Ï1; remove the newly positioned verticesÏ*
		 (SET-DIFFERENCE vertices-not-positioned
				 (SEND current-root :get-self-n-descendents))))))

  ;Ï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 necessary.Ï*
  (LOOP for vertex in vertices do (SEND vertex :set-positioned-p nil))
  ;Ï1; draw the graphÏ*
  (LOOP for item in (APPEND vertices edges)
	do
	(SEND item :draw-self))

  ;Ï1; tell the window about the new itemsÏ*
  (SEND self :set-item-list (REMOVE-DUPLICATES (APPEND (SEND self :item-list) edges vertices))))

(DEFUN Ï4pick-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)) ;Ï1; return thisÏ*

(DEFMETHOD Ï4(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 ((MEMBER child vertices :key #'CAR))	;Ï1; must be a cycle so do nothing moreÏ*
		(t (PUSH `(,child ,@vertex-options) vertices)
		   (PUSH `(,parent ,child ,@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 Ï4(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
	  (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))
		    ;Ï1;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 "Ï3there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~aÏ*" (CAR edge) edge)))))
		  :to-vertex
		  (ETYPECASE (SECOND edge)
		    (vertex (SECOND edge))
		    ;Ï1;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 "Ï3there is not vertex instance for the vertex ~
                                                                     , ~a, in the edge, ~aÏ*" (SECOND edge) edge)))))
		  (CDDR edge)))))		;Ï1; user 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 :draw-self))

(DEFMETHOD Ï4(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
	  (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))))) ;Ï1; user supplied optionsÏ*
  ;Ï1; tell the windowÏ*
  (SEND self :set-item-list (NCONC (SEND self :item-list) (LIST vertex)))
  (SEND vertex :draw-self))			;Ï1probably at 0,0Ï*

(DEFMETHOD Ï4(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 edge 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
	    (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 "Ï3Ignore delete-edge requestÏ*"
		     "Ï3The edge, ~a, is not on the item-list of the windowÏ*" edge)))))

(DEFMETHOD Ï4(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 "Ï3Ignore delete vertex requestÏ*"
		     "Ï3The vertex, ~a, is not on the item-list of the windowÏ*" vertex)))))

;Ï1;------------ edit-graph-display-mixin --------------Ï*

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

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

(DEFFLAVOR Ï4edit-graph-display-mixinÏ* 
	   ((vertex-being-dragged nil)
	    (subtree-being-dragged nil)
	    ;Ï1; we 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 Ï4(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 Ï4(edit-graph-display-mixin :after :handle-mouseÏ*) (&rest ignore)
  "Ï2If the mouse wanders far, don't take the vertex with it!Ï*"
  (turn-off-vertex-dragging)
  (turn-off-subtree-dragging))

(DEFMETHOD Ï4(edit-graph-display-mixin :mouse-clickÏ*) (button ignore ignore)
  "Ï2If the user clicked on a vertex with a mouse-m or mouse-m-2 then
   initiate the dragging.Ï*"
  ;Ï1; just to be safeÏ*
  (AND vertex-being-dragged (turn-off-vertex-dragging))
  (AND subtree-being-dragged (turn-off-subtree-dragging))
  (WHEN  (TYPEP currently-boxed-item 'vertex)
    (CASE button
       (#\mouse-m (turn-on-vertex-dragging  currently-boxed-item) t)
       (#\mouse-m-2 (turn-on-subtree-dragging currently-boxed-item) t))))

(DEFUN-METHOD Ï4turn-on-vertex-draggingÏ*  edit-graph-display-mixin (vertex)
  (turn-on-xor)
  (turn-off-mouse-sensitivity)
  (move-mouse-to-upper-corner vertex)
  (IF vertex-being-dragged
      (FORMAT self "Ï3trouble: initiating vertex dragging but something is already being dragged. ~
      In function tv:turn-on-vertex-draggingÏ*"))
  (SETQ vertex-being-dragged  vertex))

(DEFUN-METHOD Ï4turn-off-vertex-draggingÏ* edit-graph-display-mixin ()
  (turn-off-xor)
  (SETQ vertex-being-dragged  nil)
  (restore-mouse-sensitivity)
  (SEND self :Refresh)) ;Ï1; patch put in here by JPR. on 08/16/89 Ï*

(DEFUN-METHOD Ï4turn-on-subtree-draggingÏ*  edit-graph-display-mixin (vertex)
    (turn-on-xor)
  (turn-off-mouse-sensitivity)
  (move-mouse-to-upper-corner vertex)
  (IF subtree-being-dragged
      (FORMAT self "Ï3trouble: initiating subtree dragging but something is already being dragged. ~
      In function tv:turn-on-subtree-draggingÏ*"))
  (SETQ subtree-being-dragged  vertex))

(DEFUN-METHOD Ï4turn-off-subtree-draggingÏ*  edit-graph-display-mixin ()
    (turn-off-xor)
  (restore-mouse-sensitivity)
  (SETQ subtree-being-dragged  nil))

(DEFUN-METHOD Ï4turn-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 Ï4restore-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 Ï4turn-on-xorÏ* edit-graph-display-mixin ()
  (SETQ char-aluf-temp-var (SEND self :char-aluf)
	erase-aluf-temp-var (SEND self :erase-aluf))  
  (SEND self :set-char-aluf alu-xor)
  (SEND self :set-erase-aluf alu-xor))

(DEFUN-METHOD Ï4turn-off-xorÏ* edit-graph-display-mixin ()
  (SEND self :set-char-aluf char-aluf-temp-var)
  (SEND self :set-erase-aluf erase-aluf-temp-var))

(DEFUN-METHOD Ï4move-mouse-to-upper-cornerÏ* edit-graph-display-mixin (vertex)
  ;Ï1; 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 Ï4(edit-graph-display-mixin :after :mouse-movesÏ*) (x y)
  "Ï2This actually does the draggingÏ*"
  ;Ï1; It will never happen that (and vertex-being-dragged subtree-being-dragged) is true. Ï*
  (WHEN (OR vertex-being-dragged subtree-being-dragged)
     (IF ;Ï1; 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)))
      ;Ï1; elseÏ*
      (PROGN (turn-off-vertex-dragging)
	     (turn-off-subtree-dragging)))))

;Ï1; ---------- vertex and edge definitions -------------Ï*

(DEFFLAVOR Ï4vertexÏ* 
	   ((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)	    ;Ï1; to avoid getting trapped in drawing or positioning a cycleÏ*
	    (being-drawn-p nil)		    ;Ï1; we set these flags (using the macro with-positioning-flag-set)Ï*
	    (being-moved-p nil)		    ;Ï1; while drawing or positioning or moving.Ï*
	    (getting-descendents-p nil)
	    
	    (positioned-p nil))		    ;Ï1; also need this which is set once and for allÏ*
					    ;Ï1; so that diags don't cause us to move this vertexÏ*
					    ;Ï1; to a new position. Ï*
	   (scrollable-text-item)               
  (:default-init-plist :mouse-sensitive-type :vertex)  ;Ï1; put vertex in keyword package cause it sure don't belong in tv.Ï*
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

(DEFCONSTANT Ï4anchor-spaceÏ* 4 
  "Ï2How many pixels away from a word to put it's anchor. The anchor is where the
 edge attaches to the vertex.Ï*")

(DEFMETHOD Ï4(vertex :after :initÏ*) (&rest ignore)
  (SEND self :set-anchors))

(DEFMETHOD Ï4(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 Ï4(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 :draw-self))))

(DEFMETHOD Ï4(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 Ï4(vertex :add-to-child-edgesÏ*) (edge)
  (UNLESS (FIND edge child-edges) (PUSH edge child-edges)))

(DEFMETHOD Ï4(vertex :add-to-parent-edgesÏ*) (edge)
  (UNLESS (FIND edge parent-edges) (PUSH edge parent-edges)))

(DEFMETHOD Ï4(vertex :delete-from-parent-edgesÏ*) (edge)
  (SETQ parent-edges (DELETE edge parent-edges)))

(DEFMETHOD Ï4(vertex :delete-from-child-edgesÏ*) (edge)
  (SETQ child-edges (DELETE edge child-edges)))

(DEFMETHOD Ï4(vertex :draw-self-n-descendentsÏ*) ()
  (SEND self :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 Ï4(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 Ï4(vertex :move-self-relativeÏ*) (x y &optional inhibit-redraw-p)
  (SEND self :move-to (+ x logical-x) (+ y logical-y)  inhibit-redraw-p))

(DEFMETHOD Ï4(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 Ï4(vertex :position-self-n-descendentsÏ*) (at-x at-y)
  "Ï2Positions 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))))	;Ï1; this because we only want to  Ï*
						;Ï1; increment child-at-y by :sibling-spacing n-1 timesÏ*
						;Ï1; 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 ;Ï1; parallel/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))))	;Ï1; this because we only want to  Ï*
						;Ï1; increment child-at-x by :sibling-spacing n-1 timesÏ*
						;Ï1; 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 Ï4(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))))

;Ï1;;------------- boxed vertex -----------------Ï*

(DEFFLAVOR Ï4abstract-boxing-thingÏ*
	   ()
	   (vertex)
  :Abstract-Flavor)

(DEFMETHOD Ï4(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)))
       (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 Ï4(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 alu-xor)))

(DEFMETHOD Ï4(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 Ï4(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 Ï4draw-a-boxÏ* (l r tp b alu window)
  (LET ((dashed-p (IF (NUMBERP (SEND self :Dashed-P))
		      (MIN (SEND self :Dashed-P) 3)
		      (IF (SEND self :Dashed-P)
			  3
			  nil))))
       (IF dashed-p
	   (PROGN (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)))
	   (PROGN (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 Ï4draw-a-rectangleÏ* (l r tp b alu window)
  (SEND window :draw-rectangle (- r l) (- b tp) l tp alu))

(DEFMETHOD Ï4(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 pred
      ;Ï1; Undraw in old place.Ï*
      (IF current
	  (IF partial
	      (LEXPR-SEND self partial-undo-method current)
	      (SEND self undo-method alu-off))
	  nil)
      nil))

(DEFMETHOD Ï4(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 Ï4(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))
	(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))))

;Ï1-------------------------------------------------------------------------------Ï*

(DEFFLAVOR Ï4boxed-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 Ï4(boxed-vertex :after :refreshedÏ*) ()
  (SETQ currently-boxed nil)
  (SETQ partially-boxed nil))

(DEFMETHOD Ï4(boxed-vertex :before :draw-selfÏ*) (&rest ignore)
  (SEND self :undraw-self-this-way :draw-box :draw-box :draw-a-rectangle
	box-myself-p currently-boxed partially-boxed alu-ior alu-andca))

(DEFMETHOD Ï4(boxed-vertex :after :draw-selfÏ*) (&rest ignore)
  (SEND self :draw-self-this-way :draw-box :draw-box :draw-a-rectangle
	box-myself-p currently-boxed partially-boxed alu-ior alu-andca))

(DEFMETHOD Ï4(boxed-vertex :draw-a-rectangleÏ*)
  (top bottom left right &optional (x-offset nil) (y-offset nil) (alu alu-xor))
  (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 alu alu-andca))

(DEFMETHOD Ï4(boxed-vertex :before :set-dashed-pÏ*) (IGNORE)
  (SEND self :Erase-Self))

(DEFMETHOD Ï4(boxed-vertex :after :set-dashed-pÏ*) (IGNORE)
  (SEND self :draw-Self))

(DEFMETHOD Ï4(boxed-vertex :after :set-box-myself-pÏ*) (IGNORE)
  (IF box-myself-p
      (SEND self :draw-box alu-ior)
      (SEND self :draw-box alu-andca)))

(DEFMETHOD Ï4(boxed-vertex :draw-boxÏ*) (&optional (alu alu-seta))
  (MULTIPLE-VALUE-BIND (top bottom left right)
      (SEND self :box-coords)
    (SEND self :draw-a-rectangle
	  top bottom left right nil nil alu)))

(DEFMETHOD Ï4(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))

(DEFPARAMETER Ï4*Number-Of-Times-To-Flash-Vertices*Ï* 10)

(DEFMETHOD Ï4(boxed-vertex :flashÏ*) ()
  (LOOP for i from 1 to *Number-Of-Times-To-Flash-Vertices* Do
	(SEND self :Set-Box-Myself-P (NOT Box-Myself-P))
	(SLEEP 0.1)))

;Ï1-------------------------------------------------------------------------------Ï*

(DEFFLAVOR Ï4filled-vertexÏ*
	   ((fill-myself-p t)
	    (currently-filled nil)
	    (partially-filled nil))
	   (abstract-boxing-thing)
  :Initable-Instance-Variables
  :Settable-Instance-Variables
  :Gettable-Instance-Variables)

(DEFMETHOD Ï4(filled-vertex :after :refreshedÏ*) ()
  (SETQ currently-filled nil)
  (SETQ partially-filled nil))

(DEFMETHOD Ï4(filled-vertex :draw-a-filled-rectangleÏ*)
  (top bottom left right &optional (x-offset nil) (y-offset nil) (alu alu-xor))
  (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))

(DEFMETHOD Ï4(filled-vertex :before :draw-selfÏ*) (&rest ignore)
  (SEND self :undraw-self-this-way :draw-block :draw-block
	:draw-a-filled-rectangle
	fill-myself-p currently-filled partially-filled
	alu-xor alu-xor))

(DEFMETHOD Ï4(filled-vertex :after :draw-selfÏ*) (&rest ignore)
  (SEND self :draw-self-this-way :draw-block :draw-block
	:draw-a-filled-rectangle
	fill-myself-p currently-filled partially-filled
	alu-xor alu-xor))

(DEFMETHOD Ï4(filled-vertex :after :set-fill-myself-pÏ*) (IGNORE)
  (IF fill-myself-p
      (SEND self :draw-block alu-xor)
      (SEND self :draw-block alu-xor)))

(DEFMETHOD Ï4(filled-vertex :draw-blockÏ*) (&optional (alu alu-xor))
  (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 Ï4(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 Ï4(filled-vertex :flashÏ*) ()
  (LOOP for i from 1 to *Number-Of-Times-To-Flash-Vertices* Do
	(SEND self :Set-Fill-Myself-P (NOT Fill-Myself-P))
	(SLEEP 0.1)))

;Ï1-------------------------------------------------------------------------------Ï*

(DEFFLAVOR Ï4boxed-filled-vertexÏ*
	   ()
	   (filled-vertex boxed-vertex)
  (:default-init-plist :fill-myself-p nil))

(DEFMETHOD Ï4(boxed-filled-vertex :toggleÏ*) ()
  (IF box-myself-p
      (SEND self :set-fill-myself-p t)
      (SEND self :set-box-myself-p  t)))

(DEFMETHOD Ï4(boxed-filled-vertex :flashÏ*) ()
  (LET ((old-box  Box-Myself-P)
        (old-fill Fill-myself-p)
	(*already-toggling* t))
       (DECLARE (SPECIAL *already-toggling*))
       (IF old-box  (SEND self :Set-Box-Myself-P  nil))
       (IF old-fill (SEND self :Set-Fill-Myself-P nil))
       (LOOP for i from 1 to (TRUNCATE *number-of-times-to-flash-vertices* 4)
	     do (SEND self :Set-Box-Myself-P t)
	        (SLEEP 0.1)
		(SEND self :Set-Box-Myself-P nil)
	        (SLEEP 0.1)
		(SEND self :Set-Fill-Myself-P t)
		(SLEEP 0.1)
		(SEND self :Set-Fill-Myself-P nil)
		(SLEEP 0.1))
       (IF old-box  (SEND self :Set-Box-Myself-P  old-box))
       (IF old-fill (SEND self :Set-Fill-Myself-P old-fill))))

(DEFMETHOD Ï4(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 Ï4(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))))

;Ï1;----------------------- edge ----------------------------------Ï*

(DEFFLAVOR Ï4edgeÏ* ()
	   (undirected-possibly-mixin
	    dashed-line-mixin
	    arrowhead-mixin
	    edge-label-mixin
	    basic-edge))

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

(DEFMETHOD Ï4(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 Ï4(basic-edge  :position-self-n-descendentsÏ*) (at-x at-y)
  (IF (AND  (NOT (SEND to-vertex :being-positioned-p)) ;Ï1; watch out for cyclesÏ*
	    (NOT (SEND to-vertex :positioned-p)))  ;Ï1; watch our for diagsÏ*
      (SEND to-vertex :position-self-n-descendents at-x at-y)
      (VALUES 0 0)) ;Ï1; this else handles cycles.Ï*
  ;Ï1; we can't calculate from-x and from-y yet because from-vertex isÏ*
  ;Ï1; not positoned yet.  We depend upon from-vertex to send us a Ï*
  ;Ï1; :calculate-your-position message when it has finished positioning itselfÏ*
  )

(DEFMETHOD Ï4(basic-edge :draw-self-n-descendentsÏ*) ()
  (SEND self :draw-self)
  (UNLESS (SEND to-vertex :being-drawn-p)  ;Ï1; this to handle cyclesÏ*
  (SEND to-vertex  :draw-self-n-descendents)))

(DEFMETHOD Ï4(basic-edge :move-self-n-descendents-relativeÏ*) (x y &optional inhibit-redraw-p)
  (UNLESS (SEND to-vertex :being-moved-p)   ;Ï1; this to handle cyclesÏ*
    (SEND to-vertex :move-self-n-descendents-relative x y inhibit-redraw-p)))

(DEFMETHOD Ï4(basic-edge :get-self-n-descendentsÏ*) ()
  (UNLESS (SEND to-vertex :getting-descendents-p) (SEND to-vertex :get-self-n-descendents)))

(DEFMETHOD Ï4(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))))

(DEFFLAVOR Ï4edge-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 Ï4(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) ;Ï1; fine, do nothingÏ*
      (symbol  ;Ï1; help out the silly user.Ï*
         (SETQ label (STRING-DOWNCASE (SYMBOL-NAME label)))))))

(DEFMETHOD Ï4(edge-label-mixin :after :draw-selfÏ*) (&rest ignore)
  (WHEN label 
    (CONDITION-CASE ()			     ;Ï1; trap divide-by-zero errors generated from lines of no lengthÏ*
	(LET* ((slope (CONDITION-CASE ()     ;Ï1; 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))))   ;Ï1; close?Ï*
		       ;Ï1; If the line is going downhill from left to right (Slope pos.) Ï*
                       ;Ï1; 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			;Ï1; else choose the lower (whose y is greater) anchorÏ*
			      (SETQ label-position (IF (>= (SECOND label-anchor1) (SECOND label-anchor2))
						       label-anchor1
						       label-anchor2)))))
		      
		      (t			;Ï1; else 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
		(SEND window :char-aluf)))
      (sys:divide-by-zero))))


(DEFMETHOD Ï4(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
	  (SEND window :erase-aluf))))


(DEFCONSTANT Ï4deg-to-rads-constÏ* (/ pi 180))
(DEFCONSTANT Ï4pi/2Ï* (/ pi 2))

(DEFUN Ï4rotateÏ* (point center theta &optional (theta-type :degrees))
  "Ï2Rotates point theta around center.  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)))))
    ;Ï1; translate to 0,0 ,rotate, then translate back.Ï*
    (L+ center (matrix-multiply rotation-matrix (L- point center)))))

(DEFUN Ï4matrix-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 Ï4L+Ï* (x y)
  (LIST (+ (FIRST x)
	   (FIRST y))
	(+ (SECOND x)
	   (SECOND y))))

(DEFUN Ï4L-Ï* (x y)
  (LIST (- (FIRST x)
	   (FIRST y))
	(- (SECOND x)
	   (SECOND y))))

(DEFFLAVOR Ï4arrowhead-mixinÏ* 
	   ((arrowhead-p t)
	    (tip1-x nil) (tip1-y nil)
	    (tip2-x nil) (tip2-y nil))
	   ()
  (:initable-instance-variables arrowhead-p)
  (:settable-instance-variables arrowhead-p)
  (:required-instance-variables from-x from-y to-x to-y window))

(DEFCONSTANT Ï4*arrowhead-length*Ï* 10)
(DEFCONSTANT Ï4*arrowhead-angle*Ï* 24)

(DEFMETHOD Ï4(arrowhead-mixin :after :draw-selfÏ*) (&rest ignore)
  (IF arrowhead-p (SEND self :draw-arrowhead)))

(DEFMETHOD Ï4(arrowhead-mixin :after :erase-selfÏ*) (&rest ignore)
  (SEND self :erase-arrowhead))

(DEFUN-METHOD Ï4draw-arrowheadÏ* arrowhead-mixin ()
  (IF tip1-x (SEND self :erase-arrowhead))	;Ï1; this so we don't leave do-do's in random places.Ï*
  (LET* ((slope (/ (- from-y to-y)		;Ï1; positive slope is downhill cause of window coordsÏ*
		   (- from-x to-x)))
	 (shaft-length (SQRT (+ (* (- to-y from-y)(- to-y from-y))
				(* (- to-x from-x)(- to-x from-x)))))
	 (ratio (/ *arrowhead-length* shaft-length))
	 (head-x (- to-x (* ratio (- to-x from-x))))
	 (head-y (- to-y (* slope (* ratio (- to-x from-x)))))
	 ;Ï1;                              \Ï*
	 ;Ï1;                                \Ï*
	 ;Ï1;      ------------------------h--->      ; the h is at (head-x, head-y)Ï*
	 ;Ï1;                                /Ï*
	 ;Ï1;                              /Ï*
	 
	 (tip-1 (rotate (LIST head-x head-y) (LIST to-x to-y) *arrowhead-angle*))
	 (tip-2 (rotate (LIST head-x head-y) (LIST to-x to-y) (- *arrowhead-angle*))))
   ;Ï1; (format window "~a ~a ~a ~a ~a ~a~&" tip-1 tip-2 to-x 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))
    ;Ï1; convert to physical coordinates, and draw.Ï*
    (SEND window :draw-line
	  (- to-x (SEND window :x-pl-offset))
	  (- to-y (SEND window :y-pl-offset))
	  (- tip1-x (SEND window :x-pl-offset))
	  (- tip1-y (SEND window :y-pl-offset))
	  (SEND window :char-aluf) nil)
    (SEND window :draw-line
	  (- to-x (SEND window :x-pl-offset))
	  (- to-y (SEND window :y-pl-offset))
	  (- tip2-x (SEND window :x-pl-offset))
	  (- tip2-y (SEND window :y-pl-offset))
	  (SEND window :char-aluf) nil)))


(DEFMETHOD Ï4(arrowhead-mixin :draw-arrowheadÏ*) ()
  ;Ï1; can't draw the arrowhead for a veritical shaft. big deal.Ï*
  (CONDITION-CASE ()
      (draw-arrowhead)
    (sys:divide-by-zero nil)))

(DEFMETHOD Ï4(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 window :draw-line
	    physical-to-x physical-to-y
	    physical-tip2-x physical-tip2-y
	    (SEND window :erase-aluf) nil)
      (SEND window :draw-line
	    physical-to-x physical-to-y
	    physical-tip1-x physical-tip1-y
	    (SEND window :erase-aluf) nil)
      (SETQ tip2-y nil
	    tip2-x nil
	    tip1-y nil
	    tip1-x nil))))

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

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

(DEFMETHOD Ï4(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 (SEND window :erase-aluf))
    (CASE dashed-p
       (1 (SEND window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		(SEND window :char-aluf) (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
		(SEND window :char-aluf) (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
	      (SEND window :char-aluf) (dashed-line-spacing 3) nil 0 (dashed-line-length 3)))))))

(DEFMETHOD Ï4(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 (SEND window :erase-aluf))
    (CASE dashed-p
       (1 (SEND window :draw-dashed-line p-from-x p-from-y p-to-x p-to-y
		(SEND window :erase-aluf) (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
		(SEND window :erase-aluf) (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
		(SEND window :erase-aluf) (dashed-line-spacing 3) nil 0 (dashed-line-length 3)))))))

(DEFUN Ï4dashed-line-spacingÏ* (type)
  (ECASE type
    (1 10)
    (2 20)
    (3 30)))

(DEFUN Ï4dashed-line-lengthÏ* (type)
  (ECASE type
    (1 5)
    (2 5)
    (3 20)))


;Ï1;;---------------- undirected-possibly-mixin ----------------------Ï*

(DEFFLAVOR  Ï4undirected-possibly-mixinÏ* 
	   ((undirected-p))
	   ()
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables
  (:required-flavors basic-edge))

(DEFMETHOD Ï4(undirected-possibly-mixin :after :initÏ*) (&rest ignore)
  (AND undirected-p 
       (SEND self :set-arrowhead-p nil)))

(DEFMETHOD Ï4(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 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)))))

#|

Ï3(SEND w :draw-graph
      (LIST "ver1" "ver2" "ver3" "ver31" "ver311" "ver32" "ver21" "ver22" "ver221" "ver2211" "ver22111"Ï*
	Ï3    "ver22112" "ver22113" "2ver1" "2ver2" "2ver3" "3ver1" "3ver2" "4ver1")
      (LIST (LIST "ver1" "ver2")Ï*
	Ï3    (LIST "ver1" "ver3" :dashed-p 1)Ï*
	Ï3    (LIST "ver3" "ver31" :dashed-p t)Ï*
	Ï3    (LIST "ver3" "ver32" :dashed-p 2)Ï*
	Ï3    (LIST "ver3" "ver1")Ï*
	Ï3    (LIST "ver31" "ver311")Ï*
	Ï3    (LIST "ver2" "ver21")Ï*
	Ï3    (LIST "ver2" "ver22")Ï*
	Ï3    (LIST "ver22" "ver221")Ï*
	Ï3    (LIST "ver221" "ver2211")Ï*
	Ï3    (LIST "ver2211" "ver22111")Ï*
	Ï3    (LIST "ver2211" "ver22112")Ï*
	Ï3    (LIST "ver2211" "ver22113")Ï*
	Ï3    (LIST "2ver1" "2ver2")Ï*
	Ï3    (LIST "2ver1" "2ver3")Ï*
	Ï3    (LIST "3ver1" "3ver2")))Ï*
	Ï3    
(PROGN
  (SEND w :set-label (FORMAT nilÏ*
			Ï3     "AKO links:   solid line ~&~
                              IS-A links:  short dashes ~&~
                              HATES links: long dashes"))
  (SEND w :draw-graphÏ*
	Ï3'((rover :FONT fonts:tr10i)  (jasmine :font fonts:tr10i) (sleepy :font fonts:tr10i)Ï*
	Ï3  cat dog pig domesticated-animal animal)Ï*
	Ï3`((rover dog :dashed-p 1 :label "note!")Ï*
	Ï3  (jasmine dog :dashed-p 1)Ï*
	Ï3  (sleepy cat :dashed-p 1)Ï*
	Ï3  (dog domesticated-animal)Ï*
	Ï3  (cat domesticated-animal)Ï*
	Ï3  (domesticated-animal animal)Ï*
	Ï3  (pig animal)Ï*
	Ï3  (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)Ï*
	Ï3(a c)Ï*
	Ï3(a d)Ï*
	Ï3(b e :label "from b to e" :label-font fonts:hl12b)Ï*
	Ï3(b f :undirected-p t :label "undirected")Ï*
	Ï3(b g :arrowhead-p nil :label "directed")Ï*
	Ï3(c h :item '(c j))Ï*
	Ï3(c i :mouse-sensitive-type 'foo-edge)Ï*
	Ï3(d j :dashed-p 1)Ï*
	Ï3(d k :dashed-p 2)Ï*
	Ï3(d l :dashed-p 3)Ï*
	Ï3(d m :dashed-p t)Ï*
	Ï3(n o :undirected-p t)Ï*
	Ï3(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)Ï*
	Ï3     '((a b)Ï*
	Ï3       (a c)Ï*
	Ï3       (a d)Ï*
	Ï3       (b e :label "from b to e" :label-font fonts:hl12b)Ï*
	Ï3       (b f :undirected-p t :label "undirected")Ï*
	Ï3       (b g :arrowhead-p nil :label "directed")Ï*
	Ï3       (c h :item '(c j))Ï*
	Ï3       (c i :mouse-sensitive-type 'foo-edge)Ï*
	Ï3       (d j :dashed-p 1)Ï*
	Ï3       (d k :dashed-p 2)Ï*
	Ï3       (d l :dashed-p 3)Ï*
	Ï3       (d m :dashed-p t)Ï*
	Ï3       (n o :undirected-p t)Ï*
	Ï3       (o p :undirected-p t)Ï*
	Ï3       (p j)))
       (SEND w :expose)
       (SEND w :set-item-type-alist '((:vertex foo "foo" (foo foo2)))))Ï*	
|#
