(in-package "KPML")

;;; File: resource-grapher.lisp
;;; Author: John Bateman
;;; Updates: 20.10.95 (0.9 compatibility)
;;;          Jan 96   (proper realization statement displays,
;;;                    graph pruning)

;;;-------------------------------------------------------------------
;;; In order to avoid huge unreadable graphs, the default behavior
;;; of the grapher is set so as to:
;;;
;;;  *  not print out gates in the graph
;;;  *  not to go over region boundaries
;;;
;;; In addition, it is possible (via  *region-external-links-visible?*)
;;; to change the behavior so that systems outside of the region are
;;; still collected and added into the graph, *but their features are
;;; not then included* (see first condition in function 
;;; DESCENDENT-GRAMMAR-NODES). 
;;; This allows us to see how self-contained the graphed region actually is.
;;;
;;; KPML 0.8: contrastive graphing added.
;;; KPML 0.9: Allegro CLIM-2 only.
;;;           Attempt to use the Allegro multiprocessing facilities
;;;           in order to maintain proper behavior with multiple graphs.
;;; ----------------------------------------------------------------------


;;; Additional graphing feature with 1.0:
;;; When the following flag is unset, features are free to be shown
;;; as belong to several systems as may be the case for multiple
;;; languages. When the flag is set, the unity of systems and their
;;; features is enforced, even if this means that features are
;;; duplicated in a multilingual resource graph.
#+ignore(defvar *preserve-systems-in-ml-graphs* nil)

(defvar *include-system-stubbs* T)

(defvar *rs-box-width* 30)
#+(or acl3.0 (and lispworks4 :win32)) (defvar *print-right-margin* 60)

;;; ----------------------------------------------------------------------
;;; 1.1 removed some lingering references to global variables...
;;;     and cleaned up some;
;;;
;;;     display views added... 
;;;         this complicates the simple process of finding descendents
;;;         in a delicacy-increasing fashion since we have to check
;;;         whether we are dealing with a shortcut path or not that
;;;         collapses the usual child-relations of the network. We also
;;;         have some dependent display forms when setting these types
;;;         of display views up. A shortcut path runs either from system
;;;         to system, or from feature to feature. The behaviour is 
;;;         as follows:
;;;           system->system is an :after method that replaces a found
;;;                          child system by its end-path
;;;           feature->feature is a :before method that replaces a found
;;;                    parent feature by its end-path.
;;;         Since these behaviours are somewhat different, we need to
;;;         record whether we are dealing with a feature or a system.

