(in-package "KPML")

;;; File: structure.lisp
;;;
;;; Contains basic structure building code that is used during generation...
;;; Starts off generation, goes through cycles of network traversal, 
;;; collects the realization constraints imposed and does them. Repeats
;;; until full structure generated. Essentially as inherited from Penman
;;; but with very many add-ons and slight changes.

;;; Additions:
;;; 0.7.34: trivial addition of resetting the global variable for
;;;         prosodies; should go away sometime.
;;;         John Wilkinson speed patch added.
;;; 3.1     agreement extensions
;;; 3.2     CLISP out.

(defun ALL-PARTS (&OPTIONAL Features Root-Hub )
  (setq alias-function-stack nil)
  (SETQ Constituent-Index 0)

  ;; 0.7.34 + 2.1 for prosodies...
  (setf *prosodies* nil)
  (clrhash *fundle-hub-linkage*)

  ;; 3.1 more focused lexicalization tracing...
  (clrhash *lexical-selection-history*)

  ;; 4.1 the following is generally a good idea...
  (clear-old-features-of-systems)
  
  (setq associations nil)
;speed-patch:  The (clrhash ...) below supercedes the (setq ...) above;
;the latter can probably be removed.
  (clrhash *associations-table*)
  (clrhash show-pass-hash-table)
  (when window-interface-flag
	(printwindow :clear-item-list-for-show-pass-menu))
  (progn
    (setq sentence-tree
	  (All-Parts0 (make-Whiteboard-Elt
		       :id  'Preselect
		       :aliasfn  '-top-
		       :featurelist  Features
		       :hub  Root-Hub)
		      (make-Brownboard-Elt
		       :functionlist  (make-conflation
				       :alias '-top-
				       :othernodes nil)
		       :featurespecs (List (make-Selection-Def
					    :id  'Preselect
					    :fn  '-top-
					    :features  Features)))))
    (Unwind-Passes sentence-tree)
    ;; (Do-Ordering "Final orderings: " T)
;;; 0.8: change of information given back and printing behavior makes
;;;      some of the following redundent, leave it for now and take
;;;      it out to test when the other has been finalized... The
;;;      only variable used should now be *mouseable-sentences*, which
;;;      could then be the result returned by this function altogether.
;;;      Following the operations performed here, *mouseable-sentences*
;;;      contains a list of the printable-constituent structures 
;;;      containing the *final* strings.
    (let ((orderings (all-orderings sentence-tree)))
      (setf *mouseable-sentence* (cdr (first orderings)))
      (setf *mouseable-sentences* (mapcar #'cdr orderings))
      (setf final-orderings
	    (loop for ordering in orderings
		  collect
		  (let ((printable-structure (cdr ordering)))
		    (multiple-value-bind
			(string structure)
			(mouseable-processed-string-from-printable-constituent
			 printable-structure)
		      (declare (ignore structure))
		      (cons (first ordering)
			    string))))))
    ))

;;;--------------------------------------------------------------------
;;; all-parts0 is responsible for the basic construction of the
;;; constituency tree. This originally bottomed out with
;;; classify/inflectify-ied nodes which call realize-classify (which
;;; calls realize-inflectify) in order to obtain a string appropriate
;;; for the realization. We now modify this so that such nodes now call
;;; for a further traversal of the grammar network, this time at word
;;; rank. This is enforced automatically by the presence of classify's
;;; or inflectify's. The word rank then takes on full responsibility for
;;; producing a final string. In future versions we can imagine that
;;; this will be generalized further to an inter-stratal realization
;;; relationship into the graphology or phonology. We still use the 
;;; old-style Penman lexicon, particularly the property-list, 
;;; for expressing irregular forms.
;;;
;;; Note that the update really only affects morphology at present;
;;; hence the distinctive treatment of inflectifies and classifies.
;;; The latter still refer to lexical features that should be defined
;;; in the lexicon and the lexical hierarchy. This opens up a 
;;; potential hole in the treatment, since some resources may rely
;;; on classifies producing a lexical item without providing
;;; appropriate morphological/word constraints directly. (This
;;; is the case, for example, in the Penman91:Nigel treatment of
;;; prepositions. Two cases use classifies rather than lexifies.)
;;; The consequence of this is that one can reach normal looking
;;; potential word constituents that do not have any word or
;;; morphology rank constraints. If this occurs, we now give a
;;; warning and refrain from attempting to realize the constituent.
;;; We must also, however, make sure that the already selected 
;;; lexical item is accepted as the realization (cf. update 3).

;;; Updates:
;;;    0:      First version: John, IPSI:11Dec91
;;;    1:      Second version: John, IPSI:17Oct92
;;;    2:      Improved tracing: John, IPSI:13Sep94
;;;    3:      Classification-gap treated: John, IPSI: 23Dec94
;;; KPML 0.7
;;; 0.7.10:    Was not passing on lexical selection information to
;;;            lower units. John:IPSI:Jan95
;;; 0.7.34     Agreement domains added.
;;; 1.1        KPML Coding tool hook added. John:Edinburgh:Jan98
;;; 2.0        main substructure construction code broken out into the 
;;;            following function where WBE and BS are the current pair
;;;            describing a subconstituent to be generated...
;;; 2.0.3      behaviour for lexify changed so that it is still possible
;;;            to use inflectifies, via the method realize-inflectify.
;;; 3.1        protect associations so that they are rebound on each cycle
;;;            rather than being thrown away.
;;; ----------------------------------------------------------------------

(defun GENERATE-SUBSTRUCTURE (wbe bs optional)
  (let ((Realize-Selectively-Flag optional))
    (declare (special Realize-Selectively-Flag))
    (Case 
     (whiteboard-elt-id WBE)
     (Preselect
      ;; Have to check whether a realization has already been decided on, 
      ;; since this has to be passed down to constituent0 (by means of 
      ;; the realization slot on the whiteboard). A realization is decided 
      ;; if the term of the FAT entry of the current microfunction 
      ;; has been set. This is to be found in the constituent-pass-associations
      ;; that is returned from the previous call to constituent0. 
      ;; The current microfunction is found in the whiteboard-elt-aliasfn
      ;; of WBE (but we have to strip off the microfunction numbering
      ;; unfortunately).
      ;;
      (setf (whiteboard-elt-realization WBE)
            (find-association 
             (remove-fn-tag (whiteboard-elt-aliasfn WBE)) 'term))  ;; 4.0
      (if (selectively-realize? bs Constituent-Index)
          ;; 3.1 Prague, Feb00. Make sure that current associations do not get
          ;;     lost by substructure generation... And also make available
          ;;     the associations of the parent while doing substructure (for
          ;;     use with prosodies).
          (let ((*parent-associations-table* *associations-table*)
                (*associations-table* (make-hash-table)))
            (declare (special *associations-table* *parent-associations-table*))
            (All-Parts0 WBE BS))))
		    
     ;;> Now, we introduce the variation for the traversal of word rank 
     ;;> triggered by a classify or lexify.
     ((Classify inflectify);; was (classify lexify)
      (cond 
       (*activate-word-rank-and-below*
	
	;; first check if we have an irregular form already specified in the
	;; lexicon which has to overrule  the regularities specified at word
	;; rank:  this   is   facilitated  by    the    altered version of
	;; realize-classify  which  now stores the list of Chosen-Word and
	;; Feature-List in the :realization slot of the whiteboard. We then
	;; need to pick up this info and throw it down to the word and below
	;; ranks in an appropriate manner.
	;;
	(let ((irregular
	       (check-word-rank-irregularity 
		(first (whiteboard-elt-realization WBE))
		(second (whiteboard-elt-realization WBE))
		curlan)))    ;; 2.0 addition
	  (cond (irregular 
		 (setf (whiteboard-elt-realization WBE) irregular)
		 (make-Constituent-Pass :whiteboard  (list WBE)))
		(t

		 ;;> Convert the existing whiteboard element so that
		 ;;> it is appropriate for another pass through the grammar: 
		 ;;> i.e., change the inflectified features to preselects.
		 ;;
		 (let* ((new-BS (prepare-word-rank-traversal-bs BS))
			(constraints (get-list-of-preselects new-bs)))
				     
		   ;;3>  Have to check for constraint-less constituents
		   ;;3>  being passed on to the word rank; caused by the
		   ;;3>  resources relying on classifies to do the job...
		   ;;
		   (cond (constraints
			  (setf (whiteboard-elt-id wbe) 'preselect)
			  (setf (whiteboard-elt-featurelist wbe) constraints)
				     
;;; (print "ALL-PARTS0 tuning; realization is currently:")
;;; (print (whiteboard-elt-realization wbe))

			  ;;> and then enter the grammar as for a normal
			  ;;> non-word rank... (if required!) having first
			  ;;> ensured that the classify information is 
			  ;;> accessible... Have to be careful of whether
			  ;;> we get a list of words or a single word (!)
			  ;;
			  (setf (whiteboard-elt-realization wbe)
			    (if (listp
				 (car (whiteboard-elt-realization wbe)))
				(caar (whiteboard-elt-realization wbe))
			      (car (whiteboard-elt-realization wbe))))
			 
			  (if (selectively-realize? new-bs Constituent-Index)
			      (All-Parts0 WBE new-BS)))

			 (t
			  ;; 2.0 removes an annoying and often meaningless
			  ;;     warning about lack of constraints.
			  (setf (whiteboard-elt-realization wbe)
			    (get-classified-lexeme WBE))
			  (make-Constituent-Pass :whiteboard (list wbe)))
			 ))))))
       (t 
	(make-Constituent-Pass
	 :whiteboard  (list WBE)))))

     ;;> Now have, separate behavior for lexifies... Just consider us done
     ;;> -- before this was also the case for classify.
     (Lexify
      ;; 2.0.3  pass the lexicalized item on to realize-inflectify
      ;;        whiteboard elements now extended so that they allow
      ;;        lexified information to contain inflection information.
      ;;        This relies on the :featurelist of the WBE be a list
      ;;        where the first element is the lexical item and the
      ;;        rest are the inflection features... Note now that this
      ;;        *always* calls realize-inflectify to give a possibly
      ;;        language specific method specialization a chance to
      ;;        operate (even when there are no inflectify features).
      ;;        Only if there is no lexical item selected at all (which
      ;;        is the case, for example, if we are doing a template),
      ;;        does realize-inflectify not get called here.
      (when (whiteboard-elt-featurelist wbe)
	(setf (whiteboard-elt-realization wbe)
	  (realize-inflectify (first (whiteboard-elt-featurelist wbe))
			      (cdr   (whiteboard-elt-featurelist wbe))
			      curlan)))
      (make-Constituent-Pass
       :whiteboard  (list WBE)))

     ;; And add  the  kind of  entity  that finally  bottoms out   of the
     ;; lexico-morpho-grammar into  linguistic substance. This  sets the
     ;; realization   element of the whiteboard accordingly via the new
     ;; function:  make-substance. Entities of  this kind are created by
     ;; means of the realization statement `preselect-substance'.
     (Substance
      (make-Constituent-Pass :whiteboard  (list (make-substance WBE))))

     ;; Otherwise, no idea what to do with it, so do nothing... this is
     ;; just a constraint-free constituent...
     (otherwise NIL))))



;;; 2.0 gutted all-part0 (see above).
(defvar GRAPHICAL-SELECTION nil)
;;; This only gets set T when we are doing generation and have started using
;;; graphical selective realization.

(defun ALL-PARTS0 (&OPTIONAL Whiteboard-Elt Bundle-For-Display )
  (let 
;;; ----------------------------------------------------------------------
;;;> the beginning is almost as it was before... initialization...
    ((Constituent-pass-data nil)
     (prosody-dependents nil)
     (dependency-ordering nil)
     )
    ;;;reset windows here
    (incf Constituent-Index)
    (setf (whiteboard-elt-index whiteboard-elt) constituent-index)
    (push (whiteboard-elt-aliasfn Whiteboard-Elt) 
	  alias-function-stack) ;used by whereamiidcode

    ;; 0.7.34+3.1 Reset the prosody globals...
    (setf *active-unit-dependencies* nil
	  *active-conditional-preselections* nil
	  *active-self-conditional-preselections* nil)

;;; ----------------------------------------------------------------------
    ;; >>> This is where we initiate a traversal of the network to gather
    ;;     structure constraints...
    ;;
    (setq Constituent-Pass-data 
	  (Constituent0 Whiteboard-Elt Bundle-For-Display))
;;; ---------------------------------------------------------------------

    (setf (gethash constituent-index show-pass-hash-table) 
      constituent-pass-data)
    (when window-interface-flag 
      (printwindow :setup-item-list-for-show-pass-menu))
    (when (eq constituent-index *trace-this-constituent*)
      (set-tracing-profile))
    (when Show-Constituent-Starts
      (printwindow :display-pane 
		   (format nil "  |======|======|======|======|======| ~a" 
			   Constituent-Index )))

    ;; ----------------------------------------------------------------------
    ;; And on to the subconstituents if there are any...

    (cond
     ((Constituent-Pass-whiteboard Constituent-pass-data)

      ;; 0.7.34 : the further realization at this point in structure is
      ;;   determined by the lists CONSTITUENT-PASS-WHITEBOARD  and -BROWNBOARD
      ;;   of CONSTITUENT-PASS-DATA. Rearranging these lists therefore 
      ;;   rearranges the generation strategy. Breadth prior to depth is
      ;;   however more firmly hardwired. Following function just rearranges
      ;;   these two lists and adds the prosody information to a permanently
      ;;   accessible association list. Does this when there is prosody information
      ;;   by SIDE-EFFECTING the order of elements on the white- and brownboards.       

      (setf dependency-ordering
	    (agreement-domain-enforcement Constituent-pass-data))
      (setf prosody-dependents (extract-prosodies dependency-ordering))
      
       ;; 1.1 tools: Coding hook...
      (when *coding-mode* (do-coding-operations-following-a-cycle
			   Constituent-Pass-data))
      
      (setf (constituent-pass-constituents Constituent-Pass-data)
	 (if (or (not window-interface-flag)                   ;; 2.0
		 (and realize-selectively-flag                 ;; add two ways of
		      (eq *realize-selectively-mode* :serial)) ;; selectively
		 (not (or graphical-selection                  ;; realizing...
			  realize-selectively-flag)))

	     ;; (1) the old way...
	     (let ((one-rank-collection nil))                  
	       (loop for WBE in (constituent-pass-whiteboard Constituent-pass-data) 
		   as BS in (constituent-pass-brownboard Constituent-pass-data)
		   do
		     (setf one-rank-collection
		       (append 
			one-rank-collection
			(list
			 (progn 
			   ;; 0.7.34 take additional action if this function is 
			   ;;         a dependent... note: once we are in this
			   ;;         loop, new constituents are being generated...
			   (when (and prosody-dependents
				      (agreement-domain-dependent-p 
				       bs prosody-dependents one-rank-collection))
			     (agreement-domain-dependent-actions 
			      wbe bs dependency-ordering one-rank-collection))
			    
			   (generate-substructure 
			    wbe bs realize-selectively-flag))))))
	       one-rank-collection)

	   ;; (2) and the new way...
	   (let ((wbe-bs-pairs (make-subconstituent-list constituent-pass-data))
		 (graphical-selection T))
	     (declare (special graphical-selection))
	     (loop 
		 until (loop for pair in wbe-bs-pairs
			   always (constituent-to-generate-status pair))
		 do
		   (loop for pair 
		       in (bring-up-a-constituent-selection-dialog wbe-bs-pairs)
		       when (eq (constituent-to-generate-status pair) :generate)
		       do 
			 (setf (constituent-to-generate-status pair)
			   (generate-substructure
			    (constituent-to-generate-wbe pair)
			    (constituent-to-generate-bs pair)
			    nil))))
	     (substitute 
	      nil :unwanted
	      (mapcar #'constituent-to-generate-status wbe-bs-pairs))
	   )))
	 ))
      (pop alias-function-stack)	;usedbywhereamidcode
      Constituent-pass-data))

;;; ----------------------------------------------------------------------
;;; 2.0
;;; Graphical selection stubb... overwritten when KPML-I interface loaded...  
;;;
;;; Function needs to return  a revised  version of its   parameter where the
;;; subconstituents to be generated receive status :generate. Any that
;;; will never be generated should  receive status  :unwanted. As long  as
;;; any constituent has status nil, it will be  re-offered to the user to
;;; see if  it should  be  generated or not. Possible dependencies
;;; (such as may be set up with agreement) are *not* enforced.
;;; If the function as a whole returns nil, then
;;; the user is just re-presented with the current options.
;;;
;;; The following
;;; stubb therefore causes all subconstituents to be generated directly
;;; after giving a warning. 

(defun BRING-UP-A-CONSTITUENT-SELECTION-DIALOG (wbe-bs-pairs) "stubb"
       (warning "No window interface in place, cannot do graphical selection.")
       (loop for p in wbe-bs-pairs
	   do (setf (constituent-to-generate-status p) :generate))
       wbe-bs-pairs)

;;; ----------------------------------------------------------------------
;;; Need to explicitly make available the selected term that is being
;;; passed down to the grammar traversal at word and below rank. Was
;;; originally based on the corresponding Penman function. Now there are
;;; so many additions that it is better not to assume any direct
;;; equivalence.
;;;
;;; Folded in changes necessary for: kpml-templates.lisp

(defun CONSTITUENT0 
    (&OPTIONAL Whiteboard-element-param Bundle-For-Display-param)
  "Only called where white-board-elt-id=preselect signifying a real pass through the grammar"    
  (let ((spl-term (whiteboard-elt-hub whiteboard-element-param)))
    (cond ((and (symbolp spl-term)          ;; 1.1 (avoid numbers)
		(symbol-value spl-term)     ;; 1.0.21b (for, e.g., genre)
		(eq (term-graph-type (symbol-value spl-term)) 'template))
	  
	   ;; Found a template...
	   (make-constituent-pass-from-template
	    (cdr (assoc 'pattern 
			(term-graph-features (symbol-value spl-term))))
	    whiteboard-element-param bundle-for-display-param))

	  ;; else do as before...
	  (t
	   (constituent1 Whiteboard-element-param Bundle-For-Display-param)
	   ))))

;;; ----------------------------------------------------------------------
;;; The following function is just the old constituent0 function renamed.
;;; Some of the internal structure is now broken out into smaller 
;;; functions for readability. It is otherwise unchanged for templates.
;;; 2.0 also uses the grammatical constituent to index selection
;;;     expressions in the example records...
;;; 2.1 SPL-settable preselections and language are added. Care is needed with the
;;;     latter because it is not quite clear what this means for example records that
;;;     may themselves be multilingual. It is assumed at this point that it someone
;;;     uses this rather obscure possibility, then they need to know what they are doing.
;;;     The feature is not documented so as to avoid people shooting their feet.
;;; 4.0 per-constituent language switching enforced

(defun CONSTITUENT1 
    (&optional Whiteboard-element-param Bundle-For-Display-param)
  "Only called where white-board-elt-id=preselect signifying a real pass 
   through the grammar"    
  ;;; whiteboard-element, bundle-for-display and current-preselections 
  ;;; were specvars. (Penman comment)
  (setq whiteboard-element whiteboard-element-param)
  (setq bundle-for-display bundle-for-display-param)
  (constituent-startup-messages bundle-for-display whiteboard-element)
  ;; 2.1
  (let* ((hub (whiteboard-elt-hub whiteboard-element))
         (hub-is-term-graph? (and hub
                                  (symbolp hub)
                                  (boundp hub)
                                  (term-graph-p (symbol-value hub)))))

    ;; 2.1 allow term-per-term rebinding of curlan...
    ;; 4.0 also need to scope further for all subcalls and for
    ;;     the structure and lexicon.
    (let ((curlan 
	   (cond ((and hub-is-term-graph?
		       (term-graph-language (symbol-value hub)))
		  (term-graph-language (symbol-value hub)))
		 ((whiteboard-elt-language whiteboard-element)
		  (whiteboard-elt-language whiteboard-element))
		 (t
		  curlan))))
      (declare (special curlan))

    (prog (Hold-Preselections)
      (setq used-inquiry-operators nil)
      (incf Network-Entry-Count)
					;(Check-Derived-Data)
      (SETQ Current-Preselections
	    (Augment-Preselections 
             (append
	      (whiteboard-elt-featurelist whiteboard-element)
              ;; 2.1
              (if hub-is-term-graph? (term-graph-grammatical-features (symbol-value hub))
                nil))))

      (SETQ Hold-Preselections Current-Preselections )
      (Reset-Systems)
      (clrhash *associations-table*)
      (funcall 'Associate 'ONUS 
	       (whiteboard-elt-hub whiteboard-element) 'Concept)

      ;;;> Here is the extra clause for systemicized morphology; 
      ;;;> this should also be added into any other 
      ;;;> further independently arrived-at versions of constituent0
      ;;;> that have been developed.
      (if (and 
	   *activate-word-rank-and-below* 
	   (whiteboard-elt-realization whiteboard-element))
	  (funcall 'Associate 'ONUS
		   (whiteboard-elt-realization whiteboard-element) 'Term))
      
      (Traverse-Grammar 'Start '*Top-Level*)
        
      ;; 3.1 : adds in the inter-rank agreement, or multiple conditional preselection
      (multiple-conditional-preselection-according-to feature-selections)

      (when (or Domain-Implemented-Value-Compare-Flag
                Manual-Response-Mode-Flag
                Store-To-Environment-Flag)
        (Update-Example (whiteboard-elt-hub whiteboard-element)
                        (whiteboard-elt-aliasfn whiteboard-element) ;; 2.0
                        ))
      (SETQ Brownboard (Bundle-Blackboard Blackboard))
      (SETQ Whiteboard (Process-Brownboard Brownboard))
      (Results) 
      (when Current-Preselections
        (Warning "Unconsumed Preselections are:" Current-Preselections 
	         " from original set: "
	         Hold-Preselections)
        (incf Warning-Count (LENGTH (CDR Current-Preselections))))
      (Add-Top-Level-Expansion-To-Blackboard 
       (whiteboard-elt-aliasfn whiteboard-element))
      (Left-To-Right 
       (CAR (Do-Ordering "Orderings: " Show-Orderings)))
      (RETURN (make-Constituent-Pass
	       :associations associations
	       :blackboard (Number-only-Functions Blackboard)             ;; 2.1
	       :brownboard (Number-Functions-in-brownboard Brownboard)
	       :orderingrelations (Number-Functions Ordering-Relations)
	       :whiteboard 
	       (loop for wbe in Whiteboard
		     collect (make-Whiteboard-Elt
			      :id (whiteboard-elt-id wbe)
			      :aliasfn (Number-Functions
				        (whiteboard-elt-aliasfn wbe))
			      :featurelist (whiteboard-elt-featurelist wbe)
			      :realization
                              ;;;> Also: if a realization has been found 
                              ;;;> (by lexifies, for example),
                              ;;;> then this information should be maintained --- 
                              ;;;> alternatively,
                              ;;;> if substance constraints have  been found (in FAT
                              ;;;> under term), then these should also be maintained.
			      (if (whiteboard-elt-realization wbe)
			          (whiteboard-elt-realization wbe)
			        (find-association 
			         (Number-Functions
			          (whiteboard-elt-aliasfn wbe))
			         'term))
			      :hub (whiteboard-elt-hub wbe)
			      :index nil
			      :language curlan                         ;; 4.0
			      ))
	       :sequences (Number-Functions Sequences)
	       :selection-expression feature-selections))))))
  
(defun CONSTITUENT-STARTUP-MESSAGES (bundle-for-display whiteboard-element)
  (when (And Bundle-For-Display Show-Constituent-Starts)
    (printwindow :display-pane " ")
    (printwindow :display-pane (indent-and-fill "Starting on bundle:"))
    (printwindow :display-pane 
		 (pretty 
		  (list-of-brownboard-elt-functionlist bundle-for-display)))
    (printwindow :display-pane 
		 (pretty 
		  (list-of-brownboard-elt-featurespecs bundle-for-display)))
    (when (whiteboard-elt-hub whiteboard-element)
      (printwindow 
       :display-pane
       (indent-and-fill 
	(format nil 
		"Currently constructing a constituent associated with hub: ~a"
		(whiteboard-elt-hub whiteboard-element)))))))


;;; Following returns T if realization is required for the
;;; mentioned constituent, else NIL.

(defun SELECTIVELY-REALIZE?  (bs Constituent-Index)
  (if 
      (cond ((> Constituent-Index Complexity-Maximum)
	     (printwindow 
	      :display-pane 
	      `(" "
		"*** Too many constituents ***"
		" (Complexity-Maximum = "
		,(format nil "~a" complexity-maximum)
		")"  " "
		"...not further realizing this constituent:"
		,(format nil "~a" BS) " "))
	     nil)
	    (Realize-Selectively-Flag
;;; 0.9 add in some housekeeping...
	     (when *clear-old-features* (clear-old-features-of-systems))
	     (when window-interface-flag
	       (printwindow 
		:display-pane 
		(indent-and-fill (format nil "Do you want to realize: ")))
	       (printwindow 
		:display-pane 
		(pretty (list-of-brownboard-elt BS))))
	     (askwindow :yes-or-no 
			(cons "Do you want to realize: "
			      (pretty (list-of-brownboard-elt BS)))))
	    (T T))
      (progn ()
	(when Show-Constituent-Starts
	      (printwindow 
	       :display-pane 
	       '("" " |******|******|******|******|******| " " " " ")))
	(make-Constituent-Pass
	 :whiteboard
	 (list (make-whiteboard-elt
		:id 'classify
		:aliasfn (car (list-of-brownboard-elt-functionlist BS))
					;(conflation-alias (brown..))
		:realization 
		(feature-pack (list-of-brownboard-elt-functionlist BS))
		:index nil
		)))
	T)
    nil))

;;; ----------------------------------------------------------------------
;;; The  following function (originally from Penman's boards.lisp) 
;;; needed  to be changed in
;;; order to   handle the bottoming out  of  constituents in chunks of
;;; linguistic  substance.  This   is  indicated by  a  new blackboard
;;; bundle of type  `substance', introduced by the preselect-substance
;;; realization statement.
;;;
;;; 2.0.3   lexify used to swamp all other information, 
;;;         including inflectifies...
;;;         (clisp also removed and the very repetitive code cleaned-up)
;;; ----------------------------------------------------------------------

(defun BUNDLE-BLACKBOARD (board)
  ;; 2.0.3 make the more repetitive parts into macros..
  (macrolet ((MAKE-REALOP-LIST (realop)
	       `(loop for E in Board 
		    when (And (value-if-listp E)
			      (member (Second E) Function-List)
			      (Eq ',realop (CAR E)))
		    append (loop for Feature in (CDDR E) 
			       collect (LIST ',realop (Second E) Feature))))
	     (MAKE-BROWNBOARD-ELTS (list)
	       `(loop for item in ,list collect
		      (make-selection-def :id (first item)
					  :fn (second item)
					  :features (third item)))))

    ;; 2.0.3 no point doing all these checks if no cautions are given...
    (when show-cautions-flag  
      (loop for Operator 
	  in '(Lexify Classify Inflectify Out-Classify Preselect Substance)
	  do (loop for item in Board 
		 when (and (value-if-listp item)
			   (eq (CAR item) Operator)
			   (not (Insert-P Board (Second item))))
		 do (caution Operator "'s function " (Second item)
			     " has not been inserted."))))

    (loop for Expression in Board
	;;;> added type of realization to list...
	with Expanded-Fns = (loop for Expression in Board 
				when (And (value-if-listp Expression)
					  (Eq (CAR Expression) 'Expanded-Object))
				collect (Second Expression))
	and Function-List and Preselect-List and Substance-list 
	and Class-List and Lexify-List and Inflectify-List
	and Out-Classify-List and Bundles
	unless (Or (member Expression Expanded-Fns)
		   (And (value-if-listp Expression)
			(member (CAR Expression)
				'(Expanded-Object Preselect Substance
				  Lexify Inflectify Outclassify
				  Classify))))
	do (SETQ Function-List
		 (cond
		  ((ATOM Expression)
		   (list Expression))
		  (T (Case (CAR Expression)
			   (Complex-Object (COPY-LIST (CDR Expression)))
			   (otherwise 
			    (Warning "Function Realization Unable to handle " 
				     Expression))))))
	   
	   (SETQ Inflectify-List   (make-realop-list inflectify))
	   (SETQ Out-Classify-List (make-realop-list out-classify))
	   (SETQ Preselect-List    (make-realop-list preselect))
	   (SETQ Substance-List    (make-realop-list substance))
	   (SETQ Class-List        (make-realop-list classify))
	   (SETQ Lexify-List       (make-realop-list lexify))

	   ;; 2.0.3 no point doing all these checks if no cautions are given...
	   (when show-cautions-flag  
	     (when (And Preselect-List Inflectify-List)
	       (Caution "Mixed Inflectified and Preselected realization of " 
			Function-List " -- " 
			Inflectify-List " and " Preselect-List))
	     (when (And Preselect-List Out-Classify-List)
	       (Caution "Mixed Out-Classified and Preselected realization of " 
			Function-List " -- " 
			Out-Classify-List " and " Preselect-List))
	     (when (And Preselect-List Class-List)
	       (Caution "Mixed Classified and Preselected realization of " 
			Function-List " -- " 
			Class-List " and " Preselect-List))
	     (when (And Preselect-List Lexify-List)
	       (caution "Mixed Lexified and Preselected realization of " 
			Function-List " -- " 
			Lexify-List " and " Preselect-List))
	     (when (And Class-List Lexify-List)
	       (Caution "Mixed Classified and Lexified realization of " 
			Function-List " -- "
			Class-List  " and " Lexify-List))
	     (when (and substance-list 
			(or Preselect-List Inflectify-List Out-Classify-List
			    Class-List Lexify-List))
	       (Caution 
		"Mixed commitment to linguistic substance and lexicogrammatical"
		" realization of " Function-list)))
       
	   (when (> (LENGTH Lexify-List) 1)
	     (Warning 
	      "The current constituent has been lexified more than once:  " 
	      Lexify-List)
	     (loop for Sub-List on Lexify-List 
		 do (loop for Individual-List in (CDR Sub-List)
			when (Eq (CADAR Sub-List) (Second Individual-List))
			do (Warning "Function " (CADAR Sub-List)
				    " has been double lexified by features "
				    (Third (CAR Sub-List)) " and "
				    (Third Individual-List) ".")))
	     (SETQ Lexify-List (List (CAR Lexify-List))))
       
	   (setq lexify-list     (make-brownboard-elts lexify-list)
		 class-list      (make-brownboard-elts class-list)
		 inflectify-list (make-brownboard-elts inflectify-list)
		 preselect-list  (make-brownboard-elts preselect-list)
		 substance-list  (make-brownboard-elts substance-list))

	   (push (make-Brownboard-Elt
		  :functionlist  (make-conflation
				  :alias (car function-list)
				  :othernodes (cdr function-list))
		  :featurespecs 
		  ;; 2.0.3  this used to make lexifies take precedence over
		  ;;        all other information, then classifies/inflectifies,
		  ;;        preselects and substances... the first information
		  ;;        found caused all other to be lost... Rearrange this
		  ;;        so that substance is highest priority and lexifies
		  ;;        do not swamp inflectifies...
		  ;;        Note: lexify-list is maximally a singleton list.
		  (Or substance-list
		      (if (and lexify-list inflectify-list)
			  (append lexify-list inflectify-list)
			lexify-list)
		      (append Class-List Inflectify-List)
		      Preselect-List))
		 Bundles)
	finally (return (dreverse  (remove-duplicates Bundles :test #'equal))))))


;;; ----------------------------------------------------------------------
;;; 4.0 the old function MICROFUNCTION-NAME is replaced by the duplicate
;;;     function REMOVE-FN-TAG, previously defined in orderings.lisp
;;; ----------------------------------------------------------------------

(defun REMOVE-FN-TAG (f) 
  (let ((sf (symbol-name f)))
    (intern (subseq sf 0 (position #\# sf)) "KPML")))

(DEFUN Unwind-Passes (Passes)
  "Take the tree of Constituent-Pass records and 
   distribute it to appropriate global vars"
  (setq blb nil)
  (setq brb nil)
  (setq whb nil)
  (setq ors nil)
  (setq fat nil)
  (Unwind-Passes0 Passes)
  (SETQ Blackboard blb)
  (SETQ Brownboard brb)
  (SETQ Whiteboard whb)
  (SETQ Ordering-Relations ors)
  (setq associations fat))

(DEFUN Unwind-Passes0 (Passes)
  (when passes
    (SETQ blb (append blb (constituent-pass-blackboard Passes)))
    (SETQ brb (append brb (constituent-pass-brownboard Passes)))
    (SETQ whb (append whb (constituent-pass-whiteboard Passes)))
    (SETQ ors (append ors (constituent-pass-orderingrelations Passes)))
    (setq fat (append fat (constituent-pass-associations passes)))
    (loop for P in (constituent-pass-constituents Passes)
	  do (Unwind-Passes0 P))))

(defun COMPLETE-CLOSURE (head closure-list)
  (let ((ans nil)
	(this-closure nil)
	(elt nil)
	(seen nil)
	(queue (list head))
        ;; 2.1 try to pick up loops...
        (current-length 0)
        (repeats 0)
        )
    (while (progn
             (if (>= (length queue) current-length)
                 (progn
                   (setf current-length (length queue))
                   (setf repeats (1+ repeats))
                   (when (> repeats 100) 
                     (warning "Possible cycle in defined system dependencies. Check before trying again.")
                     (throw 'kpml-say-error nil)))
               (setf current-length (length queue)
                     repeats 0))
             (setq elt (pop queue)))
	   do (when (not (member elt seen))
		(setq this-closure (assoc elt closure-list))
		(setq ans (UNION ans (rest this-closure))) ;(closure-element-reachablefns this-closure)
		(setq queue (UNION queue (rest this-closure))) ;(closure-element-reachablefns this-closure)
		(push seen elt)))
    (rplacd (assoc head closure-list) ans)))

;; 0.9: reference to CLISP function MKLIST removed.

(DEFUN Augment-Preselections (Preselection-Set)
  (PROG ((New-Preselections Preselection-Set))
	More-Preselections
	(when Show-Preselections-Flag
	  (printwindow :display-pane " ")
	  (printwindow :display-pane 
		       (indent-and-fill 
			(format nil 
				"Given preselections are: ~a"  
				new-preselections)))
	  (printwindow :display-pane " "))
	(SETQ New-Preselections
	      (remove-Duplicates
	       (Dremove 
		'Start
		(append New-Preselections
			(loop for Selection in New-Preselections
			     nconc (PROG (Augs)
					(SETQ Augs
					      (COPY-LIST
					       (fetch-exact-Feature-def-field 
						'Preselection-Features
						Selection)))
					(cond
					 ((Not Augs)
					  (Caution 
					   "Unenforceable Preselection Has no Path: "
					   Selection))
					 ((Not (member 'Start Augs))
					  (caution 
					   "Preselection of a Feature without a Guaranteed Path: "
					   Selection)))
					(RETURN Augs))))) :test #'equal))
	
	(when (or Show-Preselections-Flag Supplement-preselections-flag)
	  (printwindow :display-pane " ")
	  (printwindow :display-pane  "Preselections after path augmentation are: ")
	  (printwindow :display-pane (pretty new-preselections))
	  (printwindow :display-pane " "))
	
	(when (And Supplement-Preselections-Flag
		   (askwindow :yes-or-no "Want to add more Preselections? "))
	  (setq New-Preselections 
	    (UNION New-Preselections  
		   (coerce-list-of-kpml-symbols
		    (askwindow :value
			       "Input a feature: "))))
	  (Go More-Preselections))
	(SETQ New-Count (- (LENGTH New-Preselections)
				    (LENGTH Preselection-Set)))
	(incf Augmentation-Count New-Count)
	(RETURN New-Preselections)))


;;; 0.9 stand-in, there's probably one of these lying around already too
;;;     somewhere...

(defun COERCE-LIST-OF-KPML-SYMBOLS (x)
  (unless (consp x) (setf x (list x)))
  (loop for y in x collect (intern (string y) "KPML")))
	  


;; 4.0 providing more discriminating information...
;;
;;     In Penman there were two sources of expanded-objects on the
;;     blackboard, one directly from expand realisation statements,
;;     and this one here, whereby dependent head constituents are
;;     added into an expanded object. This conflation of functionality
;;     means that it is more difficult afterwards to recover the
;;     genuine expansions from the straightforward rank expansion of
;;     filling. So we separate out the two kinds here and make sure
;;     that the ordering functions can respond to both of them.

(DEFUN Add-Top-Level-Expansion-To-Blackboard (Head-Function)
  "Adds top level expanded object to the blackboard"
;;; The interlisp implementation uses both record and list access to the blackboard.
;;; Since this coding practice is not possible in commonlisp (nor desirable) all
;;; references to the blackboard will be done via list access to keep recoding to 
;;;  a minimum.
  (PROG (Expand-Offspring Simple-Terminals)
	(SETQ Expansions (clisp::for Node in Blackboard
			      when (And (value-if-listp Node)
					(Eq (first Node)
					    'Expanded-Object))
			      collect (cdr Node)))
	(SETQ Conflations (clisp::for Node in Blackboard
			       when (And (value-if-listp Node)
					 (Eq (first Node)
					     'Complex-Object))
			       collect (cdr Node)))
	(SETQ Expand-Parents (clisp::for Ex in Expansions collect (car Ex)))
	(clisp::for Ex in Expansions
	     do (clisp::for Fn in (cdr Ex)
		     do (PushNew fn Expand-Offspring )))
	(SETQ Simple-Terminals (clisp::for Node in Blackboard
				    when (And (ATOM Node)
					      (Not (member Node Expand-Parents)))
				    collect Node))
	;; 4.0
	(push (cons 'filled-expanded-object
		    (cons head-function
			  (PROG (topfns)
				(clisp::for C in Conflations
				     do (SETQ topfns (append C topfns)))
				(SETQ topfns (append Simple-Terminals 
						     Expand-Parents 
						     topfns))
				(RETURN (set-difference
					  (remove-duplicates topfns)
					  Expand-Offspring)))))
	      blackboard)))


(DEFUN Insert-P (Board function)
  (clisp::for item in Board thereis (Or (Eq item function)
				 (And (listp item)	;car of item should give nil
				   (Eq (CAR item)
					  'Complex-Object)
				      (clisp::for x in (CDR item) thereis (Eq x function))))))



					    
(defun hub-analyze (function-list bundle-type)
  (let ((found-hubs nil)( hub nil))
    (dolist (item function-list)
      (when (setq hub (find-association item 'concept))
	(push hub found-hubs)))
    (setq hubs (remove-duplicates found-hubs :test #'equal))
    (case (length found-hubs)
      (1 (first found-hubs))
      (0 (when (equal bundle-type 'preselect)
	   (warning "There was no hub associated with a function among: " function-list))
	 nil)
      (otherwise
	(case bundle-type
	  ((classify lexify) 
	   (first found-hubs))
	  (otherwise
	    (caution "The functions " function-list " had multiple associated hubs with a bundle type of " bundle-type
		     " Using hub " (first found-hubs))
	    (first found-hubs)))))))

(defun prepare-word-rank-traversal-bs (BS)
  (let ((new-bs (copy-brownboard-elt BS)))
    (setf (brownboard-elt-featurespecs new-bs)
	  (loop for sel-def in (brownboard-elt-featurespecs bs)
		when (or (equal (selection-def-id sel-def) 'inflectify)
			 (equal (selection-def-id sel-def) 'preselect))
		  collect (make-selection-def
				    :id 'preselect
				    :fn (selection-def-fn sel-def)
				    :features (selection-def-features sel-def))))
    new-bs))

(defun get-list-of-preselects (bs)
  (loop for sel-def in (brownboard-elt-featurespecs bs)
		when (equal (selection-def-id sel-def) 'preselect)
		  collect (selection-def-features sel-def)))




(defun LIST-OF-BROWNBOARD-ELT-CLASSIFYSPECS (bundle)
  "returns the list of all classify feature specs of a bundle"
;;; 0.7.9 added.

  (loop for item in (brownboard-elt-featurespecs bundle)
	when (eq (selection-def-id item) 'classify)
	collect (selection-def-features item)))

;;; ----------------------------------------------------------------------
;;; 2.0.3  following gave a warning if there appeared to be a multiple lexify,
;;;        but this cannot occur here since the whiteboard processing of
;;;        bundle-blackboard would have thrown it out already. Leaving this
;;;        here would then pick up our new combination of lexify and
;;;        inflectify information, so the warning is removed here...
;;;        (clisp also removed)
;;; ----------------------------------------------------------------------

(defun PROCESS-BROWNBOARD (board)
  (let ((temp nil))
    (loop for Bundle in Board
	for id = (if (car (setq temp (brownboard-elt-featurespecs  Bundle)))
		     (selection-def-id (car temp))
		   nil)
	for hub = (Hub-Analyze (list-of-brownboard-elt-functionlist  Bundle) Id)
	for feature-list = (loop for Presel 
			       in (brownboard-elt-featurespecs Bundle)
			       collect (selection-def-features Presel))
	collect 
	  (cond
	   ((Or Id Hub)
	    (make-Whiteboard-Elt
	     :id  Id
	     :aliasfn (conflation-alias (brownboard-elt-functionlist  Bundle))
	     :featurelist  Feature-List
	     :hub  Hub
	     :realization 
	     (Case Id
		   ((Classify Inflectify)
		    (when Show-Constituent-Starts
		      (printwindow 
		       :display-pane 
		       (pretty-with-header
			(list-of-brownboard-elt bundle)
			"Immediately (nonsystemically) realizing bundle: ")))
		    (Realize-Classify Bundle))
		   (Lexify
		    (when  Show-Constituent-Starts
		      (printwindow 
		       :display-pane 
		       (pretty-with-header
			(list-of-brownboard-elt bundle)
			"Immediately (nonsystemically) lexifying bundle: ")))
		    ;; 2.0.3 check for (> (LENGTH Feature-List) 1) removed
		    ;;       at this point...
		    (cond
		     ((setq temp 
			(fetch-lexicon-info (car Feature-List) 'spelling))
		      (fetch-lexicon-info (car Feature-List) 'spelling))
		     (T (Warning "The Lexified item " (CAR Feature-List)
				 " has no spelling"))))
		   ;;> addition for substance...
		   (substance
		    (selection-def-features (car temp)))		     
		   (otherwise NIL))))
	   (T (Push  Bundle No-Function-Realization)
	      (make-Whiteboard-Elt
	       :id  'Classify
	       :aliasfn (conflation-alias (brownboard-elt-functionlist  Bundle))
	       :featurelist 
	       (List (Feature-Pack
		      (append
		       (list
			(conflation-alias (brownboard-elt-functionlist  Bundle)))
		       (conflation-othernodes 
			(brownboard-elt-functionlist  Bundle)))))
	       :hub  Hub))))))

;;; ----------------------------------------------------------------------
;;; Hook used by coder to break out after a single cycle of traversal
;;; through the network. Only called when *coder-mode* is T.
;;; When called, the full results of the last traversal are available in
;;; the parameter sentence-tree from all-parts0. 

(defun DO-CODING-OPERATIONS-FOLLOWING-A-CYCLE (sentence-tree)
  ;; keep the stats and turn off coding just in case...
  (update-coding-stats)
  (when *perform-realizations*
        (Unwind-Passes sentence-tree)
	(let ((orderings (all-orderings sentence-tree))
	      (structures nil))
	  (setf *mouseable-sentence* (cdr (first orderings)))
	  (setf *mouseable-sentences* (mapcar #'cdr orderings))
	  (setf final-orderings
	    (loop for ordering in orderings
		  collect
		  (multiple-value-bind
		      (string structure)
		      (mouseable-processed-string-from-printable-constituent
		       (cdr ordering))
		    (push structure structures)
		    (cons (first ordering) string))))
	  (setf (fetch-example-info *most-recent-example* 'structure curlan)
	     structures)
	  (setf (fetch-example-info 
		 *most-recent-example* 'generatedform curlan)
	    (cdar final-orderings))))
    
  (setf *coding-mode* nil)
  (throw 'coding-loop T))

