(in-package "KPML-I")
;;;
;;; File: resource-grapher-interface.lisp
;;;
;;; --------------------------------------------------------
;;;    RESOURCE GRAPHER: ACCESS FROM THE WINDOW INTERFACE
;;; --------------------------------------------------------

;;; General interface commands for graphing systemic resources.
;;;
;;; --  Additional functionality to Penman interface:
;;;        grammar graphing with particular support for region-oriented
;;;        browsing, hardcopying, etc.
;;;
;;; KPML 0.8: contrastive graphing added (for regions, not yet for strata).
;;; KPML 0.9: realization statements added to graphs (conditionally).
;;;           trivial semantic graphing added (using kb interface functions).
;;; 0.9.46 replaces the old *always-show-collecteds* defvar with more options
;;; KPML 1.0.28: made to look more systemic and several options added.
;;; KPML 1.1: graphing overhauled so that the code is more integrated,
;;;           and there are various more systemic options provided for
;;;           customizing the look of the graph produced.
;;; KPML 2.0: added compatibility with Harlequin Lispworks for PC. 
;;; 2.0.44:   a reference to the descendent function had not been updated to
;;;           be in the right package (Martin Soffner, TU-Berlin, Dec98).
;;;           and since we're here, try to make the font a bit more controllable
;;;           in the hardcopy graphs...
;;; KPML 2.1: user control of foreground and background colours (i.e.,
;;;           highlighted and not highlighted info in the graph) added.
;;;         : option of careful-graphing added as option...
;;; KPML 3.0  size of fonts more directly controllable, altered inspection
;;;           menu, and hardcopy back in for ACL5 and LWW4.1
;;; KPML 4.0  minor additions for compatibility with Loom4 and general KR.
;;;           further graphing options for controlling stubs and visibility
;;;           for semantic graphs
;;;
;;; ----------------------------------------------------------------------

(defvar *RESOURCE-GRAPHER-PROCESS* nil)
(defvar *RESOURCE-GRAPHER* nil)
(defvar *GRAPHED-REGION* nil)
(defvar *GRAPHED-REGIONS* nil)
(defvar *GRAPHED-STRATUM* nil)
(defvar *ROOT-SYSTEM* nil)

