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

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



;Ï1;; A vertex node.  This represents a vertex in the graph and has encoded in itÏ*
;Ï1;; both the thing that the user actually wants to graph itself and theÏ*
;Ï1;; child-function for the graph, the desired depth for the graph and sundryÏ*
;Ï1;; other interesting things like the print function.Ï*
(defstruct Ï4(vertex-nodeÏ* :named)
  node child-function depth dash-function
  label-function directedness-function
  mouse-sensitive-type-function print-function
  font-function vertex)

(PUTPROP 'vertex-node 'general-structure-message-handler
	 'NAMED-STRUCTURE-INVOKE)

(DEFVAR Ï4*type-to-node-coercions*Ï*
	      '((vertex-node vertex-node-node)
		(local-kids-spec-node local-kids-spec-node-node))
"Ï2An AList of the mappings between graph node types and the functions,
 which can extract the actual nodes from them.Ï*")

(DEFUN Ï4try-to-match-typeÏ* (of in)
"Ï2Tries 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.Ï*"
  (DECLARE (optimize (safety 0)))
  (IF in
      (IF (TYPEP of (FIRST (FIRST in)))
	  (VALUES (FUNCALL (SECOND (FIRST in)) of) t)
	  (try-to-match-type of (REST in)))
      (VALUES of nil)))

(DEFUN Ï4coerce-to-nodeÏ* (x)
"Ï2Given something, coerces it into a thing that's a graph node..  Uses the
 AList *type-to-node-coercions* to help in this.Ï*"
  (MULTIPLE-VALUE-BIND (thing coerced-p)
      (try-to-match-type x *type-to-node-coercions*)
    (IF (AND coerced-p (NOT (EQUAL x thing)))
	(coerce-to-node thing)
	thing)))

(DEFUN Ï4grapher-inspectÏ* (window something)
"Ï2Inspects something.  Window is the window that called this function and is
 ignored.Ï*"
  (IGNORE window)
  (INSPECT (coerce-to-node something)))

(DEFVAR Ï4*stand-alone-grapher-default-edges*Ï* '(0 0 400 400)
"Ï2The default edges for stand-alone grapher panes.Ï*")

(DEFVAR Ï4*grapher-font-map*Ï* '(fonts:tvfont)
"Ï2The default font-map for grapher panes.Ï*")

(DEFUN Ï4default-stand-alone-grapher-edgesÏ* ()
"Ï2Returns 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 *Stand-Alone-Grapher-Default-Edges*.Ï*"
  (DESTRUCTURING-BIND (left top right bottom)
		      *stand-alone-grapher-default-edges*
    (LIST (MIN left   (SEND default-screen :inside-width))
	 (MIN top    (SEND default-screen :inside-height))
	 (MIN right  (SEND default-screen :inside-width))
	 (MIN bottom (SEND default-screen :inside-height)))))

(DEFUN Ï4map-resource-returnÏ* (FUNCTION resource)
"Ï2Maps 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.Ï*"
  (LET ((results nil))
      (MAP-RESOURCE #'(lambda (thing used-p name)
			 (MULTIPLE-VALUE-BIND (result dont-use-p)
			     (FUNCALL function thing used-p name)
			   (IF dont-use-p
			      nil
			      (PUSH result results))))
		       resource)
      results))

(DEFVAR Ï4*stand-alone-grapher-new-pane-offset*Ï* 30
"Ï2The 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.Ï*")

(DEFUN Ï4occurencesÏ* (of in)
"Ï2Returns a count of the number of occurences of Of in the list In.Ï*"
  (IF in
      (IF (EQUAL of (FIRST in))
	  (+ 1 (occurences of (REST in)))
	  (occurences of (REST in)))
      0))

(DEFUN Ï4frequenciesÏ* (LIST so-far)
"Ï2Returns 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.Ï*"
  (IF list
     (frequencies (REMOVE (FIRST list) list)
		  (CONS (LIST (FIRST list) (occurences (FIRST list) (REST list)))
			so-far))
     so-far))

