(in-package "KPML")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  File: structure-grapher.lisp
;;;  ----------------------------
;;;  (fully replaces Penman's pint: graph-sentence-structure.lisp)
;;;
;;;  Provides considerably more access
;;;  and display functions for inspecting the internal data
;;;  structures holding information about the construction
;;;  of a syntagmatic structure. The functions directly triggered
;;;  from the CLIM interface are held in structure-grapher-interface, etc.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;  First extensions: John:IPSI:March94
;;;  Major extensions: John:IPSI:Dec94
;;;  Adapted for KPML 0.9: John:IPSI:Oct95 
;;;     -- more highlighting and tracing facilities added
;;;     -- current constituent being generated (for use when the
;;;        generation process is halted before completion) is
;;;        now also highlighted.
;;;  1.0.1 and 1.0.37 linking realization statements with the features
;;;        that activated them....
;;;  2.0.2 extension and correction of the inspection options directly
;;;        from the structure graphs... These are now made to use 
;;;        consistent methods and are generalized so that all the
;;;        realization statements can now be reached in this way.
;;;        John:Edinburgh:May98
;;;
;;;------------------------------------------------------------

(defvar in-situ-use-of-pass-data nil)             ;; 2.0

;;;------------------------------------------------------------
;;; From pint:
;;; GET-PASS-DATA
;;; gets the constituent-pass record corresponding to the wbe in pass.
;;; 0.8: lexical access function changed for multilinguality.
;;; ----------------------------------------------------------------------

(defun GET-PASS-DATA (pass-wbe)
  (let ((show-pass-hash-table 
	 (or in-situ-use-of-pass-data             ;; 2.0
	     (slot-value clim:*application-frame* 'kpml-i::info))))
    (cond
     ((eq pass-wbe 'top)
      ;; BK: sentence-tree is not up-to-date if generation is in progress
      (gethash 1 show-pass-hash-table))
     ((stringp pass-wbe) nil)
     ((symbolp pass-wbe) nil)
     (t (let ((wbe (cdr pass-wbe)))
	  (when wbe
	    (cond ((eq (whiteboard-elt-id WBE) 'preselect)
		   ;; this is a nonterminal
		   (gethash (whiteboard-elt-index WBE)
			    show-pass-hash-table))
		  ((eq (whiteboard-elt-id wbe) 'substance)
		   ;; this is a morphological terminal (note: may have to 
		   ;; to something more complicated here for stems. The
		   ;; place to look is in the featurelist slot of wbe.
		   ;; John: Sep13, 1994)
		   (fetch-lexicon-info (whiteboard-elt-realization wbe)
				       'spelling))
		  ;; this is a simple terminal
		  (t (whiteboard-elt-realization wbe)))))))))


(defun CONSTIT-CHILDREN (pass-wbe)
;;; 0.7.1: updated to deal with partially complete structures passing thru.
  (let ((pass-tree (get-pass-data pass-wbe)))
    (if pass-tree
	(cond ((or (stringp pass-tree)
		   (symbolp pass-tree))
	       (list pass-tree))
	      ((listp pass-tree)
	       (list (first pass-tree)))
	      (t
	       (let ((wb-assoc-list
		      (for WB-ELT in (constituent-pass-whiteboard pass-tree)
			   collect (LIST (whiteboard-elt-aliasfn WB-ELT)
					 WB-ELT)))
		     (sequence-list (constituent-pass-sequences pass-tree)))
		 (cond
		  ((Not Sequence-list)
		   (error "No valid constituent structure"))
		  (T (mapcar
		      #'(lambda (fn)
			  (cons pass-tree (second (assoc Fn wb-assoc-list))))
		      (car Sequence-list)))))))
      ;; no more structure
      nil)))

	
(defun CONSTIT-LABEL (node 
		      &optional (orientation 
				 kpml-i::*hardcopy-structure-orientation*))
  (node-label node orientation))

	
 ;;
 ;; 4.0 extension to provide information about expansions...
 ;;
(defun NODE-LABEL (node-value &optional 
			      (orientation 
				 kpml-i::*hardcopy-structure-orientation*))
  (cond
   ((eq node-value 'top)
    (princ-to-string *structure-graph-top-node*))
   ((stringp node-value)
    (if (string<= node-value "")
	"\"\""
      node-value))
   ((atom node-value)
    ;; just use the default pname function
    nil)
   ((listp node-value)
    ;; this is a nonterminal
    (let* ((output-string nil)
	   (pass (car node-value))
	   (wbe (cdr node-value))
	   (fundle (get-fundle (whiteboard-elt-aliasfn wbe) pass))
	   (cycle (extract-index (string (first fundle))))
	   (expansions (slot-value clim:*application-frame* 'kpml-i::expansion-info))
	   (fn-name nil))
      (dolist (fn fundle)
	(setf fn-name (first (extract-fundle-names fn)))
	(unless kpml-i::*show-cycle-numbers-in-graph* (setf fn fn-name))
	(if output-string
	    (setq output-string 
		  (let ((extension                             ;; 4.0
			 (if kpml-i::*show-expansions*  
			     (extend-node-description-with-expansions 
			      cycle output-string fn fn-name expansions)
			   (format nil "~a/ ~a" output-string fn))))
		    (case orientation
			  (:vertical
			   (substitute #\newline #\space extension))
			  (:horizontal extension))))
	  (setq output-string 
		(if kpml-i::*show-expansions*  
		    (node-description-with-expansion cycle fn fn-name expansions)
		  (format nil "~a" fn)))
	  ))
      output-string))
   (t 
    (warning "Ill-structured sentence structure!")
    nil)))

 ;;
 ;; For now, just add in the expanded function as an additional
 ;; piece of information tagged on...
 ;; (Do not show the cycle number for the expanded function)
 ;;
(defun EXTEND-NODE-DESCRIPTION-WITH-EXPANSIONS 
  (cycle output-string fn-display fn expansions)
  (let ((expansion 
	 (loop for (c f . r) in expansions
	       when (and (= cycle c)
			 (member fn r :test #'equal))
	       return f)))
    (if expansion
	(format nil "~a/ ~a[~a]" 
                output-string fn-display 
                (first (extract-fundle-names expansion)))
      (format nil "~a/ ~a" output-string fn-display))))

(defun NODE-DESCRIPTION-WITH-EXPANSION
  (cycle fn-display fn expansions)
  (let ((expansion 
	 (loop for (c f . r) in expansions
	       when (and (= cycle c)
			 (member fn r :test #'equal))
	       return f)))
    (if expansion
	(format nil "~a[~a]" fn-display (first (extract-fundle-names expansion)))
      (format nil "~a"  fn-display))))


;;; ----------------------------------------------------------------------
;;; DISPLAY-CONSTIT-FEATURES
;;; displays all features in the selection expression of node.
;;;
;;; John:IPSI:March94; modified to pass the list of features
;;;     in the selection expression through pen-pprint-for-clim
;;;     so that they become mouse-sensitive...
;;; John:IPSI:Jan96: modified to present the selection expression
;;;     in a popup window if :selection-expressions is on the list
;;;     of popups held in *pop-ups*
	
(defun DISPLAY-CONSTIT-FEATURES (node window)
  (let ((pass-tree (get-pass-data node)))
    (if (and pass-tree
	     (typep pass-tree 'constituent-pass))
	(if (member :selection-expressions *pop-ups*)
            (if kpml-i::*selection-expression-tool*
                ;; 2.1 extra option...
                (kpml-i::startup-selexpression-tool node pass-tree clim:*application-frame*)
	      (pop-up-a-selection-expression
	       (constit-label node :horizontal)
	       (constituent-pass-selection-expression pass-tree)
               :origin (extract-fundle node)
	       :preselections 
	       (if (equal node 'top) nil
	         (extract-constraints node 'preselect))))
	  (progn
	    (format window "~%Selection expression of ~a:~%"
		    (constit-label node :horizontal))
	    (kpml-i::pen-pprint-for-clim 
	     (constituent-pass-selection-expression pass-tree)
	     nil
	     window)))
      (progn
        (clim:notify-user window "Terminal node: try clicking on its parent for more information")
        (format window
	        "~%Terminal node: no selection expression.~%")))))
	




(defun POP-UP-A-SELECTION-EXPRESSION (label selexpr 
				      &key (offset nil)
					   (incomplete-p nil)
                                           (origin nil)
					   (preselections nil))
  (kpml-i::startup-an-info-window
   (format nil (if incomplete-p
		   "Sel. Expr. (incomplete): for ~A"
		 "Selection expression for ~a"
		 )
	   label)
   (reverse selexpr) 
   :type 'kpml-i::feature 
   :node-origin origin
   :offset offset
   :highlight1-p (if preselections
		     #'(lambda (x) (member x preselections :test #'equal))
		   nil)))

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

;;; EASING ACCESS TO THE INTERNAL PENMAN-STYLE ACTUALIZATION DATA
;;; DATA STRUCTURES...
;;;                                              (John:IPSI:Nov94)
;;; --------------------------------------------------------------------
;;; 
;;; Takes the kind of object that you get when you click on a node in
;;; the structure graph window...  ... and mother-of returns the
;;; equivalent of the mother node, i.e., a constituent-pass structure.
;;; Definition relies on the first blackboard entry being an
;;; expanded-object which indicates where the current node is rooted.
;;; Problems come in because of the way the top of the tree
;;; is signalled and the consequences of realized terminal elements
;;; on various parts of the internal structure.

(defun MOTHER-OF (node)
  (let* ((show-pass-hash-table 
	  (slot-value clim:*application-frame* 'kpml-i::info))
	 (pass-tree (get-pass-data node))
	 (node-info (if (and pass-tree
			     (typep pass-tree 'constituent-pass))
			pass-tree
		      (first node)))
	 (mother-fn (second 
		     (first 
		      (constituent-pass-blackboard node-info)))))
    (cond ((eq mother-fn '-TOP-)
	   (gethash 1 show-pass-hash-table))
	  (t
	   (gethash 
	    (extract-index
	     (string mother-fn))
	    show-pass-hash-table)))))


(defun COPY-PASS-TABLE (pass-table)
  (let ((copy (make-hash-table)))
    (loop for pass 
	being the hash-key in pass-table using (hash-value pass-info)
	do (setf (gethash pass copy)
	     (copy-structure pass-info)))
    copy))


;;; 2.0 modification...
(defun EXTRACT-INDEX (label)
  (let ((p (position #\# label)))
    (if p
	(read-from-string (subseq label (1+ p)))
      0)))

(defun EXTRACT-FUNDLE (node-value)
  "Returns micro-functions that make up the node as a list"
  (let (pass wbe)
    
    (when (listp node-value)
	  (setq pass (car node-value))
	  (setq wbe (cdr node-value)))
    
    (cond
     ((eq node-value 'top)
      '(sentence))
     ((stringp node-value)
      (if (string<= node-value "")
	  '(nil)
	(list node-value)))
     ((atom node-value)
      ;; just use the default pname function
      (list node-value))
     (t  ;; (eq (whiteboard-elt-id node-value) 'preselect)
      ;; this is a nonterminal
      (get-fundle (whiteboard-elt-aliasfn wbe) pass)))))


;;;---------------------------------------------------------------------
;;; All ordering information for the mother (i.e., those involving the
;;; sisters    of  the      clicked        upon node)    are       in:
;;; constituent-pass-ordering-relations.  Thus, following  picks   out
;;; those ordering   relations    that concern   the   node originally
;;; selected.

(defun SELECTED-ORDERING-RELATIONS (node)
  (let ((fundle (extract-fundle node)))
    (loop for ordering in
	  (constituent-pass-orderingrelations (mother-of node))
	  when (intersection fundle ordering)
	  collect ordering)))

;;; And the display function for this...
;;; 2.0 altered by putting in more or less a copy of the code for
;;;     filtering against the current selection expression. Can
;;;     probably do a better job of parameterizing this and re-using
;;;     that code, but for now...

(defun DISPLAY-SELECTED-ORDERING-RELATIONS (node window)
  (let ((selected-constraints nil))
    (cond ((eq node 'top)
	   (Format window "~% Top node: no higher ordering constraints!"))
	  ((or (stringp node)(null node)(symbolp node))
           (clim:notify-user window "Terminal node: try clicking on its parent for more information")
	   (format window "~%Terminal node; no such information!"))
	  ((setf selected-constraints (selected-ordering-relations node))
	   (format window "~%Ordering relations imposed on ~a as follows:~%"
		   (constit-label node :horizontal))
	   (let* ((pass-tree 
		   (if (typep (get-pass-data node) 'constituent-pass)
		       (mother-of node)
		     (first node)))
		  (selexpr 
		   (and pass-tree
			(typep pass-tree 'constituent-pass)
			(constituent-pass-selection-expression pass-tree)))
		     (functions (extract-fundle-names node)))
	     (flet ((EXTRACT-RELEVANT-SYSTEMS (fe0 possibles)
		      (let ((used nil)
			    (fe (flatten (mapcar #'extract-fundle-names fe0))))
			(declare (ignore X))
			(remove-duplicates
			 (loop for (p X) in possibles
			     when 
			       (and 
				(setf used
				  (first (intersection 
					  (fetch-output-features p) selexpr)))
				(loop for r in
				      (fetch-realization-statements-of-feature
				       used)
				    thereis 
				      (generate-equiv-realizations
				       r fe functions)))
			     collect p)))))
	       (loop for el in (remove-duplicates selected-constraints)
		     do
		     (format window "~%    ")
		     (kpml-i::pen-pprint-for-clim el nil window T)
		     (clim:with-text-style 
			 (window kpml-i::*sans-serif--italic--8*)
		       (format window "           (in:")
		       (kpml-i::pen-pprint-for-clim 
			(extract-relevant-systems
			 el
			 (loop for e in (cdr el)
			     for ename = (extract-fundle-names e)
			     append (apply #'who-can-order ename)))
			:systems window T)
		       (format window ")"))))))
	  (t (format window "~%No ordering constraints imposed on~%  ~a:"
		     (constit-label node :horizontal))))))

;;; 2.0 accompanying the above...
;;; Following hack lets us recognize realizations via other members of
;;; their fundles... Not really checked out yet...
;;;
(defun GENERATE-EQUIV-REALIZATIONS (r-in-system r-target functions)
  (let ((inter nil))
    (or (equal r-in-system r-target)
	(and (setf inter (intersection r-in-system functions))
	     (loop for f in functions
		 thereis (loop for i in inter
			     thereis (equal (substitute f i r-in-system)
					    r-target)))))))

;;;---------------------------------------------------------------------
;;; Preselects,  lexifies,    classifies, inflectifies   are   in  the
;;; whiteboard entries: constituent-pass-whiteboard; i.e.:
;;;
;;; ...WHITEBOARD (#S(WHITEBOARD-ELT ID PRESELECT ALIASFN MEDIUM#2
;;;                     FEATURELIST (NOMINATIVE) REALIZATION NIL HUB E-23672-23724
;;;                     INDEX 3)
;;;                  #S(WHITEBOARD-ELT ID PRESELECT ALIASFN TIMELOCATIVE#2
;;;                     FEATURELIST (PREPOSITIONAL-PHRASE TEMPORAL-PROCESS)
;;;                     REALIZATION NIL HUB TEMPORAL-LOCATION-ID-23723 INDEX 5)
;;;                  #S(WHITEBOARD-ELT ID PRESELECT ALIASFN CAUSE#2
;;;                     FEATURELIST (REASON-PROCESS) REALIZATION NIL HUB R-23675
;;;                     INDEX 9)
;;;                  #S(WHITEBOARD-ELT ID LEXIFY ALIASFN SUBORDINATOR#2
;;;                     FEATURELIST (IFCONJCT) REALIZATION "if" HUB I1-23647
;;;                     INDEX NIL)
;;;                  #S(WHITEBOARD-ELT ID CLASSIFY ALIASFN TEMPO0#2
;;;                     FEATURELIST (DOVERB MIDDLE OUTCLASSIFY-METEOROLOGY
;;;                                  OUTCLASSIFY-REDUCED OUTCLASSIFY-NEGATIVE
;;;                                  THIRDPERSON-FORM SINGULAR-FORM THIRDPERSON-FORM
;;;                                  PRESENT-FORM)
;;;                     REALIZATION "END" HUB END-23671 INDEX NIL))
;;;  

;;; 1.0.37 the previous assumption  that all the lexical information
;;; can be retrieved from the whiteboard appears not to be true: when
;;; a lexify is made this swamps the classify information. So we have
;;; to go back to the blackboard in order to get the original classify
;;; information.

;;; 2.1    even worse than that, we have to go back to the brownboard
;;;        to be completely sure! The following version of extract-constraints
;;;        does this, the old version is kept below commented out in case
;;;        some curious interaction raises its ugly head at some stage in
;;;        in the near future. (John, Bremen, 1July99)

(defun EXTRACT-CONSTRAINTS (node constraint-type)
  "Extracts those features used in inter-rank constraints on the selected node"
  (let ((fundle (extract-fundle node))
	(constraint-list nil))
    (remove-duplicates
     (loop for constraint in (constituent-pass-brownboard (first node))
           as fundle-spec = (brownboard-elt-functionlist constraint)
           when (member (conflation-alias fundle-spec) fundle)
           append
           (loop for i in (brownboard-elt-featurespecs constraint)
                 when (equal (selection-def-id i) constraint-type)
                 collect (selection-def-features i))))))

#+ignore
(defun EXTRACT-CONSTRAINTS (node constraint-type)
  "Extracts those features used in inter-rank constraints on the selected node"
  (let ((fundle (extract-fundle node))
	(constraint-list nil))
    (loop for constraint in 
	  (constituent-pass-blackboard (first node))
	  when (and (consp constraint)
		    (eq (first constraint) constraint-type)
		    (member (second constraint) fundle))
	  do
	  (setf constraint-list
		(append constraint-list (cddr constraint))))
    constraint-list))

;;; an ugly support thing...
(defun EXTRACT-FUNDLE-NAMES (node)
  (mapcar #'(lambda (f) (intern (subseq f 0 (position #\# f)) "KPML"))
	  (mapcar #'string (extract-fundle node))))

;;; ----------------------------------------------------------------------
;;; and display functions presenting the above...
;;; changed as of 1.0.1 to display paradigmatic context

(defun DISPLAY-SELECTED-PRESELECTS (node window)
  (display-selected-constraint node window 'preselect))

(defun DISPLAY-SELECTED-CLASSIFIES (node window)
  (display-selected-constraint node window 'classify))

(defun DISPLAY-SELECTED-INFLECTIFIES (node window)
  (display-selected-constraint node window 'inflectify))

(defun DISPLAY-SELECTED-LEXIFIES (node window)
  (display-selected-constraint node window 'lexify))

;;; 2.0 added...
(defun DISPLAY-SELECTED-INSERTS (node window)
  (display-selected-constraint node window 'insertion))

;;; 2.0.2 added...
(defun DISPLAY-SELECTED-EXPANDS (node window)
  (display-selected-constraint node window 'expanded-object))

(defun DISPLAY-SELECTED-CONFLATIONS (node window)
  (display-selected-constraint node window 'complex-object))

;;; ----------------------------------------------------------------------
;;; 2.0.2 following function is broken out of display-selected-constraint
;;;       for more effective handleability for a variety of uses...
;;;       Takes a set of cases where a relevant realization statement
;;;       occurs (as from kpml-who-can-X), the fundle of the current node
;;;       investigated, and the currently applicable selection expression.
;;;       Returns list of pairs of (system . realization-statement).
;;; ----------------------------------------------------------------------

(defun EXTRACT-RELEVANT-SYSTEMS (possibles fundle selexpr)
  (let* ((relevant nil)
	 (in-selexpr
	  ;; get just those possibles that are in the current selexpression...
	  (let ((used nil))
	    (loop for p in possibles
		when (consp p)
		do (loop for f in (cdr p)
		       when (member (first f) selexpr)
		       do (push (cons (first p)(cdr f)) used)))
	    used)))
    ;; get just those that mention some member of the current fundle...
    (loop for (system . realizations) in in-selexpr
	do (loop for r in realizations
	       when (intersection (cdr r) fundle)
	       do (push (cons system r) relevant)))
    relevant))

;;;------------------------------------------------------------
;;; The associations that have been set up during a cycle
;;; of the grammar are hold in the constituent-pass-associations
;;; slot. Following displays the associations made within
;;; the generation of the clicked upon constituent.
;;;
;;; 4.0 break out the bit of the following code that is concerned
;;;     with making an association printable so that we can use
;;;     it elsewhere in the display.
;;; ----------------------------------------------------------------------

(defun DISPLAY-ASSOCIATIONS (node window)
  (let ((pass-tree (get-pass-data node)))
    (if (and pass-tree
	     (typep pass-tree 'constituent-pass))
	(progn
	  (format window "~%Function associations made within ~a:~%"
		  (constit-label node :horizontal))
	  (loop for association in 
		(constituent-pass-associations pass-tree)
		do
		(kpml-i::pen-pprint-for-clim 
		 (make-a-printable-association-entry association)
		 nil
		 window)))
      (format window
	      "~%Terminal node: no associations.~%"))))


;;; 4.0 this code, previously in DISPLAY-ASSOCIATIONS, now broken
;;;     out here...
;;;
(defun MAKE-A-PRINTABLE-ASSOCIATION-ENTRY (association)
  (list
   (function-association-function association)
   ;; 3.0
   ;;  for cases where the actual concept is unprintable (for example because
   ;;  it is a structure and so has a presentation with nasty characters 
   ;;  in it such as hash signs and greaterthan signs....
   ;; 3.1
   ;;  but should only call it if we do really have a concept and not
   ;;  just a hub or other similar identifier from the SPL...
   ;; 
   (let ((concept (function-association-concept association)))
     (if (and 
          (symbolp concept)
          (kb-concept-p concept))
	 (make-printable-concept-name concept)
       concept))
   (function-association-presentation-spec association)
   (function-association-term-set association)
   (function-association-term association)))

;;; 4.0 single display of ONUS for the structure graph...

(defun FETCH-ONUS-ASSOCIATIONS (node)
  (let ((pass-tree (get-pass-data node)))
    (when (and pass-tree
	       (typep pass-tree 'constituent-pass))
      (loop for association 
	    in (constituent-pass-associations pass-tree)
	    until (equal (function-association-concept association) 'onus)
	    finally
	    (return (make-a-printable-association-entry association))))))


;;; ----------------------------------------------------------------------
;;; 1.0.1

;;; It was previously awkward to relate a realization constraint
;;; back to the feature/system which triggered it. The following
;;; functions activated from the structure graph are therefore
;;; streamlined and modified in order to provide this information 
;;; directly.

;;; New function streamlines the method:
;;; 2.0 insert added... but not working yet...

(defun DISPLAY-SELECTED-CONSTRAINT (node window constraint)
  (multiple-value-bind
      (name who-can-fn)
      (case constraint
	(preselect  (values "preselection"   #'kpml-who-can-preselect))
	(classify   (values "classification" #'kpml-who-can-classify))
	(inflectify (values "inflection"     #'kpml-who-can-inflectify))
	(lexify     (values "lexify"         #'kpml-who-can-lexify))
	(insertion      (values "insertion"      #'kpml-who-can-insert))
	(complex-object (values "conflation"     #'kpml-who-can-conflate))
	(expanded-object  (values "expansion"      #'kpml-who-can-expand))
	)
    (cond ((eq node 'top)
	   (format window "~% Top node: no higher ~A constraints!" name))
	  ((or (stringp node)(null node)(symbolp node))
           (clim:notify-user window "Terminal node: try clicking on its parent for more information")
	   (format window "~%Terminal node; no such information!"))
	  (t
	   ;; 2.0.1
	   ;; formerly I attempted to get the information about realization
	   ;; statements from the blackboard, but actually this is a waste
	   ;; of time since all we actually have to do is intersect the
	   ;; who-can-X with the selection expression.
	     ;;
	     ;; 1.0.37
	     ;; somewhat complicated by the fact that if a node is terminal,
	     ;; then we must not go up to the `mother' node to get the
	     ;; selection expression information since this is already at
	     ;; this node. A terminal can be recognized when get-pass-data
	     ;; returns a non constituent-pass as a result.
	   (let* ((pass-tree 
		   (if (typep (get-pass-data node) 'constituent-pass)
		       (mother-of node)
		     (first node)))
		   (selexpr 
		    (and pass-tree
			 (typep pass-tree 'constituent-pass)
			 (constituent-pass-selection-expression pass-tree)))
		   (fundle (extract-fundle-names node))
		   (relevant-cases 
		    ;; go through all the arguments of constraints of the
		    ;; sought after type to find just those which are
		    ;; relevant for the case in hand...
		    (remove-duplicates 
		     (loop for fn in fundle
			 append (extract-relevant-systems
				 (funcall who-can-fn fn) fundle selexpr))
		     :test #'equal)))
	     (if relevant-cases
		 (loop for (system . realization) in relevant-cases
		     initially (format window 
				       "~2%Following ~A constraints imposed on~%  the function bundle: ~A"
				       name (constit-label node :horizontal))
		     do (clim:with-text-style 
			    (window kpml-i::*sans-serif--italic--8*)
			  (format window "~%           (in:")
			  (clim:with-output-as-presentation 
			      (window system 'kpml-i::system)
			    (format window "~A" system))
			  (format window ")~%               "))
			(clim:surrounding-output-with-border 
			    (window :shape :rectangle 
				    :ink (if kpml-i::*monochrome?*
					     kpml-i::*grey*
					   clim:+red+))
			  (kpml-i::pen-pprint-for-clim 
			   realization nil window T))
			(format window "~%"))
	       (format window "~%No ~A constraints imposed on~%  ~a:"
		       name (constit-label node :horizontal)))
	     )))))



;;; ----------------------------------------------------------------------
;;; 3.1 lexicalization history...
;;;      :KPML-3.2.10 "Lexicalization info from structure graph restored"
;;; ----------------------------------------------------------------------

(defun DISPLAY-LEXICALIZATION-HISTORY-FOR (node message-stream)
  (if (stringp node)
      (clim:notify-user 
       message-stream
       "This is just a string: try clicking on its parent for more information")
    (let ((pass-tree 
           (if (typep (get-pass-data node) 'constituent-pass) 
               (mother-of node)
             (first node)))
          (fundle (extract-fundle-names node)))
      (loop for a in (constituent-pass-associations pass-tree)
            when (and (member (function-association-function a) fundle)
                      (function-association-term-set a))
            do
            (present-lexicalization-history 
             message-stream fundle 
             (gethash (function-association-concept a) 
		      *lexical-selection-history*))
            (return-from DISPLAY-LEXICALIZATION-HISTORY-FOR nil)
            finally
            (clim:notify-user 
             message-stream 
	     ;; 3.2.10 make message more explicit.
	     (format nil
		     "No lexicalization information for this node. ~2%  Either it was not semantically lexicalized, ~%  or lexical history recording was not on when it was generated.~2%  Lexicalization history is currently ~:[UNSET~;SET~]." kpml::*lexical-history-flag*))))))


(defun PRESENT-LEXICALIZATION-HISTORY (message-stream fundle record) 
  (if record
      (clim:notify-user
       message-stream
       (with-output-to-string (stream)
         (format stream "~% Lexicalization history (for~{ ~A~})...~%" fundle)
         (format stream "~%  Constraints from grammar when lexicalized: ~{~%       ~A~}" 
                 (remove-duplicates (lex-history-features record)))
         (case 
             (lex-history-method record)
           (:spl (format stream "~2%  Lexical item was selected from SPL."))
           (:concept
            (format stream "~2%  Lexical item was selected by concept.")
            (if (lex-history-nearest-lexicalized record)
                (progn
                  (format stream "~%  The nearest concepts with attached lexical item were:")
                  (loop for (c . lexemes) in (lex-history-nearest-lexicalized record)
                        do
                        (format stream "~%          concept: ~A (lexemes: ~A)"
                                (kb-getconceptname c)
                                lexemes)))
              (format stream "~%  But no concept with attached lexical item was found."))
            (format stream "~2%  Termset: ~S, ~%  Term: ~S" 
                 (if (> (length (lex-history-termset record)) 10)
                     (append 
                      (subseq 0 10 (lex-history-termset record))
                      (cons '|...| nil))
                   (lex-history-termset record))
                 (lex-history-term record))))))
      (clim:notify-user
       message-stream (format nil "No information recorded.~2%Is lexicalization tracing switched on?"))))


;;;------------------------------------------------------------
;;; Following not yet used...
;;;
;;; The aliasfns are shorthand for entire fundles, these are
;;; defined in the brownboard, thus:
;;; (...  #S(BROWNBOARD-ELT
;;;                   FUNCTIONLIST #S(CONFLATION ALIAS TEMPO0#2
;;;                                   OTHERNODES (FINITE#2 VOICE#2 LEXVERB#2
;;;                                               PROCESS#2))
;;;                   FEATURESPECS (#S(SELECTION-DEF ID CLASSIFY FN PROCESS#2
;;;                                    FEATURES DOVERB)
;;;                                 #S(SELECTION-DEF ID CLASSIFY FN PROCESS#2
;;;                                    FEATURES MIDDLE)
;;;                                 #S(SELECTION-DEF ID CLASSIFY FN PROCESS#2
;;;                                    FEATURES OUTCLASSIFY-METEOROLOGY)
;;;                                 #S(SELECTION-DEF ID CLASSIFY FN FINITE#2
;;;                                    ...)))
;;; ...)
;;;

;;; ----------------------------------------------------------------------
;;; 1.1 addition of explicitly different treatment of incomplete
;;;     nodes that are examined in the middle of generation (ususally
;;;     because of some error condition that has arisen...)

(defun DISPLAY-INCOMPLETE-CONSTIT-FEATURES (node stream)
  (if (member :selection-expressions *pop-ups*)
      (if kpml-i::*selection-expression-tool*
          ;; 2.1 extra option...
          (kpml-i::startup-selexpression-tool-internal
           (constit-label node :horizontal)
           nil
           feature-selections 
	   node                     ;; 4.1
           nil
           nil
           T)
        (pop-up-a-selection-expression
         (constit-label node :horizontal)
         feature-selections
         :incomplete-p T))
    (progn
      (format stream "~%Selection expression so far of ~a:~%"
	      (constit-label node :horizontal))
      (kpml-i::pen-pprint-for-clim 
       feature-selections
       nil
       stream))))
	


;;; 3.1 it is possible that we are back at an incomplete-marked node, although
;;; there is no more traversal of that node itself to do, its incompleteness lies
;;; in the fact that there is further substructure to uncover... therefore, we
;;; may be able to use the proper associations... check this first before just+
;;; giving back those from the current traversal...

(defun DISPLAY-INCOMPLETE-ASSOCIATIONS (node stream)
  (format stream "~%Function associations made so far 
within ~a:~%" (constit-label node :horizontal))
  (loop for association being the hash-value of *associations-table*
        do
        (kpml-i::pen-pprint-for-clim 
         (list
          (function-association-function association)
          (make-printable-concept-name 
           (function-association-concept association))
          (function-association-presentation-spec association)
          (function-association-term-set association)
          (function-association-term association))
         nil
         stream)))
      
;;; ----------------------------------------------------------------------
;;; 2.1 a small helper for the selection expression tool
;;; ----------------------------------------------------------------------

(defun MAKE-SUBSTRING-FROM-STRUCTURE (node)
  (labels ((get-string (node)
                       (let ((children (constit-children node)))
                         (if children
                             (loop for c in children
                                   collect 
                                   (make-substring-from-structure c))
                           (list (terminal-node-label node) " ")))))
    (apply #'concatenate
           (cons 'string (flatten (get-string node))))))
          
(defun TERMINAL-NODE-LABEL (node-value)
  (cond
   ((eq node-value 'top)
    (princ-to-string *structure-graph-top-node*))
   ((stringp node-value)
    (if (string<= node-value "")
	"\"\""
      node-value))
   ((atom node-value)
    ;; just use the default pname function
    nil)
   ((listp node-value)
    ;; this is a nonterminal so we should not be here...
    "[nonterminal]")
   (t 
    (warning "Ill-structured sentence structure!")
    nil)))

  ;; 4.1
  ;;
(defun FETCH-NODE-WHERE-AM-I-VALUE (node)
  (let ((pass-tree (get-pass-data node)))
    (if (and pass-tree		  
	     (typep pass-tree 'constituent-pass))
	(loop for association 
	      in (constituent-pass-associations pass-tree)
	      when (equal (function-association-function association)
			  'where-am-i)
	      do (return (function-association-concept association)))
      nil)))