(defun DESCENDENT-GRAMMAR-NODES-INTERNAL (ml-node)
  (cond ((kpml-i::systemic-graph-node-p ml-node)
	 (let ((type (kpml-i::systemic-graph-node-type ml-node))
	       (regions (slot-value clim:*application-frame* 'kpml-i::regions))
	       (curlan 
		(first 
		 (slot-value clim:*application-frame* 'kpml-i::languages)))
	       (node 
		(monolingualize-node 
		 (kpml-i::systemic-graph-node-value ml-node))))
	   (when (and kpml-i::*graph-display-mode* 
		      (equal type 'feature)
		      (member node (mapcar #'car kpml-i::*path-shortcuts*)))
		 (setf node (cdr (assoc node kpml-i::*path-shortcuts*))))
	   (kpml-i::check-shortcut-path-system-to-system
	    (case type
	      (stub nil)
	      ((system path-s)
	       (let ((nodetype (if (and kpml-i::*graph-display-mode*
					(member node kpml-i::*path-starters*))
				   'path-f
				 'feature)))
		 (cond (*resource-graphing-region-restricted?*
			(if (not (member (fetch-system-region node) regions))
			    nil
			  (mapcar #'(lambda (x) 
				      (kpml-i::make-systemic-graph-node
				       :type nodetype
				       :value x))
				  (fetch-output-features node))))
		       (t
			(mapcar  #'(lambda (x) 
				     (kpml-i::make-systemic-graph-node
				      :type nodetype :value x))
				 (fetch-output-features node))))))
	      ((feature path-f)
	       (let* ((descendent-systems 
                       ;; 2.1 allow complete exclusion of disabled systems...
                       (let ((all-descendents (who-has-as-input node)))
                         (if kpml-i::*show-disabled-systems-in-graph*
                             all-descendents
                           (remove-if #'fetch-disabled-system all-descendents))))
		      (candidate-systems 
		       (cond (*resource-graphing-gates-displayed?*
			      descendent-systems)
			     (t
			      (for s in descendent-systems
				   unless (and (gate-p s)
					       (null 
						(who-has-as-input 
						 (first 
						  (fetch-output-features s)))))
				   collect s))))
		      (nodetype (if (and kpml-i::*graph-display-mode*
					 (member node kpml-i::*path-starters*))
				    'path-s
				  'system)))
		 (cond ((and *resource-graphing-region-restricted?*
			     (not *region-external-links-visible?*))
			(mapcar #'(lambda (x) 
				    (kpml-i::make-systemic-graph-node
				     :type nodetype :value x))
				(for s in candidate-systems
				     when (member (fetch-system-region s) 
						  regions)
				     collect s)))
		       (t
			(mapcar #'(lambda (x) 
				    (kpml-i::make-systemic-graph-node
				     :type nodetype :value x))
				candidate-systems)))))
	      (otherwise nil)))))))

(defun GRAMMAR-NODE-LABEL (object)
    object)
  
;;; ----------------------------------------------------------------------
;;; Following function...
;;;
;;; 1.0 updated to use the proper frame slots for the originating
;;;     window. This means that the behaviour is constant at least,
;;;     although we do not maintain a history of what systems are
;;;     visible somewhere in the interface. This is probably reasonable
;;;     unless we can always bring up that displayed definition.
;;;
;;; 2.0.28
;;; It is nicer to have the graphed network update itself if we make
;;; a change in one of its systems. So we keep track of when a system
;;; editing graph is brought up by clicking in the network graph.
;;; Minimal change to the following function to cause this to occur.
;;; 3.0
;;; records info for the frame tool...
;;; ----------------------------------------------------------------------

(defun RESOURCE-GRAPH-DISPLAY-ACTION (stream ml-node)
  (with-slots (kpml-i::root-systems kpml-i::languages kpml-i::regions 
	       kpml-i::mode kpml-i::region-graphing-mode) 
      clim:*application-frame*
    (let ((node (monolingualize-node ml-node)))
      (cond ((gethash node system-table)
	     (if *region-external-links-visible?*
		 (if (member (fetch-system-region node) kpml-i::regions)
		     ;; 2.0.28
		     (describe-system-from-network-graph 
		      node clim:*application-frame*)
		   (case *ml-graphing-mode*
		     (:monolingual 
		      (let ((curlan (first kpml-i::languages)))
			(kpml-i::create-a-resource-graph node :frame-tool-label node)))
		     (:multilingual 
		      (let ((*languages-in-focus* kpml-i::languages))
			(kpml-i::create-a-contrastive-resource-graph node :frame-tool-label node)))
		     (:contrastive
		      (let ((*languages-in-focus* kpml-i::languages)
			    (curlan (first kpml-i::languages)))
			(loop for lg in (if kpml::*languages-in-focus*
					    kpml::*languages-in-focus*
					  kpml::all_languages)
			    do 
			      (setf kpml::curlan lg)
			      (kpml-i::create-a-resource-graph node :frame-tool-label node))))))
	       (describe-system node)))
	  ((gethash node all-output-features)
;;; 0.9: pop up the feature's realization statements (the 0.8 action of
;;; describing the feature does not much sense when we can see the
;;; graph anyway! Have to make the following respect the multilingual
;;; displaying options though.) Now, only pop up if no realizations
;;; are shown in the graph already.
	   (let ((curlan (first kpml-i::languages))
		 (*languages-in-focus* kpml-i::languages))
	     (if (or (eq kpml-i::*show-realizations-in-graphs* :always)
		     (and (eq kpml-i::*show-realizations-in-graphs* :used)
			  (kpml-i::feature-on-generation-path-p node)))
		 (loop for system in (who-has-as-output node)
		     when (fetch-system-chooser system)
		     do (describe-chooser (fetch-system-chooser system)))
	       (pop-up-realization-statements node))))
	  (t
	   (format stream "~%No action defined for node: ~A" node))))))


(defun DESCRIBE-SYSTEM-FROM-NETWORK-GRAPH (node frame)
  (if (member :systems *pop-ups*) ;; 1.1
      (kpml-i::create-a-system-editing-graph node nil frame)
    ;; if not poping up windows for system definitions, do the old
    (describe-system node)))

;;; ----------------------------------------------------------------------
;;; realization statement pop up for graphs without displayed
;;; realization statements.
;;; ----------------------------------------------------------------------

(defun POP-UP-REALIZATION-STATEMENTS (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 realizations:"))
      (if (or (eq *ml-display-mode* :contrastive)
	      (eq *ml-display-mode* :multilingual)
	      (eq *ml-graphing-mode* :contrastive)
	      (eq *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 "~{~%~3T~W~}" #+acl3.0 "~A"
			  (fetch-realization-statements-of-feature node))))
	       (format menu #-acl3.0 "~{~%~3T~W~}" #+acl3.0 "~%~A"
		       (fetch-realization-statements-of-feature node))))))


;;; ----------------------------------------------------------------------
;;; Following function provides pretty printing of realization statements
;;; in graphs. When the flag *show-realizations-in-graphs*
;;; is set, realization statements are displayed in boxes
;;; accompanying their features.
;;; ----------------------------------------------------------------------

(defun PP-FEATURE-WITH-RS (object stream)
  (let* ((*standard-output* stream)
	 (*print-right-margin* *rs-box-width*)
	 (rel-lg-set (if (or (eq *ml-display-mode* :contrastive)
			     (eq *ml-display-mode* :multilingual)
			     (eq *ml-graphing-mode* :contrastive)
			     (eq *ml-graphing-mode* :multilingual))
			 (if kpml::*languages-in-focus*
			     kpml::*languages-in-focus*
			   kpml::all_languages)
		       nil))
	 (rs-set (or
		  (and rel-lg-set
		       (loop for lg in rel-lg-set thereis
			     (let ((curlan lg))
			       (fetch-realization-statements-of-feature
				object))))
		  (fetch-realization-statements-of-feature object))))
    (clim:with-text-size (stream kpml-i::*resource-graph-feature-size*)
      (format stream "~(~a~)" (kpml::grammar-node-label object)))
    (pp-rs stream object rs-set rel-lg-set)
    ))


;;; Just the realization statements...
;;;
(defun PP-RS (stream object rs-set rel-lg-set)
  (when rs-set
    (clim:surrounding-output-with-border
	(stream :shape :rectangle)
      (clim:with-text-style  
	  (stream kpml-i::*fix--bold--8*)
	(clim:with-text-size (stream kpml-i::*resource-graph-rs-size*)
	  (cond 
	   (rel-lg-set
	    (loop for lg in rel-lg-set
		do 
		  (let* ((kpml::curlan lg)
			 (lg-rs-set 
			  (fetch-realization-statements-of-feature object)))
		    (when lg-rs-set
		      (clim:with-text-face 
			  (stream '(:bold :italic))
			(format stream "~%~A: " kpml::curlan))
		      (pprint-rs lg-rs-set stream)))))
	   (t
	    (kpml-i-terpri stream)
	    (pprint-rs rs-set stream))))))))

;;; ----------------------------------------------------------------------
;;; There is a slight problem with the following: that is, since there
;;; is no record of which system is being used for some feature, it
;;; is possible that misleading information is given when the feature
;;; is used in *another* language in a *different* system. This will
;;; get picked up here as a realization statement. It is however clear
;;; when this is happening, since we get a realization indicated for
;;; a language for which the feature apparently does not hold, but this
;;; is still somewhat confusing. We need in a more sophisticated version
;;; to keep the features and their originating systems together as
;;; units in the graph, and signal when such usages occur.

(defun FETCH-REALIZATION-STATEMENTS-OF-FEATURE (feature)
  (let* ((system (first (who-has-as-output feature)))
	 (outputs (fetch-system-outputs system)))
    (loop for o in outputs
	  when (equal (second o) feature)
	  do
	  (return-from fetch-realization-statements-of-feature
	    (cddr o)))))

(defun PPRINT-RS (rs-set stream)
  (let ((*standard-output* stream)
	(*print-right-margin* *rs-box-width*)) ;; 2.0.34
    (unless *systemic-notation*
      (format stream #-acl3.0 "~W" #+acl3.0 "~S" rs-set)
      (return-from PPRINT-RS nil))
    #-(or lispworks acl3.0)
    (pprint-logical-block 
     (nil rs-set)
     (loop 
       (let ((rs (pprint-pop)))
	 (pprint-single-rs rs)
	 (write-char #\.)
	 (pprint-exit-if-list-exhausted)
	 (write-char #\Space)
	 (write-char #\Space)
	 (pprint-newline :fill)
	 )))
    #+(or lispworks acl3.0)
    (loop for rs in rs-set
	  do 
	  (nonansi-pprint-single-rs rs)
	  (format t "~%"))))

;;; ----------------------------------------------------------------------
;;; 3.0 the ansi and nonansi pprinting of realisation statements moved
;;;     out to display/prettifying.lisp since they are not specific
;;;     to the interface and can always be used.
;;; ----------------------------------------------------------------------

(defun MONOLINGUALIZE-NODE (ml-node)
  (cond ((symbolp ml-node) ml-node)
	(t
	 (first (parse-clause ml-node curlan)))))
	

(defun REGION-EXTERNAL-SYSTEM-INPUTS-P (system region)
  (let* ((system-inputs (fetch-input-features system)) ;; 1.1 used wrong fn!
	 (input-features (cond 
			  ((listp system-inputs)
			   system-inputs)
			  ((eq system-inputs 'start)
			   nil)
			  (t
			   (list system-inputs)))))
    (dolist (feature input-features)
      (unless (eq (fetch-system-region 
		   (first (who-has-as-output feature)))
		  region)
	(return-from region-external-system-inputs-p t)))
    nil))


;;; Following is used in case we are asked to begin graphing from a
;;; a non-terminal gate... (or of a region??)
;;; 0.9 added in that we can actually start graphing from a feature
;;; too.

(defun STARTING-GRAMMAR-NODE (system)
  (cond ((gate-p system)
	 (let ((further-systems 
		(who-has-as-input (first (fetch-output-features system)))))
	   (if further-systems
	       (mapcar #'(lambda (x) 
			   (kpml-i::make-systemic-graph-node
			    :type 'system 
			    :value x))
		       further-systems)
	     (list 'no-further-systems))))
	((gethash system system-table)
	 (list (kpml-i::make-systemic-graph-node :type 'system 
						 :value system)))
	((gethash system all-output-features)
	 (list (kpml-i::make-systemic-graph-node :type 'feature 
						 :value system)))
	(t nil)))

;;;----------------------------------------------------------------------
;;; Experimental region graphing...
;;;
;;; following needs to return a list of starting systems...
;;; 0.9: made to be sensitive to gates, terminal gates are removed
;;;      as possible starting nodes if the no terminal gates flag
;;;      is set.
;;;      We also check more thoroughly that we are including a
;;;      system at the right place in a region graph: i.e., never
;;;      as a root unless it is the start of a noncontiguous portion
;;;      of the region.

(defun STANDARD-REGION-GRAPHING (region)
  (let ((input-features (inputs-of-region region))
	(starting-systems-in-region nil))
    (dolist (f input-features)
	    (dolist (g (who-has-as-input f))
	      (when (and (eq (fetch-system-region g) region)
			 (no-other-outputs-from-region-as-input g region))
		(pushnew g starting-systems-in-region))))
    (unless *resource-graphing-gates-displayed?*
      (setf starting-systems-in-region
	(loop for s in starting-systems-in-region
	    unless (and (gate-p s)
			(null (who-has-as-input 
			       (first (fetch-output-features s)))))
	    collect s)))    
    (setf kpml-i::*root-system* (first starting-systems-in-region))
    (mapcar #'(lambda (x) 
		(kpml-i::make-systemic-graph-node
		 :type 'system
		 :value x)) 
	    starting-systems-in-region)))


(defun NO-OTHER-OUTPUTS-FROM-REGION-AS-INPUT (system region)
  (loop for i in (fetch-input-features system)
      never (eq (fetch-system-region (first (who-has-as-output i)))
		region)))

;;;-----------------------------------------------------------------------
;;; following not used...

(defun RETURN-AS-FEATURES (feature-list)
  (mapcar #'(lambda (feature) (cons 'feature feature))
	  feature-list))

(defun RETURN-AS-SYSTEMS (system-list)
  (mapcar #'(lambda (system) (cons 'system system))
	  system-list))
  
;;; ----------------------------------------------------------------------
;;; Contrastive graphing 
;;;  - for black and white
;;;    and color.
;;; 

;;; Only defined pairwise at present. That is, can only deal
;;; with two languages at a time. Need something a bit more
;;; general if we want to look at more, although the networks
;;; become horribly complicated as it is. 

#+ignore(defvar *contrastive-graphing-languages* nil)

;;; Following function returns a slightly more complicated
;;; contrastive structure containing slots for those items
;;; that are shared across the two languages held in 
;;; *contrastive-graphing-languages*, those that are in
;;; the first only, and those that are in the second only.

(defun ML-DESCENDENT-GRAMMAR-NODES (ml-node status)
  (let* ((old-curlan curlan)
	 (ml-descendents 
	  (loop for lg in *contrastive-graphing-languages*
	       collect
	       (progn ()
		      (setf curlan lg)
		      (cons lg (contrastive-descendent-grammar-nodes ml-node)))))
	 (first-lg-decs (rest (first ml-descendents)))
	 (second-lg-decs (rest (second ml-descendents)))
	 (shared 
	  (intersection first-lg-decs second-lg-decs :test #'equal :key #'cdr))
	 (in-first-only 
	  (set-difference first-lg-decs second-lg-decs :test #'equal :key #'cdr))
	 (in-second-only 
	  (set-difference second-lg-decs first-lg-decs :test #'equal :key #'cdr)))
    (setf curlan old-curlan)
    (if *preserve-systems-in-ml-graphs*
	`((:shared ,shared)
	  (:in-1   ,(if (eq status :in-2) nil in-first-only))
	  (:in-2   ,(if (eq status :in-1) nil in-second-only)))
      (multiple-value-bind (promoteds1 in-first)
	  (promote in-first-only (second *contrastive-graphing-languages*))
	(multiple-value-bind (promoteds2 in-second)
	    (promote in-second-only (first *contrastive-graphing-languages*))
	  `((:shared ,(append shared promoteds1 promoteds2))
	    (:in-1 ,in-first)
	    (:in-2 ,in-second)))))
    ))


(defun PROMOTE (node-list lg)
  (loop for node in node-list
      when (or (and (eq (car node) 'system)
		    (system-defined-for-lg-p (cdr node) lg))
	       (and (eq (car node) 'feature)
		    (feature-defined-for-lg-p (cdr node) lg)))
      collect node into promoteds
      else collect node into remainder
      finally (return-from promote (values promoteds remainder))))


;;; ----------------------------------------------------------------------
;;; 0.9 same wrap around as for non-contrastive graphs to allow for
;;;     on the spot pruning... Same as the other but respects the
;;;     extra value returned for each candidate node...

(defun CONTRASTIVE-DESCENDENTS (ml-node)
  (let* ((candidate-set (contrastive-descendents-internal ml-node))
	 (descendents 
	  (loop for c in candidate-set
                ;; 2.0 was not conditionally stubbing, see monolingual case.
		when (and (member (third c) kpml-i::*graph-stop-points*)
                          (or kpml::*include-system-stubbs*
                              (eq (first c) 'kpml::feature)))
	        collect (list 'stub nil (third c))
	        else unless (member (third c) kpml-i::*graph-stop-points*)
	        collect c end)))
    (loop for d in descendents
	  collect (kpml-i::make-systemic-graph-node
		   :type (first d)
		   :value (third d)
		   :status (second d)))))

(defun CONTRASTIVE-DESCENDENTS-INTERNAL (ml-node)
  (when (eq (kpml-i::systemic-graph-node-type ml-node) 'stub) 
    (return-from contrastive-descendents-internal nil))
  (let* ((ml-descendents (ml-descendent-grammar-nodes 
			  (cons (kpml-i::systemic-graph-node-type ml-node)
				(kpml-i::systemic-graph-node-value ml-node))
			  (kpml-i::systemic-graph-node-status ml-node)))
	 (shareds
	  (loop for node in (second (assoc :shared ml-descendents))
		collect
		(list (car node) :shared (cdr node))))
	 (in-1s
	  (loop for node in (second (assoc :in-1 ml-descendents))
		collect
		(list (car node) :in-1 (cdr node))))
	 (in-2s
	  (loop for node in (second (assoc :in-2 ml-descendents))
		collect
		(list (car node) :in-2 (cdr node)))))
    (append in-1s shareds in-2s)))


;;; General version for any number of languages, status simply lists the
;;; languages for which the node applies...

(defun GENERAL-CONTRASTIVE-DESCENDENTS (ml-node)
  (when (eq (kpml-i::systemic-graph-node-type ml-node) 'stub) 
    (return-from GENERAL-CONTRASTIVE-DESCENDENTS nil))
  (let* ((type (kpml-i::systemic-graph-node-type ml-node))
	 (node (kpml-i::systemic-graph-node-value ml-node))
	 (candidate-set0
	  (loop for lg in *contrastive-graphing-languages*
	      collect
		(let ((curlan lg))
		  (mapcar #'(lambda (x) (list (car x) lg (cdr x)))
			  (contrastive-descendent-grammar-nodes 
			   (cons type node))))))
	 (candidate-set
	  (loop for x in candidate-set0 append x))
	 (descendents
	  (loop for c in candidate-set
                ;; 2.0 was not stubbing properly... (cf. monolingual case)
	        when (and (member (third c) kpml-i::*graph-stop-points*)
                          (or kpml::*include-system-stubbs*
                              (eq (first c) 'kpml::feature)))
	        collect (list 'stub nil (third c))
	        else unless (member (third c) kpml-i::*graph-stop-points*)
                collect c end))
	 (collection (make-hash-table :size 20)))
    (loop for d in descendents
	when (eq (first d) 'stub)
	collect d into stubs
	else
	do (push (second d)(gethash (third d) collection))
	end
	finally
	  (return
	    (append (mapcar #'(lambda (c)
				(kpml-i::make-systemic-graph-node
				 :type 'stub
				 :value (third c)))
			    stubs)
		    (loop for feature being each hash-key of collection
			using (hash-value lgs)
			collect
			  (kpml-i::make-systemic-graph-node
			   :type (if (eq type 'feature) 
				     'system 'feature)
			   :value feature
			   :status lgs)))))))

(defun CONTRASTIVE-REGION-EXTERNAL-SYSTEM-INPUTS-P (system regions)
  (let* ((system-inputs (fetch-system-inputs system))
	 (input-features (cond 
			  ((listp system-inputs)
			   system-inputs)
			  ((eq system-inputs 'start)
			   nil)
			  (t
			   (list system-inputs)))))
    (dolist (feature input-features)
	    (unless (member (fetch-system-region (first (who-has-as-output feature)))
			    regions)
		    (return-from contrastive-region-external-system-inputs-p t)))
    nil))

(defun CONTRASTIVE-DESCENDENT-GRAMMAR-NODES (ml-node)
  (cond ((consp ml-node)
	 (let ((type (car ml-node))
	       (node 
		(monolingualize-node (cdr ml-node))))
	   (cond ((eq type 'system)
		  (cond (*resource-graphing-region-restricted?*
			 (if 
			     (not (member (fetch-system-region node) 
					  kpml-i::*graphed-regions*))
			     nil
			   (mapcar #'(lambda (x) (cons 'feature x))
				   (fetch-output-features node))))
			(t
			 (mapcar  #'(lambda (x) (cons 'feature x))
				  (fetch-output-features node)))))
		 ((eq type 'feature)
		  (let ((descendent-systems (who-has-as-input node)))
		    (let ((candidate-systems 
			   (cond (*resource-graphing-gates-displayed?*
				  descendent-systems)
				 (t
				  (for s in descendent-systems
				       unless (and (gate-p s)
						   (null (who-has-as-input 
							  (first 
							   (fetch-output-features s)))))
				       collect s)))))
		      (cond ((and *resource-graphing-region-restricted?*
				  (not *region-external-links-visible?*))
			     (mapcar #'(lambda (x) (cons 'system x))
					 (for s in candidate-systems
					      when (member (fetch-system-region s) 
						       kpml-i::*graphed-regions*)
					      collect s)))
			    (t
			     (mapcar #'(lambda (x) (cons 'system x))
				     candidate-systems)))))))))
	(t nil)))


;;; ----------------------------------------------------------------------
;;; Easing the preloading of preferences for graphing grammar fragments
;;; (following redefines a stubb in utilities.lisp)

(defun DECLARE-GRAPH-STOP-POINTS-FN (list)
  (setf kpml-i::*graph-stop-points* list))