(DEFUN Ï4get-leastÏ* (of &optional (so-far '(1000000 1000000)))
"Ï2Given 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.Ï*"
  (IF of
     (IF (< (SECOND (FIRST of)) (SECOND so-far))
	 (get-least (REST of) (FIRST of))
	 (get-least (REST of) so-far))
     so-far))

(DEFUN Ï4max-offsetÏ* ()
"Ï2Returns the maximum offset that can be used in creating a new grapher pane.
 This is the number of times that *Stand-Alone-Grapher-New-Pane-Offset*
 can be fitted into the screen's smallest dimension for the default size of
 the graphers computed by Default-Stand-Alone-Grapher-Edges.Ï*"
  (DESTRUCTURING-BIND (left top right bottom)
		      (default-stand-alone-grapher-edges)
    (MIN (TRUNCATE (/ (- (SEND default-screen :inside-width) (- right left))
		       *stand-alone-grapher-new-pane-offset*))
	  (TRUNCATE (/ (- (SEND default-screen :inside-height) (- bottom top))
		       *stand-alone-grapher-new-pane-offset*)))))

(DEFUN Ï4offsetting-stand-alone-grapher-edgesÏ*
        (&optional (resource 'stand-alone-graphers))
"Ï2Returns 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.Ï*"
  (LET ((existing (map-resource-return
		    #'(lambda (win &rest ignore)
			(VALUES (SEND win :position) nil))
		    resource)))
      (LET ((modded (MAPCAR
		      #'(lambda (x)
			  (ROUND
			    (/ x *stand-alone-grapher-new-pane-offset*)))
			existing))
	   (MAX (max-offset)))
	  (LET ((least (get-least (frequencies modded nil))))
	      (IF (< (FIRST least) (- max 1))
		 (MAPCAR
		   #'(lambda (x)
		       (+ (* (+ 1 (FIRST least))
			      *stand-alone-grapher-new-pane-offset*)
			  x))
		      (default-stand-alone-grapher-edges))
		 (default-stand-alone-grapher-edges))))))

(DEFFLAVOR Ï4key-command-mixinÏ*
	   ((root-node nil)
	    (saved-marks nil)
	    (current-node nil)
	    (numeric-arg-p nil)
	    (numeric-arg 0)
	    (universal-arg 0))
	   (graph-window)
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

(DEFFLAVOR Ï4stand-alone-grapherÏ*
	   ((background-mouse-blip-functions nil)
	    (calling-args nil)
	    (graph-behaviour-changed nil))
	   (key-command-mixin
	    select-mixin
	    graph-window
	    process-mixin)
  (:default-init-plist
    :process '(stand-alone-graph-window-initial-function
		 :regular-pdl-size 16000.
		 :special-pdl-size 2000.
		 :name "Ï3Stand-Alone GrapherÏ*")
    :edges *stand-alone-grapher-default-edges*
    :font-map *grapher-font-map*
    :char-aluf alu-seta
    :activate-p t)
  (:documentation
"Ï3The 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.Ï*")
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

(DEFMETHOD Ï4(stand-alone-grapher :name-for-selectionÏ*) ()
"Ï2This is defined so that <System> ... will work.  Find-window-of-flavor
 requires that the window have a name for selection.Ï*"
  name)

(DEFVAR Ï4*char-to-method-mappings*Ï*
        '((#\M-v :page-up)
	  (#\c-v :page-down)
	  (#\m-f :page-right)
	  (#\m-b :page-left)

	  (#\c-þ :page-down)
	  (#\c-  :page-up)
	  (#\c-Ý :page-right)
	  (#\c-Ü :page-left)

	  (#\c-n :line-down)
	  (#\c-p :line-up)
	  (#\c-f :line-right)
	  (#\c-b :line-left)

	  (#\þ   :line-down)
	  (#\    :line-up)
	  (#\Ý   :line-right)
	  (#\Ü   :line-left)

	  (#\m-< :top-of-window)
	  (#\m-> :bottom-of-window)
	  (#\c-a :beginning-of-line)
	  (#\c-e :end-of-line)

	  (#\c-l :Refresh-Self)
	  (#\ :Refresh-Self) ;;; This is the clear screen character !!!

	  (#\c-s :i-search)
	  (#\c-r :reverse-i-search)

	  (#\c-u :Universal-Argument)
	  (#\c-space :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)

	  (#\ :quit)
	  (#\ :quit)
	  (#\ÏÏ :Help)
	 )
"Ï2An AList that maps chars into methods to execute when the chars are read by
 a grapher window.Ï*")

(DEFVAR Ï4*numeric-arg-methods*Ï*
  '(:universal-argument
    :control--
    :control-1
    :control-2
    :control-3
    :control-4
    :control-5
    :control-6
    :control-7
    :control-8
    :control-9
    :control-0))

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

(PUTPROP 'saved-graph-pos 'general-structure-message-handler
	 'NAMED-STRUCTURE-INVOKE)

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

(PUTPROP 'link 'general-structure-message-handler 'NAMED-STRUCTURE-INVOKE)

(DEFMETHOD Ï4(key-command-mixin :quitÏ*) ()
"Ï2Just buries the grapher.Ï*"
  (SEND self :bury))

(DEFMETHOD Ï4(key-command-mixin :find-verticesÏ*) (&optional (in nil))
"Ï2Finds 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.Ï*"
  (LET ((FIRST nil)
        (LAST nil)
      )
      (LOOP for x in (OR in item-list)
	    when (TYPEP x 'vertex)
	    do (IF last
		  (LET ((new (make-link :from last :vertex x)))
		      (SETF (link-to last) new)
		      (SETQ last new))
		  (PROGN (SETQ first (make-link :from nil :vertex x))
			 (SETQ last first))))
      first))

(DEFMETHOD Ï4(key-command-mixin :search-matchesÏ*) (STRING link)
"Ï2Is true if a search string String matches the printed representation of the
 item pointed to by Link.  This is not case-sensitive.Ï*"
  (LET ((vertex-string
	  (IF (link-cache link)
	      (link-cache link)
	      (PROGN (SETF (link-cache link)
			   (FUNCALL
			     (SEND (link-vertex link)
				    :pre-print-item-modify-function)
			     (SEND (link-vertex link) :item)))
		     (link-cache link)))))
       (SEARCH string vertex-string :test #'STRING-EQUAL)))

(DEFVAR Ï4*saved-positions*Ï* :unbound
"Ï2A dynamically held list of the saved positions saved during I-SearchÏ*")

(DEFVAR Ï4*reverse-p*Ï* :unbound
"Ï2Is true if the I-Search is going backwards.Ï*")

(DEFUN Ï4make-failed-posÏ* (STRING &optional (beep-p nil) (item-list nil))
"Ï2Makes 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.Ï*"
  (PUSH (make-saved-graph-pos
	   :string string
	   :item-list (OR item-list
			  (saved-graph-pos-item-list
			    (FIRST *saved-positions*)))
	   :failed-p t)
	 *saved-positions*)
  (IF beep-p (BEEP))
  nil)

(DEFMETHOD Ï4(key-command-mixin :scroll-to-and-flash-vertexÏ*)
   (vertex &optional (unconditionally-p nil))
"Ï2Given a Vertex it scrolls the window to look at is and then flashes the
 vertex to tell the user where it is.Ï*"
  (SETQ current-node vertex)
  (SEND self :scroll-to
	(SEND vertex :logical-x)
	(SEND vertex :logical-y))
  (IF unconditionally-p
     (SEND vertex :send-if-handles :flash)
     (LET ((CHAR (SEND *query-io* :any-tyi-no-hang)))
	 (IF char
	     (SEND *query-io* :untyi char)
	     (SEND vertex :send-if-handles :flash))
	 nil)))

(DEFMETHOD Ï4(key-command-mixin :process-next-searchÏ*)
    (&optional
     (STRING (saved-graph-pos-string (FIRST *saved-positions*)))
     (start (saved-graph-pos-item-list (FIRST *saved-positions*))))
"Ï2This 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.Ï*"
  (IF (NOT start)
      (make-failed-pos string t)
      (IF (AND *saved-positions*
		(saved-graph-pos-failed-p (FIRST *saved-positions*)))
	 nil
	 (LOOP for next = start
	       do (SETQ start
		        (IF start
			    (IF *reverse-p* (link-from start) (link-to start))
			    nil))
	       when (NOT next)
	       do (RETURN (make-failed-pos string t next))
	       when (SEND self :search-matches string next)
	       do (PUSH (make-saved-graph-pos
			   :string string :item-list next)
			 *saved-positions*)
		  (SEND self :scroll-to-and-flash-vertex (link-vertex next))
		  (RETURN t)))))

(DEFMETHOD Ï4(key-command-mixin :process-other-charÏ*) (CHAR)
"Ï2Given 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.Ï*"
  (LET ((STRING (STRING-APPEND
		 (saved-graph-pos-string (FIRST *saved-positions*))
		 (STRING char))))
       (IF (AND *saved-positions*
		 (saved-graph-pos-failed-p (FIRST *saved-positions*)))
	  (make-failed-pos string)
	  (SEND self :process-next-search string))))

(DEFMETHOD Ï4(key-command-mixin :get-a-charÏ*) ()
"Ï2Reads a char from the window.  It returns either a list for a mouse blip or a
 character object for the char read in.Ï*"
  (SEND *query-io* :mouse-select)
  (LET ((CHAR (SEND *query-io* :any-tyi)))
       (TYPECASE char
	 (CONS char)
	 (integer (INT-CHAR char))
	 (CHARACTER char)
	 (otherwise (BEEP)))))

(DEFMETHOD Ï4(key-command-mixin :i-search-1Ï*) ()
"Ï2Does 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.Ï*"
  (LOOP for char = (SEND self :get-a-char) do 
    (CASE char
      (#\× (FORMAT *query-io* "Ï3×~&Ï*") (SEND self :set-pop-mark) (RETURN nil))
      (#\c-s
       (SETQ *reverse-p* nil)
       (SEND self :process-next-search))
      (#\c-r
       (SETQ *reverse-p* :backwards)
       (SEND self :process-next-search))
      (#\rubout
       (IF (REST *saved-positions*)
	   (PROGN (POP *saved-positions*)
		  (SEND self :scroll-to-and-flash-vertex
			 (link-vertex (saved-graph-pos-item-list
					 (FIRST *saved-positions*)))))
	   (BEEP)))
      (otherwise
       (IF (CONSP char)
	   (PROGN (FORMAT *query-io* "Ï3×~&Ï*") (RETURN nil))
	   (SEND self :process-other-char char))))
    (SEND self :expose)
    (SEND *query-io* :expose)
    (SEND self :show-search-string *reverse-p*)))

(DEFMETHOD Ï4(key-command-mixin :show-search-stringÏ*) (reverse-p)
"Ï2Displays 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 (saved-graph-pos-failed-p (FIRST *saved-positions*))
      (FORMAT *query-io* "Ï3Failing Ï*")
      nil)
  (IF reverse-p (FORMAT *query-io* "Ï3Reverse Ï*") nil)
  (FORMAT *query-io* "Ï3I-Search: ~AÏ*"
	  (saved-graph-pos-string (FIRST *saved-positions*))))

(DEFFLAVOR Ï4i-search-prompt-windowÏ*
	   ()
	   (window stream-mixin)
  (:default-init-plist
    :expose-p nil :activate-p t :label "Ï3SearchÏ*" :more-p nil
    :deexposed-typeout-action :expose)
  (:documentation
    "Ï3A simple little window that gets popped up to process isearches.Ï*"))

(DEFMETHOD Ï4(i-search-prompt-window :before :deexposeÏ*) (&rest ignore)
"Ï2Make sure that we abort search if we get deexposed.Ï*"
  (SEND self :force-kbd-input #\×))

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

(DEFMETHOD Ï4(key-command-mixin :i-searchÏ*)
	    (&optional (reverse-p nil) (make-prompt-window-p t))
"Ï2Does 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.Ï*"
;Ï1  If reverse-p is true then the searching happens backwards a laÏ*
;Ï1 c-r.  If make-prompt-window-p is true then it makes a little prompt window toÏ*
;Ï1 do the isearching in, otherwise it uses *query-io*.Ï*
  (LET ((vertices (SEND self :find-vertices)))
      (LET ((*saved-positions*
	      (LIST (make-saved-graph-pos :item-list vertices :string "")))
	   (*reverse-p* reverse-p)
	   (old-selected selected-window))
	  (IF make-prompt-window-p
	     (LET ((*query-io*
		    (MAKE-INSTANCE
		      'i-search-prompt-window
		      :width  (MIN 300 (SEND default-screen :inside-width))
		      :height (MIN 30 (SEND default-screen :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 :below :left :right)
			     left top right bottom)))
		        (IF (NOT inside-superior-p)
			    ;Ï1; w:position-window-next-to-rectangle failedÏ*
			    ;Ï1; to put it beside the window, so we'll put itÏ*
			    ;Ï1; on top, but home to the top of the window.Ï*
			    ;Ï1; this corner of the grapher will hopefully beÏ*
			    ;Ï1; pretty sparse anyway.Ï*
			    (SEND *query-io* :set-position 0 0)
			    nil)))
		 (SEND *query-io* :expose)
		 (FORMAT *query-io*
			 (IF reverse-p "Ï3~&Reverse I-Search: Ï*" "Ï3~&I-Search: Ï*"))
		 (SEND self :top-of-window)
		 (UNWIND-PROTECT (SEND self :i-search-1)
		   (SEND *query-io* :bury)
		   (SEND *query-io* :kill)
		   (IF (TYPEP old-selected 'sheet)
		       (SEND old-selected :mouse-select)
		       nil)))
	    (SEND self :i-search-1)))))

(DEFMETHOD Ï4(key-command-mixin :universal-argumentÏ*) ()
  "Ï2Sets the universal argument for the grapher.Ï*"
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg 1)
  (SETQ universal-arg (+ 1 universal-arg)))

(DEFMETHOD Ï4(key-command-mixin :control--Ï*) ()
 "Ï2Specify a negative numeric.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (* numeric-arg -1)))

(DEFMETHOD Ï4(key-command-mixin :control-1Ï*) ()
  "Ï2Specify a numeric arg of 1.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 1)))

(DEFMETHOD Ï4(key-command-mixin :control-2Ï*) ()
  "Ï2Specify a numeric arg of 2.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 2)))

(DEFMETHOD Ï4(key-command-mixin :control-3Ï*) ()
  "Ï2Specify a numeric arg of 3.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 3)))

(DEFMETHOD Ï4(key-command-mixin :control-4Ï*) ()
  "Ï2Specify a numeric arg of 4.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 4)))

(DEFMETHOD Ï4(key-command-mixin :control-5Ï*) ()
  "Ï2Specify a numeric arg of 5.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 5)))

(DEFMETHOD Ï4(key-command-mixin :control-6Ï*) ()
  "Ï2Specify a numeric arg of 6.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 6)))

(DEFMETHOD Ï4(key-command-mixin :control-7Ï*) ()
  "Ï2Specify a numeric arg of 7.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 7)))

(DEFMETHOD Ï4(key-command-mixin :control-8Ï*) ()
  "Ï2Specify a numeric arg of 8.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 8)))

(DEFMETHOD Ï4(key-command-mixin :control-9Ï*) ()
  "Ï2Specify a numeric arg of 9.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 9)))

(DEFMETHOD Ï4(key-command-mixin :control-0Ï*) ()
  "Ï2Specify a numeric arg of 10.Ï*"
  (IF (NOT numeric-arg-p) (SETQ numeric-arg 0) nil)
  (SETQ numeric-arg-p t)
  (SETQ numeric-arg (+ (* numeric-arg 10) 0)))

(DEFMETHOD Ï4(Key-Command-Mixin :Basic-Help-TextÏ*) ()
  "Ï2~%The keystroke commands available in the grapher are:~%Ï*"
  )

(DEFMETHOD Ï4(Key-Command-Mixin :Refresh-SelfÏ*) ()
  "Ï2Redraws the graph.Ï*"
  (send self :Refresh))

(DEFMETHOD Ï4(Key-Command-Mixin :HelpÏ*) ()
  "Ï2Shows the meaning of the key commands for the grapher.Ï*"
  (with-help-stream (*standard-output* :Superior (send self :Superior))
    (format t (send self :Basic-Help-Text))
    (loop for (key method) in *Char-To-Method-Mappings* do
	 (let ((docs (documentation `(:Method Key-Command-Mixin ,method))))
	     (if docs
		 (format t "Ï3~&\"~C\"~20T~AÏ*" key docs)
		 (format t "Ï3~&\"~C\"~20TUndocumentedÏ*" key))))))

(DEFMETHOD Ï4(key-command-mixin :go-to-nodeÏ*) (node)
  (SEND self :scroll-to-and-flash-vertex
	 (find-vertex-for (IF (TYPEP node 'vertex)
			       (SEND node :item)
			       node)
			    self)
	 t))

(DEFMETHOD Ï4(key-command-mixin :set-pop-markÏ*) ()
  "Ï2Sets the pop mark to be the current node on the graph.Ï*"
  (IF (NOT  (EQUAL 0 universal-arg))
     (IF (> universal-arg 1)
	 (POP saved-marks)
	 (LET ((node (POP saved-marks)))
	     (IF node (SEND self :go-to-node node) nil)))
     (PROGN (IF (NOT current-node) (SETQ current-node root-node) nil)
	    (PUSH current-node saved-marks))))

(DEFMETHOD Ï4(key-command-mixin :page-upÏ*) ()
"Ï2Scrolls self back up one page.Ï*"
  (SEND self :scroll-relative 0 (* numeric-arg (- (SEND self :inside-height)))))

(DEFMETHOD Ï4(key-command-mixin :page-downÏ*) ()
"Ï2Scrolls self down one page.Ï*"
  (SEND self :scroll-relative 0 (* numeric-arg (SEND self :inside-height))))

(DEFMETHOD Ï4(key-command-mixin :page-leftÏ*) ()
"Ï2Scrolls self left by one page.Ï*"
  (SEND self :scroll-relative (* numeric-arg (- (SEND self :inside-width))) 0))

(DEFMETHOD Ï4(key-command-mixin :page-rightÏ*) ()
"Ï2Scrolls self right by one page.Ï*"
  (SEND self :scroll-relative (* numeric-arg (SEND self :inside-width)) 0))

(DEFMETHOD Ï4(key-command-mixin :line-upÏ*) ()
"Ï2Scrolls self back up one line.Ï*"
  (SEND self :scroll-relative 0
	 (- (* 2 numeric-arg (SEND self :sibling-spacing)))))

(DEFMETHOD Ï4(key-command-mixin :line-downÏ*) ()
"Ï2Scrolls self down one line.Ï*"
  (SEND self :scroll-relative 0 (* 2 numeric-arg (SEND self :sibling-spacing))))

(DEFMETHOD Ï4(key-command-mixin :line-leftÏ*) ()
"Ï2Scrolls self left by one line.Ï*"
  (SEND self :scroll-relative
	 (- (* numeric-arg (SEND self :generation-spacing))) 0))

(DEFMETHOD Ï4(key-command-mixin :line-rightÏ*) ()
"Ï2Scrolls self right by one line.Ï*"
  (SEND self :scroll-relative (* numeric-arg (SEND self :generation-spacing)) 0))

(DEFMETHOD Ï4(key-command-mixin :end-of-lineÏ*) ()
"Ï2Scrolls self right to the end of the line, i.e. until the rightmost node is
 against the right margin.Ï*"
  (SEND self :scroll-to
	(- (SEND self :logical-right-edge) (SEND self :inside-width))
	(SEND self :y-pl-offset)))

(DEFMETHOD Ï4(key-command-mixin :beginning-of-lineÏ*) ()
"Ï2Scrolls self left to the beginning of the line, i.e. until the leftmost node is
 against the left margin.Ï*"
  (SEND self :scroll-to
	(SEND self :logical-left-edge)
	(SEND self :y-pl-offset)))

(DEFMETHOD Ï4(key-command-mixin :top-of-windowÏ*) ()
"Ï2Homes the grapher to the top left corner of the graph.Ï*"
  (SEND self :scroll-to
	(SEND self :logical-left-edge)
	(SEND self :logical-top-edge)))

(DEFMETHOD Ï4(key-command-mixin :bottom-of-windowÏ*) ()
"Ï2Scrolls the grapher to the bottom left corner of the graph.Ï*"
  (SEND self :scroll-to
	(- (SEND self :logical-right-edge)  (SEND self :inside-width))
	(- (SEND self :logical-bottom-edge) (SEND self :inside-height))))

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

(DEFUN Ï4stand-alone-graph-window-initial-function-1Ï* (blip window)
"Ï2This 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.Ï*"
  (IF (CONSP blip)
      (IF (AND (KEYWORDP (FIRST blip))
	       (SEND window :operation-handled-p (FIRST blip)))
	  (LEXPR-SEND window blip)
	  (BEEP))
      (IF (OR (INTEGERP blip) (CHARACTERP blip))
	  (LET ((entry
		  (ASSOC blip *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 (((SYMEVAL-IN-INSTANCE window 'scrolling-speed)
			       1000000))
		             (SEND window :send-if-handles (SECOND entry)))
		       (SEND window :send-if-handles (SECOND entry)))
		   (BEEP))
	       (IF (NOT (MEMBER (SECOND entry) *numeric-arg-methods*))
		  (PROGN (SEND window :set-universal-arg 0)
			 (SEND window :set-numeric-arg   1)
			 (SEND window :set-numeric-arg-p nil))
		  nil))
	  nil)))

(DEFUN Ï4separate-with-semicolonsÏ* (strings)
"Ï2Given a list of strings, returns a string which has all of the strings stuck
 together with semicolons in between.Ï*"
 (IF strings
    (STRING-APPEND (FIRST strings) "Ï3; Ï*" (separate-with-semicolons (REST strings)))
    ""))

(DEFCONSTANT Ï4*mouse-key-to-keyword-mappings*Ï*
  '((#\mouse-l   :mouse-l-1)
    (#\mouse-l-2 :mouse-l-2)
    (#\mouse-m   :mouse-m-1)
    (#\mouse-m-2 :mouse-m-2)
    (#\mouse-r   :mouse-r-1)
    (#\mouse-r-2 :mouse-r-2))
"Ï2An alist mapping mouse click characters to who-line doc keywords.Ï*")

(DEFUN Ï4get-doc-stringÏ* (item window)
"Ï2Given a background mouse blip item returns the who-line doc spec for it.Ï*"
  (LIST (SECOND (ASSOC (FIRST item) *mouse-key-to-keyword-mappings*
		      :test #'CHAR-EQUAL))
      (IF (STRINGP (SECOND item))
	  (SECOND item)
	  (FUNCALL (SECOND item) window))))

(DEFMETHOD Ï4(stand-alone-grapher :get-who-line-docÏ*) ()
"Ï2Returns 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 :Mouse-XXX-Who-Line-Doc
 methods for the different mouse clicks.Ï*"
  (DELETE nil
     `(,@(LOOP for item in background-mouse-blip-functions
	       collect (get-doc-string item self)
	 )
       ,(SEND self :send-if-handles :mouse-l-who-line-doc)
       ,(SEND self :send-if-handles :mouse-l2-who-line-doc)
       ,(SEND self :send-if-handles :mouse-m-who-line-doc)
       ,(SEND self :send-if-handles :mouse-m2-who-line-doc)
       ,(SEND self :send-if-handles :mouse-r-who-line-doc)
       (:mouse-m-2 "Ï3OverviewÏ*")
       (:mouse-m-hold "Ï3Drag ScrollingÏ*")
       (:mouse-r-2 "Ï3System Menu.Ï*"))))

;Ï1*************Ï*
;Ï1 TAC 07-27-89 - moved into GENERAL-INSPECTOR where first referenced ---------Ï*
;Ï1(defun doc-size (spec intro-offset length-so-far)Ï*
;Ï1"Returns the x y motion for a mouse doc spec like (:mouse-r-2 \"system menu\")Ï*
;Ï1 in the mouse doc sheet.  Intro-offset is the motion for a string likeÏ*
;Ï1 \"M2: ,\" so that we allow for this.  Length-so-far is the length of theÏ*
;Ï1 current output so that we can compute whether we throw a newline.Ï*
;Ï1"Ï*
;Ï1  (sheet-compute-motionÏ*
;Ï1    who-line-documentation-windowÏ*
;Ï1    (+ intro-offset length-so-far) 0 (second spec) 0 nil nil 0 nil nil nilÏ*
;Ï1    (GET-DEFAULT-FONT who-line-documentation-window)Ï*
;Ï1  )Ï*
;Ï1)Ï*
;Ï1----------------------------------------------------------------------------Ï*

;Ï1(GET-DEFAULT-FONT who-line-documentation-window)Ï*
;Ï1(send *window* :expose)Ï*
;Ï1(send *window* :Who-Line-Documentation-String)Ï*


(DEFMETHOD Ï4(stand-alone-grapher :override :who-line-documentation-stringÏ*) ()
"Ï2A 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.Ï*"
  (UNLESS (SEND self :currently-boxed-item)
   (MULTIPLE-VALUE-BIND (STRING error-p)
	 (CATCH-ERROR
	   (LET ((specs (order-mouse-items (SEND self :get-who-line-doc)))
		(intro-offset (sheet-compute-motion
			       who-line-documentation-window
			       0 0 "Ï3M2: , Ï*" 0 nil nil 0 nil nil nil
			       *mouse-documentation-line-buttons-standard-font*)))
	       (maybe-split-doc-spec specs intro-offset intro-offset))
	   nil)
     (IF error-p
	"Ï3Error getting Who-line documentation.Ï*"
	string))))

(DEFMETHOD Ï4(stand-alone-grapher :mouse-buttonÏ*) (CHAR window x y)
"Ï2This 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)
  (LET ((entry (ASSOC char background-mouse-blip-functions :test #'CHAR-EQUAL)))
      (IF entry
	 (APPLY (SECOND entry) window x y (REST (REST entry)))
	 (LET ((method (SELECTOR char char-equal
			 (#\mouse-l   :mouse-l)
			 (#\mouse-l-2 :mouse-l-2)
			 (#\mouse-m   :mouse-m)
			 (#\mouse-m-2 :mouse-m-2)
			 (#\mouse-r   :mouse-r)
			 (otherwise nil))))
	      (IF (AND method (SEND self :operation-handled-p method))
		  (SEND self method x y)
		  (BEEP))))))

(DEFMETHOD Ï4(stand-alone-grapher :typeout-executeÏ*)
	   (FUNCTION vertex &rest ignore)
"Ï2This 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.Ï*"
  (IF (> (LENGTH (ARGLIST function)) 1)
      (FUNCALL function (coerce-to-node vertex) self vertex)
      (FUNCALL function (coerce-to-node vertex))))

;Ï1; RDA: Add thisÏ*
(DEFUN Ï4replot-a-graphÏ* (window vertex)
"Ï2Given 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 (SEND window :root-node)
	 :on window
	 (extract-plot-options window vertex)))

;Ï1; RDA: Add thisÏ*
(DEFUN Ï4extract-plot-optionsÏ* (window vertex)
"Ï2Given 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)))

(DEFUN Ï4stand-alone-graph-window-initial-functionÏ* (window)
"Ï2The top level function for graph winbdows.  It loops around looking for
 mouse blips and processing them.  It calls the function
 Stand-Alone-Graph-Window-Initial-Function-1 to process the blips,
 so that this function can be modded without resetting the process under Window.Ï*"
   ;Ï1;; Discard any chars in the in put buffer at start up.Ï*
   (LOOP for char = (SEND window :any-tyi-no-hang) until (NOT char))
   (LOOP for blip = (SEND window :any-tyi)
	 do (stand-alone-graph-window-initial-function-1 blip window)))

(DEFUN Ï4make-grapher-windowÏ* (&rest inits)
"Ï2Makes a stand-alone grapher window.Ï*"
  (APPLY #'MAKE-INSTANCE 'stand-alone-grapher
	  :edges (offsetting-stand-alone-grapher-edges)
	  inits))

(DEFUN Ï4merge-themÏ* (specs)
"Ï2Merges a list of specs, such that ((a b) (c d) (a d) (e f)) maps to
 ((a c e) (b d f)).Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (LIST (uniquify (APPLY #'APPEND (MAPCAR #'FIRST   specs)) nil :test #'EQUAL)
       (uniquify (APPLY #'APPEND (MAPCAR #'SECOND specs)) nil :test #'EQUAL)))

(DEFUN Ï4not-thereÏ* (x)
"Ï2Is true if X is nil or undefined.Ï*"
  (NOT x))

(DEFUN Ï4clean-upÏ* (kids &optional (args nil))
"Ï2Is 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.Ï*"
  (DECLARE (optimize (safety 0)))
  (IF (CONSP kids)
      (IF (not-there (FIRST kids))
	  (clean-up (REST kids) (REST args))
	  (MULTIPLE-VALUE-BIND (new-kids new-args)
	      (clean-up (REST kids) (REST args))
	    (VALUES (CONS (FIRST kids) new-kids)
		    (CONS (FIRST args) new-args))))
      (IF kids
	  (clean-up (LIST kids))
	  (VALUES nil nil))))

(DEFUN Ï4apply-safeÏ* (FUNCTION for kid args)
"Ï2Applies Function to For Kid &Rest args, making sure that Function takes enough
 args to allow the use of the Args arg.Ï*"
  (IF (AND args
	   (> (LENGTH (ARGLIST function)) 2))
      (APPLY function for kid args)
      (FUNCALL function for kid)))

(DEFUN Ï4get-nodes-and-edges-1Ï* (for child-function to-depth functions)
"Ï2Gets 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.Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (MULTIPLE-VALUE-BIND (kids args)
      (FUNCALL child-function for)
    (MULTIPLE-VALUE-BIND (the-kids extra-args) (clean-up kids args)
      (LET ((from-kids
	      (MAPCAR #'(lambda (x)
			  (APPLY 'get-nodes-and-edges x child-function
				  (AND to-depth (- to-depth 1)) functions))
			the-kids))
	    (links 
	      (MAPCAR
		#'(lambda (x args)
		    (APPEND
		      (LIST for x)
		      (APPLY #'APPEND
			     (MAPCAR
			       #'(lambda (fn) (apply-safe fn for x args))
			       functions))))
		  the-kids
		  extra-args)))
	   (merge-them (CONS (LIST (LIST for) links) from-kids))))))

(DEFUN Ï4get-nodes-and-edgesÏ* (for child-function to-depth &rest functions)
"Ï2Gets 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)).Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (DECLARE (SPECIAL *existing-nodes*))
  (IF (EQUAL to-depth 0)
      (LIST (LIST for) nil)
      (IF (GETHASH for *existing-nodes*)
	  (LIST (LIST for) nil)
	  (LET ((real-node
		  (IF (TYPEP for 'vertex)
		      (coerce-to-node (SEND for :item))
		      for)))
	       (SETF (GETHASH real-node *existing-nodes*)
	            (IF (TYPEP for 'vertex) for t))
	       (get-nodes-and-edges-1
		 real-node child-function to-depth functions)))))

(DEFUN Ï4find-vertex-forÏ* (something window)
"Ï2Given a vertex-node or a piece of user data finds the vertex for it.Ï*"
  (TYPECASE something
    (vertex something)
    (vertex-node (vertex-node-vertex something))
    (otherwise
     (LET ((coerced (coerce-to-node something)))
	  (FIND-IF #'(lambda (x)
		       (EQUAL (coerce-to-node (SEND x :item)) coerced))
		     (SEND window :item-list))))))

(DEFUN Ï4extract-edge-optionsÏ* (a-vertex-node)
"Ï2Returns 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.Ï*"
 `(,@(IF (vertex-node-dash-function a-vertex-node)
	(LIST :dash-function (vertex-node-dash-function a-vertex-node))
	nil)
   ,@(IF (vertex-node-label-function a-vertex-node)
	(LIST :label-function (vertex-node-label-function a-vertex-node))
	nil)
   ,@(IF (vertex-node-directedness-function a-vertex-node)
	(LIST :directedness-function
	     (vertex-node-directedness-function a-vertex-node))
	nil)
   ,@(IF (vertex-node-mouse-sensitive-type-function a-vertex-node)
	(LIST :mouse-sensitive-type-function
	     (vertex-node-mouse-sensitive-type-function a-vertex-node))
	nil)
   ,@(IF (vertex-node-print-function a-vertex-node)
	(LIST :print-function
	     (vertex-node-print-function a-vertex-node))
	nil)
   ,@(IF (vertex-node-font-function a-vertex-node)
	(LIST :font-function
	     (vertex-node-font-function a-vertex-node))
	nil)))
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1; A graph node, which knows about how to compute its kids locally.Ï*
;Ï1; This is used when it is important for the kids function to be differentÏ*
;Ï1; for each node on the graph, i.e. a closure of some sort.Ï*
(defstruct Ï4(local-kids-spec-nodeÏ* :named)
  node
  kids-function)

(PUTPROP 'local-kids-spec-node 'general-structure-message-handler
	 'NAMED-STRUCTURE-INVOKE)

(DEFUN Ï4graph-print-thingÏ* (node)
"Ï2Gets the printed representation of a node on the graph for a grapher pane.Ï*"
  (MULTIPLE-VALUE-BIND (name errorp)
      (CATCH-ERROR (FORMAT nil "Ï3~AÏ*" (coerce-to-node node)) nil)
    (IF errorp
	"Ï3Error printing a graph nodeÏ*"
	name)))

(DEFVAR Ï4*default-graph-depth*Ï* 3
"Ï2The default depth for graphs.Ï*")

(DEFUN Ï4make-vertex-forÏ*
       (for window child-function depth dash-function
	label-function directedness-function
	mouse-sensitive-type-function print-function
	font-function vertex-flavor       )
"Ï2Makes 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.Ï*"
  (LET ((vertex-node
	    (make-vertex-node
	       :node for
	       :child-function child-function
	       :depth depth
	       :dash-function dash-function
	       :label-function label-function
	       :directedness-function directedness-function
	       :mouse-sensitive-type-function
		 mouse-sensitive-type-function
	       :print-function print-function
	       :font-function font-function)))
       (LET ((vertex
	      (MAKE-INSTANCE
		(IF (FUNCTIONP vertex-flavor)
		    (FUNCALL vertex-flavor for)
		    vertex-flavor)
		:item vertex-node
		:window window
		:pre-print-item-modify-function print-function
		:font (FUNCALL font-function for))))
	    (SETF (vertex-node-vertex vertex-node) vertex)
	    vertex)))

(DEFUN Ï4get-vertex-forÏ*
       (for hash window child-function depth dash-function
	label-function directedness-function
	mouse-sensitive-type-function print-function
	font-function vertex-flavor)
"Ï2Gets 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.Ï*"
  (LET ((real-for (coerce-to-node for)))
       (LET ((entry (GETHASH real-for hash)))
	    (IF entry
		entry
		(SETF (GETHASH real-for hash)
		     (make-vertex-for real-for window
		       child-function depth dash-function
		       label-function directedness-function
		       mouse-sensitive-type-function print-function
		       font-function vertex-flavor))))))

(DEFUN Ï4verticise-1Ï*
        (LIST hash window child-function depth result dash-function
	 label-function directedness-function mouse-sensitive-type-function
	 print-function font-function vertex-flavor)
"Ï2Turns 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.Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (IF list
      (verticise-1
	(REST list) hash window child-function depth
	(CONS (get-vertex-for (FIRST list) hash window child-function depth
			       dash-function label-function
			       directedness-function
			       mouse-sensitive-type-function
			       print-function font-function
			       vertex-flavor)
	       result)
	dash-function label-function directedness-function
	mouse-sensitive-type-function print-function font-function
	vertex-flavor)
      (NREVERSE result)))

(DEFUN Ï4verticise-edgeÏ* (edge hash window child-function depth dash-function
			label-function directedness-function
			mouse-sensitive-type-function print-function
			font-function vertex-flavor)
"Ï2Verticises 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.Ï*"
  (CONS (get-vertex-for (FIRST edge) hash window child-function depth
			  dash-function	label-function directedness-function
			  mouse-sensitive-type-function print-function
			  font-function vertex-flavor)
	(CONS (get-vertex-for (SECOND edge) hash window child-function
				depth dash-function label-function
				directedness-function
				mouse-sensitive-type-function
				print-function font-function
				vertex-flavor)
	      (REST (REST edge)))))

(DEFUN Ï4verticiseÏ*
        (LIST hash window child-function depth dash-function
	 label-function directedness-function mouse-sensitive-type-function
	 print-function font-function vertex-flavor)
"Ï2Turns 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.Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (verticise-1 list hash window child-function depth nil dash-function
	        label-function directedness-function
		mouse-sensitive-type-function print-function font-function
		vertex-flavor))

(DEFUN Ï4default-dash-functionÏ* (node node2)
"Ï2A default dashing function, which draws solid lines.  A real one should
 return something like (:dashed-p 2).Ï*"
  (IGNORE node node2)
  nil)

(DEFUN Ï4coarse-dashesÏ* (node node2)
"Ï2A dashing function that draws coarse dashes.Ï*"
  (IGNORE node node2)
  '(:dashed-p 2))

(DEFUN Ï4moderate-dashesÏ* (node node2)
"Ï2A dashing function that draws moderately coarse dashes.Ï*"
  (IGNORE node node2)
  '(:dashed-p 1))

(DEFUN Ï4default-label-functionÏ* (node node2)
"Ï2A 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\").Ï*"
  (IGNORE node node2)
  nil)

(DEFUN Ï4default-directedness-functionÏ* (node node2)
"Ï2A 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).Ï*"
  (IGNORE node node2)
  nil)

(DEFUN Ï4undirected-edgesÏ* (node node2)
"Ï2A directedness function for edges that makes them undirected. 
 c.f. Default-Directedness-Function.Ï*"
  (IGNORE node node2)
  '(:undirected-p t))

(DEFUN Ï4default-node-font-functionÏ* (node)
"Ï2Defaults to printing Nodes in font 0.Ï*"
  (IGNORE node)
  0)

(DEFUN Ï4default-mouse-sensitive-type-functionÏ* (node node2)
"Ï2A default option function that supplies no extra mouse sensitive type to
 edges.  A real one should return something
 like (list :mouse-sensitive-type 'foo).Ï*"
  (IGNORE node node2)
  nil)

(DEFUN Ï4old-nodes-and-edgesÏ* (items nodes edges)
"Ï2Given 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.Ï*" 
  (IF items
      (IF (TYPEP (FIRST items) 'edge)
	  (old-nodes-and-edges (REST items) nodes (CONS (FIRST items) edges))
	  (old-nodes-and-edges (REST items) (CONS (FIRST items) nodes) edges))
      (VALUES nodes edges)))

(DEFUN Ï4get-and-verticise-nodes-and-edgesÏ*
        (verticise for actual-node kids-function to-depth &rest functions)
"Ï2Gets 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.Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (IF (EQUAL to-depth 0)
      (LIST (LIST for) nil)
      (MULTIPLE-VALUE-BIND (kids args)
	  (FUNCALL kids-function actual-node)
	(MULTIPLE-VALUE-BIND (the-kids extra-args) (clean-up kids args)
	  (LET ((kid-vertices (MAPCAR verticise the-kids)))
	      (LET ((from-kids
		      (MAPCAR #'(lambda (vert node)
				  (APPLY 'get-and-verticise-nodes-and-edges
					  verticise vert node kids-function
					  (AND to-depth (- to-depth 1))
					  functions))
				kid-vertices the-kids)))
		   (LET ((links 
			  (MAPCAR
			    #'(lambda (x args)
				(APPEND
				  (LIST for x)
				  (APPLY #'APPEND
					 (MAPCAR #'(lambda (fn)
						      (apply-safe fn
							   actual-node x args))
						 functions))))
			      kid-vertices
			      extra-args)))
		       (merge-them (CONS (LIST (LIST for) links) from-kids)))))))))

(DEFUN Ï4plot-a-graph-graph-2Ï*
   (node 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)
"Ï2Plots 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.Ï*"
  (LET ((new-edges
	 (MAPCAR
	   #'(lambda (x)
	       (verticise-edge x hash on child-function	 depth dash-function
                 label-function directedness-function
		 mouse-sensitive-type-function print-function font-function
		 vertex-flavor))
	     edges)))
      (IF (TYPEP node 'vertex)
	  (MULTIPLE-VALUE-BIND (old-nodes old-edges)
	      (old-nodes-and-edges old-items nil nil)
	    (SEND on :draw-graph node-vertices new-edges
		   (find-vertex-for (coerce-to-node (SEND on :root-node))
				     on))
	    (LOOP for x in old-nodes do (SEND x :draw-self))
	    (LOOP for x in old-edges do (SEND x :draw-self)))
	  (SEND on :draw-graph node-vertices new-edges))))

(DEFUN Ï4plot-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)
"Ï2Plots 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.Ï*"
  (LET ((*existing-nodes* (MAKE-HASH-TABLE)))
      (DECLARE (SPECIAL *existing-nodes*))
      (LOOP for x in old-items when (TYPEP x 'vertex)
	    do (SETF (GETHASH (coerce-to-node (SEND x :item))
			      *existing-nodes*)
		    x))
      (DESTRUCTURING-BIND (nodes edges)
	 (get-nodes-and-edges node child-function depth dash-function
             label-function directedness-function mouse-sensitive-type-function)
	(LET ((hash (MAKE-HASH-TABLE)))
	    (MAPHASH #'(lambda (key value &rest ignore)
			   (IF (TYPEP value 'vertex)
			       (SETF (GETHASH key hash) value)
			       nil))
			 *existing-nodes*)
	     (LET ((node-vertices
		     (verticise nodes hash on child-function depth dash-function
		       label-function directedness-function
		       mouse-sensitive-type-function print-function
		       font-function vertex-flavor)))
	          (plot-a-graph-graph-2 node 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)))
	on)))

(DEFUN Ï4plot-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)
"Ï2Plots 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.Ï*"
  (FLET ((verticise-function (for)
	 (IF (TYPEP for 'vertex)
	     for
	     (make-vertex-for for on child-function depth dash-function
	      label-function directedness-function mouse-sensitive-type-function
	      print-function font-function vertex-flavor))))
       (DESTRUCTURING-BIND (nodes edges)
	    (get-and-verticise-nodes-and-edges
	      #'verticise-function (verticise-function node)
	       (IF (TYPEP node 'vertex)
		   (coerce-to-node (SEND node :item))
		   node)
	       child-function depth dash-function label-function
	       directedness-function mouse-sensitive-type-function)
	 (IF (TYPEP node 'vertex)
	     (MULTIPLE-VALUE-BIND (old-nodes old-edges)
		 (old-nodes-and-edges old-items nil nil)
	       (SEND on :draw-graph
		      (APPEND old-nodes (REMOVE node nodes))
		      (APPEND old-edges edges))
	       (SEND on :expose)
	       (SEND on :refresh))
	    (SEND on :draw-graph nodes edges))
	 on)))

(DEFUN Ï4set-up-graph-windowÏ*
        (window node item-type-alist orientation label
	 auto-scale-p background-mouse-blip-functions node-on-graph
	 shouldnt-graph	)
"Ï2Sets up the grapher window according to its args, e.g. setting the orientation
 of the window if necessary.Ï*"
  (IF (AND (NOT (TYPEP node 'vertex)) (NOT node-on-graph) (NOT shouldnt-graph))
      (SEND window :set-root-node node)
      nil)
  (IF item-type-alist
      (SEND window :set-item-type-alist item-type-alist)
      nil)
  (IF (NOT (EQUAL :default orientation))
      (SEND window :set-orientation orientation)
      nil)
  (IF (NOT (EQUAL :default label))
       (SEND window :set-label label)
       nil)
  (IF auto-scale-p
     (PROGN (SEND window :set-logical-right-edge  :recompute)
	    (SEND window :set-logical-bottom-edge :recompute))
     nil)
  (IF (NOT (EQUAL background-mouse-blip-functions :default))
      (SEND window :set-background-mouse-blip-functions
	     background-mouse-blip-functions)
      nil))

(DEFUN Ï4autoscale-graph-windowÏ* (window scale)
"Ï2Resizes 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.Ï*"
  (MULTIPLE-VALUE-BIND (width height)
      (IF (CONSP scale)
	  (VALUES-LIST scale)
	  (SEND (SEND window :superior) :inside-size))
    (MULTIPLE-VALUE-BIND (win-width win-height)
	(SEND (SEND window :superior) :inside-size)
      (LET ((real-width (MIN width win-width))
	   (real-height (MIN height win-height))
	   (log-width  (SEND window :logical-width))
	   (log-height (SEND window :logical-height)))
	  (LET ((width-to-be
		  (MAX (+ 3 (SEND (SEND window :overview-window)
				    :right-margin-size)
			     (SEND (SEND window :overview-window)
				    :left-margin-size)
			     (SEND window :left-margin-size)
			     (SEND window :right-margin-size))
		        (MIN real-width
			      (+ log-width
				  (SEND window :left-margin-size)
				  (SEND window :right-margin-size)))))
		(height-to-be
		  (MAX (+ 3 (SEND (SEND window :overview-window)
				    :bottom-margin-size)
			     (SEND (SEND window :overview-window)
				    :top-margin-size)
			     (SEND window :top-margin-size)
			     (SEND window :bottom-margin-size))
		        (MIN real-height
			      (+ log-height
				  (SEND window :top-margin-size)
				  (SEND window :bottom-margin-size))))))
	       (MULTIPLE-VALUE-BIND (x y) (SEND window :position)
		 (LET ((left (MAX 0 (IF (> (+ width-to-be x) win-width)
					(- win-width width-to-be)
					x)))
		      (top (MAX 0 (IF (> (+ height-to-be y) win-height)
				      (- win-height height-to-be)
				      y))))
		     (SEND window :set-edges left top
			    (+ left width-to-be)
			    (+ top height-to-be)))))))))

(DEFUN Ï4finalise-graph-windowÏ*
        (node window auto-scale-p home-to-root-node-p calling-args expose-p)
"Ï2Sets 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.Ï*"
  (SEND window :set-calling-args calling-args)
  (IF (AND auto-scale-p
	    (NOT (TYPEP (SEND window :superior) 'constraint-frame)))
      (autoscale-graph-window window auto-scale-p)
      nil)
  (IF expose-p (SEND window :expose) nil)
  (IF home-to-root-node-p
     (LET ((root (IF (EQUAL home-to-root-node-p :root-node)
		    (SEND window :root-node)
		    node)))
	 (SEND window :go-to-node root))
     nil)
  (SEND window :set-graph-behaviour-changed nil)
  window)

(DEFVAR Ï4*auto-scale-graphers-by-default*Ï* nil
"Ï2When true graphers are autoscaled by default.Ï*")

(DEFVAR Ï4*force-exposure*Ï* t
"Ï2When true, by default graphers are forced to be exposed after the graph is
 plotted.Ï*")

(DEFUN Ï4plot-a-graphÏ*
       (node &key (on :from-resource)
	child-function
	(depth *default-graph-depth*)
	(dash-function 'default-dash-function)
	(label-function 'default-label-function)
	(directedness-function 'default-directedness-function)
	(mouse-sensitive-type-function
	  'default-mouse-sensitive-type-function)
	(print-function 'graph-print-thing)
	(font-function 'default-node-font-function)
	(vertex-flavor 'vertex)
	(item-type-alist nil)
	(orientation :default)
	(label :default)
	(tree-p nil)
	(resource 'stand-alone-graphers)
	(auto-scale-p *auto-scale-graphers-by-default*)
	(background-mouse-blip-functions :default)
	(home-to-root-node-p t)
	(force-exposure *force-exposure*)
	(dont-graph-if-already-graphing-this-node nil))
"Ï2Plots 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 arg 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 byb 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 onto 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 this.
  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-F-lled-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.
  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 item 1\" :value menu-function-1 :documentation
                  \"Menu mouse doc 1\")
                 ... other menu items
                 (\"Menu item 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 Stand-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 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 = *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-arg)
      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 bliped on, x and y are the mouse coords and other-args
      are any extra args provided in the arlist entry.  In the example above
      the arg Other-Arg would be the last arg 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 usefult 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.

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 Ï*Ï2 (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 args 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)

;;; Aha, 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.

  (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)

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

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

;;; We should functionise 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)Ï*"
  (DECLARE (optimize (safety 0) (speed 3)))
  (DECLARE (VALUES window-on-which-the-graph-was-plotted))
  (IF (NOT child-function) (FERROR nil "Ï3No child-function supplied.Ï*"))
  (LET ((*graph-window*
	  (IF (EQUAL :from-resource on) (ALLOCATE-RESOURCE resource) on)))
       (DECLARE (SPECIAL *graph-window*))
       (LET ((shouldnt-graph
	       (AND dont-graph-if-already-graphing-this-node
		    (SEND *graph-window* :item-list)
		    (EQUAL (coerce-to-node node)
			    (coerce-to-node
			      (SEND *graph-window* :root-node)))
		    (NOT (SEND *graph-window* :graph-behaviour-changed))))
	    (node-on-graph (IF (TYPEP node 'vertex)
			       nil
			       (find-vertex-for node *graph-window*))))
	   (set-up-graph-window
	     *graph-window* node item-type-alist orientation label
	     auto-scale-p background-mouse-blip-functions node-on-graph
	     shouldnt-graph)
	   (LET ((old-items (IF (SEND *graph-window* :graph-behaviour-changed)
			       nil
			       (SEND *graph-window* :item-list)))
		 (real-node (IF (SEND *graph-window* :graph-behaviour-changed)
			        node
				(OR node-on-graph node))))
	       (IF shouldnt-graph
		   nil
		   (PROGN (IF (OR (NOT (TYPEP real-node 'vertex))
				  (SEND *graph-window*
					:graph-behaviour-changed))
			      (SEND *graph-window* :clear-window)
			      nil)
			   (IF tree-p
			       (plot-a-graph-tree real-node old-items
				 *graph-window*
				 child-function depth dash-function
				 label-function directedness-function
				 mouse-sensitive-type-function print-function
				 font-function vertex-flavor)
			       (plot-a-graph-graph
				 real-node *graph-window* old-items
				 child-function depth dash-function
				 label-function directedness-function
				 mouse-sensitive-type-function print-function
				 font-function vertex-flavor)))))
	   (LET ((calling-args
		 `(:child-function ,child-function
		   :on ,*graph-window*
		   :depth ,depth
		   :dash-function ,dash-function
		   :label-function ,label-function
		   :directedness-function ,directedness-function
		   :mouse-sensitive-type-function
		     ,mouse-sensitive-type-function
		   :print-function ,print-function
		   :font-function ,font-function
		   :vertex-flavor ,vertex-flavor
		   :item-type-alist ,item-type-alist
		   :orientation ,orientation
		   :label ,label
		   :tree-p ,tree-p
		   :resource ,resource
		   :auto-scale-p ,auto-scale-p
		   :background-mouse-blip-functions
		     ,background-mouse-blip-functions
		   :home-to-root-node-p ,home-to-root-node-p
		   :force-exposure ,force-exposure
		   :dont-graph-if-already-graphing-this-node
		     ,dont-graph-if-already-graphing-this-node)))
	       (finalise-graph-window node *graph-window* auto-scale-p
					home-to-root-node-p calling-args
					force-exposure)))
       *graph-window*))

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

;Ï1;; A resource for stand-alone grapher panes.Ï*
(DEFWINDOW-RESOURCE Ï4stand-alone-graphersÏ* ()
  :initial-copies 0
  :constructor (make-grapher-window))

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