(defvar *HIGHLIGHTING-OPTIONS* '(:last-used :last-selected :collected))
(defvar *HIGHLIGHTING-CONDITIONS* '(:last-used))
;;; (defvar *show-generation-paths* T) ; 1.2 only used for choosers now

(defvar *WHEREAMI* nil)  ;; 4.1 used for keeping context...

(defvar *RESOURCE-GRAPH-DEPTH* nil)
(defvar *RESOURCE-GRAPH-ORIENTATION* :horizontal)
(defvar *VERTICAL-SCALING* 10)
(defvar *GRAPHER-HEADER* t)
(defvar *REPLACE-CURRENT-GRAPH* nil)
(defvar *SUITABLE-FOR-FIGURES?* nil)
(defvar *DEFAULT-KPML-HARDCOPY-DIRECTORY* #+unix "/tmp/" #-unix "C:\\tmp\\")
(defvar *HARDCOPY-VERTICAL-SCALING* 15)
(defvar *GRAPH-STOP-POINTS* nil)
(defvar *DISPLAY-EXAMPLES* T)
(defvar *BILINGUAL-STYLE* :bilingual)

(defvar *GRAPH-SIZE-THRESHOLD* 0.8)
(defvar *REGION-GRAPHING-MODE* nil) ; set true when graphing regions...

;;; 4.0 Idea of the following is to control whether a stub shows its
;;;     name or just an anchor within a semantic graph...

(defvar *KR-STOP-POINTS-DISPLAY-MODE* :maintain)
(defvar *KR-KILL-POINT-LIST* nil)

;;; ----------------------------------------------------------------------
;;; 0.9.46 replaces the old *always-show-collecteds* defvar with:
;;; ----------------------------------------------------------------------

(defvar *SHOW-COLLECTEDS* T
  "When :always, always puts a collected pane in a resource graph,
   when nil, never put a collected pane in a resource graph,
   when T, put one in only when there are collected features")

;;; ----------------------------------------------------------------------
;;;  add more selective display of realization statements as in
;;;  in Kumano etal. 94.
;;;
;;; 1.0.28 The following variable now takes three values instead of being
;;;       a boolean. The values are:
;;;          :always    always shown realizations
;;;          :used      show realizations on the traversal path
;;;          :never     never show realizations
;;;
;;; 2.1    Size of font made flexible...
;;; 3.0    more so...
;;; ----------------------------------------------------------------------

(defvar *SHOW-REALIZATIONS-IN-GRAPHS* :always)
(defvar *SHOW-SYSTEM-NAMES* T)                                 ;;; 1.1
(defvar *LG-ABBREV-STYLE* *fix--bold--6*)
(defvar *PRUNE-TO-GENERATION-PATH-P* nil)                      ;;; 2.0.33
(defvar *HARDCOPY-FONT* *fix--bold--10*)                       ;;; 2.0.44
(defvar *CAREFUL-GRAPHING* nil)                                ;;; 2.1
(defvar *SHOW-DISABLED-SYSTEMS-IN-GRAPH* T)                    ;;; 2.1
(defvar *RESOURCE-GRAPH-SYSTEM-NAME-SIZE* 12)                  ;;; 3.0
(defvar *RESOURCE-GRAPH-FEATURE-SIZE* 10)               ;;; 3.0
(defvar *RESOURCE-GRAPH-RS-SIZE* 8)                     ;;; 3.0

;;; ----------------------------------------------------------------------
;;; 1.1 all graph nodes are examples of the following structure...
;;; ----------------------------------------------------------------------

(defstruct SYSTEMIC-GRAPH-NODE
  (type nil :type (or symbol list))
  (value nil)
  (status nil :type (or symbol list)))

;;; ----------------------------------------------------------------------
;;; Macro utility for systemic-style graphing.
;;; has to come first...
;;; ----------------------------------------------------------------------

(defmacro CONNECT-FEATURE-WITH-SYSTEM (stream x1 y1 x2 y2 path)
  `(if ,path
       (let ((last-point (last ,path 2)))
	 (path-drawer ,stream ,x1 ,y1 ,path)
	 (if kpml::*systemic-notation*
	     (clim:draw-line* ,stream 
			      (first last-point)(second last-point) ,x2 ,y2
			      :line-dashes dashed-p)
	   (clim:draw-arrow* ,stream 
			     (first last-point)(second last-point) ,x2 ,y2
			     :line-dashes dashed-p)
	   ))
     (if kpml::*systemic-notation*
	 (clim:draw-line* ,stream ,x1 ,y1 ,x2 ,y2 :line-dashes dashed-p)
       (clim:draw-arrow* ,stream ,x1 ,y1 ,x2 ,y2 :line-dashes dashed-p))))

;;; Macro utilities for factoring out printing options that are applied
;;; under various other conditions...

(defmacro PRINT-POSSIBLY-DISABLED-SYSTEM-NAME (object name)
  `(clim:with-output-as-presentation 
       (stream ,object 'resource-graph-node)
     (clim:with-text-size (stream *resource-graph-system-name-size*)
       (if (kpml::fetch-disabled-system ,name)
	   (clim:with-drawing-options
	       (stream :ink *grey*)
	     (format stream "~a" ,name))
	 (format stream "~a" ,name)))))

;;; ----------------------------------------------------------------------
;;; Application frame definition and layout
;;;
;;; Graphing is now done by the display method for the systemic-resource-graph
;;; frame. This is parameterized by the mode of the frame. The mode can be
;;; one of :single, :region, :ml, :ml-region, :stratum. Start-up functions
;;; for resource graphs should therefore set the mode; they should then
;;; give the additional information of the root systems, regions, 
;;; language(s in :ml modes), and set the region-graphing-mode flag.
;;;
;;; Hardcopy is still not available for multilingual graphs, but
;;; is simple to add if someone needs it.
;;;
;;; ADDIITONS/UPDATES HISTORY:
;;; Frame slots and incremental display added...
;;; 0.9.4
;;; 0.9.27 incorporate collected feature display...
;;; 1.1    system names are by default now positioned near their systems rather
;;;        than as extra nodes in the graph. This also falls under the
;;;        control of the systemic-notation flag.
;;;        The mode :collection is also added, this allows graphs from 
;;;        arbitrary collections of features to be started.
;;;        Support for display views is also added, allowing the graph
;;;        to be modified in a variety of ways that do *not* preserve
;;;        the logical equivalence of the views presented. Mostly for
;;;        the preparation of teaching material.
;;;
;;; ----------------------------------------------------------------------

(clim:define-application-frame SYSTEMIC-RESOURCE-GRAPH ()
  ((root-systems :initform nil)
   (mode :initform nil)
   (regions :initform nil)
   (region-graphing-mode :initform nil)
   (languages :initform nil)
   (system-positions                                            ;; 1.1
    :initform (make-hash-table :test #'equal))                  ;; usage changed in 2.1
   (feature-max-y :initform (make-hash-table :test #'equal))    ;; 2.1
   (feature-min-y :initform (make-hash-table :test #'equal))    ;; 2.1
   (whereami  :initform nil)                                    ;; 4.1
   )
  (:menu-bar T)
  (:command-table 
   (systemic-resource-graph
    :menu
    (("Quit" :command com-quit-resource-grapher)
     ("Modes" :command com-display-modes)
     ("Flags" :menu resource-grapher-flags-command-table)
     ("Collecteds" :menu collected-feature-command-table)
     #+(or allegro postscript-clim lucid)("Print" :command com-printgraph-rg)
     #+(or allegro lucid)("Mail " :command com-mail-intention-to-work)
     ("Display" :menu graph-display-command-table)
     )))

  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (:panes (graph       :application
;;; 0.9.4
		       :incremental-redisplay T
		       :initial-cursor-visibility :inactive
		       :end-of-page-action :allow
		       :end-of-line-action :allow
		       :display-function 'resource-graph-displayer
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
;;; 0.9.27
	  (collecteds  :application
		       :initial-cursor-visibility :inactive
		       :incremental-redisplay T
		       :display-function 'collected-features-displayer
		       :foreground menu-fg
		       :background resource-graph-bg			
		       :text-style *sans-serif--italic--8*)
	  )
;;; 0.9.27
  (:layouts 
	    (no-collecteds (clim:vertically ()
			     (:fill graph)))
            (collecteds (clim:vertically () 
			  (:fill graph)
			  (#-lispworks 100 #+lispworks 1/5  collecteds))))
  (:command-definer t))


;;; ----------------------------------------------------------------------
;;; generic resource display function for all the various resource
;;; graph types...
;;; 0.9.31 - semantic graphing added (mode option :kr)
;;; 0.9.43 - folded in.
;;; 0.9.46 - folded in.
;;; 0.9.54 - folded in (ml-graphing contrastive got squashed by the original
;;;                     patch here).
;;; ----------------------------------------------------------------------

(defvar *inter-generation-scaling* 10)

;;; ----------------------------------------------------------------------
;;; (a) Make the graph look more like a system network...
;;;
;;;  call to graph-from-roots simply has the additional keyword for
;;;  the arc-drawing function set. The main patch is then the definition
;;;  of this arc-drawing-function which follows. 
;;;
;;;  1.0.42: hack for putting the default arcs back in for semantic graphs...
;;;  1.1   : many things added for making the graph more tailorable and
;;;          more systemic-looking
;;;  2.1   : option of careful-graphing added as option...
;;;  4.0   : added stop points for semantic graphs. 
;;;  4.1   : specially locally rebind whereami so that context is
;;;          available for highlighting... (not yet)
;;; ----------------------------------------------------------------------

(defmethod RESOURCE-GRAPH-DISPLAYER ((frame systemic-resource-graph) stream)
  (let ((descendents-function
	 (case (slot-value frame 'mode)
	   ((:single :region :stratum :collection)
	    #'descendent-grammar-nodes)
	   ((:ml :ml-region)
	    #'kpml::contrastive-descendents)
	   ((:ml>2 :ml>2-region)
	    #'kpml::general-contrastive-descendents)
	   (:kr
	    ;; 4.0 
	    #'descendent-subcs-for-graph)))
        (print-function
	 (case (slot-value frame 'mode)
	   ((:single :region :stratum :collection)
	    #'print-resource-graph-nodes)
	   ((:ml :ml-region)
	    #'print-contrastive-resource-graph-nodes)
	   ((:ml>2 :ml>2-region)
	    #'print-general-contrastive-resource-graph-nodes)
	   (:kr
	    #'print-semantic-resource-graph-nodes)))
	(gen-sep (if *show-realizations-in-graphs*
		     (+ *vertical-scaling* 10)
		   *vertical-scaling*))
	(depth *resource-graph-depth*)
	(starting-points nil)
	(kpml::curlan                              ;; 0.9.54
	 (if (member (slot-value frame 'mode) '(:stratum :region :single))
	     (first (slot-value frame 'languages))
	   kpml::curlan))
	(kpml::*contrastive-graphing-languages* (slot-value frame 'languages)))
    (clrhash (slot-value frame 'system-positions))
    (if (eq (slot-value frame 'mode) :kr)
	(setf (clim:frame-current-layout clim:*application-frame*) 
	      'no-collecteds)
      ;; -----------0.9.27+0.9.46---------------------------------------
      (setf (clim:frame-current-layout clim:*application-frame*) 
	(if (or
	     (eq *show-collecteds* :always)
	     (and *show-collecteds* kpml::*collected-features*))
	    'collecteds 
	  'no-collecteds))
      ;; -----------end 0.9.27+0.9.46-----------------------------------
      )
    (case (slot-value frame 'mode)
      (:kr
       (setf starting-points 
	     (list (kpml::kb-getnamedconcept 
		    (first (slot-value frame 'root-systems)))))
       (format stream "Semantics (note: restricted options apply)~5%~0T"))
      (:single
       (setf starting-points (kpml::starting-grammar-node 
			      (first (slot-value frame 'root-systems))))
       (when *graph-display-mode* (format stream "Display Mode. ")) ;; 4.0
       (if kpml::*resource-graphing-region-restricted?*
	   (format stream "Region: ~A; Language: ~A~5%~0T" 
		   (first (slot-value frame 'regions))
		   (first (slot-value frame 'languages)))   ;; 0.9.54
	 (format stream "Language: ~A~5%~0T" 
		 (first (slot-value frame 'languages)))))
      (:collection
       (setf starting-points
	     (mapcar #'(lambda (x) (make-systemic-graph-node
				    :type 'kpml::feature
				    :value x))
		     (slot-value frame 'root-systems)))
       (format stream "Regions:~{ ~A~}; Language: ~A~5%~0T" 
	       (slot-value frame 'regions)
	       (first (slot-value frame 'languages))))
      (:region
       (setf starting-points 
	 (kpml::standard-region-graphing 
	  (first (slot-value frame 'regions))))
       (format stream "Region: ~A; Language: ~A~5%~0T" 
	       (first (slot-value frame 'regions)) 
	       (first (slot-value frame 'languages))))
      ((:ml-region :ml>2-region)
       (format stream "Region: ~A; " 
	       (first (slot-value frame 'regions)))
       (label-resource-graph-languages stream (slot-value frame 'mode))
       (setf *graphed-regions* (slot-value frame 'regions))  ;;0.9.43
       (setf starting-points
	 (mapcar #'(lambda (s) 
		     (make-systemic-graph-node
		      :type (systemic-graph-node-type s) 
		      :status (if (eq (slot-value frame 'mode) :ml-region)
				  (shared-status 
				   (systemic-graph-node-value s)
				   (first (slot-value frame 'languages))
				   (second (slot-value frame 'languages)))
				(slot-value frame 'languages))
		      :value (systemic-graph-node-value s)))
		 (kpml::standard-region-graphing 
		  (first (slot-value frame 'regions))))))
      ((:ml :ml>2)
       (when kpml::*resource-graphing-region-restricted?*
	 (format stream "Regions: ~{~A ~}; "
		 (remove-duplicates (slot-value frame 'regions))))
       (label-resource-graph-languages stream (slot-value frame 'mode))
       (setf *graphed-regions* (slot-value frame 'regions))  ;;0.9.43
       (setf starting-points 
	     (list 
	      (make-systemic-graph-node
	       :type 'kpml::system 
	       :status (shared-status 
			(first (slot-value frame 'root-systems))
			(first (slot-value frame 'languages))
			(second (slot-value frame 'languages)))
	       :value
	       (first (slot-value frame 'root-systems))))))
      (:stratum
       (format stream "Stratum: ~A; Language: ~A~5%~0T" 
	   *graphed-stratum* (first (slot-value frame 'languages))) ;; 0.9.54
       (setf starting-points
	 (mapcar #'(lambda (x) 
		     (make-systemic-graph-node
		      :type 'kpml::system
		      :value x))
		 (slot-value frame 'root-systems))))
      )
    
    (unless (or kpml::*resource-graphing-region-restricted?*
		*resource-graph-depth*
                (> (estimate-graph-size starting-points)  ;; 4.1 outsourced...
                   *graph-size-threshold*)
                (clim:notify-user                         ;; 2.1
		                                          clim:*application-frame*
		 "You are about to graph a systemic resource network 
with no restriction set to remain within a single
region nor to only graph to a certain depth. Depending on
the resources that are loaded, this could result in an extremely
large graph (consuming both time and space).

Do you want to proceed with this?"
                :style :question))
      (format stream "~5%... Graphing abandoned.")
      (return-from RESOURCE-GRAPH-DISPLAYER nil))

    (case (slot-value frame 'mode)                        ;; 2.1
      (:kr                                                ;; 1.0.42
       (clim:updating-output (stream :unique-id starting-points)
	 (clim:format-graph-from-roots
	  starting-points
	  #'(lambda (node s)
	      (clim:updating-output (s :cache-value node)
		(apply print-function (list node s))))
	  descendents-function
	  :generation-separation gen-sep
	  :within-generation-separation *inter-generation-scaling*
	  :cutoff-depth depth :merge-duplicates t :duplicate-test #'equal
	  :move-cursor t 
	  ;; 4.0 no systemic notation here...
	  :orientation *resource-graph-orientation*
	  :stream stream)))
      (otherwise
       (when *careful-graphing*                                        ;; 2.1
	 (initialize-graph-position-records clim:*application-frame*))
       (clim:updating-output (stream :unique-id starting-points)
	(clim:format-graph-from-roots
	 starting-points
	 #'(lambda (node s)
	     (clim:updating-output (s :cache-value node)
	       (apply print-function (list node s))))
	 descendents-function
	 :generation-separation gen-sep
	 :within-generation-separation *inter-generation-scaling*
	 :arc-drawer #'systemic-arc-drawer
	 :arc-drawing-options '(:with-name T)
	 :cutoff-depth depth
	 :merge-duplicates t
	 :duplicate-test #'graph-tester
	 :move-cursor t
	 :orientation (if kpml::*systemic-notation*
			  :horizontal
			*resource-graph-orientation*)
	 :stream stream))
       ;; 2.1 reorganized this part...
       (clim:updating-output (stream :cache-value starting-points)
	 (cond ((or (eq (slot-value frame 'mode) :ml)
		    (eq (slot-value frame 'mode) :ml-region))
		(if *careful-graphing*
		    (when kpml::*systemic-notation*	
		      (do-system-shapes stream))
		  (when (and kpml::*systemic-notation*
			     *show-system-names*)
		    (ml-display-system-names stream))))
	       (t 
		(if *careful-graphing*
		    (when kpml::*systemic-notation*	
		      (do-system-shapes stream))
		  (when (and kpml::*systemic-notation*
			     *show-system-names*)
		    (display-system-names stream))))))
       ))))

;;; ----------------------------------------------------------------------
;;; NOTE: display-system-names no longer used in monolingual graphing
;;;       when in careful mode. Need to check out multilingual mode. 
;;; ----------------------------------------------------------------------

(defun GRAPH-TESTER (x y) 
  (declare (optimize speed))
  (or 
      (and (systemic-graph-node-p x)
	   (systemic-graph-node-p y)
	   (equal (systemic-graph-node-value x)(systemic-graph-node-value y))
	   (equal (systemic-graph-node-type x)(systemic-graph-node-type y))
	   (or
	    (not kpml::*preserve-systems-in-ml-graphs*)
	    (equal (systemic-graph-node-status x)
		   (systemic-graph-node-status y))))
      (equal x y)))

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

(defvar kpml-i::*large-contrasting-inks*
    '("papaya-whip" "blanched-almond" "bisque" "lavender-blush"
      "cornflower-blue" "slate-blue" "royal-blue" "dodger-blue"
      "dark-turquoise" "aquamarine" "chartreuse" "forest-green"
      "light-yellow" "goldenrod" "rosy-brown" "wheat" "dark-salmon"
      "salmon" "tomato" "orange-red" "deep-pink" "maroon" 
      "medium-violet-red" "plum" "orchid" "thistle"))

(defun COLORTEST (n)
  (let ((stream
	 (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	(colors (if (and (> n 1)(< n 8))
		    (clim:make-contrasting-inks n)
		  (mapcar #'get-color
			  *large-contrasting-inks*))))
    (clim:stream-set-cursor-position stream 0 0)
    (loop for i from 0 to (1- n)
	as j from 0 to 100 by 4
	do (clim:draw-line* stream 0 j 70 j 
			    :ink (elt colors i)
			    :line-thickness 4)
	   (terpri stream ))
    (clim:stream-set-cursor-position stream 0 100)
    (loop for i from 0 to (1- n)
	do (kpml-tick stream :color (elt colors i))
	   (format stream " "))))


;;; ----------------------------------------------------------------------
;;; 0.9 following wrap around allows us to pick off nodes from
;;;     the graph at will. Cut off nodes are marked by dots so
;;;     that it is always clear that the information being displayed
;;;     is incomplete (unless system stubbs is nil, then the
;;;     dependent systems just disappear...).
;;; 1.1 was in substrate, moved here. Includes graph-node structure.
;;; 2.0.33
;;;     Adds an option by which only the generation path is shown in
;;;     the resource graph, all other nodes are thrown on the stop
;;;     points list.
;;; ----------------------------------------------------------------------

(defun DESCENDENT-GRAMMAR-NODES (ml-nodes)
  (let* ((candidate-set (kpml::descendent-grammar-nodes-internal ml-nodes))
	 (descendents
	  (loop for c in candidate-set
	      when (and 
		    ;; 2.0.33 automatic pruning to generation path...
		    (let ((object (systemic-graph-node-value c)))
		      (or (member object *graph-stop-points*)
			  (and *prune-to-generation-path-p*
			       (check-for-generation-path 
				object (systemic-graph-node-type c))
			       )))
		    (or kpml::*include-system-stubbs*
			(eq (systemic-graph-node-type c) 'kpml::feature)))
	      collect (cons 'kpml::stub (systemic-graph-node-value c))
	      else unless (member (systemic-graph-node-value c)
				  *graph-stop-points*)
	      collect (cons 
		       (systemic-graph-node-type c)
		       (systemic-graph-node-value c))))
	 (monolingual-descendents
	  (if kpml-i::*graph-display-mode*
	      (kpml-i::prune-combined-features descendents)
	    descendents)))
    (when *collect-information-for-export*
      (push monolingual-descendents *collected-export-information*))
    (loop for d in monolingual-descendents
	  collect (kpml-i::make-systemic-graph-node
		   :type (first d)
		   :value (cdr d)))))


(defun CHECK-FOR-GENERATION-PATH (object type) 			       
  (cond ((eq type 'kpml::feature)
	 (if (not (feature-on-generation-path-p object))
	     (progn
	       (pushnew object *graph-stop-points*)
	       T)
	   nil))
	((eq type 'kpml::system)
	 (and (kpml::gate-p object)
	      (if (not (feature-on-generation-path-p 
			(first (kpml::fetch-output-features object))))
		  (progn
		    (pushnew object *graph-stop-points*)
		    T)
		nil)))))

;;; ----------------------------------------------------------------------
;;; Presentations and actions...

(clim:define-presentation-type resource-graph-node ())

(clim:define-presentation-action present-resource-graph-node
    (resource-graph-node nil systemic-resource-graph
			 :documentation "Describe this graph node")
  (object)
  (describe-resource-graph-node object))

(defvar *compass-menus* nil)

(defun describe-resource-graph-node (node)
  (let ((stream
	 (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    ;; 3.0
    (if *compass-menus*
        (case (ccd)
          (semantics (com-SHOW-CHOOSER-FOR-GRAPH-NODE node))
          (examples (com-SHOW-EXAMPLES-WITH-FEATURE node))
          (subgraph (com-SPAWN-NEW-GRAPH-FROM-HERE node))
          (path nil)
          (t 
           (kpml::resource-graph-display-action stream node)))
      (kpml::resource-graph-display-action stream node))))

;;; ----------------------------------------------------------------------
;;; The following is not yet stable enough for proper use, the menu
;;; is very sluggish under LWW4.1 when there is more than one
;;; resource graph around. May need to do the entire thing in its
;;; own frame and process, like the user response frame.
;;; ----------------------------------------------------------------------

(defun ccd ()
  (let ((x-origin 150)(y-origin 150))
  (labels ((draw-compass-point (stream ptype symbol x y)
                               (clim:with-output-as-presentation (stream symbol ptype)
                                 (clim:draw-text* stream (symbol-name symbol)
                                                  (+ x x-origin)
                                                  (+ y y-origin)
                                                  :align-x :center
                                                  :align-y :center
                                                  :text-style '(:sans-serif :roman :large))))
           (draw-compass (stream ptype)
                         (clim:draw-arrow* stream 150 175 150 125 
                                           :from-head t :to-head t :head-length 20 :head-width 10
                                           :line-thickness 3)
                         (clim:draw-arrow* stream 175 150 125 150 
                                          :from-head t :to-head t :head-length 20 :head-width 10
                                          :line-thickness 3)
                         (loop for point in '((semantics 0 -60)(examples 0 60)
                                              (subgraph 100 0)(path -60 0))
                               do (apply #'draw-compass-point stream ptype point))
                         (clim:with-output-as-presentation (stream "center" ptype)
                           (clim:draw-circle* stream 150 150 10 :filled T))))
    (clim:with-menu (menu)
      (clim:menu-choose-from-drawer
       menu 'clim:menu-item #'draw-compass)))))

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

(clim:define-presentation-type resource-graph-stubb ())

(clim:define-presentation-action resource-graph-stubb-action
    (resource-graph-stubb nil systemic-resource-graph
			  :documentation "Expand this stubb")
  (object)
  (setf *graph-stop-points* (remove object *graph-stop-points*))
  (clim:redisplay-frame-pane clim:*application-frame* 'graph)
  T)


;;; ----------------------------------------------------------------------
;;;  4.0
;;; Following is now defined generally for any KR system...

(define-systemic-resource-graph-command (com-PRINT-CONCEPT-FROM-GRAPH :name t)
    ((concept 'kr-concept :gesture :select))
  (describe-kr-concept-or-relation concept 'concept))

(define-systemic-resource-graph-command (com-GRAPH-CONCEPT-FROM-GRAPH :name t)
    ((concept 'kr-concept :gesture :select))
    (create-a-semantic-resource-graph 
     (kpml::kb-getconceptname concept)))

;;; Added new here at 4.0...

(define-systemic-resource-graph-command (com-STOP-GRAPH-CONCEPT-HERE :name t)
    ((concept 'kr-concept :gesture :select))
    (pushnew concept *graph-stop-points*))

(define-systemic-resource-graph-command (com-KILL-GRAPHED-CONCEPT :name t)
    ((concept 'kr-concept :gesture :select))
    (pushnew concept *kr-kill-point-list*))

(defun DESCENDENT-SUBCS-FOR-GRAPH (c)
  (if (member c *graph-stop-points* :test #'equal)
      nil
    (loop for c2 
          in (kpml::kb-immediatesubcs c)
	  unless (member c2 *kr-kill-point-list* :test #'equal)
	  collect c2)))

;;; ----------------------------------------------------------------------
;;; Startup functions... Resource graphing is triggered from the
;;; resource inspection window.

(defun GRAPH-UNDER-CURRENT-OPTIONS 
    (system-or-region &key 
		      (region-flag nil)
		      (whereami nil)          ;; 4.1
		      )
    (setf *whereami* whereami)
    (cond (region-flag
       (case kpml::*ml-graphing-mode*
	   (:monolingual 
            (create-a-region-graph system-or-region :frame-tool-label system-or-region))
	   (:multilingual (create-a-contrastive-region-graph 
                           system-or-region :frame-tool-label system-or-region))
	   (:contrastive
	    (let ((old-curlan kpml::curlan))
	      (loop for lg in (if kpml::*languages-in-focus*
				  kpml::*languages-in-focus*
				kpml::all_languages)
		  do
		    (setf kpml::curlan lg)
		    (create-a-region-graph system-or-region :frame-tool-label system-or-region))
	      (setf kpml::curlan old-curlan)))))
	(T
	 (case kpml::*ml-graphing-mode*
	   (:monolingual 
            (create-a-resource-graph system-or-region :frame-tool-label system-or-region))
	   (:multilingual (create-a-contrastive-resource-graph 
			   system-or-region :frame-tool-label system-or-region))
	   (:contrastive
	    (let ((old-curlan kpml::curlan))
	      (loop for lg in (if kpml::*languages-in-focus*
				  kpml::*languages-in-focus*
				kpml::all_languages)
		  do
		    (setf kpml::curlan lg)
		    (create-a-resource-graph 
                     system-or-region :frame-tool-label system-or-region))
	      (setf kpml::curlan old-curlan)))))))

(define-kpml-resource-inspector-command (com-GRAPH-GRAMMAR :name t :menu t)
  ((system 'system :gesture :select))
  (graph-under-current-options system :region-flag nil))

(define-kpml-resource-inspector-command (com-GRAPH-REGION :name t :menu t)
  ()
  (let ((selected-region (select-a-region-menu)))
    (when selected-region
      (graph-under-current-options selected-region :region-flag T))))

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

(define-kpml-resource-inspector-command 
  (com-GRAPHER-DISPLAY-MODES :name t :menu nil)
  ()
  (resource-grapher-display-modes-from-kpml))

;;; 1.0.13
(defun RESOURCE-GRAPHER-DISPLAY-MODES-FROM-GRAPHER
    (&optional
     (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (grapher-display-modes T stream))



;;;-----------------------------------------------------------------------
;;; Graph launching functions... Unlike the other windows, resource and
;;; structure graphs always create a new frame/process. In 0.8 and
;;; before, the latest process was always kept in the variable 
;;; *resource-grapher* -- this is not useful for multiple resource
;;; graphs however. No use is therefore made of this variable anymore.
;;; Following are maintained special within each launched process:
;;;   the application frame: *resource-grapher*
;;;   the graphed region: *graphed-region*
;;;   the graphed regions (for contrastives): *graphed-regions*
;;;   the starting system(s): *root-system*
;;; (actually, after 1.0 most of these are maintained as frame slots)
;;;
(defun RUN-RESOURCE-GRAPHER 
  (*package* *resource-grapher* 
	     *graphed-region* *graphed-regions* *root-system*)
  (declare 
   (special *package* *resource-grapher* 
	    *graphed-region* *graphed-regions* *root-system*))
  (setf *package* (find-package "KPML"))
  ;; make sure that the display forming options are not normally available
  ;; unless requested...
  (initialize-display-tool-variables)
  (clim:run-frame-top-level *resource-grapher*))


;;; ======================================================================
;;; 4.1 these startups are no longer current, as they are all 
;;;     managed in startups.lisp these days. Therefore make them
;;;     invisible until they disappear completely...
;;;     This is all the cases (i)-(vi) listed here.

#||

;;; (i) straight resource graph...

;;; the globals are kept for the time being in case some obscure code
;;; somewhere uses them, but most of the work should be done by the
;;; frame slots...

(defun CREATE-A-RESOURCE-GRAPH (system)
  (let ((window-name (concatenate 'string
		       "Systemic resource graph: "
		       (string system))))
    (setf *root-system* system)
    (setf *region-graphing-mode* nil)
    (setf *graphed-region* 
      (if (gethash system kpml::system-table)
	  (kpml::fetch-system-region 
	   (kpml::monolingualize-node system))
	(kpml::fetch-system-region
	 (first
	  (kpml::who-has-as-output 
	   (kpml::monolingualize-node system))))))

    (setf *resource-grapher*
      (clim:make-application-frame
       'systemic-resource-graph
       :pretty-name window-name
       :left 10 :top 10
       :width *resource-graph-width*
       :height *resource-graph-height*))
    (setf (slot-value *resource-grapher* 'mode) :single)
    (setf (slot-value *resource-grapher* 'regions) (list *graphed-region*))
    (setf (slot-value *resource-grapher* 'root-systems) (list *root-system*))
    (setf (slot-value *resource-grapher* 'languages) (list kpml::curlan))
    (setf (slot-value *resource-grapher* 'region-graphing-mode) 
		      *region-graphing-mode*)

    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	    *package* *resource-grapher* *graphed-region* *graphed-regions* 
	    *root-system*))))

;;; (ii) creating a region...

(defun CREATE-A-REGION-GRAPH (region)
  (let ((window-name (concatenate 'string
		       "Systemic region graph: "
		       (string region))))
    (setf *region-graphing-mode* t)
    (setf *graphed-region* region)
    (setf kpml::*resource-graphing-region-restricted?* t)
    (setf *resource-grapher*
	  (clim:make-application-frame
	   'systemic-resource-graph
	   :pretty-name window-name
	   :left 10 :top 10
	   :width *resource-graph-width* 
	   :height *resource-graph-height*))
    (setf (slot-value *resource-grapher* 'mode) :region)
    (setf (slot-value *resource-grapher* 'regions) (list *graphed-region*))
    (setf (slot-value *resource-grapher* 'languages) (list kpml::curlan))
    (setf (slot-value *resource-grapher* 'region-graphing-mode) T)
    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	    *package* *resource-grapher* *graphed-region* *graphed-regions* 
	    *root-system*))))

;;; (iii) And the contrastive case for the multilingual region graph...


(defun CREATE-A-CONTRASTIVE-REGION-GRAPH (region)
  (let ((window-name (concatenate 'string
		       "systemic-resource-graph (multilingual): region "
		       (string region)))
	(mode :ml-region))
    
    (setf kpml::*contrastive-graphing-languages*
	  (let ((language-set (if kpml::*languages-in-focus*
				  kpml::*languages-in-focus*
				kpml::all_languages)))
	    (cond ((> (length language-set) 2)
		   (setf mode :ml>2-region)
		   (when (and (> (length language-set) 7)
                              (eq *contrastive-label-mode* :color))
                     (kpml::warning
                      "Too many languages for a contrastive view using distinctive colors! ("
                      (length language-set)
                      ") Using language abbreviations instead.")
                     (setf *contrastive-label-mode* :abbreviations))
                   language-set)
		  ((< (length language-set) 2)
		   (kpml::warning 
		    "Not enough languages for a contrastive view!")
		   (return-from create-a-contrastive-region-graph nil))
		  (t 
		   (setf mode
		     (case *bilingual-style*
		       (:bilingual :ml-region)
		       (:multilingual :ml>2-region)))
		   language-set))))

    (setf *region-graphing-mode* t)
    (setf *graphed-region* region)
    (setf kpml::*resource-graphing-region-restricted?* t)
    (setf *resource-grapher*
	  (clim:make-application-frame
	   'systemic-resource-graph
	   :pretty-name window-name
	   :left 10 :top 10
	   :width *resource-graph-width* 
	   :height *resource-graph-height*))
    (setf (slot-value *resource-grapher* 'mode) mode)
    (setf (slot-value *resource-grapher* 'regions) (list *graphed-region*))
    (setf (slot-value *resource-grapher* 'languages) 
      kpml::*contrastive-graphing-languages*)
    (setf (slot-value *resource-grapher* 'region-graphing-mode) T)
    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	    *package* *resource-grapher* *graphed-region* *graphed-regions*
	    *root-system*))))

;;; (iv) contrastive resource graphs...  

(defun CREATE-A-CONTRASTIVE-RESOURCE-GRAPH (system)
  (let ((old-curlan kpml::curlan)
	(window-name (concatenate 'string
		       "Systemic resource graph (multilingual): "
		       (string system)))
	(mode :ml))

    (setf kpml::*contrastive-graphing-languages*
	  (let ((language-set (if kpml::*languages-in-focus*
				  kpml::*languages-in-focus*
				kpml::all_languages)))
	    (cond ((> (length language-set) 2)
		   (setf mode :ml>2)
		   (if (> (length language-set) 7)
		       (progn
			 (kpml::warning
			  "Too many languages for a contrastive view! ("
			  (length language-set)
			  "). Taking first 7.")
			 (subseq language-set 0 7))
		     language-set))
		  ((< (length language-set) 2)
		   (kpml::warning 
		    "Not enough languages for a contrastive view!")
		   (return-from CREATE-A-CONTRASTIVE-RESOURCE-GRAPH nil))
		  (t 
		   (setf mode
		     (case *bilingual-style*
		       (:bilingual :ml)
		       (:multilingual :ml>2)))
		   language-set))))

      (setf *region-graphing-mode* nil)
      (setf *graphed-regions* 
	    (remove-duplicates
	     (loop for lg in kpml::*contrastive-graphing-languages*
		   collect
		   (progn ()
			  (setf kpml::curlan lg)
			  (kpml::fetch-system-region 
			   (kpml::monolingualize-node system))))))
      (setf kpml::curlan old-curlan)
      (setf *root-system* system)
      
      (setf *resource-grapher*
	    (clim:make-application-frame
	     'systemic-resource-graph
	     :pretty-name window-name
	     :left 10 :top 10
	     :width *resource-graph-width*
	     :height *resource-graph-height*))

      (setf (slot-value *resource-grapher* 'mode) mode)
      (setf (slot-value *resource-grapher* 'root-systems) (list *root-system*))
      (setf (slot-value *resource-grapher* 'regions) *graphed-regions*)
      (setf (slot-value *resource-grapher* 'languages) 
	kpml::*contrastive-graphing-languages*)
      (setf (slot-value *resource-grapher* 'region-graphing-mode) nil)
      (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	    *package* *resource-grapher* *graphed-region* *graphed-regions* 
	    *root-system*))))
  
;;; (v) for KPML *e versions...
;;; Experimental stratum graphing...

(defun CREATE-A-STRATUM-GRAPH (stratum)
  (let ((root-systems (kpml::who-has-as-input stratum)))

    (setf *region-graphing-mode* nil
	  *graphed-stratum* stratum
	  *graphed-region* (kpml::fetch-system-region 
			    (kpml::monolingualize-node (first root-systems))))
    
    (setf kpml::*resource-graphing-region-restricted?* t)
    (setf *root-system* (first root-systems))

    (setf *resource-grapher*
	  (clim:make-application-frame
	   'systemic-resource-graph
	   :left 10 :top 10
	   :width *resource-graph-width*
	   :height *resource-graph-height*))

    (setf (slot-value *resource-grapher* 'mode) :stratum)
    (setf (slot-value *resource-grapher* 'root-systems) root-systems)
    (setf (slot-value *resource-grapher* 'regions) (list *graphed-region*))
    (setf (slot-value *resource-grapher* 'languages) (list kpml::curlan))
    (setf (slot-value *resource-grapher* 'region-graphing-mode) nil)
    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	   *package* *resource-grapher* *graphed-region* *graphed-regions* 
	   *root-system*))))


;;; (vi)
;;; Graphs from arbitary collections of features...

(defun CREATE-A-RESOURCE-GRAPH-FROM-FEATURES (feature-list)
  (let ((window-name "Systemic resource graph from features"))
    (setf *region-graphing-mode* nil)
    (setf *graphed-regions* 
	  (remove-duplicates
	   (loop for f in feature-list
		 collect
		 (kpml::fetch-system-region 
		  (first (kpml::who-has-as-output f))))))
    (setf *resource-grapher*
	  (clim:make-application-frame
	   'systemic-resource-graph
	   :pretty-name window-name
	   :left 10 :top 10
	   :width *resource-graph-width*
	   :height *resource-graph-height*))

    (setf (slot-value *resource-grapher* 'mode) :collection)
    (setf (slot-value *resource-grapher* 'root-systems) feature-list)
    (setf (slot-value *resource-grapher* 'regions) *graphed-regions*)
    (setf (slot-value *resource-grapher* 'languages) (list kpml::curlan))
    (setf (slot-value *resource-grapher* 'region-graphing-mode) nil)
    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	   *package* *resource-grapher* *graphed-region* *graphed-regions* 
	   *root-system*))))

||#

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

(defun LABEL-RESOURCE-GRAPH-LANGUAGES (stream mode)
  (if *monochrome?*
      (format stream "Languages:~{ ~A~}~5%~0T" 
	      kpml::*contrastive-graphing-languages*)
    (progn
      (format stream "Languages: ")
      (case mode
	((:ml :ml-region)
	 (clim:with-drawing-options 
	     (stream :ink clim:+red+)
	   (format stream "~a " 
		   (first kpml::*contrastive-graphing-languages*)))
	 (clim:with-drawing-options 
	     (stream :ink clim:+blue+)
	   (format stream "~a " 
		   (second kpml::*contrastive-graphing-languages*)))
	 )
	((:ml>2 :ml>2-region)
	 (loop for l in kpml::*contrastive-graphing-languages*
	     as i from 0
	     with n = (min (length kpml::*contrastive-graphing-languages*) 7)
	     do 
	       (clim:with-drawing-options 
		   (stream :ink (clim:make-contrasting-inks n (min i 6)))
		 (format stream "~a " l)))))
      (format stream "~5%~0T"))))



;;; ----------------------------------------------------------------------
;;; Commands... References to the current process replaced by proper
;;;   reference to the (always correctly bound) frame.

(define-systemic-resource-graph-command 
  (com-QUIT-RESOURCE-GRAPHER :name "Quit" :menu T)
  ()
  (close-a-window clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; Now the commands get changed to use the frame-slots...

(define-systemic-resource-graph-command 
  (com-DISPLAY-MODES :name "Modes"  :menu T)
  ()
  (resource-grapher-display-modes-from-grapher)
  (with-slots (root-systems regions mode region-graphing-mode) 
      clim:*application-frame*
    (case *replace-current-graph* 
      (printgraph 
       (setf *replace-current-graph* 'no)
       (hardcopy-graph 
	(merge-pathnames *default-kpml-hardcopy-directory* 
			 (make-hardcopy-filename 
			  (if kpml::*resource-graphing-region-restricted?*
			      (first regions) "GRAPH")))
	(not *suitable-for-figures?*)
	clim:*application-frame*))
      (yes
       (if region-graphing-mode
	   (create-a-region-graph (first regions) :frame-tool-label (first regions))
	 (create-a-resource-graph 
          (first root-systems) :frame-tool-label (first root-systems)))
       (close-a-window clim:*application-frame*))
      (no
       (if region-graphing-mode
	   (create-a-region-graph (first regions) :frame-tool-label (first regions))
	 (create-a-resource-graph 
          (first root-systems) :frame-tool-label (first root-systems))))
      (no-action nil))))

;;; ----------------------------------------------------------------------
;;; first attempt at being able to get hardcopies...
;;; (seems to work well enough... adopted as standard: 0.9)

;;; 0.9.31 :kr mode added...
;;; Note that hardcopy of semantics only works from the Print Graph
;;; command in the resource grapher. 

;;; ACLPC, ACL3.0 CLIM2.1 does not appear to know about postscript!
;;; Lispworks4 PC too!

#-(or acl3.0 (and lispworks (not postscript-clim)))
(define-systemic-resource-graph-command 
    (com-PRINTGRAPH-RG :name "Print Graph" :menu T)
    ()
  (with-slots (mode regions) clim:*application-frame*
    (case mode
      (:kr
       (hardcopy-kr-graph 
	(merge-pathnames *default-kpml-hardcopy-directory* 
			  (make-hardcopy-filename "SEMANTICS"))
	(not *suitable-for-figures?*)
	clim:*application-frame*))
      (otherwise
       (hardcopy-graph 
	(merge-pathnames  *default-kpml-hardcopy-directory* 
			  (make-hardcopy-filename 
			   (if kpml::*resource-graphing-region-restricted?* 
			       (first regions)
			     "GRAPH")))
	(not *suitable-for-figures?*)
	clim:*application-frame*)
       ))
    ;; 4.0 ... added an explicit redisplay here to make
    ;;         sure (or to try to!) that the graph gets
    ;;         completely drawn again after the command...
    (clim:redisplay-frame-pane clim:*application-frame* 'graph)
    ))


(define-systemic-resource-graph-command 
  (com-COLLECT-FEATURE :name t)
  ((object 'resource-graph-node :gesture :select))
  (let ((node (kpml::monolingualize-node object)))
    (if (gethash node kpml::all-output-features)
	(pushnew node kpml::*collected-features*)
      (kpml::warning Node " not a feature!"))))

(define-systemic-resource-graph-command 
  (com-UNCOLLECT-FEATURE :name t)
  ((object 'resource-graph-node :gesture :select))
  (let ((node (kpml::monolingualize-node object)))
    (if (gethash node kpml::all-output-features)
	(setf kpml::*collected-features*
	  (remove node kpml::*collected-features*))
      (kpml::warning Node " not a feature!"))))


(define-systemic-resource-graph-command 
  (com-CLEAR-COLLECTED-FEATURES :name t :menu nil)
  ()
  (setf kpml::*collected-features* '()))

(define-systemic-resource-graph-command 
    (com-SHOW-COLLECTED-ALWAYS  :name t :menu nil)
    ()
  (setf *show-collecteds* :always))

(define-systemic-resource-graph-command 
    (com-SHOW-COLLECTED-CONDITIONAL  :name t :menu nil)
    ()
  (setf *show-collecteds* T))

(define-systemic-resource-graph-command 
    (com-SHOW-COLLECTED-NEVER :name t :menu nil)
    ()
  (setf *show-collecteds* nil))


(define-systemic-resource-graph-command 
  (com-SHOW-EXAMPLES-WITH-FEATURE :name t)
  ((object 'resource-graph-node :gesture :select))
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (feature (kpml::monolingualize-node object))
	 (examples (kpml::get-examples-with-features (list feature))))
    (cond ((gethash feature kpml::all-output-features)
	   (when *display-examples*
	     (bring-up-a-list-of-examples (list feature)))
	   (kpml-i-terpri stream)
	   (if examples
	       (progn 
		 (pen-pprint-for-clim 
		  (format nil "Examples using feature: ~A are~%" feature)
		  ':string stream)
		 (dolist (ex examples)
		   (clim:with-output-as-presentation
		       (stream ex 'example-name)
		     (format stream "~A " ex))))
	     (format stream "No examples use: ~A ~%" feature)))
	  (t
	   (when (and *display-examples* 
		      (kpml::fetch-output-features feature))
	     (bring-up-a-list-of-examples 
	      (kpml::fetch-output-features feature)))
	   (kpml::warning feature " not a feature!")))))



(define-systemic-resource-graph-command 
  (com-SHOW-CHOOSER-FOR-GRAPH-NODE :name t)
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object)))
    (cond ((gethash node kpml::system-table)
	   (when (kpml::fetch-system-chooser node)
	     (kpml::describe-chooser (kpml::fetch-system-chooser node))))
	  ((gethash node kpml::all-output-features)
	   (loop for s in (kpml::who-has-as-output node)
	       when (kpml::fetch-system-chooser s)
	       do (kpml::describe-chooser (kpml::fetch-system-chooser s))))
	  (t nil))))


(define-systemic-resource-graph-command 
  (com-TRACE-INQUIRIES-INFLUENCING-GRAPH-NODE :name t)
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object)))
    (cond ((gethash node kpml::system-table)
	   (let ((ch (kpml::fetch-system-chooser node)))
	     (when ch
	       (loop for inq in (kpml::inquiries-of-chooser ch)
		   do (push (cons ch inq) 
			    kpml::*traced-chooser-inquiries*)))))
	  ((gethash node kpml::all-output-features)
	   (let ((chs (loop for s in (kpml::who-has-as-output node)
			  when (kpml::fetch-system-chooser s)
			  collect (kpml::fetch-system-chooser s))))
	     (loop for ch in chs
		 do (loop for inq in (kpml::inquiries-of-chooser ch)
			do (push (cons ch inq) 
				 kpml::*traced-chooser-inquiries*)))))
	  (t nil))))


(define-systemic-resource-graph-command 
  (com-DELETE-SYSTEM-FROM-GRAPH :name "Delete Associated System")
    ;; 2.0.30
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object))
	 (system 
	  (cond ((gethash node kpml::system-table) node)
		(t (first (kpml::who-has-as-output node))))))
    (when system
      (with-slots (languages) clim:*application-frame*
	(loop for curlan in languages
	    do (let ((kpml::curlan curlan))
		 (kpml::delete-system system)))))))

;;; ----------------------------------------------------------------------
;;; 0.8.23 activation of mailing...
;;; 2.1    parameterizable things moved to KPML package...
;;; ----------------------------------------------------------------------

#+unix
(define-systemic-resource-graph-command 
    (com-MAIL-INTENTION-TO-WORK :name t :menu T)
    ()
  #-(or LUCID ALLEGRO)
  (clim:notify-user 
   clim:*application-frame*
   "Message sending not supported for non-Lucid,
non-Allegro, or non-Unix systems.
Please send mail yourself.")
  #+(or LUCID ALLEGRO)
  (let* ((message 
	  (format 
	   nil
	   ";;; KPML Sending mail to register intention of working on region: ~A"
	   (first (slot-value clim:*application-frame* 'regions))))
	 (mail-command (concatenate 'string
			 "echo \"" message "\" | "
			 kpml::*mail-command*
			 (let ((recipients " "))
			   (loop for r in kpml::*kpml-mail-recipient-list*
			       do (setf recipients
				    (concatenate 'string 
				      recipients r " ")))
			   recipients))))

    (format *trace-output* "~%~A" message)
  
    #+LUCID(lcl::shell mail-command)
    #+ALLEGRO(excl::run-shell-command mail-command)))

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

(define-systemic-resource-graph-command 
  (com-SHOW-EXAMPLES-WITH-COLLECTED-FEATURES :name t :menu nil)
  ()
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	(examples (kpml::get-examples-with-features 
		   kpml::*collected-features*)))
    (kpml-i-terpri stream)
    (if examples
	(progn 
	  (pen-pprint-for-clim 
	   (format nil "Examples using features: ~A are~%" 
		   kpml::*collected-features*)
	   ':string stream)
	  (dolist (ex examples)
		  (clim:with-output-as-presentation
		   (stream ex 'example-name)
		   (format stream "~A " ex))))
      (format stream "No examples use: ~A ~%" kpml::*collected-features*))))


;;;----------------------------------------------------------------------
;;; Graphing options menus, etc.

;;; The clim:null-or-type presentation does not appear to work, so
;;; replaced here with a hack---can only use integers... for no depth,
;;; give something big.
;;;
;;; 2.0.34
;;; Added control of width of realization boxes...
;;; ----------------------------------------------------------------------

(defun RESOURCE-GRAPHER-DISPLAY-MODES-FROM-KPML  
    (&optional
     (stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (grapher-display-modes nil stream))  ;; 0.9.32b (name was wrong)




(defun GRAPHER-DISPLAY-MODES (from-grapher stream)
  (clim:accepting-values
   (#-acl3.0 stream #+acl3.0 *query-io* :own-window *own-window*
	   :scroll-bars :vertical
	   :height 250
	   :resynchronize-every-pass t
	   :label "Resource Grapher Display Modes" :exit-boxes 
	   '((:exit "Click here to exit")(:abort "")))
   (let ((stream #-acl3.0 stream #+acl3.0 *query-io*))
     (on-or-off kpml::*resource-graphing-region-restricted?*
		"Graphing restricted by region   .........")
     (radio-box-accept *show-realizations-in-graphs*  ;; 1.0.28
                       (member :always :used :never) 
                       "Realization statements shown  ...........")
     ;;; 0.9.42   
     (when (eq kpml::*ml-graphing-mode* :multilingual)
	   (kpml-i-terpri stream)
	   (on-or-off kpml::*preserve-systems-in-ml-graphs*
		      "System integrity preserved   ............")
	   (kpml-i-terpri stream)
           (radio-box-accept *bilingual-style* (:bilingual :multilingual) 
                             "View bilingual graphs as ................")
           (radio-box-accept *contrastive-label-mode*
                             *contrastive-label-options*
                             "Contrastive graph labelling mode ....... ")
           )
     ;; 2.0.34
     (kpml-i-terpri stream)
     (setq kpml::*rs-box-width*
	   (clim:accept 
	    'clim:integer :stream stream
	    #+lispworks :view #+lispworks clim:+textual-dialog-view+
	    :prompt "Width of realization statement boxes ...."
	    :default kpml::*rs-box-width*))
     (kpml-i-terpri stream)
     (setq *resource-graph-depth*
	   (clim:accept ;; 0.9.32 following does not work
	    ;;'(clim::null-or-type integer) 
	    'clim:integer :stream stream
	    #+lispworks :view #+lispworks clim:+textual-dialog-view+
	    :prompt "Maximum depth                ............"
	    :default *resource-graph-depth*))
     (radio-box-accept kpml::curlan kpml::all_languages "Current language             ............")
     (kpml-i-terpri stream)
     (setf *vertical-scaling*
       (clim:accept 
	'integer :stream stream
	#+lispworks :view #+lispworks clim:+textual-dialog-view+
	:prompt "Delicacy scaling             ............"
	:default *vertical-scaling*))
     (kpml-i-terpri stream)
     (setf *inter-generation-scaling*
       (clim:accept 'integer :stream stream
		    #+lispworks :view #+lispworks clim:+textual-dialog-view+
		    :prompt "Inter-generation scaling     ............"
		    :default *inter-generation-scaling*))
     (kpml-i-terpri stream)
     (setf *hardcopy-vertical-scaling*
	   (clim:accept 'integer :stream stream
			#+lispworks :view #+lispworks clim:+textual-dialog-view+
			:prompt "Hardcopy vertical scaling    ............"
			:default *hardcopy-vertical-scaling*))
     (kpml-i-terpri stream)
     (setf *default-kpml-hardcopy-directory*
       (clim:accept 
	'clim:pathname :stream stream
	#+lispworks :view #+lispworks clim:+textual-dialog-view+
	:prompt "Hardcopy directory           ............"
	:default *default-kpml-hardcopy-directory*))
     (kpml-i-terpri stream)
     (on-or-off *grapher-header* "Hardcopy with header         ............")
     (kpml-i-terpri stream)
     (when from-grapher
       ;; 4.0 changed so that orientation is not even offered if
       ;;     we are committed to systemic notation, which is not
       ;;     the case if we are graphing semantics anyway...
       (when (or (not kpml::*systemic-notation*)
		 (equal (slot-value *resource-grapher* 'mode) :kr))
         (radio-box-accept *resource-graph-orientation* (:vertical :horizontal)
                           "Graph orientation .......................")
         (on-or-off *suitable-for-figures?* "Suitable for eps (ie. not multipage)?  ..")
         (radio-box-accept *replace-current-graph* (yes no printgraph no-action)
                           "Replace current graph        ............"))
         )
     )))

(defun SELECT-A-REGION-MENU () 
  (let ((region-list (kpml::get-regions)))
    (cond ((equal (length region-list) 0)
	   nil)
	  ((equal (length region-list) 1)
	   (first region-list))
	  (t
	   (menu-choose region-list
			:n-columns 3
			:scroll-bars :vertical
			:max-height 400
			:associated-window 
			(clim:frame-top-level-sheet clim:*application-frame*)
			:label "Select a region...")))))


;;; ----------------------------------------------------------------------
;;; Node printing functions...
;;; 1.1 many extensions over 1.0, including customizeable views and
;;;     unified graph node structures.
;;; 4.0 collect information for export.

(defun PRINT-RESOURCE-GRAPH-NODES (object+type stream)
  (when *collect-information-for-export*
    (push object+type *collected-export-information*))
  (clim:with-text-size (stream *resource-graph-feature-size*)
    (if (systemic-graph-node-p object+type)
      (let ((object (systemic-graph-node-value object+type)))
	(case (systemic-graph-node-type object+type)
	  (kpml::stub
	   (clim:with-output-as-presentation
	       (stream object 'resource-graph-stubb)
	     (format stream "...")))
	  (kpml::combi
	   (clim:with-output-as-presentation
	       (stream (cdr object) 'combined-displayed-feature)
	     (format stream "~A" (car object))))
	  (kpml::path-s
	   (clim:with-output-as-presentation
	       (stream object 'path-continuation-option)
	     (clim:with-drawing-options 
		 (stream :ink clim:+blue+)
	       (format stream "~A" (kpml::grammar-node-label object)))))
	  (kpml::path-f
	   (clim:with-output-as-presentation
	       (stream object 'path-continuation-option)
	     (clim:with-drawing-options 
		 (stream :ink clim:+blue+)
	       (format stream "~A" object))))
	  (kpml::system
           (clim:with-text-size (stream *resource-graph-system-name-size*)
	     (cond (kpml::*region-external-links-visible?*
		    (region-external-sensitive-node-print 
		     object+type stream))
		   (t
		    (let ((name (kpml::grammar-node-label object)))
		      (if kpml::*systemic-notation*
			  (if *show-system-names*
			      nil ;; not done here anymore...
			    (clim:with-output-as-presentation 
			        (stream object 'resource-graph-node)
			      (format stream " ")))
		        (if *show-system-names*
			    (clim:surrounding-output-with-border
			        (stream :shape :rectangle)
			      (print-possibly-disabled-system-name object name))
			  (clim:with-output-as-presentation 
			      (stream object 'resource-graph-node)
			    (format stream " ")))))))))
	   (t		;; features come though here...
	   (cond ((and *graph-display-mode*
		       (member object *combined-feature-set*))
		  (clim:with-drawing-options 
		      (stream :ink clim:+cyan+)
		    (present-feature-as-node stream object)))
		 ((feature-on-generation-path-p object)
		  (clim:with-drawing-options 
		      (stream :ink *resource-foreground-colour*)
		    (present-feature-as-node stream object)))
		 (t
                  (clim:with-drawing-options 
		      (stream :ink *resource-background-colour*)
		    (present-feature-as-node stream object))))
	   )))
    (format stream "~a" object+type))))


(defun PRESENT-FEATURE-AS-NODE (stream object)		      
  (let* ((feature (kpml::grammar-node-label object))
	 (used-in-systems (kpml::who-has-as-output feature)))
    (macrolet 
	((print-it ()
	   '(clim:with-text-size (stream *resource-graph-feature-size*)
	     (clim:with-output-as-presentation 
		 (stream object 'resource-graph-node)
	       (if (or (eq *show-realizations-in-graphs* :always)
		    (and (eq *show-realizations-in-graphs* :used)
			 (feature-on-generation-path-p object)))
		   (kpml::pp-feature-with-rs object stream)
		 (format stream 
		  ;; 2.0.9
		  (if kpml::*systemic-notation* "~(~a~)" "~a")
		  feature))))))
      (if (loop for s in used-in-systems
	      thereis (kpml::fetch-disabled-system s))
	  (clim:with-drawing-options
	      (stream :ink *grey*)
	    (print-it))
	(print-it)))))

(defun REGION-EXTERNAL-SENSITIVE-NODE-PRINT (node stream)
  (let ((object (systemic-graph-node-value node))
	(type   (systemic-graph-node-type node)))
  (with-slots 
   (regions) clim:*application-frame*  ;; 1.1 was getting out of step 
   (cond ((eq type 'kpml::system)
	  (if (member (kpml::fetch-system-region object) regions)
	      (cond 
	       ((and *show-system-names* kpml::*systemic-notation*)
		;; if systemic notation, do all the system names
		;; separately.
		nil)
	       (*show-system-names*
		(clim:surrounding-output-with-border
		    (stream :shape :rectangle)
		  (let ((name (kpml::grammar-node-label object)))
		    (if (kpml::region-external-system-inputs-p
			 object (first regions))
			(clim:with-text-style  
			    (stream *fix--bold-italic--10*)
			  (print-possibly-disabled-system-name object name))
		      (print-possibly-disabled-system-name object name)))))
	       (t
		(format stream " ")))
	    (clim:with-text-style 
		(stream *sans-serif--italic--8*)
	      (clim:with-output-as-presentation 
		  (stream object 'resource-graph-node)
		(format stream "...~a [~a]" 
			(kpml::grammar-node-label object)
			(kpml::fetch-system-region object))))))
	 (t
	  (clim:with-output-as-presentation 
	      (stream object 'resource-graph-node)
	    (format stream "~a" (kpml::grammar-node-label object))))))))
	 

;;;----------------------------------------------------------------------
;;; Contrastive graphing added, 0.8. Needs distinctive node printing
;;; methods...

(defun PRINT-CONTRASTIVE-RESOURCE-GRAPH-NODES (type+status+object stream)
  (clim:with-text-size (stream *resource-graph-feature-size*)
    (cond ((not (kpml-i::systemic-graph-node-p type+status+object))
	   (format stream "~a" type+status+object))
	  (t
	   (let ((object (systemic-graph-node-value type+status+object))
		 (type (systemic-graph-node-type type+status+object))
		 (status (systemic-graph-node-status type+status+object)))
	     (cond ((eq type 'kpml::stub)
		    (clim:with-output-as-presentation
			(stream object 'resource-graph-stubb)
		      (format stream "...")))
		   ((eq type 'kpml::combi)
		    (clim:with-output-as-presentation
			(stream (cdr object) 'combined-displayed-feature)
		      (format stream "~A" (car object))))
		   ((eq type 'kpml::system)
		    (cond (kpml::*region-external-links-visible?*
			   (contrastive-region-external-sensitive-node-print 
			    status object stream))
			  (*show-system-names* 
			   (if *careful-graphing*
			       nil ;; not done here anymore...
                             (clim:with-text-size (stream *resource-graph-system-name-size*)
			       (contrasting-system-nodes status object stream))))
			  (t 
			   (clim:with-output-as-presentation 
			       (stream object 'resource-graph-node)
			     (format stream " ")))))
		   (t		
		    (clim:with-output-as-presentation 
			(stream object 'resource-graph-node)
		      (contrasting-feature-nodes status object stream)
		      ))))))))


(defun SHARED-STATUS (system lg1 lg2)
  (let ((defined-lg1 (kpml::system-defined-for-lg-p system lg1))
	(defined-lg2 (kpml::system-defined-for-lg-p system lg2)))
    (cond ((and defined-lg1 defined-lg2)
	   :shared)
	  (defined-lg1
	    :in-1)
	  (defined-lg2
	    :in-2))))
  
(defun CONTRASTING-FEATURE-NODES (status object stream)
  (macrolet ((fs () 
	       '(format stream 
		 (if kpml::*systemic-notation* "~(~a~)" "~a")
		 (kpml::grammar-node-label object))))
    (if *monochrome?*
	(case status
	  (:shared (fs))
	  (:in-1
	   (format stream "~a:" (first kpml::*contrastive-graphing-languages*))
	   (fs))
	  (:in-2
	   (format stream "~a:" 
		   (second kpml::*contrastive-graphing-languages*))
	   (fs)))
      (case status
	(:shared
	 (clim:with-drawing-options (stream :ink clim:+black+) (fs)))
	(:in-1
	 (clim:with-drawing-options (stream :ink clim:+red+) (fs)))
	(:in-2
	 (clim:with-drawing-options (stream :ink clim:+blue+) (fs)))))
    (when (or (eq *show-realizations-in-graphs* :always)
	      (and (eq *show-realizations-in-graphs* :used)
		   (feature-on-generation-path-p object)))
      (let* ((*standard-output* stream)
	     (*print-right-margin* 30)
	     (rs-set (loop for lg in kpml::*contrastive-graphing-languages*
			 thereis
			   (let ((kpml::curlan lg))
			     (kpml::fetch-realization-statements-of-feature
			      object)))))
	(kpml::pp-rs 
	 stream object rs-set kpml::*contrastive-graphing-languages*)
	))))


(defun CONTRASTING-SYSTEM-NODES (status object stream)
  (if *monochrome?* 
      (monochrome-contrasting-resource-nodes status object stream)
    (color-contrasting-resource-nodes status object stream)))


(defun MONOCHROME-CONTRASTING-RESOURCE-NODES (status object stream)
  (case status
	(:shared
	 (clim:surrounding-output-with-border
	  (stream :shape :rectangle)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:surrounding-output-with-border
	    (stream :shape :rectangle)
	    (clim:with-output-as-presentation 
	     (stream object 'resource-graph-node)
	     (format stream "~a" (kpml::grammar-node-label object)))))))
	(:in-1
	 (clim:surrounding-output-with-border
	  (stream :shape :rectangle)
	  (clim:with-output-as-presentation 
	   (stream object 'resource-graph-node)
	   (format stream "~a:~a" 
		   (first kpml::*contrastive-graphing-languages*)
		   (kpml::grammar-node-label object)))))
	(:in-2 
	 (clim:surrounding-output-with-border
	  (stream :shape :rectangle)
	  (clim:with-output-as-presentation 
	   (stream object 'resource-graph-node)
	   (format stream "~a:~a" 
		   (second kpml::*contrastive-graphing-languages*)
		   (kpml::grammar-node-label object)))))))


;;; Use macro with-ml-color-contrast when working...

(defun COLOR-CONTRASTING-RESOURCE-NODES (status object stream)
  (case status
	(:shared
	 (clim:with-drawing-options 
	  (stream :ink clim:+black+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    (format stream "~a" (kpml::grammar-node-label object))))))
	(:in-1
	 (clim:with-drawing-options
	  (stream :ink clim:+red+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    (format stream "~a" (kpml::grammar-node-label object))))))
	(:in-2 
	 (clim:with-drawing-options
	  (stream :ink clim:+blue+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    (format stream "~a" (kpml::grammar-node-label object))))))))


(defun CONTRASTIVE-REGION-EXTERNAL-SENSITIVE-NODE-PRINT (status object stream)
  (cond ((gethash object kpml::system-table)
	 (if (member (kpml::fetch-system-region object) *graphed-regions*)
	     (cond (kpml::*systemic-notation*
		    nil)
		   (*show-system-names* 
                    (clim:with-text-size (stream *resource-graph-system-name-size*)
		      (clim:surrounding-output-with-border
			  (stream :shape :rectangle)
		        (clim:with-output-as-presentation 
			    (stream object 'resource-graph-node)
			  (if (kpml::contrastive-region-external-system-inputs-p
			       object *graphed-regions*)
			      (clim:with-text-style 
				  (stream *fix--bold-italic--10*)
			        (contrasting-system-nodes status object stream))
			    (contrasting-system-nodes status object stream))))))
		   (t
                    (clim:with-text-size (stream *resource-graph-feature-size*)
		      (clim:with-output-as-presentation 
			  (stream object 'resource-graph-node)
		        (format stream " ")))))
	   (clim:with-text-style 
	    (stream *sans-serif--italic--8*)
	    (clim:with-output-as-presentation 
	     (stream object 'resource-graph-node)
	     (format stream "...~a [~a]" 
		     (kpml::grammar-node-label object)
		     (kpml::fetch-system-region object))))))
	(t
         (clim:with-text-size (stream *resource-graph-feature-size*)
	   (clim:with-output-as-presentation 
	       (stream object 'resource-graph-node)
	     (contrasting-feature-nodes status object stream))
	  ))))

;;; ----------------------------------------------------------------------
;;; 2.0 general multilingual graphs with any number of languages shown...
;;;     option: languages can be identified by color or by a language
;;;             label from the following list... setup to reflect the
;;;             standard language abbreviations... 
;;;
;;;             The color ticks as superscript
;;;             flag controls whether color ticks appear following
;;;             feature names as superscripts are appear underneath
;;;             the feature name.

(defvar *contrastive-label-options* '(:color :abbreviations))
(defvar *contrastive-label-mode*    :color)
(defvar *color-ticks-as-superscripts* T)

(defun PRINT-GENERAL-CONTRASTIVE-RESOURCE-GRAPH-NODES 
    (type+status+object stream)
  (clim:with-text-size (stream *resource-graph-feature-size*)
    (cond ((not (systemic-graph-node-p type+status+object))
	   (format stream "~a" type+status+object))
	  (t
	   (let ((object (systemic-graph-node-value type+status+object))
		 (type (systemic-graph-node-type type+status+object))
		 (status (systemic-graph-node-status type+status+object)))
	     (cond ((eq type 'kpml::stub)                      ;; first two
		    (clim:with-output-as-presentation          ;; options stay
			(stream object 'resource-graph-stubb)     ;; as they
		      (format stream "...")))                   ;; were...
		   ((eq type 'kpml::combi)
		    (clim:with-output-as-presentation
			(stream (cdr object) 'combined-displayed-feature)
		      (format stream "~A" (car object))))
		   ((eq type 'kpml::system)
                    (clim:with-text-size (stream *resource-graph-system-name-size*)
		      (cond 
		       (kpml::*region-external-links-visible?*
		        (general-contrastive-region-external-sensitive-node-print 
		         status object stream))
		       (t
		        (general-contrasting-system-nodes status object stream)
		        ))))
		   (t		
		    (clim:with-output-as-presentation 
			(stream object 'resource-graph-node)
		      (general-contrasting-feature-nodes status object stream)
		      ))))))))

;;; Following is the same as the non-general version but for the 
;;; embedded function calls that do the work...
;;;
(defun GENERAL-CONTRASTIVE-REGION-EXTERNAL-SENSITIVE-NODE-PRINT 
    (status object stream)
  (cond ((gethash object kpml::system-table)
         (clim:with-text-size (stream *resource-graph-system-name-size*)
	   (if (member (kpml::fetch-system-region object) *graphed-regions*)
	       (if (kpml::contrastive-region-external-system-inputs-p
		    object *graphed-regions*)
		   (clim:surrounding-output-with-border
		       (stream :shape :rectangle)
		     (clim:with-text-style 
		         (stream *fix--bold-italic--10*)
		       (general-contrasting-system-nodes status object stream)))
	         (if kpml::*systemic-notation*
		     (format stream "")
		   (clim:surrounding-output-with-border
		       (stream :shape :rectangle)
		     (general-contrasting-system-nodes status object stream))))
	     (clim:with-text-style 
	         (stream *sans-serif--italic--8*)
	       (clim:with-output-as-presentation 
		   (stream object 'resource-graph-node)
	         (format stream "...~a [~a]" 
		         (kpml::grammar-node-label object)
		         (kpml::fetch-system-region object)))))))
	(t
         (clim:with-text-size (stream *resource-graph-feature-size*)
           (clim:with-output-as-presentation 
	       (stream object 'resource-graph-node)
	     (general-contrasting-feature-nodes status object stream))
	  ))))

(defun GENERAL-CONTRASTING-SYSTEM-NODES (status object stream)
  (clim:with-text-size (stream *resource-graph-system-name-size*)
    (clim:with-output-as-presentation 
	(stream object 'resource-graph-node)
      (format stream "~a" (kpml::grammar-node-label object)))))

(defun GENERAL-CONTRASTING-FEATURE-NODES (status object stream)
  (let* ((output-string 
	  (format nil "~(~a~)" (kpml::grammar-node-label object)))
	 (width (clim:stream-string-width stream output-string)))
    (multiple-value-bind (x y)
	(clim:stream-cursor-position stream)
      (clim:with-text-size (stream *resource-graph-feature-size*)
	(clim:with-drawing-options (stream :ink clim:+black+)
	  (format stream "~A" output-string))
	(let ((l (length kpml::*contrastive-graphing-languages*)))
	  (macrolet ((contrastive-color ()
		       '(clim:make-contrasting-inks 
			 (min l 7)      ;; make sure that when there are more
			 (min           ;; lgs the last color just repeats...
			  (position lg kpml::*contrastive-graphing-languages*) 
			  6))))         ;; max-limit comes first, then index.
	    (case *contrastive-label-mode*
	      (:color
	       (if *color-ticks-as-superscripts*
		   (clim:stream-set-cursor-position stream (+ x width)(- y 5))
		 (progn 
		   (format stream "~%")
		   (clim:stream-set-cursor-position stream (+ x 3)(+ y 15))))
	       (loop for lg in (reverse status)
		   do (kpml-tick stream :color (contrastive-color))
		      (format stream " ")))
	      (otherwise
	       (clim:stream-set-cursor-position stream (+ x width)(- y 5))
	       (if *monochrome?*
		   (loop for lg in (reverse status)
		       as abbrev = (cdr (assoc lg kpml::*contrastive-labels*))
		       do (clim:with-text-style (stream *lg-abbrev-style*)
			    (format stream " ~A" (if abbrev abbrev lg))))
		 (loop for lg in (reverse status)
		     as abbrev = (cdr (assoc lg kpml::*contrastive-labels*))
		     do (clim:with-drawing-options 
			    (stream :ink (contrastive-color))
			  (clim:with-text-style (stream *lg-abbrev-style*)
			    (format stream " ~A" 
				    (if abbrev abbrev lg))))))))))))))


;;; ----------------------------------------------------------------------
;;; 0.9 graph editing for improved displays, experimental...
;;; The following command when given stops graphing from the
;;; specified node; when the graph is redisplayed, the marked
;;; point is not gone beyond.

(define-systemic-resource-graph-command 
  (com-STOP-GRAPH-HERE :name t)
    ((object 'resource-graph-node :gesture :menu))
  (pushnew  (kpml::monolingualize-node object) *graph-stop-points*))

;;; ----------------------------------------------------------------------
;;; 2.1 added... can sometimes be a problem when system and feature
;;;              have the same name, because then we always get the
;;;              system!
;;; ----------------------------------------------------------------------

(define-systemic-resource-graph-command 
  (com-SPAWN-NEW-GRAPH-FROM-HERE :name t)
    ((object 'resource-graph-node :gesture :menu))
  (graph-under-current-options 
   (kpml::monolingualize-node object)))

;;; ----------------------------------------------------------------------
;;; 2.0 disabling/enabling added...
;;; ----------------------------------------------------------------------

(define-systemic-resource-graph-command 
  (com-ENABLE-DISABLE-SYSTEM :name "Enable/Disable Associated System")
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object))
	 (system 
	  (cond ((gethash node kpml::system-table) node)
		(t (first (kpml::who-has-as-output node))))))
    (if (kpml::fetch-disabled-system system)
	(kpml::enable-system system)
      (kpml::disable-system system))))

;;; ----------------------------------------------------------------------
;;; Blank space options...
;;; 4.0 clearing semantic stop lists added.
;;; ----------------------------------------------------------------------

(define-systemic-resource-graph-command 
  (com-BLANK-SPACE-OPTIONS :name t)
    ()
  (case
      (menu-choose
       '(("Regraph" :value :regraph)
	 ;; 2.0.33
         ("Reformat" :value :reformat)
	 ("Prune to generation path" :value :prune-to-path)
	 ("Clear graph stop points" :value :clear-stops)
	 ("Clear collected features" :value :clear-features)))
    (:regraph 
     (if *region-graphing-mode*
	 (graph-under-current-options *graphed-region* :region-flag T)
       (graph-under-current-options *root-system* :region-flag nil))
     (close-a-window clim:*application-frame*))
    (:clear-stops
     (setf *graph-stop-points* nil)
     (when (equal (slot-value clim:*application-frame* 'mode) :kr)
       (setf *kr-kill-point-list* nil))
     )
    (:clear-features
     (setf kpml::*collected-features* nil))
    ;; 2.0.33
    (:prune-to-path
     (setf *prune-to-generation-path-p* T)
     (clim:redisplay-frame-pane clim:*application-frame* 'graph)
     (setf *prune-to-generation-path-p* nil)
     )
    ;; 3.0
    (:reformat
     (graph-reformatter-dialog))))

(clim:define-presentation-to-command-translator resgraph-blank-space-options
    (clim:blank-area com-blank-space-options systemic-resource-graph
		     :documentation "Resource Graph Options")
  (x y)
  (declare (ignore x y))
  (values))


;;; ----------------------------------------------------------------------
;;; 3.0 inplace graph formatting modification...
;;; ----------------------------------------------------------------------

(defun GRAPH-REFORMATTER-DIALOG ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (clim:accepting-values
      (#-acl3.0 stream #+acl3.0 *query-io*  
                :own-window *own-window*
	        :label "Graph reformatting and font resizing"
	        :exit-boxes '((:exit "Click here to exit")(:abort "")))
      (let ((stream #-acl3.0 stream #+acl3.0 *query-io*))
        (format stream "System name size: (~A)" *resource-graph-system-name-size*)
        (hd-accepts *resource-graph-system-name-size* '(integer 1 30) "System name size"
                    '(clim:slider-view :show-value-p t))
        (kpml-i-terpri stream)
        (format stream "Feature size: (~A)" *resource-graph-feature-size*)
        (hd-accepts *resource-graph-feature-size* '(integer 1 30) "Feature size"
                    '(clim:slider-view :show-value-p t))
        (kpml-i-terpri stream)
        (format stream "Realizations size: (~A)" *resource-graph-rs-size*)
        (hd-accepts *resource-graph-rs-size* '(integer 1 30) "Realization size"
                    '(clim:slider-view :show-value-p t))
        (radio-box-accept *show-realizations-in-graphs* (:always :used :never)
                        "Realization statements shown  ...........")
        (kpml-i-terpri stream)
        (format stream "Box width: (~A)" kpml::*rs-box-width*)
        (hd-accepts kpml::*rs-box-width* '(integer 10 100) "Realization box width"
                    '(clim:slider-view :show-value-p t))
        (kpml-i-terpri stream)
        (format stream "Delicacy spacing: (~A)" *vertical-scaling*)
        (hd-accepts *vertical-scaling* '(integer 1 300) "Delicacy spacing"
                    '(clim:slider-view :show-value-p t))
        (kpml-i-terpri stream)
        (format stream "Intra-system feature spacing: (~A)" *inter-generation-scaling*)
        (hd-accepts *inter-generation-scaling* '(integer 1 300) "Intra-system Feature spacing"
                    '(clim:slider-view :show-value-p t))
        (kpml-i-terpri stream)
        (clim:redisplay-frame-pane clim:*application-frame* 'graph)))))


;;; ----------------------------------------------------------------------
;;; Trivial semantic grapher... using only the KB interface functions...
;;;
;;; Add updated form of semantic kr graphing...
;;; 0.9.31, 2.0.9
;;; ----------------------------------------------------------------------

(defvar *dont-name-graphed-kr-internals* T)

#|| ;;; Also in startups.lisp

(defun CREATE-A-SEMANTIC-RESOURCE-GRAPH (concept)
  (let ((window-name (concatenate 'string
			"systemic-resource-graph (semantics): "
			;; 2.0.9 was sometimes getting a concept-object
			;;       through here (with Loom) that string
			;;       was not (understandably) happy with...
			(string (kpml::kb-getconceptname concept)))))
    (setf *root-system* concept)
    (setf *region-graphing-mode* nil)
    (setf *graphed-region* nil)
    (setf *resource-grapher*
	  (clim:make-application-frame
	   'systemic-resource-graph
	   :pretty-name window-name
	   :left 10 :top 10
	   :width *resource-graph-width*
	   :height *resource-graph-height*))
    
    (setf (slot-value *resource-grapher* 'mode) :kr)
    (setf (slot-value *resource-grapher* 'regions) (list *graphed-region*))
    (setf (slot-value *resource-grapher* 'root-systems) (list *root-system*))
    (setf (slot-value *resource-grapher* 'languages) (list kpml::curlan))
    (setf (slot-value *resource-grapher* 'region-graphing-mode) 
	  *region-graphing-mode*)

    (setq *resource-grapher-process*
	  (process-run-function 
	   "KPML-RES-GR"
	   #'run-resource-grapher 
	    *package* *resource-grapher* *graphed-region* nil
	    *root-system*))))

||#


(defun PRINT-SEMANTIC-RESOURCE-GRAPH-NODES (concept-arg stream)
  ;;
  ;; 4.0 these functions were terminally confused about whether they
  ;;     are receiving a concept or a name of a concept. This may
  ;;     be due to some change in Loom4. Make sure we deal with
  ;;     anything that comes in...
  ;;
  (let ((concept-name (if (symbolp concept-arg)
			  concept-arg
			(kpml::kb-getconceptname concept-arg)))
	(concept (if (symbolp concept-arg)
		     (kpml::kb-getnamedconcept concept-arg)
		   concept-arg)))
    (if (member concept-arg *graph-stop-points* :test #'equal)
	;;
	;; 4.0 add stop points for the graph... these work by presenting
	;;     a cons with the concept in the cdr.
	;;
	(clim:with-output-as-presentation
	 (stream concept-arg 'resource-graph-stubb)
	 (if (equal *kr-stop-points-display-mode* :maintain)
	     (format stream "~A->..." concept-name)
	   (format stream "...")))
    
      (clim:with-output-as-presentation
       (stream concept 'kr-concept)
       (if (and *dont-name-graphed-kr-internals*
		(kpml::kb-system-defined-name-p concept))
	   (format stream "o")
	 (format stream "~A" concept-name))))))

;;; ----------------------------------------------------------------------
(clim:define-presentation-type collected-feature ())

(clim:define-presentation-action erase-collected-feature
  (collected-feature nil systemic-resource-graph)
  (object)
  (setf kpml::*collected-features*
    (remove object kpml::*collected-features*))
  (clim:redisplay-frame-pane clim:*application-frame* 'collecteds))

(defmethod COLLECTED-FEATURES-DISPLAYER 
    ((frame systemic-resource-graph) stream)
  (format stream "~%Collected features:~%")
  (if kpml::*collected-features*
      (loop for f in (reverse kpml::*collected-features*)
	  do (clim:with-output-as-presentation 
		 (stream f 'collected-feature)
	       (format stream " ~a" f)))
    (format stream "NONE.")))


;;; ----------------------------------------------------------------------
;;; Systemic-style graph support...
;;; 1.1 looks out for several special display types being passed through.
;;;     These can affect various aspects of the display (dashing or coloring
;;;     the arcs, etc.). The internal form of a node is standardized as
;;;     a systemic-graph-node structure, thereby removing the former
;;;     difference between contrastive and non-contrastive graphing and
;;;     allowing for more straightforward extensions.
;;;
;;; 2.1
;;; Modified from of the arc drawer now draws 
;;; the path to where a representation of the
;;; system itself is to start (i.e., to the point where an arrow to
;;; the system shape will appear). It does not draw the system shape
;;; however, it records where the feature is to be placed instead
;;; using note-feature-positions.
;;; ----------------------------------------------------------------------

(defun SYSTEMIC-ARC-DRAWER (stream from-node to-node x1 y1 x2 y2
			    &rest drawing-options
			    &key path draw-nodes (with-name nil)
			    &allow-other-keys)
  (declare (ignore drawing-options draw-nodes))
  (if (systemic-graph-node-p from-node)
      (let* ((object (systemic-graph-node-value from-node))
	     (type   (systemic-graph-node-type from-node))
	     (dashed-p
	      (and *graph-display-mode*
		   *dashed-shortcuts*
		   (systemic-graph-node-p to-node)
		   (if (rassoc (systemic-graph-node-value to-node)
			      *path-shortcuts*) T nil))))
	(case type
	  ((kpml::feature kpml::path-f)
	   ;; 2.1 wraps an updating output around that was not there before
	   ;;     to help with cautious graphing... 
	   (clim:updating-output (stream :cache-value (list x1 y1 x2 y2 path))
	     (if (feature-on-generation-path-p object)
		 (clim:with-drawing-options 
		     (stream :ink *resource-foreground-colour*)
		   (connect-feature-with-system stream x1 y1 x2 y2 path))
               (clim:with-drawing-options 
                   (stream :ink *resource-background-colour*)
	         (connect-feature-with-system stream x1 y1 x2 y2 path)))))
	  ((kpml::system kpml::path-s)
	   (cond (*careful-graphing*
		  ;; 2.1 all-new because we always need to note the positions...
		  (clim:updating-output (stream :all-new T)
		    (if path
			(let ((i-x (first path))
			      (i-y (second path)))
			  (note-feature-positions 
			   stream clim:*application-frame*
			   from-node x1 y1 i-x i-y)
			  (path-drawer 
			   stream i-x i-y `(,@(cddr path) ,x2 ,y2)))
		      (note-feature-positions 
		       stream clim:*application-frame*
		       from-node x1 y1 x2 y2))))
		 (t  ;; old case...
		  (if path
		      (let ((i-x (first path))
			    (i-y (second path)))
			(make-system-shape stream from-node x1 y1 i-x i-y
					   :with-name T)
			(path-drawer stream i-x i-y `(,@(cddr path) ,x2 ,y2)))
		    (make-system-shape stream from-node x1 y1 x2 y2
				       :with-name with-name)))))))))

;;; systemic graph drawing utilities...
;;; 1.2 added conditionalization of the precise highlighting behaviour
;;; 4.1 we can now use the more detailed information on the
;;;     old-feature slot of the systems to get a more accurate
;;;     view of what has been used in generation for a constituent
;;;     and what not. We could probably redo the entire thing using
;;;     the recorded-history structure that has this kind of information
;;;     in, but this trick here also works. 

(defun FEATURE-ON-GENERATION-PATH-P (object)
  (or 
   (and (member :last-selected *highlighting-conditions*)
	(member object kpml::feature-selections))
   (and (member :last-used *highlighting-conditions*)
	(loop for (where . feature) 
	      in (kpml::fetch-system-old-feature
		  (first (kpml::who-has-as-output object)))
	      when (and (equal object feature)
			(equal *whereami* where))
	      do (return t)))
   (and (member :collected *highlighting-conditions*)
	(member object kpml::*collected-features*))))

;;; 1.1 adds the separation of graph from system names...
;;; 4.0 allows names to be printed also directly if
;;;     we are not in careful mode, this has the
;;;     advantage that we do not jump all over the
;;;     canvas and so also works during hardcopying
;;;     to a postscript stream

(defun MAKE-SYSTEM-SHAPE (stream from-node x1 y1 x2 y2 
			  &key (with-name nil))
  (let ((s-x (+ x1  (/ (* (- x2 x1) 9) 10))))
    (if (kpml::gate-p (systemic-graph-node-value from-node))
	(clim:draw-line* stream x1 y1 x2 y2)
      (progn
	(if *show-system-names*
	    (if *careful-graphing*
		(clim:draw-arrow* stream x1 y1 s-x y1)
	      (let ((name (systemic-graph-node-value from-node)))
		(clim:draw-arrow* stream x1 y1 s-x y1)
		(when with-name
		  (clim:with-output-as-presentation 
		      (stream name 'resource-graph-node)
		    (draw-multiple-line-text 
		     stream (string name) s-x y1)))))
	  (clim:draw-arrow* stream 
			    (- x1 (clim:text-size stream " ") 2) y1 s-x y1))
	(clim:draw-line* stream s-x y1 s-x y2)
	(clim:draw-line* stream s-x y2 x2 y2)))
    (when (and *careful-graphing* with-name)
      (setf (gethash 
	     from-node
	     (slot-value clim:*application-frame* 'system-positions))
	    (list s-x y1)))))


(defun PATH-DRAWER 
    (stream s-x s-y point-sequence 
	    &key (drawer #'clim:draw-line*)(dashed-p nil)
	    )
  (loop for y1 in (rest point-sequence) by #'cddr
      and y0 = s-y then y1
      for x1 in point-sequence by #'cddr 
      and x0 = s-x then x1
      do (apply drawer (list stream x0 y0 x1 y1))))

;;; ----------------------------------------------------------------------
;;; Make the generation path easier to factor out...
;;; 1.2 and other options...

(define-systemic-resource-graph-command 
  (com-TOGGLE-GENERATION-PATH :name t :menu nil)
  ()
  (manage-highlighting :last-selected))

(define-systemic-resource-graph-command 
    (com-TOGGLE-HIGHLIGHT-COLLECTEDS :name t :menu nil)
    ()
  (manage-highlighting :collected))

(define-systemic-resource-graph-command 
    (com-TOGGLE-LAST-USED-FEATURE :name t :menu nil)
    ()
  (manage-highlighting :last-used))

(defun MANAGE-HIGHLIGHTING (option)
  (if (member option *highlighting-conditions*)
      (setf *highlighting-conditions*
	(remove option *highlighting-conditions*))
    (pushnew option *highlighting-conditions*))
  T)

;;; and add most of the yes/no flags as togglable direct from
;;; a menu command...

(define-systemic-resource-graph-command 
  (com-TOGGLE-SYSTEM-NAME-VISIBILITY :name t :menu nil)
  ()
  (setf *show-system-names*
	(not *show-system-names*))
  T)

(define-systemic-resource-graph-command 
  (com-TOGGLE-REGION-RESTRICTION :name t :menu nil)
  ()
  (setf kpml::*resource-graphing-region-restricted?*
	(not kpml::*resource-graphing-region-restricted?*))
  T)

(define-systemic-resource-graph-command 
  (com-TOGGLE-SYSTEM-STUBBS-VISIBILITY :name t :menu nil)
  ()
  (setf kpml::*include-system-stubbs*
	(not kpml::*include-system-stubbs*))
  T)

(define-systemic-resource-graph-command 
  (com-TOGGLE-GATES-VISIBILITY :name t :menu nil)
  ()
  (setf kpml::*resource-graphing-gates-displayed?*
	(not kpml::*resource-graphing-gates-displayed?*))
  T)

;; 2.1
(define-systemic-resource-graph-command 
  (com-TOGGLE-DISABLED-VISIBILITY :name t :menu nil)
  ()
  (setf kpml-i::*show-disabled-systems-in-graph*
	(not kpml-i::*show-disabled-systems-in-graph*))
  T)

(define-systemic-resource-graph-command 
  (com-TOGGLE-REGION-EXTERNAL-LINKS-VISIBILITY :name t :menu nil)
  ()
  (setf kpml::*region-external-links-visible?*
   	(not kpml::*region-external-links-visible?*))
  T)

(define-systemic-resource-graph-command 
  (com-TOGGLE-SYSTEMIC-NOTATION :name t :menu nil)
  ()
  (setf  kpml::*systemic-notation*
   	(not  kpml::*systemic-notation*))
  T)

(define-systemic-resource-graph-command 
    (com-toggle-show-example-strings :name t :menu nil)
    ()
  (setf *display-examples* (not *display-examples*)))

(define-systemic-resource-graph-command 
    (com-toggle-SHOW-CONCEPT-AS-POPUPS :name t :menu nil)
    ()
  (setf *concept-info-as-popups?*
	(not *concept-info-as-popups?*)))

;;; ----------------------------------------------------------------------
;;; 2.1 this operation does not previously respect the graphing options,
;;;     particularly concerning multilinguality, that may have been
;;;     set... Need to separate this from other modes as they are 
;;;     orthogonal.
;;; ----------------------------------------------------------------------

(define-systemic-resource-graph-command 
  (com-GRAPH-FROM-COLLECTEDS :name t :menu nil)
  ()
  (when kpml::*collected-features*
    (create-a-resource-graph-from-features kpml::*collected-features*)
    T))

;;; ----------------------------------------------------------------------
(define-systemic-resource-graph-command 
    (com-SHOW-ENTRY-CONDITIONS :name t)
  ((object 'resource-graph-node :gesture :describe)) ;; middle click
  (let ((node (kpml::monolingualize-node object)))
    (cond ((gethash node kpml::system-table)
	   (pop-up-entry-conditions node))
	  ((gethash node kpml::all-output-features)
	   (pop-up-entry-conditions 
	    (first
	     (kpml::who-has-as-output node))))
	  (t 
	   (kpml::warning Node " is a weird resource graph node!")))))

(defun POP-UP-ENTRY-CONDITIONS (node)
  (clim:with-menu 
      (menu
       (clim:get-frame-pane kpml-i::*resource-grapher* 'kpml-i::graph))
    (clim:accepting-values 
	(menu :own-window t 
	      :label 
	      (concatenate 'string (string node) " has entry conditions:"))
      (if (or (eq kpml::*ml-display-mode* :contrastive)
	      (eq kpml::*ml-display-mode* :multilingual)
	      (eq kpml::*ml-graphing-mode* :contrastive)
	      (eq kpml::*ml-graphing-mode* :multilingual))
	  (loop for lg in (if kpml::*languages-in-focus*
			      kpml::*languages-in-focus*
			    kpml::all_languages)
	      do 
		(let ((kpml::curlan lg))
		  (clim:with-text-face 
		      (menu '(:bold :italic))
		    (format menu "~%~A: " kpml::curlan))
		  (format menu 
			  #-acl3.0 "~W"
			  #+acl3.0 "~S"
			  (kpml::fetch-system-inputs node))))
	(format menu 
		#-acl3.0 "~%~W"
		#+acl3.0 "~%~S"
		(kpml::fetch-system-inputs node))))))

(defun DISPLAY-SYSTEM-NAMES (stream)
  (with-slots (system-positions regions) clim:*application-frame*
    (maphash 
     #'(lambda (key value)
	 (clim:updating-output (stream :cache-value key)
	   (let ((name (kpml::grammar-node-label 
			(systemic-graph-node-value key))))
	     (clim:with-output-as-presentation 
		 (stream name 'resource-graph-node)
	       (macrolet
		   ((print-it ()
		      '(draw-multiple-line-text 
			stream (string name) 
			(first value) (second value)
			:size *resource-graph-system-name-size*)))
		 (macrolet 
		     ((print-it-possibly-disabled ()
			'(if (kpml::fetch-disabled-system name)
			  (clim:with-drawing-options
			      (stream :ink *grey*)
			    (print-it))
			  (print-it))))
		   (if (and kpml::*region-external-links-visible?*
			    (kpml::region-external-system-inputs-p
			     name (first regions)))
		       (clim:with-text-style  
			   (stream *fix--bold-italic--10*)
			 (print-it-possibly-disabled))
		     (print-it-possibly-disabled))))))))
	 system-positions)))


(defmacro WITH-ML-COLOR-CONTRAST (&body body)
  `(case status
     (:shared
      (clim:with-drawing-options 
	  (stream :ink clim:+black+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    ,@body))))
	(:in-1
	 (clim:with-drawing-options
	  (stream :ink clim:+red+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    ,@body))))
	(:in-2 
	 (clim:with-drawing-options
	  (stream :ink clim:+blue+)
	  (clim:surrounding-output-with-border
	   (stream :shape :rectangle)
	   (clim:with-output-as-presentation 
	    (stream object 'resource-graph-node)
	    ,@body))))))

;;; ----------------------------------------------------------------------
;;; 2.1 following function is not necessary if we are cautious graphing mode
;;;     so conditionalize... (actually, should never land up here)
;;; ----------------------------------------------------------------------

(defun ML-DISPLAY-SYSTEM-NAMES (stream)
  (unless *careful-graphing*
    (with-slots (system-positions regions) clim:*application-frame*
      (macrolet
	  ((print-it ()
	     '(draw-multiple-line-text 
	       stream (string object) (first value) (second value)
	       :size *resource-graph-system-name-size*)))
	(macrolet 
	    (
	   ;;; following is as for the display-system-names case...
	     (region-sensitive-system-presentation 
	       ()
	     '(if (and kpml::*region-external-links-visible?*
		   (kpml::region-external-system-inputs-p
		    object (first regions)))
	       (clim:with-text-style  
		   (stream *fix--bold-italic--10*)
		 (print-it))
	       (print-it))))
	(maphash 
	 #'(lambda (key value)
	     (clim:updating-output (stream :cache-value key)
	       (let ((object (kpml::grammar-node-label 
			      (systemic-graph-node-value key)))
		     (status (systemic-graph-node-status key)))
		 (with-ml-color-contrast
		     (region-sensitive-system-presentation)))))
	 system-positions))))))

;;; ----------------------------------------------------------------------
;;; 2.1
;;; Simple change of draw-multiple-line-text to make it right, left, or
;;; mid-justify against the given coords... keyword addition...
;;; There was also a problem with clim:stream-string-width.
;;; ----------------------------------------------------------------------

(defun DRAW-MULTIPLE-LINE-TEXT
    (stream string x-base y-base
     &key (style *sans-serif--bold--7*)
	  (size 7)
	  (x-offset -10)	
	  (y-offset -10)
	  (align-x :center)
	  (align-block :center))
  (let* ((x (+ x-base x-offset))
	 (y (+ y-base y-offset))
	 (sized-style (clim:parse-text-style 
		       (make-text-style-with-size style size)))
	 (incr (clim:stream-line-height stream sized-style))
	 (lines (break-string string))
	 (nr-lines (1- (length lines)))
	 (maxwidth 
	  ;; the following clim function is meant to work over newlines,
	  ;; but does not under ACL4.3 at least...
	  (loop for s in lines
	      maximizing (clim:stream-string-width 
			  stream s
			  :text-style sized-style              ;; 2.1
			  )))
	 (s-x (case align-block
		(:right (- x maxwidth))
		(:center (- x (/ maxwidth 2)))
		(:left x))))
    (loop for s in lines
	for base from (- y (* nr-lines incr)) by incr
	do 
	  (clim:draw-text* stream s s-x base 
			   :align-x align-x :text-style sized-style))))



      
(defun BREAK-STRING (s &optional (breakch #\-))
  (let ((bds `(-1 ,@(loop for j from 0 to (1- (length s))
			when (char= (char s j) breakch)
		       collect j) ,(length s))))
    (loop for x in bds
	for y in (cdr bds) 
	collect (subseq s (1+ x) y))))



;;;------------------------------------------------------------------------
;;; Hardcopy support functions...
;;; 
;;; 1.0.34 adds the new systemic graphing appearance to 
;;;        the hardcopies...
;;; 2.0    name of postscript stream changed in an attempt to net
;;;        in Lispworks... Nope... not there.
;;;        LWW4.1+ ok.
;;; 2.0.44
;;; 4.0    added careful graphing mode to the hardcopy 
;;;        graphs... sometimes looses the first system
;;;        names on the lefthand side but the graphing
;;;        is better...
;;;
;;; ----------------------------------------------------------------------

    
#+(or acl3.0 (and lispworks (not postscript-clim)))
(defun HARDCOPY-GRAPH 
    (filename multipage? launching-graph 
     &optional (hardcopy-font *hardcopy-font*))
  (clim:notify-user launching-graph
		    "No postscript capability in this Lisp version!"))

  ;; ......................................................................
  ;; 4.0 insert...

(defmacro OLD-STYLE-GRAPHING-BEHAVIOUR ()
  '(progn
     (with-open-file 
      (fstr filename :direction :output :if-exists :overwrite 
	    :if-does-not-exist :create)
      (clim::with-output-to-postscript-stream 
       (*standard-output* fstr :multi-page multipage?)
       (when *grapher-header*
	 (clim:with-text-style  
	  (*standard-output* *fix--bold--16*)
	  (if kpml::*resource-graphing-region-restricted?*
	      (format *standard-output* 
		      "Region: ~A; Language: ~A; ~A~10%~0T"
		      (first regions)
		      (first languages)
		      (kpml::time-stamp))
	    (format *standard-output* "Language: ~A; ~A~10%~0T"             
		    (first languages) (kpml::time-stamp)))))
       (clim:with-text-style  
	(*standard-output* hardcopy-font)
	(clim:format-graph-from-roots
	 (if region-graphing-mode
	     (kpml::standard-region-graphing (first regions))
	   (kpml::starting-grammar-node (first root-systems)))
	 #'print-resource-graph-nodes
	 #'kpml-i::descendent-grammar-nodes ;; 2.0.44
	 :generation-separation         gen-sep
	 :arc-drawer                    #'systemic-arc-drawer
	 :arc-drawing-options           '(:with-name T)
	 :within-generation-separation  *inter-generation-scaling*
	 :cutoff-depth                  *resource-graph-depth*
	 :merge-duplicates              t
	 :duplicate-test                #'graph-tester
	 :move-cursor                   nil
	 :orientation                   (if kpml::*systemic-notation*
					    :horizontal
					      *resource-graph-orientation*)
	 :stream                        *standard-output*)
	fstr)))
     (when *auto-print* (auto-print filename))))


  ;; ......................................................................
  ;; 4.0 the new-style behaviour copies down the normal graph creation
  ;;     code for careful graphing, including the initialization
  ;;     of positions and the two-pass graphing of nodes and connectives
  ;;     in the hope that the postscript stream will still understand
  ;;     what is happening...
  ;; ......................................................................

(defmacro NEW-STYLE-GRAPHING-BEHAVIOUR ()
  '(progn
     (with-open-file 
      (fstr filename :direction :output :if-exists :overwrite 
	    :if-does-not-exist :create)
      (clim::with-output-to-postscript-stream 
       (*standard-output* fstr :multi-page multipage?)
       
       (let ((stream *standard-output*)
	     (starting-points 
	      (if region-graphing-mode
		  (kpml::standard-region-graphing (first regions))
		(kpml::starting-grammar-node (first root-systems)))))

	 (when *grapher-header*
	   (clim:with-text-style  
	    (*standard-output* *fix--bold--16*)
	    (if kpml::*resource-graphing-region-restricted?*
		(format *standard-output* 
			"Region: ~A; Language: ~A; ~A~10%~0T"
			(first regions)
			(first languages)
			(kpml::time-stamp))
	      (format *standard-output* "Language: ~A; ~A~10%~0T"             
		      (first languages) (kpml::time-stamp)))))
       
	 (clim:with-text-style  
	  (*standard-output* hardcopy-font)

	  (clim:updating-output (stream :unique-id starting-points)

	    ;; initialize...
	    (when *careful-graphing*                                        
	      (initialize-graph-position-records clim:*application-frame*))

	    (clim:format-graph-from-roots
	     starting-points

	     ;; wrap an output record update around the print function
	     ;; to secure the positions...
	     ;;
	     #'(lambda (node s)
		 (clim:updating-output (s :cache-value node)
				       (apply #'print-resource-graph-nodes (list node s))))

	     #'kpml-i::descendent-grammar-nodes ;; 2.0.44
	     :generation-separation         gen-sep
	     :within-generation-separation  *inter-generation-scaling*
	     :arc-drawer                    #'systemic-arc-drawer
	     :arc-drawing-options           '(:with-name T)
	     :cutoff-depth                  *resource-graph-depth*
	     :merge-duplicates              t
	     :duplicate-test                #'graph-tester
	     :move-cursor                   nil
	     :orientation                   (if kpml::*systemic-notation*
						:horizontal
					      *resource-graph-orientation*)
	     :stream                        *standard-output*))

	  ;; Second pass ...
	  (clim:updating-output (stream :cache-value starting-points)
	     (cond ((or (eq (slot-value launching-graph 'mode) :ml)
			(eq (slot-value launching-graph 'mode) :ml-region))
		(if *careful-graphing*
		    (when kpml::*systemic-notation*	
		      (do-system-shapes stream))
		  (when (and kpml::*systemic-notation*
			     *show-system-names*)
		    (ml-display-system-names stream))))
	       (t 
		(if *careful-graphing*
		    (when kpml::*systemic-notation*	
		      (do-system-shapes stream))
		  (when (and kpml::*systemic-notation*
			     *show-system-names*)
		    (display-system-names stream))))))

	  fstr))))))

#-(or acl3.0 (and lispworks (not postscript-clim)))
(defun HARDCOPY-GRAPH 
    (filename multipage? launching-graph 
     &optional (hardcopy-font *hardcopy-font*))
  (let ((gen-sep (if *show-realizations-in-graphs*
		     (+ *hardcopy-vertical-scaling* 10)
		   *hardcopy-vertical-scaling*)))
    (declare (special *careful-graphing*))
    (with-slots (region-graphing-mode languages regions root-systems) 
	launching-graph
	;; 4.0 split here between old behaviour with careful graphing
	;;     off and new behaviour... Can recombine and conditionalize
	;;     more appropriately when testing and user trials complete...
	;;
	(if *careful-graphing*
	    (new-style-graphing-behaviour)
	  (old-style-graphing-behaviour)))))

  ;; ......................................................................


;;; 2.0 name of postscript stream changed in an attempt to net in
;;;     Lispworks.
(defun HARDCOPY-KR-GRAPH (filename multipage? launching-graph)
  (let ((gen-sep   *hardcopy-vertical-scaling*)
	(inter-gen-sep *inter-generation-scaling*))
    (with-slots (root-systems) launching-graph
      (with-open-file 
	  (fstr filename :direction :output :if-exists :overwrite 
	   :if-does-not-exist :create)
	(clim::with-output-to-postscript-stream 
	    (*standard-output* fstr :multi-page multipage?)
	  (when *grapher-header*
	    (clim:with-text-style  
		(*standard-output* *fix--bold--16*)
		(format *standard-output* "Semantics: ~A~10%~0T"
			(kpml::time-stamp))))
	  (clim:format-graph-from-roots
	   (list (kpml::kb-getnamedconcept 
		    (first root-systems)))
	   #'print-semantic-resource-graph-nodes
	   #'descendent-subcs-for-graph  	   ;; 4.0  for stop points...
	   :generation-separation gen-sep
	   :within-generation-separation inter-gen-sep
	   :cutoff-depth *resource-graph-depth*
	   :merge-duplicates t
	   :duplicate-test #'equal
	   :move-cursor nil
	   ;; 4.0 systemic notation does not apply to semantics at present...
	   ;;
	   :orientation *resource-graph-orientation*
	   :Stream *standard-output*)
	  fstr)))
    (when *auto-print* (auto-print filename))))

(defun MAKE-HARDCOPY-FILENAME (region)
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (format nil "~a-~a~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D.ps" 
	   region year month date hour minute second)))

(defun AUTO-PRINT (filename)
  #+allegro (excl:shell (format NIL "lpr ~A" filename))
  #+lucid   (lcl:shell (format NIL "lpr ~A" filename))
  #-(or lucid allegro)
  (clim:notify-user
   clim:*application-frame* 
   (concatenate
       'string
     "Do not know how to send to the printer in this Lisp.  "
     "Postscript file has been left in the file "
     (string filename) "however.")))


;;; ----------------------------------------------------------------------
;;; 2.1 
;;; The colour setting commands and colour management... (adapted en masse
;;; from the example mismatch case).
;;; ----------------------------------------------------------------------

(defmacro RESOURCE-COLOR-SETTER (com-label color clim-color fg?)
  `(define-systemic-resource-graph-command 
       (,(intern (format nil "RESOURCEG-~A-~A" (if fg? :fg :bg) color)
		 "KPML-I")
	:name ,com-label :menu nil)
       ()
     (setf ,(intern (if fg? 
                        "*RESOURCE-FOREGROUND-COLOUR*" 
                      "*RESOURCE-BACKGROUND-COLOUR*") "KPML-I")
           ,clim-color)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'graph :force-p t)))

(defmacro DEFINE-RESOURCE-COLOR-COMMANDS ()
  `(progn
     ,@(loop for fg in '(T nil)
	   append
	 (loop for (color label clim-color)
	       in *kpml-colour-wheel*
	       collect
	       `(resource-color-setter ,color ,label ,clim-color ,fg)))))

(define-resource-color-commands)

;;; ----------------------------------------------------------------------
;;; 4.1 this should provide an indication of how large the graph
;;;     is. If the result is greater than the *graph-size-threshold*
;;;     value, we get a warning each time we graph. Unfortunately,
;;;     I have no idea how to estimate this without actually doing
;;;     the graph! So just give some absolute guess for now.

(defun ESTIMATE-GRAPH-SIZE (starting-points)
  (if (> (length (kpml::list-grammatical-features)) 300)
      0.9
    0.7))


