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

;;; **********************************************************************
;;; 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.
;;; **********************************************************************

(eval-when (compile) (load-tools '(:36xx-explorer :structure-enhancements)))

;;; A vertex node.  This represents a vertex in the graph and has encoded in it
;;; both the thing that the user actually wants to graph itself and the
;;; child-function for the graph, the desired depth for the graph and sundry
;;; other interesting things like the print function.
(defflavor Vertex-Node-Mixin
  ((child-function nil)
   (depth nil)
   (dash-function nil)						 
   (label-function nil)
   (directedness-function nil)
   (mouse-sensitive-type-function nil)
   (print-function nil)
   (font-function nil)
   (parent-function nil)
   )
  ()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables
)

(defun vertex-node-node (vertex)
  (send vertex :item)
)

(defun vertex-node-child-function (vertex)
  (send vertex :child-function)
)

(defun vertex-node-depth (vertex)
  (send vertex :depth)
)

(defun vertex-node-dash-function (vertex)
  (send vertex :dash-function)
)

(defun vertex-node-label-function (vertex)
  (send vertex :label-function)
)

(defun vertex-node-directedness-function (vertex)
  (send vertex :directedness-function)
)

(defun vertex-node-mouse-sensitive-type-function (vertex)
  (send vertex :mouse-sensitive-type-function)
)

(defun vertex-node-print-function (vertex)
  (send vertex :print-function)
)

(defun vertex-node-font-function (vertex)
  (send vertex :font-function)
)

(1defun* make-cache-map (test-function)
"Makes a mapping between keys and values using test-function as the test.
If it can it choses to use a hash table.
"
  (1if* (1or* (1and* (1fboundp* 'sys:compute-hash-function)
	       (1funcall* 'sys:compute-hash-function test-function)
	 )
	 (1member* test-function
		   `(1eq*    '1eq*    ,#'1eq*
		     eql   '1eql*   ,#'1eql*
		     equal '1equal* ,#'1equal*
		    )
	 )
     )
     (1make-hash-table* 3:Test* test-function)
     (1list* test-function nil)
  )
)

(1defun* map-over-cache (1function* table &rest args)
"Looks up key in the table specified by a call to make-cache-map."
  (1if* (1consp* table)
      (1loop* for (key 4value*) in (1second* table) do
	    (1apply* function key 4value* args)
      )
      (1apply* 'map1hash* function table args)
  )
)

(1defun* get-from-cache (key table)
"Looks up key in the table specified by a call to make-cache-map."
  (1if* (1consp* table)
      (1second*
	(1assoc* key (1second* table) 3:Test* (1first* table))
      )
      (1gethash* key table)
  )
)

(1defun* set-in-cache (key table value)
"Sets a value associated with a key in the table created
 by a call to make-cache-map.
"
  (1if* (1consp* table)
      (1let* ((entry 
	      (1assoc* key (1second* table)
		     3:Test* (1first* table)
	      )
	    )
	   )
	   (1if* entry
	      (1setf* (1second* entry) 4value*)
	      (1setf* (1second* table)
		   (1cons* (1list* key 4value*) (1second* table))
	      )
	   )
	   value
      )
      (1setf* (1gethash* key table) 4value*)
  )
)

(1defsetf* 2Get-From-Cache* 2Set-In-Cache*)

(defvar *Type-To-Node-Coercion-Functions*
	      '((4basic-vertex*-p 2Vertex-Node-Node*)
		(Local-Kids-Spec-Node-p Local-Kids-Spec-Node-Node)
	       )
"An AList of the mappings between graph node types and the functions,
 which can extract the actual nodes from them.
"
)

(1defun* basic-vertex-p (x)
  (1typep* x '4basic-vertex*)
)

(1defun* 2Try-To-Match-Type* (of in)
"Tries to match the type of Of to the type/action AList In.  If
 Of matches the type given in the First of an element in In, then
 the Second of that element is called on Of to deliver the KBNode.
"
  (1declare* (optimize (safety 0)))
  (1if* in
      (1if* (funcall (1first* (1first* in)) of)
	  (1values* (1funcall* (1second* (1first* in)) of) t)
	  (2Try-To-Match-Type* of (1rest* in))
      )
      (1values* of nil)
  )
)

(1defun* 2Coerce-To-Node* (x)
"Given something, coerces it into a thing that's a graph node..  Uses the
 AList *type-to-node-coercion-functions* to help in this.
"
  (1multiple-value-bind* (thing coerced-p)
      (2Try-To-Match-Type* x 2*Type-To-Node-Coercion*-function2s**)
    (1if* (1and* coerced-p (1not* (1equal* x thing)))
	(2Coerce-To-Node* thing)
	thing
    )
  )
)

(1defun* 2Remove-*edge (thing 4window* edge)
"Sets the edge visibility to invisible."
  (1ignore* thing 4window*)
  (1send* 4edge* 3:Make-Me-Invisible*)
)

(1defun* 2Collapse* (thing 4window* item)
"Sets the vertex's and all its children visibility to invisible."
  (1ignore* thing 4window*)
  (1send* item 3:Make-Me-And-My-Children-Invisible*)
)

(1defun* 2Expand* (thing 4window* item)
"Sets the vertex's and all its children visibility to visible."
  (1ignore* thing 4window*)
  (1send* item 3:Make-Me-And-My-Children-Visible*)
)

(1defun* 2Collapse-Children* (thing 4window* item)
"Sets the vertex's children visibility to invisible."
  (1ignore* thing 4window*)
  (1send* item 3:Make-Children-Invisible*)
)

(1defun* 2Expand-Children* (thing 4window* item)
"Sets the vertex's children visibility to visible."
  (1ignore* thing 4window*)
  (1send* item 3:Make-Children-Visible*)
)

;;; By Jamie Zawinski
(1defun* Collapse-one (thing 4window* item)
"Sets this vertex's visibility to invisible, but leaves child-vertices visible."
  (1ignore* thing 4window*)
  (1send* item 3:Make-Me-Invisible*)
)

(1defun* 2Grapher-Inspect* (4window* something)
"Inspects something.  Window is the window that called this function and is
 ignored.
"
  (1ignore* 4window*)
  (1inspect* (2Coerce-To-Node* something))
)

(1defvar* 2*Stand-Alone-Grapher-Default-Edges** '(0 0 400 400)
"The default edges for stand-alone grapher panes."
)

(1defvar* 2*Grapher-Font-Map** '(Fonts:Tvfont)
"The default font-map for grapher panes."
)

(1defun* 2Default-Stand-Alone-Grapher-Edges* ()
"Returns some default edges for stand alone graphers, making sure that it
 fits on the current screen.  The original default values from which it
 works are in 2*Stand-Alone-Grapher-Default-Edges**.
"
  (1destructuring-bind* (left top right bottom)
		      2*Stand-Alone-Grapher-Default-Edges**
    (1list* (1min* left   (1send* 4default-screen* 3:Inside-Width*))
	 (1min* top    (1send* 4default-screen* 3:Inside-Height*))
	 (1min* right  (1send* 4default-screen* 3:Inside-Width*))
	 (1min* bottom (1send* 4default-screen* 3:Inside-Height*))
    )
  )
)

(1defun* map-resource-return (1function* resource)
"Maps Function over the resource named by Resource and returns a list of
 the values of the functions called.  The function must take three args:
 the thing in the resource, a flag that's true if the thing is in use and
 the name of the resource.  It should return two values; the value to put into
 the map list and a flag, which if true causes the first value not to be
 included in the list.  For instance, if you don't want to include values
 for elements in the resource, which are not in use then you should make
 this value T when the used-p argument is nil.
"
  (1let* ((results nil))
      (1map-resource* #'(lambda (thing used-p name)
			 (1multiple-value-bind* (result dont-use-p)
			     (1funcall* function thing used-p name)
			   (1if* dont-use-p
			      nil
			      (1push* result results)
			   )
			 )
		       )
		       resource
      )
      results
  )
)

(1defvar* 2*Stand-Alone-Grapher-New-Pane-Offset** 30
"The offset in pixels of one grapher pane to the next one to be created.  This
 is used to make sure that new graphers walk down the screen and overlap neatly.
"
)

(1defun* occurences (of in)
"Returns a count of the number of occurences of Of in the list In."
  (1if* in
      (1if* (1equal* of (1first* in))
	  (1+* 1 (occurences of (1rest* in)))
	  (occurences of (1rest* in))
      )
      0
  )
)

(1defun* frequencies (1list* so-far)
"Returns a list of the frequencies of the different elements in List.  These
 are accumulated into So-Far.  For example, if List is '(a b c d a f e c a d b)
 then this function returns: '((e 0) (f 0) (d 1) (c 1) (b 2) (a 2)).  Note the
 frequencies are zero indexed.
"
  (1if* list
     (frequencies (1remove* (1first* list) list)
		  (1cons* (1list* (1first* list) (occurences (1first* list) (1rest* list)))
			so-far
		  )
     )
     so-far
  )
)

(1defun* 2Get-Least* (of &optional (so-far '(1000000 1000000)))
"Given a list of pairs of the form ((e 0) (f 0) (d 1) (c 1) (b 2) (a 2)),
 returns the one that has the lowest number as its second element.
"
  (1if* of
     (1if* (1<* (1second* (1first* of)) (1second* so-far))
	 (2Get-Least* (1rest* of) (1first* of))
	 (2Get-Least* (1rest* of) so-far)
     )
     so-far
  )
)

(1defun* max-offset ()
"Returns the maximum offset that can be used in creating a new grapher pane.
 This is the number of times that 2*Stand-Alone-Grapher-New-Pane-Offset**
 can be fitted into the screen's smallest dimension for the default size of
 the graphers computed by 2Default-Stand-Alone-Grapher-Edges*.
"
  (1destructuring-bind* (left top right bottom)
		      (2Default-Stand-Alone-Grapher-Edges*)
    (1min* (1truncate* (1/* (1-* (1send* 4default-screen* 3:*Inside-3Width*) (1-* right left))
		       2*Stand-Alone-Grapher-New-Pane-Offset**
		    )
	  )
	  (1truncate* (1/* (1-* (1send* 4default-screen* 3:*Inside-Height) (1-* bottom top))
		       2*Stand-Alone-Grapher-New-Pane-Offset**
		    )
	  )
     )
  )
)

(1defun* 2Offsetting-Stand-Alone-Grapher-Edges*
        (&optional (resource '2Stand-Alone-Graphers*))
"Returns a new set of edges for a new grapher.  It uses the existing members of
 Resource to compute the new edges so that the new panes walk down the screen.
"
  (1let* ((existing (2Map-Resource-Return*
		    #'(lambda (win &rest ignore)
			(1values* (1send* win 3:Position*) nil)
		      )
		    resource
		 )
       )
      )
      (1let* ((modded (1mapcar*
		      #'(lambda (x)
			  (1round*
			    (1/* x 2*Stand-Alone-Grapher-New-Pane-Offset**)
			  )
			)
			Existing
		   )
	   )
	   (1max* (max-offset))
	  )
	  (1let* ((least (2Get-Least* (2Frequencies* modded nil))))
	      (1if* (1<* (1first* least) (1-* max 1))
		 (1mapcar*
		   #'(lambda (x)
		       (1+* (1** (1+* 1 (1first* least))
			      2*Stand-Alone-Grapher-New-Pane-Offset**
			  )
			  X
			)
		      )
		      (2Default-Stand-Alone-Grapher-Edges*)
		 )
		 (2Default-Stand-Alone-Grapher-Edges*)
	      )
	  )
      )    
  )
)

(1defflavor* 2Key-Command-Mixin*
	   ((root-node nil)
	    (saved-marks nil)
	    (current-node nil)
	    (numeric-arg-p nil)
	    (numeric-arg 0)
	    (universal-arg 0)
	   )
	   (4graph-window*)
  3:Initable-Instance-Variables*
  3:Gettable-Instance-Variables*
  3:Settable-Instance-Variables*
)

(1defflavor* 2Stand-Alone-Grapher*
	   ((background-mouse-blip-functions nil)
	    (calling-args nil)
	    (graph-behaviour-changed nil)
	   )
	   (2Key-Command-Mixin*
	    4select-mixin*
	    4graph-window*
	    4process-mixin*
	    sys:property-list-mixin
	   )
  (3:Default-Init-Plist*
    3:Process* '(2Stand-Alone-Graph-Window-Initial-Function*
		 3:Regular-Pdl-Size* 16000.
		 3:Special-Pdl-Size* 2000.
		 3:Name* "Stand-Alone Grapher"
	      )
    3:Edges* 2*Stand-Alone-Grapher-Default-Edges**
    3:Font-Map* 2*Grapher-Font-Map**
    3:Char-Aluf* 4alu-seta*
    3:Activate-P* t
  )
  (3:Documentation*
"The basic flavor of grapher.  This is just a grapher window with a
 process underneath it to understand the mouse blips.  Root-Node should
 always point to the root of the graph being drawn.
 Background-Mouse-Blip-Functions is an AList of functions to call for
 mouse-blips on the window's background.  Calling args is a list of the
 keyword arg values used to plot the graph when plotted by Plot a graph. 
 Saved-Root-Nodes is used to save roots so that we can pop them.
"
  )
  3:Initable-Instance-Variables*
  3:Gettable-Instance-Variables*
  3:Settable-Instance-Variables*
)

(1defmethod* (2Stand-Alone-Grapher* 3:Name-For-Selection*) ()
"This is defined so that <System> ... will work.  4Find-window-of-flavor*
 requires that the window have a name for selection.
"
  name
)

(1defmethod* (2Stand-Alone-Grapher* 3:Scroll-To-From-Inspector*) (inspector new-y)
"Called when we are an inferior of an inspector."
  (1send* self 3:Scroll-To* 0 (1** new-y (1send* inspector 3:Line-Height*)))
)

(1defmethod* (2Stand-Alone-Grapher* 3:Scroll-Relative-From-Inspector*)
	   (inspector new-y)
"Called when we are an inferior of an inspector."
  (1send* self 3:Scroll-Relative* 0 (1** new-y (1send* inspector 3:Line-Height*)))
)

(1defmethod* (2Stand-Alone-Grapher* 3:Setup*) (display-list)
"Called when we are an inferior of an inspector.  The display list gives us
instructions on what to graph.  If we have already graphed it the display
object in the cache entry (display-list) is a cons that encapsulates the
messages that we send to self in order to reconstruct ourselves.
"
  (1destructuring-bind*
    (printer arg display-obj the-top-item the-label the-item-generator flavor)
    display-list
    (1ignore* printer arg the-label the-top-item
	    the-item-generator flavor
    )
    (1if* (1consp* display-obj)
	(1progn* (1loop* for (message . args) in display-obj do
		     (1if* (1keywordp* message)
			 (1lexpr-send* self message args)
			 (1setf* (1symeval-in-instance* self message) (1first* args))
		     )
	       )
	       (1loop* for item in item-list do (1send* item 3:Set-Window* self))
	       (1send* self 3:Refresh*)
	)
	(1progn* (1send* display-obj 3:Setup-For-Window* self display-list)
	       (1let* ((cache-info (1send* display-obj 3:Cache-Info* self)))
		    (1setf* (1third* display-list) cache-info)
	       )
        )
    )
  )
)

(1defmethod* (2Stand-Alone-Grapher* 3:Cache-Info*) ()
"The methods and calls necessary to reconstitute a graph from a cache."
  `((3:Set-Item-List* ,(1send* self 3:Item-List*))
    (3:Set-Logical-Bottom-Edge* ,(1send* self 3:Logical-Bottom-Edge*))
    (3:Set-Logical-Top-Edge* ,(1send* self 3:Logical-Top-Edge*))
    (3:Set-Logical-Right-Edge* ,(1send* self 3:Logical-Right-Edge*))
    (3:Set-Logical-Left-Edge* ,(1send* self 3:Logical-Left-Edge*))
    (x-pl-offset ,(1send* self 3:X-Pl-Offset*))
    (y-pl-offset ,(1send* self 3:Y-Pl-Offset*))
    (3:Set-Current-Node* ,(1send* self 3:Current-Node*))
    (3:Set-Root-Node* ,(1send* self 3:Root-Node*))
    (3:Set-Item-Type-Alist* ,(1send* self 3:Item-Type-Alist*))
    (3:Set-Background-Mouse-Blip-Functions*
      ,(1send* self 3:Background-Mouse-Blip-Functions*)
    )
    (3:Set-Calling-Args* ,(1send* self 3:Calling-Args*))
    (3:Set-Label* ,(1send* self 3:Label*))
   )
)

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

(1defvar* 2*Char-To-Method-Mappings**
        '((#\M-v 3:Page-Up*)
	  (#\c-v 3:Page-Down*)
	  (#\m-f 3:Page-Right*)
	  (#\m-b 3:Page-Left*)

	  (#\c-
 3:Page-Down*)
	  (#\c- 3:Page-Up*)
	  (#\c- 3:Page-Right*)
	  (#\c- 3:Page-Left*)

	  (#\c-n 3:Line-Down*)
	  (#\c-p 3:Line-Up*)
	  (#\c-f 3:Line-Right*)
	  (#\c-b 3:Line-Left*)

	  (#\
   3:Line-Down*)
	  (#\   3:Line-Up*)
	  (#\   3:Line-Right*)
	  (#\   3:Line-Left*)

	  (#\m-< 3:Top-Of-Window*)
	  (#\m-> 3:Bottom-Of-Window*)
	  (#\c-a 3:Beginning-Of-Line*)
	  (#\c-e 3:End-Of-Line*)

	  (#\c-l 3:Refresh-Self*)
	  (#\ 3:Refresh-Self*)

	  (#\c-s 3:I-Search*)
	  (#\c-r 3:Reverse-I-Search*)

	  (#\c-u     3:Universal-Argument*)
	  (#\c-space 3:Set-Pop-Mark*)

	  (#\c-- :control--)
	  (#\c-1 :control-1)
	  (#\c-2 :control-2)
	  (#\c-3 :control-3)
	  (#\c-4 :control-4)
	  (#\c-5 :control-5)
	  (#\c-6 :control-6)
	  (#\c-7 :control-7)
	  (#\c-8 :control-8)
	  (#\c-9 :control-9)
	  (#\c-0 :control-0)

	  (#\” 3:Quit*)
	  (#\‘ 3:Quit*)
	  (#\† 3:Help*)
	 )
"An AList that maps chars into methods to execute when the chars are read by
 a grapher window.
"
)

(1defvar* 2*Numeric-Arg-Methods**
  '(3:Universal-Argument*
    :control--
    :control-1
    :control-2
    :control-3
    :control-4
    :control-5
    :control-6
    :control-7
    :control-8
    :control-9
    :control-0
   )
)

;;; A saved position in the grapher.  Used by the I-Search facility.
(1defstruct-safe* (saved-graph-pos 3:Named*) string item-list failed-p)

(1putprop* '2Saved-Graph-Pos* '1general-structure-message-handler*
	 '1named-structure-invoke*
)

;;; A link in a bidirectionally linked queue.  When I-Search is being used
;;; the item list of the window is translated into a doubly linked list so that
;;; reverse I-Search will work.
(1defstruct-safe* (link 3:Named*) from to 4vertex* cache)

(1putprop* '2Link* '1general-structure-message-handler* '1named-structure-invoke*)

(1defmethod* 4(Key-Command-Mixin :3Quit**) ()
"Just buries the grapher."
  (1send* self 3:Bury*)
)

(1defmethod* 4(Key-Command-Mixin :*find-vertices) (&optional (in nil))
"Finds all of the vertices in the list In or in the item list of Self if In is
 nil.  It returns the items as a doubly linked list.
"
  (1let* ((1first* nil)
        (1last* nil)
      )
      (1loop* for x in (1or* in item-list)
	    when (4vertexp* x)
	    do (1if* last
		  (1let* ((4new* (2Make-Link* 3:From* last 3:Vertex* x)))
		      (1setf* (2Link-To* last) 4new*)
		      (1setq* last 4new*)
		  )
		  (1progn* (1setq* first (2Make-Link* 3:From* nil 3:Vertex* x))
			 (1setq* last first)
		  )
	       )
      )
      first
  )
)

(1defmethod* 4(Key-Command-Mixin :3Search-Matches**) (1string* link)
"Is true if a search string String matches the printed representation of the
 item pointed to by Link.  This is not case-sensitive.
"
  (1let* ((vertex-string
	  (if (2Link-Cache* 2Link*)
	      (2Link-Cache* 2Link*)
	      (1progn* (1setf* (2Link-Cache* 2Link*)
			   (1funcall*
			     (1send* (2Link-Vertex* 2Link*)
				    3:Pre-Print-Item-Modify-Function*
			     )
			     (1send* (2Link-Vertex* 2Link*) 3:Item*)
			   )
		     )
		     (2Link-Cache* 2Link*)
	      )
	  )
	)
       )
       (1search* string vertex-string 3:Test* #'1char-equal*)
  )
)

(1defvar* 2*Saved-Positions** 3:Unbound*
"A dynamically held list of the saved positions saved during I-Search"
)

(1defvar* 2*Reverse-P** 3:Unbound*
"Is true if the I-Search is going backwards."
)

(Defun make-failed-pos (1string* &optional (beep-p nil) (item-list nil))
"Makes a saved position object to denote a failure to find the search string.
 We were searching for String.  If Beep-p is true then we beep to the user,
 since this was the first time that we failed.  Item list is the position in
 the linked list where we should be.
"
  (1push* (2Make-Saved-Graph-Pos*
	   3:String* string
	   3:Item-List* (1or* item-list
			  (2Saved-Graph-Pos-Item-List*
			    (1first* *saved-positions*)
			  )
		      )
	   3:Failed-P* t
	 )
	 *saved-positions*
  )
  (1if* beep-p (1beep*))
  nil
)

(1defmethod* 4(Key-Command-Mixin :3Scroll-To-And-Flash-Vertex**)
   (4vertex* &optional (unconditionally-p nil))
"Given a Vertex it scrolls the window to look at is and then flashes the
 vertex to tell the user where it is.
"
  (1setq* current-node 4vertex*)
  (1multiple-value-bind* (x y)
      (1send* self :Find-Good-Place-To-Scroll-A-Vertex-To 4vertex*)
    (1let* ((4window* (1send* 4vertex* 3:Window*)))
        (1if* (1and* (1equal* (send 4window* 3:X-Pl-Offset*) x)
		 (1equal* (send 4window* 3:Y-Pl-Offset*) y)
	    )
	    nil
	    (1send* self 3:Scroll-To* x y)
	)
    )
  )
  (1if* unconditionally-p
     (1send* 4vertex* 3:Send-If-Handles* 3:Flash*)
     (1let* ((1char* (1send* 4*query-io** 3:Any-Tyi-No-Hang*)))
	 (1if* char
	     (1send* 4*query-io** 3:Untyi* char)
	     (1send* 4vertex* 3:Send-If-Handles* 3:Flash*)
	 )
	 nil
     )
  )
)

(1defmethod* 4(Key-Command-Mixin :3Process-Next-Search**)
    (&optional
     (1string* (2Saved-Graph-Pos-String* (1first* 2*Saved-Positions**)))
     (Start (2Saved-Graph-Pos-Item-List* (1first* 2*Saved-Positions**)))
    )
"This method is invoked when the user either types a new char to I-Search or if
 he does another c-s/c-r.  It searches for a new match to the current search
 string and if it finds one then it scrolls to it and flashes for a while. 
 If no match is found then we go into failed more.
"
  (1if* (1not* start)
      (make-failed-pos 1string* t)
      (1if* (1and* 2*Saved-Positions**
		(2Saved-Graph-Pos-Failed-P* (1first* 2*Saved-Positions**))
	 )
	 nil
	 (1Loop* for next = start
	       do (1setq* start
		        (1if* start
			    (1if* *reverse-p* (2Link-From* start) (2Link-To* start))
			    nil
			)
		  )
	       when (1not* next)
	       do (1return* (2Make-Failed-Pos* string t next))
	       when (1send* self 3:Search-Matches* string next)
	       do (1push* (2Make-Saved-Graph-Pos*
			   3:String* string 3:Item-List* next
			 )
			 *saved-positions*
		  )
		  (1send* self 3:Scroll-To-And-Flash-Vertex* (2Link-Vertex* next))
		  (1return* t)
	 )
      )
  )
)

(1defmethod* 4(Key-Command-Mixin :3Process-Other-Char**) (1char*)
"Given a new char typed by the user other than a command char like c-s or c-r
 adds this to the current search string and starts looking for it.
"
  (1let* ((1string* (1string-append*
		 (2Saved-Graph-Pos-String* (1first* *saved-positions*))
		 (1string* char)
	       )
	)
       )
       (1if* (1and* 2*Saved-Positions**
		 (2Saved-Graph-Pos-Failed-P* (1first* *saved-positions*))
	  )
	  (2Make-Failed-Pos* 1string*)
	  (1send* self 3:Process-Next-Search* string)
       )
  )
)


(1defmethod* 4(Key-Command-Mixin :3Get-A-Char**) ()
"Reads a char from the window.  It returns either a list for a mouse blip or a
 character object for the char read in.
"
  (1send* *query-io* 3:Mouse-Select*)
  (let ((char (send *query-io* :any-tyi)))
       (typecase char
	 (cons char)
	 (integer (int-char char))
	 (character char)
	 (otherwise (beep))
       )
  )
)

(1defmethod* 4(Key-Command-Mixin :*i-search-1) ()
"Does the actual work for I-Search, reading in chars and processing them. 
 Makes special cases for the command chars c-s, c-r, esc and rubout, which
 it has to know how to deal with.  otherwise it just searches for the
 accumulated search string.
"
  (1loop* for char = (1send* self 3:Get-A-Char*) do 
    (case char
      (#\ (format *query-io* "~&") (1send* self 3:Set-Pop-Mark*) (return nil))
      (#\c-s
       (setq *reverse-p* nil)
       (send self 3:Process-Next-Search*)
      )
      (#\c-r
       (setq *reverse-p* :backwards)
       (send self 3:Process-Next-Search*)
      )
      (#\rubout
       (if (rest *saved-positions*)
	   (progn (pop *saved-positions*)
		  (1send* self 3:Scroll-To-And-Flash-Vertex*
			 (2Link-Vertex* (2Saved-Graph-Pos-Item-List*
					 (first *saved-positions*)
				       )
			 )
		  )
	   )
	   (beep)
       )
      )
      (otherwise
       (if (consp char)
	   (progn (format *query-io* "~&") (return nil))
	   (send self :process-other-char char)
       )
      )
    )
    (1send* self 3:Expose*)
    (1send* 4*query-io** 3:Expose*)
    (send self :show-search-string *reverse-p*)
  )
)

(defmethod 4(Key-Command-Mixin :*show-search-string) (reverse-p)
"Displays the current search string in the prompt line with a prompt like
 I-Search, Reverse I-Search or Failing I-Search, depending on how we're doing
 with the search.
"
  (declare (special *saved-positions*))
  (send *query-io* :set-cursorpos 0
       (second (multiple-value-list (send *query-io* :read-cursorpos)))
  )
  (send *query-io* :clear-eol)
  (if (2Saved-Graph-Pos-Failed-P* (first *saved-positions*))
      (format *query-io* "Failing ")
      nil
  )
  (if reverse-p (format *query-io* "Reverse ") nil)
  (format *query-io* "I-Search: ~A"
	  (2Saved-Graph-Pos-String* (first *saved-positions*))
  )
)

(1defflavor* i-search-prompt-window
	   ()
	   (4window* 4stream-mixin*)
  (3:Default-Init-Plist*
    3:Expose-P* nil 3:Activate-P* t 3:Label* "Search" 3:More-P* nil
    3:Deexposed-Typeout-Action* 3:Expose*
  )
  (3:Documentation*
    "A simple little window that gets popped up to process isearches."
  )
)

(1defmethod* (2I-Search-Prompt-Window* 3:Before* 3:Deexpose*) (&rest ignore)
"Make sure that we abort search if we get deexposed."
  (1send* self 3:Force-Kbd-Input* #\)
)

(1defmethod* 4(Key-Command-Mixin 3:Reverse-I-Search**) ()
  "Does a reverse I-Search, just like I-Search only it looks backwards."
  (1send* self 3:I-Search* t)
)

(1defmethod* 4(Key-Command-Mixin :3I-Search**)
	    (&optional (reverse-p nil) (make-prompt-window-p t))
"Does an incremental search much like Zmacs.  There's no particular order
 for the nodes in the graph so the grapher tends to jump around a bit, but
 it still works. 
"
;;; If reverse-p is true then the searching happens backwards a la
;;; c-r.  If make-prompt-window-p is true then it makes a little prompt
;;; window to do the isearching in, otherwise it uses *query-io*.
  (1let* ((vertices (1send* self 3:Find-Vertices*)))
      (1let* ((*saved-positions*
	      (1list* (2Make-Saved-Graph-Pos* 3:Item-List* vertices 3:String* ""))
	   )
	   (*reverse-p* reverse-p)
	   (old-selected 4selected-window*)
	  )
	  (1if* make-prompt-window-p
	     (1let* ((4*query-io**
		    (1make-instance*
		      '2I-Search-Prompt-Window*
		      3:Width*  (1min* 300 (1send* 4default-screen* 3:Inside-Width*))
		      3:Height* (1min* 30 (1send* 4default-screen* 3:Inside-Height*))
		    )
		  )
		 )
		 (multiple-value-bind (Left Top Right Bottom)
		     (send self :Edges)
		   (let ((inside-superior-p
			   (w:position-window-next-to-rectangle
			     *query-io* '(:Above 3:Below* 3:Left* :right)
			     Left Top Right Bottom
			   )
			 )
			)
		        (if (not inside-superior-p)
			    ;;; w:position-window-next-to-rectangle failed
			    ;;; to put it beside the window, so we'll put it
			    ;;; on top, but home to the top of the window.
			    ;;; this corner of the grapher will hopefully be
			    ;;; pretty sparse anyway.
			    (send *query-io* :set-position 0 0)
			    nil
			)
		   )
		 )
		 (1send* 4*query-io** 3:Expose*)
		 (format 4*query-io**
			 (if reverse-p "~&Reverse I-Search: " "~&I-Search: ")
		 )
		 (1send* self 3:Top-Of-Window*)
		 (1unwind-protect* (1send* self 3:I-Search-1*)
		   (1send* 4*query-io** 3:Bury*)
		   (1send* 4*query-io** 3:Kill*)
		   (1if* (1typep* old-selected '4sheet*)
		       (1send* old-selected 3:Mouse-Select*)
		       nil
		   )
		 )
	    )
	    (1send* self 3:I-Search-1*)
	 )
      )
  )
)

(1defmethod* 2(Key-Command-Mixin :3Universal-Argument**) ()
  "Sets the universal argument for the grapher."
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg 1)
  (1setq* universal-arg (1+* 1 universal-arg))
)

(1defmethod* 2(Key-Command-Mixin :3Control-**-) ()
  "Specify a negative numeric."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1** numeric-arg -1))
)

(1defmethod* 2(Key-Command-Mixin :3Control-1**) ()
  "Specify a numeric arg of 1."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 1))
)

(1defmethod* 2(Key-Command-Mixin :3Control-2**) ()
  "Specify a numeric arg of 2."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 2))
)

(1defmethod* 2(Key-Command-Mixin :3Control-3**) ()
  "Specify a numeric arg of 3."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 3))
)

(1defmethod* 2(Key-Command-Mixin :3Control-4**) ()
  "Specify a numeric arg of 4."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 4))
)

(1defmethod* 2(Key-Command-Mixin :3Control-5**) ()
  "Specify a numeric arg of 5."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 5))
)

(1defmethod* 2(Key-Command-Mixin :3Control-6**) ()
  "Specify a numeric arg of 6."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 6))
)

(1defmethod* 2(Key-Command-Mixin :3Control-7**) ()
  "Specify a numeric arg of 7."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 7))
)

(1defmethod* 2(Key-Command-Mixin :3Control-8**) ()
  "Specify a numeric arg of 8."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 8))
)

(1defmethod* 2(Key-Command-Mixin :3Control-9**) ()
  "Specify a numeric arg of 9."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 9))
)

(1defmethod* 2(Key-Command-Mixin :3Control-0**) ()
  "Specify a numeric arg of 10."
  (1if* (1not* numeric-arg-p) (1setq* numeric-arg 0) nil)
  (1setq* numeric-arg-p t)
  (1setq* numeric-arg (1+* (1** numeric-arg 10) 0))
)

(1defmethod* (2Key-Command-Mixin* 3:Basic-Help-Text*) ()
  "~%The keystroke commands available in the grapher are:~%"
)

(1defmethod* (2Key-Command-Mixin* 3:Refresh-Self*) ()
  "Redraws the graph."
  (1send* self 3:Refresh*)
)

(1defmethod* (2Key-Command-Mixin* 3:Help*) ()
  "Shows the meaning of the key commands for the grapher."
  (4with-help-stream* (4*standard-output** 3:Superior* (1send* self 3:Superior*))
    (1format* t (1send* self 3:Basic-Help-Text*))
    (1loop* for (key method) in 2*Char-To-Method-Mappings** do
	 (1let* ((docs (1documentation* `(3:Method* 2Key-Command-Mixin* ,method))))
	     (1if* docs
		 (1format* t "~&\"~C\"~20T~A" key docs)
		 (1format* t "~&\"~C\"~20TUndocumented" key)
	     )
	 )
    )
  )
)
	  
(1Defmethod* 2(Key-Command-Mixin 3:Go-To-Node**) (node)
  (1let* ((4vertex* (4find-vertex-for* (1if* 1(vertexp node)*
				       (1send* node 3:Item*)
				       node
				   )
				   4self*
	        )
       )
      )
      (1if* (1typep* 4vertex* '4basic-vertex*)
	  (1send* 4self* 3:Scroll-To-And-Flash-Vertex* 4vertex* t)
	  (1ferror* nil "Cannot find a vertex for ~S" node)
      )
  )
)

(1defmethod* 2(Key-Command-Mixin :3Set-Pop-Mark**) ()
  "Sets the pop mark to be the current node on the graph."
  (1if* (1not*  (1equal* 0 universal-arg))
     (1if* (1>* universal-arg 1)
	 (1pop* saved-marks)
	 (1let* ((node (1pop* saved-marks)))
	     (1if* node (1send* self 3:Go-To-Node* node) nil)
	 )
     )
     (progn (1if* (1not* current-node) (1setq* current-node root-node) nil)
	    (1push* current-node saved-marks)
     )
  )
)


(1defmethod* 2(Key-Command-Mixin :3Page-Up**) ()
"Scrolls self back up one page."
  (1send* self 3:Scroll-Relative* 0 (1** numeric-arg (1-* (1send* self 3:Inside-Height*))))
)

(1defmethod* 2(Key-Command-Mixin :3Page-Down**) ()
"Scrolls self down one page."
  (1send* self 3:Scroll-Relative* 0 (1** numeric-arg (1send* self 3:Inside-Height*)))
)

(1defmethod* 2(Key-Command-Mixin :3Page-Left**) ()
"Scrolls self left by one page."
  (1send* self 3:Scroll-Relative* (1** numeric-arg (1-* (1send* self 3:Inside-Width*))) 0)
)

(1defmethod* 2(Key-Command-Mixin :3Page-Right**) ()
"Scrolls self right by one page."
  (1send* self 3:Scroll-Relative* (1** numeric-arg (1send* self 3:Inside-Width*)) 0)
)

(1defmethod* 2(Key-Command-Mixin :3Line-Up**) ()
"Scrolls self back up one line."
  (1send* self 3:Scroll-Relative* 0
	 (1-* (1** 2 numeric-arg (1send* self 3:Sibling-Spacing*)))
  )
)

(1defmethod* 2(Key-Command-Mixin :3Line-Down**) ()
"Scrolls self down one line."
  (1send* self 3:Scroll-Relative* 0 (1** 2 numeric-arg (1send* self 3:Sibling-Spacing*)))
)

(1defmethod* 2(Key-Command-Mixin :3Line-Left**) ()
"Scrolls self left by one line."
  (1send* self 3:Scroll-Relative*
	 (1-* (1** numeric-arg (1send* self 3:Generation-Spacing*))) 0
  )
)

(1defmethod* 2(Key-Command-Mixin :3Line-Right**) ()
"Scrolls self right by one line."
  (1send* self 3:Scroll-Relative* (1** numeric-arg (1send* self 3:Generation-Spacing*)) 0)
)

(1defmethod* 2(Key-Command-Mixin :3End-Of-Line**) ()
"Scrolls self right to the end of the line, i.e. until the rightmost node is
 against the right margin.
"
  (1send* self 3:Scroll-To*
	(- (1send* self 3:Logical-Right-Edge*) (1send* self 3:Inside-Width*))
	(1send* self 3:Y-Pl-Offset*)
  )
)

(1defmethod* 2(Key-Command-Mixin :3Beginning-Of-Line**) ()
"Scrolls self left to the beginning of the line, i.e. until the leftmost node is
 against the left margin.
"
  (1send* self 3:Scroll-To*
	(1send* self 3:Logical-Left-Edge*)
	(1send* self 3:Y-Pl-Offset*)
  )
)

(1defmethod* 2(Key-Command-Mixin :3Top-Of-Window**) ()
"Homes the grapher to the top left corner of the graph."
  (1send* self 3:Scroll-To*
	(1send* self 3:Logical-Left-Edge*)
	(1send* self 3:Logical-Top-Edge*)
  )
)

(1defmethod* 2(Key-Command-Mixin :3Bottom-Of-Window**) ()
"Scrolls the grapher to the bottom left corner of the graph."
  (1send* self 3:Scroll-To*
	(1-* (1send* self 3:Logical-Right-Edge*)  (1send* self 3:Inside-Width*))
	(1-* (1send* self 3:Logical-Bottom-Edge*) (1send* self 3:Inside-Height*))
  )
)

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

(1defun* Stand-Alone-2Graph-Window-Initial-Function*-1 (blip 4window*)
"This is the function that actually processes the blips and keystrokes that
 the user generates.  Blip is a blip or a keyboard char.  If it is a blip then
 the blip is lexpr-sent to Window.  If blip is actually a char then this is
 looked up in *Char-To-Method-Mappings* and if an entry is found then that
 message is sent to Window.
"
  (1if* (1consp* blip)
      (if (and (1keywordp* (1first* blip))
	       (1send* 4window* 3:Operation-Handled-P* (1first* blip))
	  )
	  (1lexpr-send* 4window* blip)
	  (beep)
      )
      (if (or (integerp blip) (characterp blip))
	  (let ((entry
		  (assoc blip 2*Char-To-Method-Mappings**
			 :Test #'(lambda (x y)
				   (and (char-equal x y)
					(if (integerp x)
					    (equal (int-char x) y)
					    t
					)
				   )
				 )
		  )
		)
	       )
	       (if entry
		   (if (mx-p)
		       (letf (((1symeval-in-instance* 4window* 'scrolling-speed)
			       1000000
			      )
			     )
		             (send window 3:Send-If-Handles* (second entry))
		       )
		       (send window 3:Send-If-Handles* (second entry))
		   )
		   (beep)
	       )
	       (1if* (1not* (1member* (second entry) *numeric-arg-methods*))
		  (1progn* (1send* 4window* 3:Set-Universal-Arg* 0)
			 (1send* 4window* 3:Set-Numeric-Arg*   1)
			 (1send* 4window* :set-numeric-arg-p nil)
		  )
		  nil
	       )
	  )
	  nil
      )
  )
)

(1defun* 2Separate-With-Semicolons* (strings)
"Given a list of strings, returns a string which has all of the strings stuck
 together with semicolons in between.
"
 (1if* strings
    (1string-append* (1first* strings) "; " (separate-with-semicolons (1rest* strings)))
    ""
 )
)

(1defconstant* 2*Mouse-Key-To-Keyword-Mappings**
  '((#\mouse-l   3:Mouse-L-1*)
    (#\mouse-l-2 3:Mouse-L-*2)
    (#\mouse-m   3:Mouse-M-1*)
    (#\mouse-m-2 3:Mouse-M-2*)
    (#\mouse-r   3:Mouse-R-1*)
    (#\mouse-r-2 3:Mouse-R-2*)
   )
"An alist mapping mouse click characters to who-line doc keywords."
)

(1defun* 2Get-Doc-String* (4item* window)
"Given a background mouse blip item returns the who-line doc spec for it."
  (1list* (1second* (1assoc* (1first* 4item*) 2*Mouse-Key-To-Keyword-Mappings**
		      3:Test* #'1char-equal*
	       )
      )
      (1if* (1stringp* (1second* 4item*))
	  (1second* 4item*)
	  (1funcall* (1second* 4item*) 4window*)
      )
  )
)

(1defmethod* (2Stand-Alone-Grapher* :get-who-line-doc) ()
"Returns an AList of mouse doc specs for Self.  Each element is something like
 (:mouse-r-2 \"system menu\").  It does it not only by looking at the
 background-mouse-blip-functions slot, but also for 3:Mouse-*XXX3-Who-Line-Doc*
 methods for the different mouse clicks.
"
  (1delete* nil
     `(,@(1loop* for 4item* in background-mouse-blip-functions
	       collect (2Get-Doc-String* 4item* self)
	 )
       ,(1send* self 3:Send-If-Handles* 3:Mouse-L-Who-Line-Doc*)
       ,(1send* self 3:Send-If-Handles* 3:Mouse-L2-Who-Line-Doc*)
       ,(1send* self 3:Send-If-Handles* 3:Mouse-M-Who-Line-Doc*)
       ,(1send* self 3:Send-If-Handles* 3:Mouse-M2-Who-Line-Doc*)
       ,(1send* self 3:Send-If-Handles* 3:Mouse-R-Who-Line-Doc*)
       (3:Mouse-M-2* "Overview")
       (3:Mouse-M-Hold* "Drag Scrolling")
       (3:Mouse-R-2* "System Menu.")
      )
  )
)


(1Defmethod* (2Stand-Alone-Grapher* 3:Override* 3:Who-Line-Documentation-String*)
	    ()
"A doc string method for grapher windows.  Tries to do smart things about
 getting the docs in the right order and about throwing newlines in the
 right place.
"
  (1unless* (1send* self 3:Currently-Boxed-Item*)
   (1multiple-value-bind* (1string* error-p)
	 (1catch-error*
	   (1let* ((specs (order-mouse-items (1send* self :get-who-line-doc)))
		(intro-offset (doc-size '(ignore "M2: , ") 0 0))
	       )
	       (2Maybe-Split-Doc-Spec*	 specs intro-offset intro-offset)
	   )
	   nil
	 )
     (1if* error-p
	"Error getting Who-line documentation."
	string
     )
   )
  )
)

(defmethod (2Stand-Alone-Grapher* :mouse-button) (char window x y)
"This is a handler method that gets invoked when the user mouses on the window
 somewhere that isn't a mouse sensitive item.  If the user has supplied a
 function that matches Char in background-mouse-blip-functions then this is
 called on the window, x, y and any extra args in the alist entry.  Otherwise
 methods are invoked for the different types of mouse clicks, e.g. :mouse-l-2
 and are passed the coords, just in case these could be of use if there are any
 matching methods.
"
  (ignore window)
  (1let* ((entry (1assoc* char background-mouse-blip-functions 3:Test* #'1char-equal*)))
      (1if* entry
	 (1apply* (third entry) 4window* x y (1rest* (1rest* (1rest* entry))))
	 (1let* ((method (selector char char-equal
			 (#\mouse-l   3:Mouse-L*)
			 (#\mouse-l-2 3:Mouse-L-2*)
			 (#\mouse-m   3:Mouse-M*)
			 (#\mouse-m-2 3:Mouse-M-2*)
			 (#\mouse-r   3:Mouse-R*)
			 (otherwise nil)
		       )
	       )
	      )
	      (1if* (1and* method (1send* self 3:Operation-Handled-P* method))
		  (1send* self method x y)
		  (1beep*)
	      )
	 )
     )
  )
)

(defmethod (2Stand-Alone-Grapher* :typeout-execute)
	   (function item vertex &rest ignore)
"This method is called when the user left buttons on a mouse sensitive item.
 It has as its args a function to call and the vertex that got blipped on.
 The function gets called on the the data represented by the vertex.  This is
 a little tricky, since most of the time we just want to deal with this data
 that the user put on the vertex, not the vertex itself.  Thus, most of the time
 we call the fucntion with (coerce-to-node vertex).  However, there are times
 when the user needs more information in the function, e.g. the window so that
 it can be refreshed or some such.  If the function has an arglist that's
 longer than one then it is called with 3 args.  These are:
 (coerce-to-node vertex), Self (the window) and the Vertex.  The function is
 contractually required, therfore to take either 1 or 3 args.
"
  (1if* (1and* function
	    (1or* (1compiled-function-p* function)
	        (1consp* function)
		(1and* (1symbolp* function) (1fboundp* function))
	    )
     )
     (if (> (length (arglist function)) 1)
	 (funcall function item self vertex)
	 (funcall function item)
     )
     (1beep*)
  )
)

;;;RDA: Add this
(defun replot-a-graph (window vertex)
"Given a vertex and a window replot the graph denoted by vertex.  This is called
 when some user action has changed the way that a graph might be computed, i.e.
 changed the number of children or some such.  This then redraws everything.
"
  (apply #'plot-a-graph (1send* 4window* 3:Root-Node*)
	 :on window
	 (extract-plot-options window vertex)
  )
)

;;;RDA: Add this
(defun extract-plot-options (window vertex)
"Given a window and a vertex, extracts the extra options associated with a
 vertex, such as the child function and the directedness function and returns
 them as a plist that can be used as args to plot-a-graph.  This is useful
 when you want to replot an existing graph, but don't want to have to figure
 out what all of the magic keyword args were with which plot-a-graph was
 originally called.
"
  (declare (ignore window))
  (list* :child-function (vertex-node-child-function vertex)
	 :depth (vertex-node-depth vertex)
	 (extract-edge-options vertex)
  )
)

(1defun* 2Stand-Alone-Graph-Window-Initial-Function* (4window*)
"The top level function for graph winbdows.  It loops around looking for
 mouse blips and processing them.  It calls the function
 2Stand-Alone-Graph-Window-Initial-Function-1* to process the blips,
 so that this function can be modded without resetting the process under Window.
"
   ;;; Discard any chars in the in put buffer at start up.
   (1loop* for char = (1send* 4window* 3:Any-Tyi-No-Hang*) until (1not* char))
   (1loop* for blip = (1send* 4window* 3:Any-Tyi*)
	 do (2Stand-Alone-Graph-Window-Initial-Function-1* blip 4window*)
   )
)

(1defun* 2Make-Grapher-Window* (&rest inits)
"Makes a stand-alone grapher window."
  (1apply* #'1make-instance* '2Stand-Alone-Grapher*
	  3:Edges* (2Offsetting-Stand-Alone-Grapher-Edges*)
	  inits
  )
)

(1defun* 2Merge-Them* (specs)
"Merges a list of specs, such that ((a b) (c d) (a d) (e f)) maps to
 ((a c e) (b d f)).
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1list* (1apply* #'1append* (1mapcar* #'1first*   specs))
       (1apply* #'1append* (1mapcar* #'1second* specs))
  )
)

(1defun* 2Not-There* (x)
"Is true if X is nil or undefined."
  (1not* x)
)

(1defun* 2Clean-Up* (kids &optional (args nil) (edge-values nil))
"Is passed a kid or a list of kids and maybe some args, which will be passed to
 sundry graph functions.  Returns 2 values a) a list containing all of the
 kids which are not Not-There and b) a list of their matching args.
"
  (1declare* (optimize (safety 0)))
  (1declare* (1values* cleaned-up-kids cleaned-up-args cleaned-up-edge-values))
  (1if* (1consp* kids)
      (1if* (2Not-There* (1first* kids))
	  (2Clean-Up* (1rest* kids) (1rest* args) (1rest* edge-values))
	  (1multiple-value-bind* (new-kids new-args new-edge-values)
	      (2Clean-Up* (1rest* kids) (1rest* args) (1rest* edge-values))
	    (1values* (1cons* (1first* kids) new-kids)
		    (1cons* (1first* args) new-args)
		    (1cons* (1first* edge-values) new-edge-values)
	    )
	  )
      )
      (1if* kids
	  (2Clean-Up*
	    (1list* kids) (zwei:list-if-not args) (zwei:list-if-not edge-values)
	  )
	  (1values* nil nil nil)
      )
  )
)

(1defun* 2Apply-Safe* (1function* for kid args)
"Applies Function to For Kid &Rest args, making sure that Function takes enough
 args to allow the use of the Args arg.
"
  (1if* (1and* args
	   (1>* (1length* (1arglist* function)) 2)
      )
      (1apply* function for kid args)
      (1funcall* function for kid)
  )
)

(1defun* 2Get-Nodes-And-Edges*-2 (for child-function to-depth on functions)
"Gets the nodes and edges for the node to be graphed For using the child
 function Child-function, to a depth of to-depth.  Functions is a list of extra
 functions that are called to compute things like the directness of edges
 and the font of the nodes.
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1declare* (1special* *existing-edges* *existing-edges-cache*))
  (1multiple-value-bind* (kids args edge-values)
      (1funcall* child-function for)
    (1multiple-value-bind* (the-kids extra-args extra-edge-values)
	(2Clean-Up* kids args edge-values)
      ;;; Process all of the kids we need to.
      (1mapc* #'(lambda (x)
		 (1apply* '2Get-Nodes-And-Edges* x child-function
			 (and to-depth (1-* to-depth 1)) on functions
		 )
	       )
	       the-kids
      )
      (1loop* for kid in the-kids
	    for arg in extra-args
	    for edge-value in extra-edge-values
	    do
	    (1let* ((and-rest
		   (1apply* #'1append*
			   (1mapcar*
			     #'(lambda (fn)
				 (2Apply-Safe* fn for kid args)
			       )
			     functions
			   )
		    )
		  )
		 )
	         (1let* ((actual-edge (1append* (1list* edge-value for kid) and-rest)))
		      (1setf* (2Get-From-Cache*
			      actual-edge *existing-edges-cache*
			    )
			    t
		      )
		      (1push* actual-edge *existing-edges*)
		 )
	     )
      )
    )
  )
)

(1defun* 2Get-Nodes-And-Edges* (for child-function to-depth on &rest functions)
"Gets the nodes and edges for the graphed thing For using the child function
 Child-function, to a depth of to-depth.  Functions is a list of extra
 functions that are called to compute things like the directness of edges
 and the font of the nodes.  If we have already reached the maximum depth then
 we stop here.  We cache the computed nodes in a hash table.  This means that
 we don't keep recomputing for EQ nodes and can, therefore, deal with
 circularities and such.  Returns a list of two elements.  The first is a list
 of all of the nodes pointed to by For, including For and the second is a list
 of pairs denoting all of the edges between the nodes in the first list.  Thus
 if For has the childen A and B and A has C as its child then the result will be
 ((For A B C) ((For A) (For B) (A C))).
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1declare* (1special* *existing-nodes* *existing-edges*))
  (1declare* (1values* list-of-list-of-nodes-and-list-of-edges))
  (1apply* '2Get-Nodes-And-Edges-1*
	  for child-function to-depth on functions
  )
  (1list* *existing-nodes* *existing-edges*)
)

(1defun* 2Get-Nodes-And-Edges-1*
        (for child-function to-depth on &rest functions)
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1declare* (1special* *existing-nodes* *existing-nodes-cache*))
  (1let* ((real-node
	  (1if* (4vertexp* for)
	      (2Coerce-To-Node* (1send* for 3:Item*))
	      for
	  )
	)
       )
       (1if* (1equal* to-depth 0)
	   (1progn* 
	     (1setf* (2Get-From-Cache* real-node *existing-nodes-cache*)
		   (1if* (4vertexp* for) for t)
	     )
	     (1push* for *existing-nodes*)
	   )
	   (1let* ((was-found-p (2Get-From-Cache* for *existing-nodes-cache*)))
	       (1if* was-found-p
		   nil
		   (1progn* (1setf* (2Get-From-Cache*
				  real-node *existing-nodes-cache*
				)
			        (1if* (4vertexp* for) for t)
			   )
			   (1push* for *existing-nodes*)
			   (2Get-Nodes-And-Edges-*2
			     real-node child-function to-depth on functions
			   )
		   )
	       )
	   )
       )
  )
)

(1defun* 2Find-Vertex-For* (something 4window*-or-list)
"Given a vertex-node or a piece of user data finds the vertex for it."
  (1typecase* something
    (4vertex* something)
    (otherwise
     (1let* ((coerced (2Coerce-To-Node* something)))
	  (1find-if* #'(lambda (x)
		       (1and* (1typep* x '4basic-vertex*)
			     (1equal* (2Coerce-To-Node* (1send* x 3:Item*)) coerced)
		       )
		     )
		     (1typecase* window-or-list
		       (1list* window-or-list)
		       (otherwise (1send* 4window*-or-list 3:Item-List*))
		     )
	  )
     )
    )
  )
)

(1defun* 2Extract-Edge-Options* (a-vertex-node)
"Returns the edge options from a-vertex-node, i.e. a plist of the keyword value
 pairs that, when passed to plot-a-graph, would plot a graph like the one of
 which a-vertex-node is a node.
"
 `(,@(1if* (2Vertex-Node-Dash-Function* a-vertex-node)
	(1list* 3:Dash-Function* (2Vertex-Node-Dash-Function* a-vertex-node))
	nil
     )
   ,@(1if* (2Vertex-Node-Label-Function* a-vertex-node)
	(1list* 3:Label-Function* (2Vertex-Node-Label-Function* a-vertex-node))
	nil
     )
   ,@(1if* (2Vertex-Node-Directedness-Function* a-vertex-node)
	(1list* 3:Directedness-Function*
	     (2Vertex-Node-Directedness-Function* a-vertex-node)
	)
	nil
     )
   ,@(1if* (2Vertex-Node-Mouse-Sensitive-Type-Function* a-vertex-node)
	(1list* 3:Mouse-Sensitive-Type-Function*
	     (2Vertex-Node-Mouse-Sensitive-Type-Function* a-vertex-node)
        )
	nil
     )
   ,@(1if* (2Vertex-Node-Print-Function* a-vertex-node)
	(1list* 3:Print-Function*
	     (2Vertex-Node-Print-Function* a-vertex-node)
        )
	nil
     )
   ,@(1if* (2Vertex-Node-Font-Function* a-vertex-node)
	(1list* 3:Font-Function*
	     (2Vertex-Node-Font-Function* a-vertex-node)
        )
	nil
     )
  )
)

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

;;; A graph node, which knows about how to compute its kids locally.
;;; This is used when it is important for the kids function to be different
;;; for each node on the graph, i.e. a closure of some sort.

(1eval-when* (1compile* load eval)
(1defstruct* (2Local-Kids-Spec-Node* 3:Named*)
  node
  kids-function
)
)

(1putprop* '2Local-Kids-Spec-Node* '1general-structure-message-handler*
	 '1named-structure-invoke*
)

(1defvar* *graph-print-thing-stream*
	 (1let* ((temp nil))
	     (1with-output-to-string* (1stream*) (1setq* temp stream))
	     temp
         )
)

(1defun* 2Graph-Print-Thing* (node)
"Gets the printed representation of a node on the graph for a grapher pane."
  (1let* ((4*dont-shift-string-streams** t)
        (4*print-circle** nil)
	(4*print-pretty** nil) ;;; Just print on a line.
       )
      (1declare* (1special* 4*dont-shift-string-streams**))
      (1Multiple-value-bind* (name errorp)
	  (1catch-error* (1format* nil "~A" (2Coerce-To-Node* node)) nil)
	(1if* errorp
	    "Error printing a graph node"
	    name
	)
      )
  )
)

(1defvar* 2*Default-Graph-Depth** 3
"The default depth for graphs."
)

(1defun* reset-instance-1 (instance wrt-flavor)
"Resets an instance to have ivs like it had when it was consed."
  (1let* ((supers (sys:flavor-depends-on wrt-flavor)))
      (1loop* for thing in (sys:flavor-local-instance-variables wrt-flavor)
	    for iv = (ucl:first-if-list thing)
	    for init = (1if* (1listp* thing) (1second* thing) nil) do
	    (1setf* (1symeval-in-instance* instance iv) (1eval* init))
      )
      (1loop* for super in supers do
	    (reset-instance-1 instance (1get* super 'sys:flavor))
      )
  )
)

;(1defun* reset-instance
;        (instance &optional (wrt-flavor (1get* (1type-of* instance) 'sys:flavor)))
;"Resets an instance to have ivs like it had when it was consed."
;  (1loop* for index from 1 below (sys:flavor-instance-size wrt-flavor)
;        for iv in (sys:flavor-all-instance-variables wrt-flavor)
;        do (sys:%p-store-data-type-and-pointer
;	     (1locf* (sys:%instance-ref instance index)) sys:dtp-null iv
;	   )
;  )
;)

(1defun* reset-instance
        (instance &optional (wrt-flavor (1get* (1type-of* instance) 'sys:flavor)))
"Resets an instance to have ivs like it had when it was consed."
  (1loop* for index from 1 below (sys:flavor-instance-size wrt-flavor)
        do (sys:%p-store-data-type-and-pointer
	     (1locf* (sys:%instance-ref instance index)) sys:dtp-null nil
	   )
  )
)

;;; Copied from sys:instantiate-flavor
(1defun* 2Execute-Init-Plist*
        (instance fl init-plist &aux new-plist unhandled-keywords)
  (let ((var-keywords (sys:flavor-all-inittable-instance-variables fl))
	(remaining-keywords (sys:flavor-remaining-init-keywords fl)))
	;; First, process any user-specified init keywords that
	;; set instance variables.  When we process the defaults,
	;; we will see that these are already set, and will
	;; refrain from evaluating the default forms.
	;; At the same time, we record any init keywords that this flavor
        ;; doesn't handle.
    (do ((pl (cdr init-plist) (cddr pl)))
	((null pl))
      (let ((index (position (car pl) (the list var-keywords) :test #'eq)))
	(cond
	  (index
	   (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ index))))
	      (setf (%instance-ref instance (1+ index)) (cadr pl))))
	  ((not (member (car pl) remaining-keywords :test #'eq))
	   (pushnew (car pl) unhandled-keywords)))))
    ;; Now do all the default initializations, of one sort or other,
    ;; that have not been overridden.
    (let ((self instance))
      (dolist (d (sys:flavor-instance-variable-initializations fl))
	(or (/= dtp-null (%p-data-type (%instance-loc instance (1+ (car d)))))
	   (setf (%instance-ref instance (1+ (car d)))
		 (sys:fast-eval (cadr d)))))
      ;; Now stick any default init plist items that aren't handled by that
      ;; onto the actual init plist.
      (do ((pl (sys:flavor-remaining-default-plist fl) (cddr pl)))
	  ((null pl))
	(or (sys:memq-alternated (car pl) (cdr init-plist))
	   (progn
	     (unless (eq init-plist (locf new-plist))
	       (setq new-plist (cdr init-plist)
		     init-plist (locf new-plist)))
	     (setq new-plist
		   (list* (car pl) (sys:fast-eval (cadr pl)) new-plist)))))))
)

(1defun* allocate-instance (flavor &rest inits)
"Allocates an instance from the resource if it can, otherwise conses a new one."
  (1let* ((bin (1assoc* flavor 2*Item-Resource**)))
      (1if* (1and* 4*resourcify-items** (1rest* bin))
	 (1let* ((instance (1second* bin)))
	     (1setf* (1rest* bin) (1rest* (1rest* bin)))
	     (2Reset-Instance* instance)
	     (2Execute-Init-Plist* instance (1get* flavor 'sys:flavor) (1locf* inits))
	     (1send* instance 3:Init* (1list* nil))
	     instance
	 )
	 (1apply* '1make-instance* flavor inits)
     )
  )
)

(1defun* 2Make-Vertex-For*
       (for 4window* child-function depth dash-function
	label-function directedness-function
	mouse-sensitive-type-function print-function
	font-function vertex-flavor Vertex-Initargs parent-function
       )
"Makes a grapher vertex for the user object For.  All of the extra args are
 parcelled up inside a Vertex-node so that they can be extracted at some useful
 point.
"
  (1let* ((4font* (1funcall* font-function for)))
     ; (4coerce-font* 4font* 4window*)
      (1apply* 'allocate-instance
	(1if* (1functionp* vertex-flavor)
	   (1funcall* vertex-flavor for)
	   vertex-flavor
	)
	3:Window* 4window*
	3:Pre-Print-Item-Modify-Function* print-function
	3:Font* font
	
	3:Item* for
	3:Child-Function* child-function
	3:Parent-Function* parent-function
	3:Depth* depth
	3:Dash-Function* dash-function
	3:Label-Function* label-function
	3:Directedness-Function* directedness-function
	3:Mouse-Sensitive-Type-Function*
	  mouse-sensitive-type-function
	3:Print-Function* print-function
	3:Font-Function* font-function
	(1if* (1functionp* Vertex-Initargs)
	    (1funcall* Vertex-Initargs for)
	    Vertex-Initargs
	)
      )
  )
)

(1defun* 2Get-Vertex-For*
       (for hash 4window* child-function depth dash-function
	label-function directedness-function
	mouse-sensitive-type-function print-function
	font-function vertex-flavor Vertex-Initargs parent-function
       )
"Gets a vertex for a graph node.  The vertex may be cached in the hash table
 Hash.  If it is then this is returned, otherwise a new vertex is made and
 initialised with all of the other args.
"
  (1let* ((real-for (2Coerce-To-Node* for)))
       (1let* ((entry (2Get-From-Cache* real-for hash)))
	    (1if* entry
		entry
		(1setf* (2Get-From-Cache* real-for hash)
		     (2Make-Vertex-For* real-for 4window*
		       child-function depth dash-function
		       label-function directedness-function
		       mouse-sensitive-type-function print-function
		       font-function vertex-flavor Vertex-Initargs
		       parent-function
		     )
		)
	    )
       )
  )
)

(1defun* 2Verticise-1*
        (1list* hash 4window* child-function depth result dash-function
	 label-function directedness-function mouse-sensitive-type-function
	 print-function font-function vertex-flavor Vertex-Initargs
	 parent-function
        )
"Turns a list of nodes into vertices for a grapher.  Hash is a hash table that
 maps elements in List into their vertices.  This prevents multiple vertices
 representing the same node being created.  Window is the window into which
 things will be graphed.  Child-Function is the function applied to each user
 object in List to deliver the next level of items in the tree.  Depth is the
 maximum depth for the tree.  Result accumulates the verticised components as
 they are determined.  All of the other arguments are used to initialise the
 nodes and edges as appropriate.
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1if* list
      (2Verticise-1*
	(1rest* list) hash 4window* child-function depth
	(1cons* (2Get-Vertex-For* (1first* list) hash 4window* child-function depth
			       dash-function label-function
			       directedness-function
			       mouse-sensitive-type-function
			       print-function font-function
			       vertex-flavor Vertex-Initargs
			       parent-function
               )
	       result
	)
	dash-function label-function directedness-function
	mouse-sensitive-type-function print-function font-function
	vertex-flavor Vertex-Initargs parent-function
      )
      (1nreverse* result)
  )
)

(1defun* edge-item-value (4edge*)
  (1etypecase* 4edge*
    (1cons* (first 4edge*))
    (4edge* (1send* 4edge* 3:*Item))
  )
)

(1defun* edge-from (4edge*)
  (1etypecase* 4edge*
    (1cons* (second 4edge*))
    (4edge* (1send* 4edge* 3:From-Vertex*))
  )
)

(1defun* edge-to (4edge*)
  (1etypecase* 4edge*
    (1cons* (third 4edge*))
    (4edge* (1send* 4edge* 3:To-Vertex*))
  )
)

(1defun* edge-args (4edge*)
  (1etypecase* 4edge*
    (1cons* (1rest* (1rest* (rest 4edge*))))
    (4edge* nil) ;;;!!!!
  )
)


(1defun* 2Verticise-Edge* (1edge* hash 4window* child-function depth dash-function
			label-function directedness-function
			mouse-sensitive-type-function print-function
			font-function vertex-flavor Vertex-Initargs
			Edge-flavor Edge-Initargs parent-function
		       )
"Verticises an edge spec.  The edge is a two-list of items in the tree.  Given
 an edge, such as (a b) it returns a pair such as:
 (#<Vertex for A> #<Vertex for B>).  The extra args are used to initialise the
 verticies as appropriate if it fails to find the vertex for the edge component
 in the cache hash table Hash.
"
  (1if* (1typep* 4edge* '4edge*)
      (1list* (edge-from edge) (edge-to edge) (edge-args 4edge*))
      (1let* ((from (2Get-Vertex-For*
		    (edge-from edge) hash 4window* child-function depth
		    dash-function	label-function directedness-function
		    mouse-sensitive-type-function print-function
		    font-function vertex-flavor Vertex-Initargs
		    parent-function
		 )
	    )
	    (to  (2Get-Vertex-For* (edge-to edge) hash 4window* child-function
				    depth dash-function label-function
				    directedness-function
				    mouse-sensitive-type-function
				    print-function font-function
				    vertex-flavor Vertex-Initargs
				    parent-function
		  )
	    )
	   )
	   (make-edge-for from to 4edge* edge-flavor edge-initargs window)
      )
  )
)

(1defun* 2Make-Edge-For*
        (from to 4edge* edge-flavor edge-initargs 4window*)
  (1check-arg* from 4vertexp* "a vertex")
  (1check-*arg to 4vertexp* "a vertex")
  (1apply* 'allocate-instance
	  (1if* (1functionp* Edge-flavor)
	      (1funcall* Edge-flavor (edge-from edge) (2Edge-To* edge))
	      Edge-flavor
	  )
	  3:Window* 4window*
	  3:From-Vertex* from
	  3:To-Vertex* to
	  3:Item* (2Edge-Item-Value* 4edge*)
	  (1append* (1if* (1functionp* Edge-Initargs)
		       (1funcall* Edge-Initargs
				(edge-from edge) (edge-to edge)
		       )
		       Edge-Initargs
		   )
		   (2Edge-Args* 4edge*)
	  )
  )
)


(1defun* 2Verticise*
        (1list* hash 4window* child-function depth dash-function
	 label-function directedness-function mouse-sensitive-type-function
	 print-function font-function vertex-flavor Vertex-Initargs
	 parent-function
        )
"Turns a list of nodes into vertices for a grapher.  Hash is a hash table that
 maps elements in List into their vertices.  This prevents multiple vertices
 representing the same user object being created.  Window is the window into
 which things will be graphed.  Child-Function is the function applied to
 each object to deliver the next level of items in the tree.  Depth is the
 maximum depth for the tree.  The other function args are used to compute the
 font and such like for the vertex that's generated.
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (2Verticise-1* list hash 4window* child-function depth nil dash-function
	        label-function directedness-function
		mouse-sensitive-type-function print-function font-function
		vertex-flavor Vertex-Initargs parent-function
  )
)

(1defun* 2Default-Dash-Function* (node node2)
"A default dashing function, which draws solid lines.  A real one should
 return something like (:dashed-p 2).
"
  (1ignore* node node2)
  nil
)

(1defun* 2Coarse-Dashes* (node node2)
"A dashing function that draws coarse dashes."
  (1ignore* node node2)
  '(3:Dashed-P* 2)
)

(1defun* 2Moderate-Dashes* (node node2)
"A dashing function that draws moderately coarse dashes."
  (1ignore* node node2)
  '(3:Dashed-P* 1)
)

(1defun* 2Default-Label-Function* (node node2)
"A default option function that puts no label on edges.  A real one should
 return something like (list :label \"Hello\" :Label-font fonts:hl12b) or
 (list :label \"Hello\").
"
  (1ignore* node node2)
  nil
)

(1defun* 2Default-Directedness-Function* (node node2)
"A default function for the directedness of an edge.  Edges, by default, are
 directed from node to node2.  A real one should return something like 
 (:undirected-p t).
"
  (1ignore* node node2)
  nil
)

(1defun* 2Undirected-Edges* (node node2)
"A directedness function for edges that makes them undirected. 
 c.f. 2Default-Directedness-Function*.
"
  (1ignore* node node2)
  '(3:Undirected-P* t)
)

(1defun* 2Default-Node-Font-Function* (node)
"Defaults to printing Nodes in font 0."
  (1ignore* node)
  0
)

(1defun* 2Default-Mouse-Sensitive-Type-Function* (node node2)
"A default option function that supplies no extra mouse sensitive type to
 edges.  A real one should return something
 like (list :mouse-sensitive-type 'foo).
"
  (1ignore* node node2)
  nil
)

(1defun* old-nodes-and-edges (items nodes edges)
"Given a list of items in a window returns two values; the nodes and the edges.
 These are accumulated into Nodes and Edges as Items is processed.
"
  (1declare* (optimize (speed 3) (safety 0)))
  (1if* items
      (1if* (1typep* (1first* items) '4edge*)
	  (old-nodes-and-edges (1rest* items) nodes (1cons* (1first* items) edges))
	  (old-nodes-and-edges (1rest* items) (1cons* (1first* items) nodes) edges)
      )
      (1values* nodes edges)
  )
)

(1defun* 2Get-And-Verticise-Nodes-And-Edges*
       (2Verticise* Edgise for actual-node kids-function to-depth &rest functions)
"Gets the nodes and edges for the user object For using the child function
 Function, to a depth of to-depth and using the functions Functions to
 initialise the generated vertices as appropriate.
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1if* (1equal* to-depth 0)
      (1list* (1list* for) nil)
      (1multiple-value-bind* (kids args edge-values)
	  (1funcall* kids-function actual-node)
	(1multiple-value-bind* (the-kids extra-args extra-edge-values)
	    (2Clean-Up* kids args edge-values)
	  (1let* ((kid-vertices (1mapcar* 2Verticise* the-kids)))
	      (1let* ((from-kids
		      (1mapcar* #'(lambda (vert node)
				  (1apply* '2Get-And-Verticise-Nodes-And-Edges*
					  2Verticise* edgise vert node
					  kids-function
					  (and to-depth (1-* to-depth 1))
					  functions
				  )
				)
				kid-vertices the-kids
		      )
		    )
		   )
		   (1let* ((links 
			  (1mapcar*
			    #'(lambda (x args edge-value)
				(1append*
				  (1list* edge-value for x)
				  (1apply* #'1append*
					 (1mapcar* #'(lambda (fn)
						      (2Apply-Safe* fn
							   actual-node x args
						      )
						    )
						 functions
					 )
				  )
				)
			      )
			      kid-vertices
			      extra-args
			      extra-edge-values
			  )
			)
		       )
		       (1let* ((edgified-links (1mapcar* edgise links)))
			   (2Merge-Them* (1cons* (1list* (1list* for) edgified-links)
					        from-kids
					  )
			   )
		       )
		   )
	      )
	  )
	)
      )
  )
)

(1defun* 2Plot-A-Graph-Graph-2*
   (root-node nodes edges old-items node-vertices hash on child-function depth
    dash-function label-function directedness-function
    mouse-sensitive-type-function print-function font-function vertex-flavor
    Vertex-Initargs Edge-flavor Edge-Initargs parent-function
   )
"Plots a graph for Nodes on the window On.  Edges are the old edges in the graph
 if any, old-items are the old vertices if any.  All the other args are just
 like those passed to plot-a-graph.
"
  (1ignore* nodes)
  (1let* ((new-edges
	 (1mapcar*
	   #'(lambda (x)
	       (2Verticise-Edge* x hash on child-function	 depth dash-function
                 label-function directedness-function
		 mouse-sensitive-type-function print-function font-function
		 vertex-flavor Vertex-Initargs Edge-flavor Edge-Initargs
		 parent-function
	       )
	     )
	     edges
	 )
       )
      )
      (if (vertexp root-node)
	  (multiple-value-bind (old-nodes old-edges)
	      (2Old-Nodes-And-Edges* old-items nil nil)
	    (1let* ((root (2Find-Vertex-For*
			  (2Coerce-To-Node* (1send* on 3:Root-Node*))
			  on
			)
		  )
		 )
	         (1send* on 3:Draw-Graph* (1append* old-nodes node-vertices)
		        (1append* old-edges new-edges) root 0 0
		        root-node
			;(2Get-From-Cache* (2Coerce-To-Node* root-node) hash)
		 )
            )
	  )
	  (1progn* (1send* on 3:Draw-Graph* node-vertices new-edges
		        nil 0 0
			(2Get-From-Cache* (2Coerce-To-Node* root-node) hash)
		 )
          )
      )
 )
)

(1defun* 2Plot-A-Graph-Graph*
        (node on old-items child-function depth dash-function label-function
	 directedness-function mouse-sensitive-type-function print-function
	 font-function vertex-flavor Vertex-Initargs Edge-flavor Edge-Initargs
	 vertex-comparator parent-function
        )
"Plots a graph for Node on the window On.  Edges are the old edges in the graph
 if any, old-items are the old vertices if any.  All the other args are just
 like those passed to plot-a-graph.
"
  (1let* ((child-cache (2Make-Cache-Map* vertex-comparator))
       (parent-cache (1if* parent-function
			 (2Make-Cache-Map* vertex-comparator)
			 nil
		     )
       )
       (child-edge-cache (2Make-Cache-Map* #'equal))
       (parent-edge-cache (1if* parent-function
			      (2Make-Cache-Map* #'1equal*)
			      nil
			  )
       )
      )
      (1loop* for x in old-items when (4vertexp* x)
	    do (1setf* (2Get-From-Cache* (2Coerce-To-Node* (1send* x 3:Item*))
				        child-cache
		    )
		    x
	       )
	    when parent-function
	    do (1setf* (2Get-From-Cache* (2Coerce-To-Node* (1send* x 3:Item*))
				        parent-cache
		    )
		    x
	       )
      )
      (1destructuring-bind* (nodes edges)
	 (1let* ((*existing-nodes-cache* child-cache)
	       (*existing-edges-cache* child-edge-cache)
	       (*existing-nodes* nil)
	       (*existing-edges* nil)
	      )
	     (1declare* (1special* *existing-nodes* *existing-edges*
			      *existing-nodes-cache* *existing-edges-cache*
		      )
	     )
	     (2Get-Nodes-And-Edges* node child-function depth on dash-function
				      label-function directedness-function
				      mouse-sensitive-type-function
	     )
	 )
	(1destructuring-bind* (parent-nodes parent-edges)
	  (1if* parent-function
	     (1let* ((*existing-nodes-cache* parent-cache)
		   (*existing-edges-cache* parent-edge-cache)
		   (*existing-nodes* nil)
		   (*existing-edges* nil)
		  )
	          (1declare* (1special* *existing-nodes* *existing-edges*
				    *existing-nodes-cache*
				    *existing-edges-cache*
		           )
	          )
		  (2Get-Nodes-And-Edges* node parent-function depth on
		    dash-function label-function directedness-function
		    mouse-sensitive-type-function
		  )
             )
	     (1list* nil nil)
	  )
	  ;;; Make sure that parent edges point in the right direction.
	  (1loop* for edge in parent-edges
	        do  (1if* (1listp* 4edge*)
			(1psetf* (1third* 4edge*) (1second* 4edge*)
			       (1second* 4edge*) (1third* 4edge*)
			)
			nil
		    )
	  )
	  (1let* ((hash (2Make-Cache-Map* vertex-comparator)))
	      (2Map-Over-Cache*
		 #'(lambda (key 4value* &rest ignore)
		      (1if* (4vertexp* 4value*)
			  (1setf* (2Get-From-Cache* key hash) 4value*)
			  nil
		      )
		    )
		    child-cache
	       )
	       (1if* parent-cache
		  (2Map-Over-Cache*
		     #'(lambda (key 4value* &rest ignore)
			  (1if* (4vertexp* 4value*)
			      (1setf* (2Get-From-Cache* key hash) 4value*)
			      nil
			  )
			)
			parent-cache
		   )
		   nil
	       )
	       (1setq* parent-nodes (1rest* (1nreverse* parent-nodes)))
	       (1let* ((all-nodes (1append* parent-nodes nodes))
		     (all-edges (1append* parent-edges edges))
		    )
		    (1let* ((node-vertices
			    (2Verticise* all-nodes
			      hash on child-function depth
			      dash-function label-function directedness-function
			      mouse-sensitive-type-function print-function
			      font-function vertex-flavor Vertex-Initargs
			      parent-function
			    )
			  )
			 )
			 (2Plot-A-Graph-Graph-2* node all-nodes all-edges
			   old-items node-vertices hash on child-function depth
			   dash-function label-function directedness-function
			   mouse-sensitive-type-function print-function
			   font-function vertex-flavor Vertex-Initargs
			   Edge-flavor Edge-Initargs parent-function
			 )
		    )
	       )
	  )
	)
	on
      )
  )
)

(1defun* 2Plot-A-Graph-Tree*
        (node old-items on child-function depth dash-function label-function
	 directedness-function mouse-sensitive-type-function print-function
	 font-function vertex-flavor Vertex-Initargs Edge-flavor Edge-Initargs
	 parent-function
	)
"Plots Node on the window On as a Tree, rather than a graph.  This function is
 invoked by Plot-a-graph when the tree-p arg is true.  old-items are the old
 vertices in the window if any.  The other args are just like those given
 to plot-a-graph.
"
  (1flet* ((verticise-function (for)
	 (1if* (4vertexp* for)
	     for
	     (2Make-Vertex-For* for on child-function depth dash-function
	      label-function directedness-function mouse-sensitive-type-function
	      print-function font-function vertex-flavor Vertex-Initargs
	      parent-function
	     )
	 )
	)
	(edgise-function (edge)
	  (1if* (1typep* edge '4edge*)
	      edge
	      (make-edge-for (4edge-from* edge) (4edge-to* edge)
			     4edge* edge-flavor edge-initargs on
	      )
	  )
	)
       )
       (1destructuring-bind* (nodes edges)
	    (2Get-And-Verticise-Nodes-And-Edges*
	      #'verticise-function #'edgise-function (verticise-function node)
	       (1if* 1(vertexp node)*
		   (2Coerce-To-Node* (1send* node 3:Item*))
		   node
	       )
	       child-function depth dash-function label-function
	       directedness-function mouse-sensitive-type-function
	    )
	 (1destructuring-bind* (parent-nodes parent-edges)
	    (1if* parent-function
	       (2Get-And-Verticise-Nodes-And-Edges*
		 #'verticise-function #'edgise-function
		 (verticise-function node)
		  (1if* 1(vertexp node)*
		      (2Coerce-To-Node* (1send* node 3:Item*))
		      node
		  )
		  parent-function depth dash-function label-function
		  directedness-function mouse-sensitive-type-function
	       )
	       (1list* nil nil)
	    )
	    ;;; Make sure that parent edges point in the right direction
	    ;;; by mutating them.
	    (1let* ((desired-root (1first* nodes))
		  (actual-root (1first* parent-nodes))
		 )
		 (1loop* for edge in parent-edges
		       when (1eq* (1symeval-in-instance* 4edge* 'from-vertex)
				actual-root
			    )
		       do
			(1setf* (1symeval-in-instance* 4edge* 'from-vertex)
			      desired-root
			)
		       do (if (1typep* 4edge* '1list*)
			      (1psetf* (1third* 4edge*) (1second* 4edge*)
				     (1second* 4edge*) (1third* 4edge*)
			      )
			      (1psetf* (1symeval-in-instance* 4edge* 'from-vertex)
				     (1symeval-in-instance* 4edge* 'to-vertex)
				     (1symeval-in-instance* 4edge* 'to-vertex)
				     (1symeval-in-instance* 4edge* 'from-vertex)
			      )
			  )
		 )
	    )
	    (1let* ((all-nodes (1append* (1rest* parent-nodes) nodes))
		  ;;; Make sure we don't reference the root more than once
		  (all-edges (1append* parent-edges edges))
		 )
		 (if (vertexp node)
		     (multiple-value-bind (old-nodes old-edges)
			 (2Old-Nodes-And-Edges* old-items nil nil)
		       (1let* ((root (2Find-Vertex-For*
				     (2Coerce-To-Node* (1send* on 3:Root-Node*))
				     on
				   )
			    )
			   )
			   (1send* on 3:Draw-Graph*
				  (1append* old-nodes (1remove* node all-nodes))
				  (1append* old-edges all-edges) root 0 0
				  node
			   )
		       )
		       (1send* on 3:Expose*)
		     )
		    (1send* on 3:Draw-Graph* all-nodes all-edges nil 0 0
			  (2Find-Vertex-For* node all-nodes)
		    )
		 )
	    )
	   On
	 )
       )
  )
)

(1Defun* 2Set-Up-Graph-Window*
        (4window* node item-type-alist orientation label
	 auto-scale-p background-mouse-blip-functions node-on-graph
	 shouldnt-graph
	)
"Sets up the grapher window according to its args, e.g. setting the orientation
 of the window if necessary.
"
  (1if* (1and* (1not* 1(vertexp node)*)
	    (1not* node-on-graph) (1not* shouldnt-graph)
      )
      (1send* 4window* 3:Set-Root-Node* node)
      nil
  )
  (if item-type-alist
      (send window :Set-Item-Type-Alist item-type-alist)
      nil
  )
  (1if* (1not* (1equal* 3:Default* orientation))
      (1send* 4window* 3:Set-Orientation* orientation)
      nil
  )
  (1if* (1not* (1equal* 3:Default* label))
       (1send* 4window* 3:Set-Label* label)
       nil
   )
  (1if* auto-scale-p
     (1progn* (1send* 4window* :set-logical-right-edge  :recompute)
	    (1send* 4window* :set-logical-bottom-edge :recompute)
     )
     nil
  )
  (1if* (1not* (1equal* background-mouse-blip-functions 3:Default*))
      (1send* 4window* 3:Set-Background-Mouse-Blip-Functions*
	     background-mouse-blip-functions 
      )
      nil
  )
)

(1defun* 2Autoscale-Graph-Window* (4window* scale)
"Resizes a graph window (Window) so that it fits the graph being drawn.  Scale
 can be either true, in which case the window makes itself as big as will
 fit into the superior if need be, or it can be a cons, in which case this is
 interpretted as being the max width and max height to use.
"
  (1multiple-value-bind* (width height)
      (1if* (1consp* scale)
	  (1values-list* scale)
	  (1send* (1send* 4window* 3:Superior*) 3:Inside-Size*)
      )
    (1multiple-value-bind* (win-width win-height)
	(1send* (1send* 4window* 3:Superior*) 3:Inside-Size*)
      (1let* ((real-width (1min* width win-width))
	   (real-height (1min* height win-height))
	   (log-width  (1send* 4window* 3:Logical-Width*))
	   (log-height (1send* 4window* 3:Logical-Height*))
	  )
	  (1let* ((width-to-be
		  (1max* (1+* 3 (1send* (1send* 4window* 3:Overview-Window*)
				    3:Right-Margin-Size*
			     )
			     (1send* (1send* 4window* 3:Overview-Window*)
				    3:Left-Margin-Size*
			     )
			     (1send* 4window* 3:Left-Margin-Size*)
			     (1send* 4window* 3:Right-Margin-Size*)
			)
		        (1min* real-width
			      (1+* log-width
				  (1send* 4window* 3:Left-Margin-Size*)
				  (1send* 4window* 3:Right-Margin-Size*)
			      )
			)
		  )
		)
		(height-to-be
		  (1max* (1+* 3 (1send* (1send* 4window* 3:Overview-Window*)
				    3:Bottom-Margin-Size*
			     )
			     (1send* (1send* 4window* 3:Overview-Window*)
				    3:Top-Margin-Size*
			     )
			     (1send* 4window* 3:Top-Margin-Size*)
			     (1send* 4window* 3:Bottom-Margin-Size*)
			)
		        (1min* real-height
			      (1+* log-height
				  (1send* 4window* 3:Top-Margin-Size*)
				  (1send* 4window* 3:Bottom-Margin-Size*)
			      )
			)
		  )
		)
	       )
	       (1multiple-value-bind* (x y) (1send* 4window* 3:Position*)
		 (1let* ((left (1max* 0 (1if* (1>* (1+* width-to-be x) win-width)
					(1-* win-width width-to-be)
					x
				    )
			     )
		      )
		      (top (1max* 0 (1if* (1>* (1+* height-to-be y) win-height)
				      (1-* win-height height-to-be)
				      y
				   )
			   )
		      )
		     )
		     (1send* 4window* 3:Set-Edges* left top
			    (1+* left width-to-be)
			    (1+* top height-to-be)
		     )
		 )
	       )
	  )
      )
    )
  )
)


(1defun* 2Finalise-Graph-Window*
        (node 4window* auto-scale-p home-to-root-node-p calling-args expose-p)
"Sets up the graph window Window now that the graph has actually been plotted.
 Resizes the graph window (Window) so that it fits the graph being drawn
 according to Auto-Scale-P.  Auto-Scale-P can be either true, in which case
 the window makes itself as big as will fit into the superior if need be, or
 it can be a cons, in which case this is interpretted as being the max width
 and max height to use.
 If Home-To-Root-Node-P then it homes the window to the top node of the graph
 if Home-To-Root-Node-P = :root-node, otherwise to Node.
"
  (1send* 4window* :set-calling-args calling-args)
  (1if* (1and* auto-scale-p
	    (1not* (1typep* (1send* 4window* 3:Superior*) '4constraint-frame*))
      )
      (2Autoscale-Graph-Window* 4window* auto-scale-p)
      nil
  )
  (1progn* ;with-window-ops-on-bit-array (window)
    (1if* home-to-root-node-p
       (1let* ((root (1if* (1equal* home-to-root-node-p 3:Root-Node*)
		      (1send* 4window* 3:Root-Node*)
		      node
		  )
	    )
	   )
	   (1send* 4window* 3:Go-To-Node* root)
       )
       nil
    )
    (1if* expose-p (1send* 4window* 3:Expose*) nil)
  )
  (1send* window 3:Set-Graph-Behaviour-Changed* nil)
  window
)

(1defvar* 2*Auto-Scale-Graphers-By-Default** Nil
"When true graphers are autoscaled by default."
)

(1defvar* 2*Force-Exposure** T
"When true, by default graphers are forced to be exposed after the graph is
 plotted.
"
)

(1defun* 2Plot-*A2-Graph*
       (node &key (on 3:From-Resource*)
	child-function
	(depth 2*Default-Graph-Depth**)
	(Dash-function '2Default-Dash-Function*)
	(label-function '2Default-Label-Function*)
	(directedness-function '2Default-Directedness-Function*)
	(mouse-sensitive-type-function
	  '2Default-Mouse-Sensitive-Type-Function*
	)
	(print-function '2Graph-Print-Thing*)
	(font-function '2Default-Node-Font-Function*)
	(vertex-flavor 'vertex)
	(edge-flavor 'edge)
	(item-type-alist nil)
	(orientation 3:Default*)
	(label 3:Default*)
	(tree-p nil)
	(resource 'Stand-Alone2-Graphers*)
	(auto-scale-p 2*Auto-Scale-Graphers-By-Default**)
	(background-mouse-blip-functions 3:Default*)
	(home-to-root-node-p t)
	(force-exposure 2*Force-Exposure**)
	(dont-graph-if-already-graphing-this-node nil)
	(vertex-initargs nil)
	(edge-initargs nil)
	(vertex-comparator #'1eq*)
	(parent-function #'(lambda (x) nil))
	(top-node-visible-p t)
       )
"Plots a graph for Node.  A simple way to use this function is simply to
 say:

   (tv:plot-a-graph thing :child-function #'links-coming-out-of-thing)

 such that links-coming-out-of-thing is a function, which when called
 with thing (or one of its children) as its argument will return a list of
 the members of the next generation.

Returned Value
==============
      The function always returns the window on which the graph was plotted.
      This makes it simple to call the function the first time using the
      default value for the :On argument, but supplying the result of the
      first call for all subsequent calls if you always want the graphs
      to be plotted in the same window.

 There are a number of more sophisticated ways to use plot-a-graph.  One
 particularly significant thing that you should be aware of is that there
 are three main ways to affect the way that the vertices of the graph
 appear.  These are:
  a) The text string used to print out the vertex.
  b) The font of the text.
  c) The sort of box into which the text is printed.  This might be a
     filled rectangle or might have a line around it.
 All of these are under your control.

 Below you will find an explanation of the numerous keyword arguments
 supported by plot-a-graph.  This is followed by a discussion of the
 keystroke commands supported by grapher windows, some important things
 to remember/note and a worked example, showing how one might develop
 a means of plotting CLOS classes, making mouse-sensitive boxes to
 display the classes, background menus and such-like.

--------------------------------------------------------------------------------

 The keyword args have the following meanings:
  On - The window on to which to plot the graph.  If this is defaulted then a
       window is drawn from the resource specified in the :resource argument.
  Child-Function - The function which, when applied to a node (such as Node),
       will return a List of the nodes to which the node is to be connected.
       The grapher knows how to deal with circularity, so you don't have to
       worry about it.
       This function can return up to three values.
         The first value is a list of the children of the node in question,
         as mentioned above.
         The second is a list of extra args that can be supplied to functions
         such as label functions to fill out their arg lists.
         The third arg can be a list whose length is the same as that of
         the first arg.  This is the list of values that are to sit under
         the links, as opposed to the child nodes.
  Depth - The depth of the graph, i.e. the number of generations of children
       to have.  If this arg is Nil, then the graph will go deep enough to find
       all leaves (which could be very large).
  Dash-Function - a function which, when called with the nodes at the end of
       an arc, will return a specification for the way in which the line for
       the arc should be dashed (default = solid line).
  Label-Function - a function which, when called with the nodes at the end of
       an arc, will return a specification for the text with which to label
       the arc (default = no label).
  Directedness-Function - a function which, when called with the nodes at the
       end of an arc, will return a specification for whether the arc should be
       directed or not (default - node1 ----> node2).
  Mouse-Sensitive-Type-Function - a function which, when called with the nodes
       at the end of an arc, will return a specification for the mouse-sensitive
       type for the thing.  This is like the type defined in
       tv:basic-mouse-senstive-items.
  Print-Function - a function which, when called with a node, should return a
       string that represents the way in which it should appear.
  Font-Function - a function which, when called with a node, should return
       the font number for the font in which to display the node.
       (default = 0).
  Vertex-Flavor - the flavor of vertices to create in the graph.  Could be
       anything like Vertex, Boxed-Vertex or Filled-Vertex or
       Boxed-Filled-Vertex (default = Vertex).  If this argument is a function
       then it is called with the node as its argument.  This function
       should return the name of the flavor to instantiate for that graph
       node.
  Edge-Flavor - the flavor of edges to create in the graph.  If this argument
       is a function then it is called with the edge pair as its arguments.
       This function should return the name of the flavor to instantiate for
       that edge.
  Item-Type-Alist - The item type alist to use for the mouse-sensitive items
       in the grapher.  This is a list of the form:
        ((<type> <mouse-l-function>
                 \"Mouse doc string\"
                 (\"Menu 4item* 1\" :value menu-function-1 :documentation
                  \"Menu mouse doc 1\"
                 )
                 ... other menu items
                 (\"Menu 4item* n\" :value menu-function-n :documentation
                  \"Menu mouse doc n\"
                 )
        )
        ... other entries
       )
      where <type> is :vertex or :edge.  <Mouse-l-function> must conform to the
      contract specified in (:method 2Stand-Alone-Grapher* :typeout-execute)
      as must menu-function-1.
Orientation - The orientation of the graph.  This can be either :horizontal
      or :vertical.  (default = the way it was or :horizontal).
Label - The label to use for the graph (default = the way it was).
Tree-p - Controls whether the grapher will draw the structure as a graph or
      a tree.  If you pick Nil for this then you'll get graphs like the
      following:
            a ----> b ----> c
              \          /
               \        /
                \      /
                 \    /
                  > d
      whereas if you pick T for this argument the above structure would
      be printed as follows:
            a ----> b ----> c
              \
               \
                \
                 \
                  > d ----> c
      In the former case there are fewer nodes on the graph but more crossing
      arcs.  In the latter there are more nodes on the graph, but fewer crossing
      arcs.  (default = nil).
Resource - the resource from which to get the grapher panes to use if the :On
      argument is defaulted.
Auto-Scale-P - causes the grapher pane to resize itself so as to be the size of
      the graph, where possible.  It can have three values; nil = no resizing,
      a two-list, e.g. (200 300), in which case these are taken to be the
      maximum values for the width and height, or some other value, in which
      case it will end up being either the size of the graph or of the
      superior, which ever is the smaller.
      (default = 2*Auto-Scale-Graphers-By-Default**).
Background-Mouse-Blip-Functions - an AList for the behaviour of mouse clicks on
      the background of the window (i.e. not on a mouse-sensitive item).  Each
      entry has the form:
         (#\mouse-l-2 \"Does something\" process-l-2 . other-args)
      where you provide the mouse char for the blip (like #\mouse-l-2 above)
      a who-line doc string fragment for this operation and a function name
      (in this case process-l-2).  If the doc-string fragment is not stringp
      then it is called as a function with the window as its argument.  It
      must return a doc string for this key.  The function is called with the
      following args: (window x y &rest other-args), in which Window is the
      window that was blipped on, x and y are the mouse coords and other-args
      are any extra arguments provided in the arlist entry.  In the example above
      the argument Other-Arg would be the last argument to the call to 
      process-l-2.  (default = no background blip processors)
Home-To-Root-Node-P - when true the grapher will scroll the window so that
      the root node or the expanded node is in the window and will flash it
      if it can so that the user can see where it is (default = t).  If this
      argument is :root-node, then the grapher will home to the top of the
      grapher, even if Node is a Vertex and the graph is extending itself.
Force-Exposure - when true this forces the graph window to be exposed after
      a call to Plot-A-Graph.  It is useful to set this to nil if you have
      a graph window that is keeping track of something that you're doing,
      but you don't want to have the grapher exposed unless you tell it to
      be (default = *force-exposure*).
Dont-Graph-If-Already-Graphing-This-Node - when true this inhibits regraphing
      if you call plot-a-graph on something that is already the root node of
      the window on which it's to be plotted.
Vertex-Initargs - An initplist to give to the vertex when it is initialised.
      If this is a function then the function is called with the node value
      as its arg to deliver the initargs.
Edge-Initargs - An initplist to give to each edge when it is initialised.
      If this is a function then the function is called with the edge pair
      as its args to deliver the initargs.
Vertex-Comparator - When plotting in graph mode the grapher has a cache that it
      uses to uniquify the nodes.  Most of the time it is correct to check that
      these nodes are identically equal (EQ) so the vertex-comparator function
      default of EQ is proper.  However, if you choose to use child functions
      that return values that you intend to match values for other vertices,
      but which are freshly consed by the child function then you should use a
      different vertex-comparator function, e.g. EQUAL.
Parent-Function - Just like the child-function only delivers parents,
      not children.
Top-Node-Visible-P - When nil this makes the top node of the tree and the edges
      that descend from it invisible.  This allows you to have the effect of
      plotting multiple trees on the one window.

The grapher windows (when selected) will respond to all of the normal keyboard
cursor movement commands, e.g. c-f, m-v, and also such commands as ” (bury)
and c-s and c-r (I-Search, just like in Zmacs/the Inspector).

Note: The functions that the user supplies as arguments may be called in a
 number of contexts.  The arguments that are passed to them may or may not
 be the actual objects that you thought you were plotting.  To ensure that
 you're looking at the object that you want to plot you should always call
 the function Coerce-To-Node on it just in case.  For instance in the worked
 example below the print function used is:
    #'(lambda (x) (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))

Note: If Plot-a-Graph is called with a Vertex instance as the value for the
 Node argument then a new graph will not be plotted.  Instead the existing graph
 will be recomputed to extend the graph below the vertex denoted by Node.
 You can find a vertex for a particular graph node by calling the function
 (tv:find-vertex-for <value> <in-window>).

Note: The window on which your graphs are plotted always cache the arguments you
 supplied to Plot-A-Graph.  This means that you can always send the window
 a :calling-args message so as to plot a similar graph, e.g.
   (setq *window* (plot-a-graph thing :child-function #'things-children))
   (apply #'plot-a-graph another-thing (send *window* :calling-args))

Worked example:
===============

;;; Let's plot a graph for class inheritance.
  (setq *window* (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
                    :child-function #'ticlos:class-precedence-list))

;;; Oops, this seemed to plot rather a lot.  Let's try a smaller depth
;;; and see what's going on.

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-precedence-list
    :on *window*
    :depth 1)

;;; Ah ha, class-precedence-list was the wrong function to call.  This gives all
;;; children, grandchildren... we need to get just the local children.
;;; class-direct-superclasses should get this.

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-direct-superclasses
    :on *window*
    :depth 3)

;;; That's much better, but it still looks a bit ugly.  Let's try a better print
;;; function.

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-direct-superclasses
    :on *window*
    :depth 3
    :print-function
      #'(lambda (x) (format nil \"~A\" (ticlos:class-name (coerce-to-node x)))))

;;; Excellent.  Now let's try it the other way around.

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-direct-superclasses
    :on *window*
    :depth 3
    :print-function
      #'(lambda (x) (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))
    :orientation :vertical)

;;; That doesn't seem any better.  Maybe it'd look nicer with highlit nodes,
;;; and let's have it as a tree, not as a graph.

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-direct-superclasses
    :on *window*
    :depth 3
    :print-function
      #'(lambda (x) (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))
    :tree-p t
    :vertex-flavor 'filled-vertex)

;;; We could use a label here and it would be nice if the graph was the right
;;; size:

  (tv:plot-a-graph (ticlos:find-class 'tv:lisp-listener)
    :child-function #'ticlos:class-direct-superclasses
    :on *window*
    :depth 3
    :print-function
      #'(lambda (x) (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))
    :vertex-flavor 'filled-vertex)
    :label (format nil \"~A's superclasses\" 'tv:lisp-listener)
    :auto-scale-p t)

;;; Now it would be nice if we had a few menus of useful operations.
;;; We'll make the left button graph the node clicked on and the right
;;; button menu have an Edit and Inspect option.

  (defun inspect-a-class (thing)
    (inspect (coerce-to-node thing)))

  (defun edit-a-class (thing)
    (try-and-edit (coerce-to-node thing)))

  (1def*parameter *my-item-type-alist*
    '((3:Vertex* graph-a-class
       \"L: Graph this Class; M: Drag object; Sh-M/M2: Overview; R: Menu of operations\"
       (\"Inspect\" 3:Value* inspect-a-class 3:Documentation*
	\"Inspect this class.\"
       )
       (\"Edit\" 3:Value* 2Edit-A-Class* 3:Documentation* \"Edit this class.\"))))

;;; We should functionize the thing we're doing:

  (defun graph-a-class (class &optional (on-window *window*) &rest ignore)
    (let ((class (if (symbolp class) (ticlos:find-class class) class)))
         (tv:plot-a-graph class
           :child-function #'ticlos:class-direct-superclasses
           :on on-window
           :depth 3
           :print-function
             #'(lambda (x)
                 (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))
           :vertex-flavor 'filled-vertex
           :label (format nil \"~A's superclasses\" (ticlos:class-name class))
           :auto-scale-p t
           :item-type-alist *my-item-type-alist*)))

  (graph-a-class 'tv:lisp-listener)

;;; Now, maybe it would be nice if we were to put a right button menu on the
;;; background that would refresh the graph.  We could put a menu here if
;;; we had things to do for the window as a whole.

  (defun replot-my-graph-window (window x y)
    (ignore x y)
    (apply #'plot-a-graph (coerce-to-node (send window :root-node))
           (send window :calling-args)))

  (defun graph-a-class (class &optional (on-window *window*) &rest ignore)
    (let ((class (if (symbolp class) (ticlos:find-class class) class)))
         (tv:plot-a-graph class
           :child-function #'ticlos:class-direct-superclasses
           :on on-window
           :depth 3
           :print-function
             #'(lambda (x)
                 (format nil \"~A\" (ticlos:class-name (coerce-to-node x))))
           :vertex-flavor 'filled-vertex
           :label (format nil \"~A's superclasses\" (ticlos:class-name class))
           :auto-scale-p t
           :item-type-alist *my-item-type-alist*
           :background-mouse-blip-functions
              '((#\mouse-r \"RePlot\" replot-my-graph-window)))))

  (graph-a-class 'tv:lisp-listener)

;;; That'll do.
"
  (1declare* (optimize (safety 0) (1speed* 3)))
  (1declare* (1values* window-on-which-the-graph-was-plotted))
  (1if* (1not* child-function) (1ferror* nil "No child-function supplied."))
  (let ((*graph-window*
	  (1if* (1equal* 3:From-Resource* on) (1allocate-resource* resource) on)
	)
       )
       (1declare* (1special* *graph-window*))
       (1let* ((shouldnt-graph
	       (1and* dont-graph-if-already-graphing-this-node
		    (1send* 4*graph-window** 3:Item-List*)
		    (1equal* (2Coerce-To-Node* node)
			    (2Coerce-To-Node*
			      (1send* 4*graph-window** 3:Root-Node*)
			    )
		    )
		    (1not* (1send* *graph-window* 3:Graph-Behaviour-Changed*))
	       )
	    )
	    (node-on-graph (1if* 1(vertexp node)*
			       nil
			       (2Find-Vertex-For* node 4*graph-window**)
			   )
	    )
	    (vertex-flavor (1if* top-node-visible-p
			       vertex-flavor
			       #'(lambda (for)
				   (1if* (1eq* (2Coerce-To-Node* for) node)
				       '4invisible-vertex*
				       (1if* (1functionp* vertex-flavor)
					   (1funcall* vertex-flavor for)
					   vertex-flavor
				       )
				   )
				 )
			   )
	    )
	    (edge-flavor (1if* top-node-visible-p
			     edge-flavor
			     #'(lambda (from to)
				 (1if* (1or* (1eq* (2Coerce-To-Node* from) node)
					 (1eq* (2Coerce-To-Node* to) node)
				     )
				     '4invisible-edge*
				     (1if* (1functionp* edge-flavor)
					 (1funcall* edge-flavor from to)
					 edge-flavor
				     )
				 )
			       )
			 )
	    )
	   )
	   (2Set-Up-Graph-Window*
	     4*graph-window** node item-type-alist orientation label
	     auto-scale-p background-mouse-blip-functions node-on-graph
	     shouldnt-graph
	   )
	   (1let* ((old-items (1if* (1send* *graph-window* 3:Graph-Behaviour-Changed*)
			       nil
			       (1send* 4*graph-window** 3:Item-List*)
			   )
		 )
		 (real-node (1if* (1send* *graph-window* 3:Graph-Behaviour-Changed*)
			        node
				(1or* node-on-graph node)
			    )
		 )
	       )
	       (1if* shouldnt-graph
		   nil
		   (1progn* (1if* (1or* (1not* (4vertexp* real-node))
				  (1send* *graph-window*
					3:Graph-Behaviour-Changed*
				  )
				  t ;;; {!!!!}
			      )
			      (1send* 4*graph-window** 3:Clear-Window*)
			      nil
			   )
			   (if tree-p
			       (2Plot-A-Graph-Tree* real-node old-items
				 4*graph-window**
				 child-function depth dash-function
				 label-function directedness-function
				 mouse-sensitive-type-function print-function
				 font-function vertex-flavor Vertex-Initargs
				 Edge-flavor Edge-Initargs parent-function
			       )
			       (2Plot-A-Graph-Graph*
				 real-node 4*graph-window** old-items
				 child-function depth dash-function
				 label-function directedness-function
				 mouse-sensitive-type-function print-function
				 font-function vertex-flavor Vertex-Initargs
				 Edge-flavor Edge-Initargs vertex-comparator
				 parent-function
			       )
			   )
		    )
	       )
	   )
	   (1let* ((calling-args
		 `(3:Child-Function* ,child-function
		   3:On* ,*graph-window*
		   3:Depth* ,depth
		   3:Dash-Function* ,dash-function
		   3:Label-Function* ,label-function
		   3:Directedness-Function* ,directedness-function
		   3:Mouse-Sensitive-Type-Function*
		     ,mouse-sensitive-type-function
		   3:Print-Function* ,print-function
		   3:Font-Function* ,font-function
		   3:Vertex-Flavor* ,vertex-flavor
		   3:Edge-Flavor* ,edge-flavor
		   3:Item-Type-Alist* ,item-type-alist
		   3:Orientation* ,orientation
		   3:Label* ,label
		   3:Tree-P* ,tree-p
		   3:Resource* ,resource
		   3:Auto-Scale-P* ,auto-scale-p
		   3:Background-Mouse-Blip-Functions*
		     ,background-mouse-blip-functions
		   3:Home-To-Root-Node-P* ,home-to-root-node-p
		   3:Force-Exposure* ,force-exposure
		   3:Dont-Graph-If-Already-Graphing-This-Node*
		     ,dont-graph-if-already-graphing-this-node
		   3:Vertex-Initargs* ,Vertex-Initargs
		   3:Edge-Initargs* ,Edge-Initargs
		   3:Vertex-Comparator* ,vertex-comparator
		   3:Parent-Function* ,parent-function
		   3:Top-Node-Visible-P* ,top-node-visible-p
		  )
		)
	       )
	       (2Finalise-Graph-Window* node 4*graph-window** auto-scale-p
					home-to-root-node-p calling-args
					force-exposure
	       )
	   )
       )
       *graph-window*
  )
)

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

;;; A resource for stand-alone grapher panes.
(1defwindow-resource* 2Stand-Alone-Graphers* ()
  3:Initial-Copies* 0
  3:Constructor* (2Make-Grapher-Window*)
)

;;; How to clear the resource.
;(clear-resource 'stand-alone-graphers)