(in-package "KPML")

;;; File: orderings.lisp
;;;
;;; All original Penman code for ordering moved to here. There are
;;; a considerable number of additions and even some bug fixes with
;;; respect to the Penman code. Many additions to the basic data structures
;;; mean that this is no longer at all compatible with Penman code and
;;; should not be considered in any way exchangeable.
;;;
;;; ----------------------------------------------------------------------
;;; N.B.
;;; 4.0 Unit-preceding punctuation added 
;;;     (e.g, question mark initials in Spanish)
;;; 3.1 SPL annotation fixed: was looking for unique spl terms that are not
;;;     accessible in the input SPL but are only created during interpretation.
;;; 2.1 make the internals of linearization visible on a flag...

(defvar *internal-orderings-trace* nil)

;;;     Also: ordering-dump-flag says whats going on during the ordering itself...
;;;
;;; KPML 2.0; March98. Cleaned of all references to CLISP.
;;;                    Mostly obvious, with a few nasties...
;;;                      join -> nconc
;;;                      thereis returns the current value of the 
;;;                        *counter* when successful not T!
;;;                      for works when its list is not a list, then
;;;                        it just returns nil.
;;;
;;; (Accepted as the main version in 2.1, if problems crop up, the
;;;  original version using CLISP is in the file: orderings.old
;;;  4.0: now long gone)
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; 3.2.59
;;; Following patches the punctuate functions from generation/orderings.lisp
;;; so as to keep a record of the punctuation rules that were applied.
;;; Purely for debugging: could be added to the interface in a prettier
;;; way at some stage if useful.
;;;
;;; Overhead is probably so small, don't bother to make this one conditional.
;;;
;;; Bremen, 25 June 2001
;;;
  ;;
  ;; First make sure there is somewhere to record the rules. 
  ;;
  ;; Note that since the before/after generation actions are
  ;; in place, we may as well use them to do the necessary
  ;; initializations rather than the separate initializations
  ;; that are currently spread around the say, only-say, say-plan
  ;; and express functions! It would be a good idea somewhen to
  ;; gather the initializations together and put them either
  ;; in a single function or, if sensible, into particular groups
  ;; of before actions.
  ;; ------------------------------------------------------------

(defvar *APPLIED-PUNCTUATION-LIST* nil)

(defun CLEAR-PUNC-RECORD (input)
  (setf *applied-punctuation-list* nil)
  input)

(add-generation-action 'CLEAR-PUNC-RECORD :before :id (gensym))

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

(defun ALL-ORDERINGS (pass-tree &OPTIONAL (fundle-of-self nil))
;;; 0.7.19 fixed some final string preparation code overlooking multilinguality
;;;        Function used to be using the non-multilingual access functions
;;;        for lexical item spellings and stems.
;;; 0.8.19 spl annotations added to created structure
;;; 0.9    substances had not been added to the mouse-sensitive branch of the
;;;        constituency descent.

  (let ((wb-assoc-list (loop for WBE in (constituent-pass-whiteboard pass-tree)
			   collect (LIST (whiteboard-elt-aliasfn WBE)
					 WBE)))
	 (sequence-list (constituent-pass-sequences pass-tree))
	 (selection-expression 
	  (constituent-pass-selection-expression pass-tree))
	function-order-list word-order-list orderings
	filtered-pre-punctuations filtered-post-punctuations )
    
    (when *internal-orderings-trace* (print ">>>ENTERING ALL-ORDERINGS..."))
    (cond
      ((Not Sequence-list)
       (error "No valid sequences"))
      
      (T (unless fundle-of-self (setq fundle-of-self '(sentence)))
	 (dolist (Sequence Sequence-list)
	   
	   ;; Multiple orderings may result from constituents.
	   (setq function-order-list (list nil))
	   (setq word-order-list (list nil))
	   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; filter punctuation rules according to the current selection expression, only         ;;
;;; use those that apply in the check for functions below...                             ;;
	   (setq filtered-pre-punctuations                                               ;;
		 (mapcan #'(lambda (punctuation-rule)                                    ;;
			     (if (member (first Punctuation-rule) Selection-expression)  ;;
				 (list punctuation-rule)                                 ;;
				 nil))                                                   ;;
			 (ml-pre-punctuation)))                                          ;;
	   (setq filtered-post-punctuations                                              ;;
		 (mapcan #'(lambda (punctuation-rule)                                    ;;
			     (if (member (first Punctuation-rule) Selection-expression)  ;;
				 (list punctuation-rule)                                 ;;
				 nil))                                                   ;;
			 (ml-post-punctuation)))                                         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   
	   (dolist (Fn Sequence)
	     (let ((WBE (second (assoc Fn wb-assoc-list))))
               (when *internal-orderings-trace* (format t "~%>>> Looping. Doing: ~A" Fn))
	       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Add in punctuation whose position is defined as preceding a specified grammatical    ;;
;;; function.                                                                            ;;
	       (setq word-order-list (punctuate	                                         ;;
				      (get-fundle Fn pass-tree)                          ;;
				      word-order-list	                                 ;;
				      filtered-pre-punctuations))	                 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	       
	       (cond
		 ((null WBE)
		  (printwindow :display-pane 
                               (pretty-with-header Fn "Final Ordering: No realization for: ")))
		 ((eq (whiteboard-elt-id WBE) 'preselect)
		  ;; this is a nonterminal;
		  ;; recursively generate orderings from constituent.
		  ;; Also let that constituent know what kind of function it is realizing...
		  (let ((constit (gethash (whiteboard-elt-index WBE)
					  show-pass-hash-table)))
		    (if constit
			(let ((constit-orderings (all-orderings constit (get-fundle Fn pass-tree))))
			  ;; append constit-orderings to total ordering
			  ;; There may be multiple constit-orderings.
			  ;; NB: loop over all in constit-orderings and all in order-list
			  (setq function-order-list
				(mapcan #'(lambda (function-order)
					    (mapcar #'(lambda (constit-order)
							(append function-order
								(car constit-order)))
						    constit-orderings))
					function-order-list))

			  ;; make this sensitive to the TYPE of the constituent, as can be
			  ;; found from the selection expression...
			  ;;
			  (if (sensitize-constituent-p constit)
			      (setq word-order-list
				    (mapcan 
                                     #'(lambda (word-order)
                                         (mapcar 
                                          #'(lambda (constit-order)
                                              (append word-order
                                                      ;; put a constituent structure
                                                      ;; containing the spelling of the
                                                      ;; constituent and the corresponding
                                                      ;; hub rather than just the spelling
                                                      ;; itself... 
                                                      (list (make-printable-constituent
                                                             :id (gensym)	
                                                             :concept (find-concept-of-constituent constit)
                                                             :annotation 
                                                             (find-spl-symbol-annotation 
                                                              (find-concept-of-constituent constit))
                                                             :functions (get-fundle Fn pass-tree)
                                                             :spelling (cdr constit-order)))))
                                          constit-orderings))
                                     word-order-list))

			      (setq word-order-list
				    (mapcan #'(lambda (word-order)
						(mapcar #'(lambda (constit-order)
							    (append word-order
								    (cdr constit-order)))
							constit-orderings))
					    word-order-list)))

                          (when *internal-orderings-trace*
			    (format t "~% function-order-list becomes: ~A" function-order-list)
			    (format t "~% word-order-list becomes: ~%~A" 
                                    (trace-list-of-printables word-order-list)))
			  )
			
			;; Constit was never realized.
			(progn
			  (setq function-order-list
				(mapcar #'(lambda (function-order)
					    (append function-order
						    (list (Find-Conflation Fn))))
					function-order-list))
			  (setq word-order-list
			    (mapcar 
			     #'(lambda (word-order)
				 (append 
				  word-order
				  (list 
				   (make-printable-constituent
				    :id (gensym)
				    :concept  (whiteboard-elt-hub wbe)
				    :annotation 
				    (find-spl-symbol-annotation (whiteboard-elt-hub wbe))
				    :functions (get-fundle Fn pass-tree)
				    :spelling 
				    (list
				     (feature-pack (whiteboard-elt-featurelist WBE)))
				    :node-type :terminal))
				  ))
			     word-order-list))
			  
			  ;; 2.0 nevertheless preserve preselections...
			  (update-example-preselections
			   (find-conflation fn)
			   (whiteboard-elt-featurelist WBE))
			  )
			)))
		 
		 (T  ;; this is a terminal
		  ;; need to build a printable constituent iff this terminal's grammatical function
		  ;; is on the *mouse-sensitive-terminals* list...
		  ;; 4.0 add in the gloss and the translit of the lexical item at this point too...
		  ;;     these get passed in from GET-FINAL-GRAPHOLOGICAL-FORM
		  ;;     only do this for terminals. Remember to put in the
		  ;;     list for spelling that is now no longer delivered
		  ;;     by the get-final-graphological-form function...

		  (cond ((sensitize-terminal-p (get-fundle Fn pass-tree))
			 (setq word-order-list
			       (mapcar #'(lambda (word-order)
					   (append word-order
						   (multiple-value-bind 
						    (spelling gloss translit fe lex)
						    (get-final-graphological-form wbe)
						    (list (make-printable-constituent
							   :id (gensym)
							   :concept  (whiteboard-elt-hub wbe)
							   :annotation 
							   (find-spl-symbol-annotation (whiteboard-elt-hub wbe))
							   :functions (get-fundle Fn pass-tree)
							   :spelling (list spelling)
							   :gloss     gloss
							   :translit  translit
							   :features fe
							   :lexeme lex
							   :node-type :terminal)))))
				       word-order-list)))
			(t
			 (setq word-order-list
			       (mapcar #'(lambda (word-order)
					   (append word-order (get-final-graphological-form wbe)))
				       word-order-list)))
			)

		  (setq function-order-list
			(mapcar #'(lambda (function-order)
				    (append function-order
					    (list (Find-Conflation Fn))))
				function-order-list))
		  
		  ))
	       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Add in punctuation whose position is defined as following a specified        ;;
;;; grammatical function.                                                        ;;
	       (setq word-order-list (punctuate                                  ;;
				       (get-fundle Fn pass-tree)                 ;;
				       word-order-list                           ;;
				       filtered-post-punctuations))              ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	       
	       ))
	   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Add in punctuation that the follows the current unit as a whole, e.g. question;
;;; marks, periods, etc. Note that punctuation is sensitive to written units, so ;;
;;; it is not possible to get a build up punctuations  such as ,.                ;;
	   (setq word-order-list (post-self-punctuate                            ;;
				   fundle-of-self                                ;;
				   word-order-list                               ;;
				   selection-expression                          ;;
				   (ml-post-self-punctuation)))                  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 4.0:                                                                         ;;
;;; on the model of the preceding, also add in punctuation that precedes         ;;
;;; the current unit as a whole, e.g. questions marks in Spanish...              ;;
	   (setq word-order-list (pre-self-punctuate                             ;;
				   fundle-of-self                                ;;
				   word-order-list                               ;;
				   selection-expression                          ;;
				   (ml-pre-self-punctuation)))                   ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	   (if (eq (car fundle-of-self) 'sentence)
	       (progn nil
                 (when *internal-orderings-trace*
                   (format t "~% word-order-list is: ~%~a" (trace-list-of-printables word-order-list)))

                 (setf word-order-list
                       (mapcar
                        #'(lambda (word-order)
                            (make-printable-constituent
                             :id (gensym)
                             :functions fundle-of-self
                             :spelling word-order
                             :annotation (find-spl-symbol-annotation (find-concept-of-constituent pass-tree))
                             :concept (find-concept-of-constituent pass-tree)))
                        word-order-list))))

	   (mapc #'(lambda (function-order word-order)
		     (push (cons function-order word-order) orderings))
		 function-order-list word-order-list))))
    
    ;; all done.
    
    ;; ok; here we are, what do we have?
    (when *internal-orderings-trace*
      (format t "~%<<< EXITING.  orderings is now:")
      (print (mapcar #'first orderings)))
    
    orderings))


;;; ----------------------------------------------------------------------
;;; 2.1 attempt to make some of the internal information during
;;;     ordering intelligible to the outside... Although this
;;;     bit just refers to the linearization of an already
;;;     ordered tree and is not so useful...
;;; ----------------------------------------------------------------------

(defun TRACE-LIST-OF-PRINTABLES (printables-list)                           
  (mapcar #'printable-constituent-to-structure-tree
          (mapcar #'first printables-list)))

;;; ----------------------------------------------------------------------
;;; Includes the patch 0.8.18 concerning bad interaction of expansions
;;; and defaults.
;;; ----------------------------------------------------------------------

(DEFUN Left-To-Right (ordering)
  "This hack sorts out the brownboard and the whiteboard so that 
grammatical processing proceeds left to right and pronouns are in 
the right places"
  (SETQ Function-Sequence NIL)
  (loop for function in ordering do
	(SETQ Function-Sequence (cond
				 ((value-if-listp function)
				  (append Function-Sequence function))
				 (T (append Function-Sequence (list function))))))
  (when Function-Sequence
       (PROG (beigeboard)
	     (SETQ beigeboard (loop for whiteboard-element in Whiteboard as 
				    brownboard-element in Brownboard
				  collect (LIST brownboard-element whiteboard-element)))
	     (setq beigeboard (sort (copy-list beigeboard) #'Leftness))
	     (SETQ Brownboard (loop for element in beigeboard collect (CAR element)))
	     (SETQ Whiteboard (loop for element in beigeboard collect (Second element))))))

(DEFUN Leftness (Element1 Element2)
  ;;;Pick out the Whiteboard element from the beigeboard
  (setq element1 (second element1))
  (setq element2 (second element2))
  (let((id1 (whiteboard-elt-id Element1))
       (id2 (whiteboard-elt-id Element2)))
    ;;;Now sort the beigeboard by sorting the Whiteboard elements 
    (PROG (element1-position element2-position)
	  (cond
	    ((And (Eq 'Preselect id1)
		  (Eq 'Preselect id2))
	     (SETQ element1-position (loop for function in Function-Sequence as N from 1
					  until (Equal (whiteboard-elt-aliasfn Element1)
							 function)
					  finally (RETURN N)))
	     (SETQ element2-position (loop for function in Function-Sequence as N from 1
					  until (Equal (whiteboard-elt-aliasfn Element2)
							 function)
					  finally (RETURN N)))
	     (RETURN (< element1-position element2-position)))
	    ((And (Eq 'Preselect id1)
		  (not(equal 'Preselect id2)))
	     (RETURN T))
	    ((And (not (equal 'Preselect id1))
		  (Eq 'Preselect id2))
	     (RETURN NIL))
	    (T (RETURN NIL))))))

#+IGNORE (DEFUN Complete-Order-Info NIL
;;; Note that since the blackboard contains lists not structures we used list access methods (car's and cdr's)
;;; The actual structure reference is included to the side for easier reading and possible 
;;; conversion later.
  (catch 'complete-order-info    ;throw to this catch from test-for-ordering-cycles called in add-order-defaults
    (setq constraints nil)
    (PROG (Simple-Terminals Expanded-Relations)
	  (setq Conflations (loop for Node in Blackboard
			     when (And (value-if-listp Node)
				       (Eq (first Node)	;(complex-object-id node)
					   'Complex-Object))
			     collect (cdr Node))) ;(complex-object-conflationdef node)
	  (setq Expansions (loop for Node in Blackboard
				when (And (value-if-listp Node)
					  (Eq (first Node)	;(expanded-object-id node)
					      'Expanded-Object))
				collect (cdr Node)))	;(expanded-object-expansiondef node)
	  (SETQ Expand-Parents (loop for Ex in Expansions collect (first Ex)))	;(expansion-parent ex)
	  (SETQ Terminal-Conflations (loop for C in Conflations	;
					  unless (remove-duplicates (intersection C Expand-Parents))
					  collect C))
	  (SETQ Simple-Terminals (loop for Node in Blackboard when (And (ATOM Node)
								   (Not (member Node Expand-Parents)))
				      collect Node))
	  (SETQ Terminals (append (loop for C in Terminal-Conflations
				       collect (first C))	;(conflation-alias c)
				  Simple-Terminals))
	  (SETQ Non-Terminals 
		(loop for Ex in Expansions
		    collect 
		      (Cons (first Ex)	;(expansion-parent ex)
			    (loop for Fn
				in (cdr Ex) ;(expansion-offspring ex)
				with Result
				do
				  (PushNew (conflation-alias-function fn)
					   Result)
				finally 
				  (RETURN (Reverse Result))))))
	  (SETQ Expanded-Relations (Generate-Constraints Ordering-Relations))
	  (Add-Order-Defaults (Compile-Constraints Expanded-Relations)
			      (Compile-Defaults Fragment-Order-Lsts curlan)
			      Ordering-Dump-Flag)
	  (Return T))))


;;; ----------------------------------------------------------------------
;;; 2.1
;;;  following is changed to a method to allow specialization on a language
;;;  by language basis for Prague experiments... We also add a flag for
;;;  debugging and tracing at this point, dependent on:
(defvar *ORDERING-SPECIAL-TRACING* nil)
;;; ----------------------------------------------------------------------

(defmethod COMPILE-DEFAULTS (Default-Orderings lg)
  ;;   In Enumerate-Orderings, translate the incoming partitions of the 
  ;;   form (Fn1 Fn2 ... Fn-N) into those of the form 
  ;;   ((Fn1Set) (Fn2Set) ... (Fn-NSet)) where the Fni-Sets are the sets of 
  ;;   terminal descendants of Fni, modified by looking up the conflation 
  ;;   aliases of each Fn and dropping all Fns which do not appear in 
  ;;   expansion, conflation, or terminal lists. Additionally, reduce all 
  ;;   repeating function entries to a single element.

  (declare (special Expand-Parents Terminals Non-Terminals))
  (when *ordering-special-tracing* 
    (format t "~%>>> In default ordering compilation...")
    (format t "~%>>>  Expanded parents: ~S" Expand-parents)
    (format t "~%>>>  Local Terminals: ~S"  Terminals)
    (format t "~%>>>  Non-Terminals: ~S" Non-Terminals))

  (let ((compiled-constraints
         (let ((Valid-Fns (append Expand-Parents Terminals)))
           (loop for Order in Default-Orderings
	         with Potential-Tuple 
	         and Results 
	         do (SETQ Potential-Tuple 
                          (loop for Fn in Order
                                with Last-Alias
                                as Alias = (conflation-alias-function Fn) 
                                when (And (member Alias Valid-Fns)
                                          (not(equal Alias Last-Alias)))
                                collect (PROGN (SETQ Last-Alias Alias)
                                          (Expand-Non-Terminal Alias Non-Terminals 
                                                               Terminals))))
	         when (> (LENGTH Potential-Tuple) 1)
	         do (cond
	             ((Not (member Potential-Tuple Results))
	              (Push Potential-Tuple Results)))
	         finally (RETURN Results)))))
    (when *ordering-special-tracing* 
      (format t "~%>>>  Compiled constraints: ~S" compiled-constraints))
    compiled-constraints))


(DEFUN Expand-Non-Terminal (NT Non-Terminals Terminals)
  ;;;parameters are also globals, watch out!
  (PROG (Ans Queue Seen)
	(cond
	  ((member NT Terminals)
	   (RETURN (list NT))))
	(SETQ Queue (list NT))
	(loop while (SETQ NT (pop Queue))
	    do (PushNew NT Seen)
	       (loop for x in (CDR (assoc NT Non-Terminals)) 
		   do (cond
		       ((member x Terminals)
			(PushNew x Ans))
		       ((Not (member x Seen))
			(PushNew x Queue)))))
	(RETURN (Reverse Ans))))

(DEFUN Generate-Constraints (Ordering-Relations)
  ;;Pass through Order and Partition relations and translate 
  ;;(Orderatfront Fn) and (Orderatend Fn) relations into sets of 
  ;;Partition relations between Fn and other functions at the same 
  ;;level of expansion as Fn.
  (PROG (Boundary-Orders)
	(setq constraints nil)
	(SETQ Boundary-Orders 
	      (loop for Ex in  Non-Terminals
		  ;; (create Boundary-Order owner _(fetch-parent Ex))
		  collect  (list (car ex) nil nil))) 
	(loop for Rel in Ordering-Relations
	    as First-Op = (second rel)	;(fetch-firstop Rel)
	    as Second-Op = (third rel)	;(fetch-secondop Rel)
	    as Valid-Constraint = nil
	    with First-Op-Alias and Second-Op-Alias
	    do
	      (cond
	       ((Not (Find-Object First-Op))
		(Warning "Can't order non-inserted function: " First-Op))
	       ((And Second-Op (Not (Find-Object Second-Op)))
		(Warning "Can't order non-inserted function: " Second-Op))
	       (T (SETQ Valid-Constraint T)))
	     (SETQ First-Op-Alias (conflation-alias-function first-op))	
	     (SETQ Second-Op-Alias (conflation-alias-function second-op))	
	    when Valid-Constraint
	    do
	     (Case (first rel)		;(fetch-id Rel)
		  ((Order Partition)
		   (cond
		     ((Not (member (LIST (first rel)	;(fetch-id Rel)
					 First-Op-Alias Second-Op-Alias)
				   Constraints))
		      (Push (LIST (first rel)	;(fetch-id Rel)
				  First-Op-Alias Second-Op-Alias) 
			    Constraints))))
		  ((Orderatfront Orderatend)
		   (PROG ((Front (Eq (first rel) ;(fetch-id Rel)
				     'Orderatfront))
			  (Relevant-Expansion 
			   (loop for Ex in Non-Terminals as E in Expansions
			       when (member First-Op (cdr e))
					;(fetch-offspring E)
			       do
				 (RETURN Ex)))
			  Current-Boundary-Order)
			 (SETQ Current-Boundary-Order 
			       (assoc (car relevant-expansion)
					;(fetch-parent Relevant-Expansion)
				      Boundary-Orders))
			 (cond
			  ((And Front (second current-boundary-order))
				;(fetch-frontelt Current-Boundary-Order)
			   (Warning "Multiple Orderatfront of: " 
				    (first relevant-expansion)
					;(fetch-parent Relevant-Expansion)
				    ", was "
				    (second current-boundary-order)
				      ;(fetch-frontelt Current-Boundary-Order)
				    ", ignoring " First-Op "."))
			  ((And (Not Front)
				(third  Current-Boundary-Order))
					;(fetch-endelt Current-Boundary-Order)
			   (Warning "Multiple Orderatend of: " 
				    (first relevant-expansion)
					;(fetch-parent Relevant-Expansion)
				    ", was "
				    (third  Current-Boundary-Order)
					;(fetch-endelt Current-Boundary-Order)
				    ", ignoring " First-Op "."))
			  (T (cond
			      (Front 
			       (loop for Fn in (cdr Relevant-Expansion)
					;(fetch-offspring Relevant-Expansion)
				   do (Generate-Partitions 
				       First-Op-Alias Fn Front))
			       (setf (second current-boundary-order)
					;(frontelt Current-Boundary-Order)
				 First-Op-Alias))
			      (T (loop for Fn in (cdr Relevant-Expansion)
					;(fetch-offspring Relevant-Expansion)
				     do (Generate-Partitions
					 Fn First-Op-Alias Front))
				 (setf (third current-boundary-order)
					;(endelt Current-Boundary-Order)
				   First-Op-Alias))))))
		   )
		  (otherwise NIL)))
	(RETURN Constraints)))

(DEFUN Generate-Partitions (Fn1 Fn2 Front-Flag)
  
  ;;Generate a single partition relation between the two specified 
  ;;functions unless there is any shared structure between them. In 
  ;;that case, if they have TOTALLY shared structure then generate no 
  ;;relation. Else recursively generate a set of partition relations 
  ;;by expanding the first level offspring of Fn2 if Front-Flag else 
  ;;expanding the first level offspring of Fn1.
  
  (PROG ((Ex1 (Expand-Non-Terminal Fn1 Non-Terminals Terminals))
	 (Ex2 (Expand-Non-Terminal Fn2 Non-Terminals Terminals)))
	(cond
	  ((Not (remove-duplicates (intersection Ex1 Ex2)))
	   (cond
	     ((Not (member (LIST 'Partition
				 Fn1 Fn2)
			   Constraints))
	      (Push (LIST 'Partition
			  Fn1 Fn2) Constraints))))
	  ((Or (set-difference Ex1 Ex2)
	       (set-difference Ex2 Ex1))
	   (cond
	    (Front-Flag 
	     (let ((offspring (second (assoc Fn2 Non-Terminals))))
	       (if (consp offspring)
		   (loop for F in offspring
				  ;;(fetch-offspring (assoc Fn2 Non-Terminals))
		       do (Generate-Partitions Fn1 F Front-Flag))
		 nil)))
	    (T 
	     (let ((offspring (second (assoc Fn1 Non-Terminals))))
	       (if (consp offspring)
		   (loop for F in offspring
				  ;;(fetch-offspring (assoc Fn1 Non-Terminals))
		       do 
			 (Generate-Partitions F Fn2 Front-Flag))
		 nil))))))))

(DEFUN Compile-Constraints (Constraints)
  ;;parameter is also a global var,  watch out
  ;;In Enumerate-Orderings translate the incoming constraints of the 
  ;;form (relation Fn1 Fn2) into those of the form ((Fn1Set) (Fn2Set)) 
  ;;where Fn1Set and Fn2Set are sets of terminal descendants of Fn1 
  ;;and Fn2 (by expansion) .
  
  (loop for C in Constraints 
      collect (LIST (Expand-Non-Terminal (second C) ;(fetch-firstop C)
					 Non-Terminals Terminals)
		    (Expand-Non-Terminal (third C) ;(fetch-secondop C)
					 Non-Terminals Terminals))))

;;;----------------------------------------------------------------------
;;; BEWARE!                                        PATCH 0.8.18
;;; There now follows an excursion into some of the deepest, oldest,
;;; and most impenetrable of original Penman code.  I am going to
;;; leave a trail of comments and changes; if I am not heard of again,
;;; better not send anyone in after me: better just to get Mick to add
;;; expansions to WAG's ordering algorithm and take out this bit of
;;; code with a small tactical nuclear weapon, or an exorcism,
;;; whichever is felt more appropriate...
;;;                                          John:IPSI:July 28th. 1995.
;;; 

;;; Misc. additional comments, and useful notes from the ordering
;;; jungle:
;;; ordering-relations: are the ordering constraints given from the
;;;                     grammar
;;; expanded-relations: are the ordering-constraints plus partitions
;;;                     corresponding to orderatfronts and ends.
;;; adjacency-relations: are the subset of the previous constraints
;;;                     that constrain strict order (i.e., are not
;;;                     partitions)
;;; 
;;; running compile-constraints on these kinds of lists produces 
;;; converted lists where expanded functions are replaced by the list
;;; of their expansions. I.e., translate the incoming constraints of the 
;;; form (relation Fn1 Fn2) into those of the form ((Fn1Set) (Fn2Set)) 
;;; where Fn1Set and Fn2Set are sets of terminal descendants of Fn1 
;;; and Fn2 (by expansion).
;;; There are, therefore, two kinds of such
;;; lists, partitioning (sometimes called before-constraints in 
;;; the code) and ordering (called adjacency constraints in the
;;; code). These provide the basic information for working out the
;;; ordering, augmented as necessary by the defaults...
;;; 
;;; Another function for compiling default orders (compile-defaults)
;;; translates the incoming default partitions of the 
;;; form (Fn1 Fn2 ... Fn-N) into those of the form 
;;; ((Fn1Set) (Fn2Set) ... (Fn-NSet)) where the Fni-Sets are the sets of 
;;; terminal descendants of Fni, modified by looking up the conflation 
;;; aliases of each Fn and dropping all Fns which do not appear in 
;;; expansion, conflation, or terminal lists. Additionally, reduces all 
;;; repeating function entries to a single element.
;;;
;;; Add-order-defaults is then responsible for adding the non-redundant, 
;;; non-contradictory subset of Default-Constraint-Lists 
;;; (wrt Given-Constraints) to the global Ordering-Relations, which
;;; get passed on to the actual constraint resolution process that
;;; does the ordering (order-search).
;;;
;;; A flag for getting internal information about what happens in the
;;; ordering process is: ordering-dump-flag.
;;;
;;; Right, now the patch:

(defun ADD-ORDER-DEFAULTS 
  (Given-Constraints Default-Constraint-Lists Dump-Flag)
  ;; Parameters are both partition-style compiled ordering constraints,
  ;; the former from the grammar, the latter from the default orders.
  ;; The defaults are however a list rather than single a set.
  ;; Adds the non-redundant, non-contradictory 
  ;; subset of Default-Constraint-Lists (wrt Given-Constraints) to the 
  ;; global Ordering-Relations. Prunes out non-applicable functions from
  ;; defaults if they clash with any grammatical information (including
  ;; strict-order (adjacency): see below).
  (PROG ((Given-Closure-List (loop for Fn in Terminals collect (list Fn)))
	 Added-Constraints)
	(when Dump-Flag
	  (format *trace-output* "~%Potential default orderings: ~S~%Given closure list (i.e., just the listified terminals) prior to 
transitive closure: ~S"
		  Default-Constraint-Lists  Given-Closure-List))

	;;; Original comments for the following function:
	;;Closure-List: 
	;;initially, a list of lists consisting only of the terminal 
	;;elements; at completion, the CDR of each list is the transitive 
	;;closure of the terminal element under the given constraints.
	(Generate-Closure-List Given-Constraints Given-Closure-List)
	(when Dump-Flag
	      (format *trace-output* "~%Given ordering constraints: ~S~%Given closure list after transitive closure: ~S" 
		      Given-Constraints Given-Closure-List))

	(Test-For-Ordering-Cycles 
	 Given-Closure-List "before default ordering" 'do-ordering)
	(loop for Constraint-List in Default-Constraint-Lists
	    with Default-Closure-List
	    and Local-Added-Constraints
	    and Closure-Loops
	    do 
	     (SETQ Default-Closure-List 
		   (loop for Fn in (loop for Fn-List in Constraint-List
				       with Result
				       do (loop for Fn in Fn-List
					      do (PushNew Fn Result))
				       finally (RETURN (Dreverse Result)))
		       collect (list Fn)))
	     (Generate-Closure-List (loop for Tl on Constraint-List
					when (Second Tl)
					collect (LIST (CAR Tl)
						      (Second Tl)))
				    Default-Closure-List)

	     ;Filter from default-closure-list elements that are inconsistent with adjacency-constraints.
	     ;For each adjacency constraint (ORDER A B),
	     ;    Remove any functions intervening between A and B as follows:
	     ;    if B is in A closure,
	     ;       then for all X in A closure,
	     ;            if B is in X closure,
	     ;               then remove B from X closure, remove X from A closure.
	     (when Dump-Flag
	       (printwindow :display-pane (pretty-with-header Default-Closure-List
							      "Default-closure-list before adjacency filter: ")))

;;; KPML 0.8.18: PATCH ----------------------------------------------------
;;; Now, the following as it was:
;;;	     (dolist (adj adjacency-constraints)
;;; looks like a bug, since the adjacency-constraints still refer to
;;; expanded functions which generally do not come in the default lists
;;; (but probably could?). I guess what should really happen here is that
;;; we do a compile-constraints on the adjacency-constraints to get the
;;; relevant expanded forms, and then check these... One draw back: the
;;; parameters can then be lists... since we're dealing with expansions:
;;; i.e., (order X Y) => ((X1 X2 ... Xn) (Y1 Y2 ... Ym)) where Xi, Yi
;;; are the expansions of X and Y respectively... The safest might be
;;; to repeat that former part of the loop for all of the lefts and
;;; rights... This will knock out any default orderings that try and
;;; order any of the lefts and any of the rights in different orders.
;;; What happens if we have expanded functions in the default order
;;; lists I dread to think. Probably how the code was originally would
;;; cope with just this perverse case. So, we may as well do that too!
;;; Can someone rewrite this code please?!
;;; John:IPSI:July 28, 1995.

	     (dolist (adj (append
			   (mapcar #'(lambda (x) 
				       `((,(second x)) (,(third x))))
				   adjacency-constraints)
			   (compile-constraints adjacency-constraints)))
	       (when Dump-Flag
		     (printwindow 
		      :display-pane 
		      (pretty-with-header adj "Filtering adjacency: ")))
	       (let ((lefts (first adj))(rights (second adj)))
		 (loop for left in lefts
		       do
		       (loop for right in rights
			     do (let ((left-closure 
				       (assoc left default-closure-list)))
				  (when Dump-Flag 
					(format *trace-output* 
						"~%Left closure: ~S" 
						left-closure))
				  (when (member right left-closure)
					(dolist (x (cdr left-closure))
						(when Dump-Flag
						      (printwindow 
						       :display-pane 
						       (pretty-with-header 
							x  "Member of left-closure: ")))
						(when (not (or (eq x left)
							       (eq x right)))
						      (let ((x-closure 
							     (assoc x default-closure-list)))
							(when (member right x-closure)
							      (when Dump-Flag
								    (printwindow :display-pane (pretty-with-header x "Deleting: ")))
							      (setf (cdr x-closure) 
								    (remove right 
									    (cdr x-closure)))
							      (setf (cdr left-closure) 
								    (remove 
								     x (cdr left-closure)))))))))))))
	     (when Dump-Flag
	       (printwindow :display-pane 
			    (pretty-with-header 
			     Default-Closure-List
			     "Default-closure-list after adjacency filter: ")))

	     ;Now analyze the default closures for loops, display 
	     ;and remove them.
	     (cond
	       ((SETQ Closure-Loops (Analyze-Loops Default-Closure-List))
;		(Warning "The following cycles exist due to default ordering: " Closure-Loops)
		(loop for Cycle in Closure-Loops
		     do  ;; ( Order? Cycle)
		     (loop for fn in Cycle
			 with Closure
			 do (SETQ Closure (assoc fn Default-Closure-List))
			    (setf (cdr closure) ;(closure-element-reachablefns Closure)
			      (set-difference (cdr closure) ;(closure-element-reachablefns Closure)
					      Cycle))))))
	     
	     ;Now, remove all reachable functions from the default 
	     ;closures that are in conflict with the given closures.
	     (loop for Closure in Default-Closure-List
		 as Firstt = (first Closure)	;(closure-element-head closure)
		 as  First-Closure = (assoc Firstt Given-Closure-List)
		 do
		   (loop for Secondd
		       in (cdr closure)	;(closure-element-reachablefns Closure)
		       with Second-Closure and Ok-Fns
		       do (SETQ Second-Closure
				(assoc Secondd Given-Closure-List))
;;;  (break "In Add-Order-Defaults: first = ~a, second = ~a" firstt secondd)
			  (cond
			   ((And (Not (member Secondd (cdr first-closure)))
				;(closure-element-reachablefns First-Closure)
				 (Not (member Firstt (cdr second-closure)))
				;(closure-element-reachablefns Second-Closure)
				 (not (equal Secondd Firstt)))
;;;   (format t "~&In Add-Order-Defaults: second = ~a, OK~%" secondd)
			    (Push Secondd Ok-Fns)))
		       finally (setf (cdr closure)
					;(closure-element-reachablefns Closure)
				 (Dreverse Ok-Fns))))

	     ;;Finally, generate the "minimal" set of constraints from the 
	     ;;remaining default closures. This is done as follows: Sort closures 
	     ;;by length. Remove those of length one. Distribute the set of 
	     ;;minimum length to Local-Added-Constraints (when not duplicates) . 
	     ;;Extract reachablefns of the set from all closures. Repeat until 
	     ;;nothing left.
	     
	     (loop while Default-Closure-List
		 with Minimals and Gone-Fns
		 do 
		   (SETQ Default-Closure-List 
			 (loop for Closure
			     in (sort (copy-list Default-Closure-List)
				      #'(LAMBDA (a b)
						(< (LENGTH a)(LENGTH b))))
			     when (cdr closure)
					;(closure-element-reachablefns Closure)
			     collect  closure))
		   (SETQ Minimals 
			 (loop for Closure in Default-Closure-List
			     with Right-Length = (LENGTH 
						  (CAR Default-Closure-List))
			     while (EQ (LENGTH Closure) Right-Length)
			     collect Closure))
		   (loop for C in Minimals
		       as Firstt = (first C) ;(closure-element-head c)
		       do 
			 (loop for Second in (cdr c)
					;(closure-element-reachablefns cy)
			     as Possible-Constraint = (LIST Firstt Second)
			     do
			       (cond
				((Not (member 
				       Possible-Constraint
				       Local-Added-Constraints))
				 (Push Possible-Constraint 
				       Local-Added-Constraints))))
			 (SETQ Gone-Fns (UNION Gone-Fns (cdr c)))) ;(closure-element-reachablefns C)
		   (loop for Closure in Default-Closure-List
			do (setf (cdr closure) ;(closure-element-reachablefns Closure)
				  (set-difference (cdr closure)	;(closure-element-reachablefns Closure)
						  Gone-Fns))))
	     (cond
	       (Local-Added-Constraints (SETQ Added-Constraints (UNION (Dreverse 
									 Local-Added-Constraints)
								       Added-Constraints))
					(SETQ Local-Added-Constraints NIL))))
	(when dump-Flag (printwindow :display-pane (pretty-with-header Added-Constraints "Added default orderings: ")))
	(loop for C in (Dreverse Added-Constraints)
	     do (Push (list			;(create Input-Constraint 
			'Partition		;id _ 'Partition
			(first C)		;first _(create Input-Constraint)
			(second C))		;secondop _(internal-constraint-rhs C)
		      Ordering-Relations))))

;;; ----------------------------------------------------------------------
;;; Escaped.... but don't send me in again please!


(DEFUN Generate-Closure-List (Constraints Closure-List)
  ;;parameter is also a global var, watch out
  ;;Constraints: same as Order-Search Before-Constraints. Closure-List: 
  ;;initially, a list of lists consisting only of the terminal 
  ;;elements; at completion, the CDR of each list is the transitive 
  ;;closure of the terminal element under the given constraints.
  
  (loop for C in Constraints 
      do (loop for Fn1 in (first C)		;(internal-constraint-lhs C)
	     as This-Closure = (assoc Fn1 Closure-List)
	     do (loop for Fn2 in (second C)	;(internal-constraint-rhs C)
		    do (PushNew Fn2 (cdr This-Closure))))) ;(closure-element-reachablefns This-Closure)
  (loop for Closure in Closure-List
      do (Complete-Closure-hack (first Closure) ;(fetch-head  Closure)
				Closure-List)))


(defun complete-closure-hack (head closure-list)
  "Uses list references instead of structure references.
   When everything is converted to structure references
   use the function complete-closure."
  (let ((ans nil)
	(this-closure nil)
	(elt nil)
	(seen nil)
	(queue (list head)))
    (loop while (setq elt (pop queue))
	do
	  (when (not (member elt seen))
	    (setq this-closure (assoc elt closure-list))
	    (setq ans (UNION ans (cdr this-closure)))
			       	;(closure-element-reachablefns this-closure) 
	    (setq queue (UNION queue (cdr this-closure)))
				;(closure-element-reachablefns this-closure)
	    (push elt seen )))
    (rplacd (assoc head closure-list) ans)))

(DEFUN Analyze-Loops (Closure-List)
  ;;;Steve: " 5-Mar-82 17:47" Analyze a closurelist for 
  ;;;"self-referent" functions and return a list of sets 
  ;;;of functions in maximal loops.
  
  (PROG ((Loop-Fns (loop for Closure in Closure-List
		       when
			 (member (first closure) ;(closure-element-head closure)
				 (cdr closure)) ;(closure-element-reachablefns closure)
		       collect (first closure))) ;(closure-element-head closure)
	 Loop-List Loop-Closures)
	(loop for Closure in Closure-List when (member (first closure)	;(closure-element-head closure)
						  Loop-Fns)
	     do
	     (Push (List (first Closure)) Loop-List )	;(closure-element-head closure)
	     (Push  Closure Loop-Closures))
	(loop for Sublist on Loop-Closures
	     do (loop for Closure in (CDR Sublist)
		    as pair = (LIST (first (car sublist)) ;(closure-element-head (CAR Sublist))
				      (first closure))	;(closure-element-head  Closure)))
		    when
		      (And (SubsetP pair (cdr (CAR Sublist))) ;(closure-element-reachablefns...)
			   (SubsetP pair (cdr  Closure))) ;(closure-element-reachablefns...)
		    do
		      (Add-Atoms-To-ASSOC (CAR pair)
					  (cadr pair)
					  Loop-List)
		     (Add-Atoms-To-ASSOC (cadr pair)
					 (CAR pair)
					 Loop-List)
		     ))
	(RETURN (sort (copy-list 
		       (remove-Duplicates 
			(loop for elt in Loop-List
			    collect (sort (copy-list elt) #'String-lessp))
			:test #'equal))
		      #'String-lessp :key #'(lambda (item)
					  (if (listp item)
					      (car item)
					      item))))))



(DEFUN Mark-Fns (Expr Given-Fns Expand-Head-Fns Conflate-Fns)
  (PROG (value)
	;; was inside in the clisp version, don't know what the
	;; the difference to in is meant to be.
	(SETQ value (loop for fn in Expr
			as t0 = fn
			do 
			  (cond
			   ((member fn Given-Fns)
			    (SETQ t0 (intern (FORMAT NIL "--~a--" t0)))) 
			   ((member fn Conflate-Fns)
			    (SETQ t0 (intern (FORMAT NIL "//~a//" t0 ))))
			   ((member fn Expand-Head-Fns)
			    (SETQ t0 (intern (FORMAT NIL "**~a**" t0 )))))
			collect t0))
	(RETURN (cond
		 ((value-if-listp Expr)
		  value)
		 (T (CAR value))))))


(DEFUN Test-For-Ordering-Cycles (Closure-List When-Message Return-Fn)
  (PROG (Cyclic-Functions)
	(cond
	  ((SETQ Cyclic-Functions (Analyze-Loops Closure-List))
	   (Warning "Ordering error--" When-Message ", the following cycles exist: " 
		    Cyclic-Functions)
	   (loop for Cycle in Cyclic-Functions do ( Order? Cycle))
	   (THROW Return-Fn
	     NIL)))))

;;; ----------------------------------------------------------------------
;;; Renamed  from conflation-alias to avoid conflict with
;;; structure reference of the same name.
;;; If Function is in a Conflation, use the first function of that 
;;; conflation as the "alias" for all functions in the conflation.
;;; ----------------------------------------------------------------------

(defun CONFLATION-ALIAS-FUNCTION (Function)
  (cond
   ((first-or-nil (loop for Con in Conflations
		      as membership = (member Function Con)
					;(conflation-alias foo)
		      when membership
		      return con)))
   (T Function)))

;;;----------------------------------------------------------------------
;;; KPML 0.8: following altered to take the full structure from
;;; the printable constituent representation.

(defun PRINT-ORDERINGS (&optional (stream *standard-output*))
  (let ((*standard-output* stream))
    (loop for result in *mouseable-sentences*
	  as index from 1
	  do
	  (format stream "~2%~a: Function structure:" index )
	  (pprint-constituent-structure-as-list
	   (printable-constituent-to-structure-tree
	    result)))))


(defun find-conflation (fn)
  (let((temp (assoc fn conflations)))
    (if temp temp fn)))

(DEFUN Test-For-Ordering-Conflicts (Relations Return-Fn)
  (PROG (Conflicts)
	(loop for Tail on Relations
	    as R1 = (car tail)
	    as R1L =  (Conflation-Alias-function (second R1))
					;(input-constraint-firstop r1)
	    as R1R = (Conflation-Alias-function (third R1))
					;(input-contraint-secondop r1)
	    do
	      (loop for R2 in Tail
		  with R2L and R2R
		  unless (Eq R1 R2)
		  do
		    (SETQ R2L 
			  (Conflation-Alias-function (second R2)))
					;(input-constraint-firstop r2)
		    (SETQ R2R (Conflation-Alias-function (third R2)))
					;(input-constraint-secondop r2)
		    (cond
		     ((Or (And (Eq R1L R2L)
			       (not (equal R1R R2R)))
			  (And (Eq R1R R2R)
			       (not(equal R1L R2L))))
		      (Push (LIST 
			     R1 R2 
			     (cond
			      ((loop for C in Conflations
				   with Pair = (LIST (second R1)
					;(input-constraint-firstop r1)
						     (second R2))
					;(input-constraint-firstop r2)
				   when (Eql (LENGTH 
						(remove-duplicates 
						 (intersection Pair C)))
					     2)
				   return C))
			      ((loop for C in Conflations
				   with Pair = (LIST (third R1) ;(input-contraint-secondop r1)
						     (third R2)) ;(input-constraint-secondop r2)
				   when (Eql (LENGTH 
					      (remove-duplicates 
					       (intersection
						Pair C)))
					     2)
				   return C)))
			    (cond
			     ((Eq R1L R2L)
			      'right)
			     (T 'left)))
			   Conflicts)))))
	(cond
	 (Conflicts (loop for Cfl in Conflicts
			do (cond
			    ((Third Cfl)
			     (Warning "Ordering error--the" (Fourth Cfl)
				      "functions of Relations"
				      (CAR Cfl)
				      "and"
				      (Second Cfl)
				      "are in conflict given the Conflation"
				      (Third Cfl)
				      "."))
			    (T (Warning "Ordering error--the" (Fourth Cfl)
					"functions of Relations"
					(CAR Cfl)
					"and"
					(Second Cfl)
					"are in conflict."))))
		    (THROW Return-Fn
			   NIL)))))


(DEFUN Top-Order-Search (Before-Constraints Adjacency-Constraints Nodes Dump-Flag)
  (catch 'top-order-search
    (PROG ((Floating-Functions Nodes))
	  (setq sequences nil)
	  (setq Dead-Ends 0)
	  (when dump-flag
	    (printwindow :display-pane (pretty-with-header Before-Constraints "Compiled Precedence Constraints: "))
	    (printwindow :display-pane (pretty-with-header Adjacency-Constraints "Compiled Adjacency Constraints: ")))
	  (loop for Constraint in Before-Constraints
	      do (SETQ Floating-Functions
		       (set-difference Floating-Functions
				       (append (first Constraint) ;(internal-constraint-lhs constraint)
					       (second Constraint))))) ;(internal-constraint-rhs constraint)
	  (loop for Constraint in Adjacency-Constraints
	      do (SETQ Floating-Functions
		       (set-difference Floating-Functions
				       (append (first Constraint) ;(internal-constraint-lhs constraint)
					       (second Constraint))))) ;(internal-constraint-rhs constraint)
	  (cond
	    ((And Floating-Functions (> (LENGTH Nodes)
					1))
	     (Warning "The following functions are totally unordered: " Floating-Functions)))
	  (Order-Search NIL Before-Constraints Adjacency-Constraints Nodes)
	  (RETURN (Dreverse Sequences)))))

(DEFUN Order-Search (Path Before-Constraints Adjacency-Constraints Remaining-Nodes)
  ;;Path: initially NIL, the solution constructed by recursive 
  ;;descent. Remaining-Nodes: initially all functions to be ordered, 
  ;;the unplaced functions at this point in processing. 
  ;;Before-Constraints: a list with elements of the form 
  ;;((Fn-Set1) (Fn-Set2)) representing the fact that all functions in 
  ;;Fn-Set1 must be placed before any function in Fn-Set2. 
  ;;Adjacency-Constraints: same as Before-Constraints but stating that 
  ;;whenever all of Fn-Set1 or Fn-Set2 is placed then the next function 
  ;;MUST BE from the opposite set. Note that this supports left and 
  ;;right adjacency.
  (cond
    ((Null Remaining-Nodes)
     (cond
       ((Eq (LENGTH Sequences)
	    Max-Sequences)
	(Warning "Greater than " Max-Sequences "(Max-Sequences) sequences...aborting.")
	(THROW 'Top-Order-Search
	  (Dreverse Sequences))))
     (Push (Reverse Path) Sequences))
;     (when Watch-Search (printwindow :display-pane "+" ))
    (T (PROG ((Next-Nodes Remaining-Nodes)
	      (Forward-Adjacencies 
	       (loop for C in Adjacency-Constraints
		   unless (set-difference (first C) ;(internal-constraint-lhs c)
					  Path)
		   collect C))
	      (Reverse-Adjacencies (loop for C in Adjacency-Constraints
				       unless (set-difference (second C) ;(internal-constraint-rhs c)
							       Path)
					collect C)))
	     (loop for C in Before-Constraints
		  do (SETQ Next-Nodes (set-difference Next-Nodes
						      (second C))))	;(internal-constraint-rhs c)
	     (loop for C in Forward-Adjacencies
		  do (SETQ Next-Nodes (remove-duplicates
					(intersection Next-Nodes (second C)))))	;(internal-constraint-rhs c)
	     (loop for C in Reverse-Adjacencies
		  do (SETQ Next-Nodes (remove-duplicates
					(intersection Next-Nodes (first C)))))	;(internal-constraint-lhs c)
	     (cond
	       ((Null Next-Nodes)
		(SETQ Dead-Ends (incf Dead-Ends 1))
;		(when Watch-Search (printwindow :display-pane "-" ))
		(RETURN NIL))
	       (T (loop for N in Next-Nodes
		      with Remaining-Before-Constraints
		      and Remaining-Adjacency-Constraints
		      and Remaining-Forward-Adjacencies
		      and Remaining-Reverse-Adjacencies
		      do
			(SETQ Remaining-Adjacency-Constraints
			      (set-difference Adjacency-Constraints
					     (append 
					       Forward-Adjacencies 
					       Reverse-Adjacencies)))

		       (SETQ Remaining-Forward-Adjacencies
			     (loop for C in Forward-Adjacencies
				 as Filtered-Set = (set-difference
						    (second C)
					;(internal-constraint-lhs c)
						    (list N))
				 when Filtered-Set
				 collect (LIST (first C)
					       Filtered-Set))) ;(internal-constraint-rhs c)

		       (SETQ Remaining-Reverse-Adjacencies
			     (loop for C in Reverse-Adjacencies
				 as Filtered-Set = (set-difference
						       (first C) ;(internal-constraint-lhs c)
						       (list N))
				 when Filtered-Set
				 collect (LIST Filtered-Set
						(second C))))	;(internal-constraint-rhs c)

		       (setq Remaining-Adjacency-Constraints
			     (append Remaining-Adjacency-Constraints
				     Remaining-Forward-Adjacencies
				     Remaining-Reverse-Adjacencies))

		       (SETQ Remaining-Before-Constraints
			     (loop for C in Before-Constraints 
				  as Filtered-Set = (set-difference
						     (first C) ;(internal-constraint-lhs c)
						     (list N))
				 when Filtered-Set
				 collect (LIST Filtered-Set
					       (second C)))) ;(internal-constraint-rhs c)
		       (Order-Search (Cons N Path)
				     Remaining-Before-Constraints Remaining-Adjacency-Constraints
				     (set-difference Remaining-Nodes (list N))))))))))

(defun get-fundle (fn pass-data)
  (some #'(lambda (bbe)
	    (let ((conf (brownboard-elt-functionlist bbe)))
	      (when (eq (conflation-alias conf) fn)
		(cons (conflation-alias conf)
		      (conflation-othernodes conf)))))
	(constituent-pass-brownboard pass-data)))





;;; ----------------------------------------------------------------------
;;; Patched at 2.0.7 to not get confused with microfunction number tags
;;; ----------------------------------------------------------------------

(defun PUNCTUATE (Fundle Word-order-list  Punctuations)
  (dolist (Punctuation Punctuations)
    (if (member (second Punctuation) Fundle 
		:test #'(lambda (punctuation-condition Function)
			  (eq punctuation-condition (remove-fn-tag function))))
	(return
	  (progn
	    (push (cons :|pre/post| punctuation) 
		  *applied-punctuation-list*)  ;; 3.2.59
	    (setq word-order-list 
	      (mapcar #'(lambda (Word-order)
			  (append Word-order
				  (list (third Punctuation))))
		      Word-order-list))))))
  Word-order-list)


;;; ----------------------------------------------------------------------
;;; KPML 0.8: more user selectable flexibility...
;;; ----------------------------------------------------------------------

(defun SENSITIZE-CONSTITUENT-P (constituent)
 (case *mouse-sensitive-constituents* 
       (:all T)
       (:none nil)
       (otherwise
	(intersection
	 (constituent-pass-selection-expression constituent)
	 *mouse-sensitive-constituents*))))		     


(defun SENSITIZE-TERMINAL-P (terminal)
  (case *mouse-sensitive-terminals*
	(:all T)
	(:none nil)
	(otherwise 
	 (intersection *mouse-sensitive-terminals* terminal
		       :test #'(lambda (punctuation-condition Function)
				 (let ((result 
					(search 
					 (symbol-name punctuation-condition) 
					 (symbol-name Function))))
				   (cond
				    ((null result) nil)
				    (t (= 0 result)))))))))

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






(defun find-concept-of-constituent (constit)
;; find the concept associated with ONUS for this constituent...

  (let ((associations (constituent-pass-associations constit)))
    (dolist (association associations)
      (if (eq (function-association-function association) 'onus)
	  (return (function-association-concept association))))))


;;; KPML 0.8: building out the printable structure representation
;;; so that it can augment the example records usefully...

(defun FIND-FUNCTIONS-OF-CONSTITUENT (constit)
  (print "Basis:")(print constit)
  nil)

;;; ----------------------------------------------------------------------
;;; Punctuation interaction...

;;;=====================================================================
;;; And we need to know how to treat these during generation of the final
;;; string... 

;;; 2.0 extension for punctuation rules added here. Extension allows
;;;     a punctuating method to be called on a particular unit that
;;;     has the appropriate grammatical function and/or selection
;;;     expression members. Typical methods will be: 
;;;         kpml-upcase
;;;         kpml-downcase
;;;         kpml-capitalize
;;;
;;;     These work by calling a function of the same name to provide
;;;     a modified word-order list entry...

(defun POST-SELF-PUNCTUATE 
    (Fundle Word-order-list Selection-expression Post-Punctuations)
  (dolist (Punctuation Post-Punctuations)
    (if (and
	 (or
	  (eq (second Punctuation) '*)
	  (member (second Punctuation) Fundle
		  :test #'(lambda (punctuation-condition Function)
			    (search (symbol-name punctuation-condition) 
				    (symbol-name Function)))))
	 (member (first Punctuation) Selection-expression))
	(return
	  (let ((action (third punctuation)))
	    (push (cons :|self| punctuation) *applied-punctuation-list*)  ;; 3.2.59
	    (typecase action
	      (string
	       (setq word-order-list 
		 (mapcar #'(lambda (Word-order)
			     (append Word-order
				     (list (third Punctuation))))
			 Word-order-list)))
	      (symbol 
	       (when (fboundp action)
		 (setq word-order-list 
		   (mapcar action Word-order-list)))))))))
  Word-order-list)

(defun PRE-SELF-PUNCTUATE 
    (Fundle Word-order-list Selection-expression Post-Punctuations)
  (dolist (Punctuation Post-Punctuations)
    (if (and
	 (or
	  (eq (second Punctuation) '*)
	  (member (second Punctuation) Fundle
		  :test #'(lambda (punctuation-condition Function)
			    (search (symbol-name punctuation-condition) 
				    (symbol-name Function)))))
	 (member (first Punctuation) Selection-expression))
	(return
	  (let ((action (third punctuation)))
	    (push (cons :|self| punctuation) *applied-punctuation-list*)  ;; 3.2.59
	    (typecase action
	      (string
	       (setq word-order-list 
		 (mapcar #'(lambda (Word-order)
			     (append (list (third Punctuation))
				     Word-order
				     ))
			 Word-order-list)))
	      (symbol 
	       (when (fboundp action)
		 (setq word-order-list 
		   (mapcar action Word-order-list)))))))))
  Word-order-list)


;;; ----------------------------------------------------------------------
;;; The word-order-lists contain sequences of printable-constituents,
;;; so we need to go inside these in order to get at the strings. 
;;; This is before any messing around of those strings by phonological
;;; processing and whatnot.... The following function provides generic
;;; access to these strings and applies a string operation to them...
;;; 2.1   add provision for affecting either just the first or the last
;;;       in addition to all the constituent strings of the word order
;;;       list.... although I don't see how this copes with recursion...
;; 3.2.14 used the wrong predicate, resulting in a test that never failed...
;;; ----------------------------------------------------------------------

(defun STRING-MODIFYING-PUNCTUATION 
  (wol string-modifier-fn &optional (which :all))
  (case which
	(:all
	 (loop for c in wol
	       when (and (typep c 'printable-constituent)
			 (printable-constituent-spelling c))
	       do
	       (setf (printable-constituent-spelling c)
	         (loop for s in (printable-constituent-spelling c)
	               when (stringp s)      ;; 3.2.14
	               collect (funcall string-modifier-fn s)
	               else
	               collect s))))
    (t
     nil))
  wol)

#||

An example rule would be:

(define-post-self-punctuation :language :ENGLISH
  :punctuation-rules '((WORDS * " ") 
		       (INDIVIDUAL-NAME * upcase)
		       (INTERROGATIVE PROJECTED "?")
		       ...))

Realized by:

||#

(defun UPCASE (wol)
  (string-modifying-punctuation wol 'string-upcase))

(defun SENTENCE-CAPITALIZATION (wol)
  (string-modifying-punctuation wol #'(lambda (w) (print w) w)))

;;; Further specific examples, drawn from different languages, are
;;; in the file morphology.lisp
;;; ----------------------------------------------------------------------

  ;; 
  ;; 4.0 small extension to catch the two kinds of expanded-objects
  ;;     that are now placed on the blackboard...
  ;;
(defun ORDER? (Fns)
  (PROG (t0 Head-Fns All-Fns)
	(setq Conflations (loop for Node in Blackboard
			   when (And (value-if-listp Node)
				     (Eq (first node) 'Complex-Object))	;(complex-object-id node)
			   collect (cdr Node)))	;(complex-object-expansiondef)
	(setq Expansions (loop for Node in Blackboard
			  when (And (value-if-listp Node)
				    (or 
				     (Eq (first node) 'Expanded-Object)
				     (Eq (first node) 'filled-expanded-object) ;; 4.0
				     ))	;(expanded-object-id node)
			  collect (cdr Node))) ;(expanded-object-expansiondef node)
	(printwindow :display-pane (pretty-with-header Fns "Functions: "))
	(printwindow :display-pane "{ --  ==>  Input,  //  ==>  Conflated,  **  ==> Expanded }")
	(SETQ Head-Fns (loop for exp in Expansions collect (first exp)))	;(expansion-parent exp)
	(SETQ All-Fns (UNION (loop for fn in Fns 
				 nconc (copy-tree 
					(loop for C in Conflations
					    when (member fn c)
					    return c)))
			     Fns))
	(when (SETQ t0 (loop for con in Conflations
			   when (remove-duplicates (intersection All-Fns con))
			   collect (Mark-Fns con Fns Head-Fns All-Fns)))
	  (printwindow :display-pane (pretty-with-header t0 "Conflations: ")))
	(when (SETQ t0 (loop for exp in Expansions
			    when (remove-duplicates (intersection All-Fns exp))
			    collect (Mark-Fns exp Fns Head-Fns All-Fns)))
	  (printwindow :display-pane (pretty-with-header t0 "Expansions: ")))
	(when (SETQ t0 (loop for rel in Ordering-Relations
			    when (remove-duplicates (intersection All-Fns rel))
			    collect (Mark-Fns rel Fns Head-Fns All-Fns)))
	  (printwindow :display-pane (pretty-with-header t0 "Ordering-Relations: ")))
	(when (SETQ t0 (loop for def in (Ml-Default-Orderings)
			    when (remove-duplicates (intersection All-Fns def))
			    collect (Mark-Fns def Fns Head-Fns All-Fns)))
	  (printwindow :display-pane (pretty-with-header t0 "Default Orderings: ")))))  
  


  ;; 
  ;; 4.0 small extension as above to catch the two kinds of expanded-objects
  ;;     that are now placed on the blackboard...
  ;;
(defun DO-ORDERING (Message Result-Flag)
;;; Note that since the blackboard contains lists not structures we
;;; used list access methods (car's and cdr's) The actual structure
;;; reference is included to the side for easier reading and possible
;;; conversion later.
  (catch 'do-ordering    ;throw to this catch from test-for-ordering-cycles
    (PROG ((Word-Pairings (loop for WBE in Whiteboard
			       when (whiteboard-elt-realization WBE)
			       collect (LIST (whiteboard-elt-aliasfn WBE)
					     (whiteboard-elt-realization WBE))))
	   Simple-Terminals Expanded-Relations Total-Constraints 
	   Closure-List Final-Value)

	  (setq Expansions (loop for Node in Blackboard
				when (And (value-if-listp Node)
					  (or 
					   (Eq (first Node) 'Expanded-Object)
					   (Eq (first Node) 'filled-Expanded-Object))
					   ) 	;(expanded-object-id node)
				collect (cdr Node)))
	  (setq Conflations (loop for Node in Blackboard
				 when (And (value-if-listp Node)
					   (Eq (first Node)	;(complex-object-id node)
					       'Complex-Object))
				 collect (cdr Node)))
	  (SETQ Expand-Parents (loop for Ex in Expansions collect (first Ex)))	;(expansion-parent ex)
	  (SETQ Terminal-Conflations (loop for C in Conflations
					  unless (remove-duplicates (intersection C Expand-Parents))
					  collect C))
	  (SETQ Simple-Terminals (loop for Node in Blackboard
				      when (And (ATOM Node)
						(Not (member Node Expand-Parents)))
				      collect Node))
	  (SETQ Terminals (append (loop for C in Terminal-Conflations
				       collect (first C))	;(conflation-alias c)
				  Simple-Terminals))
	  (SETQ Non-Terminals (loop for Ex in Expansions
				   collect (Cons (first Ex)	;(expansion-parent ex)
						 (loop for Fn in (cdr Ex)	;(expansion-offspring ex)
						      with Result
						      do (PushNew (Conflation-Alias-function Fn) Result)
						      finally (RETURN (Reverse Result))))))

	  ;; inserted from complete-order-info:
	  (SETQ Expanded-Relations (Generate-Constraints Ordering-Relations))
	  ;; added to consider adjacency constraints when adding defaults:
	  (setq Adjacency-constraints (loop for R in Expanded-Relations
					   when (Eq (first R)	;(input-constraint-id r) ?
						    'Order)
					   collect R))
	  ;; end of added code.
	  (Add-Order-Defaults (Compile-Constraints Expanded-Relations)
			      (Compile-Defaults (Ml-Default-Orderings) curlan)
			      Ordering-Dump-Flag)
	  ;; end of inserted code.

	  (SETQ Closure-List (loop for Fn in Terminals collect (list Fn)))
	  (SETQ Expanded-Relations (Generate-Constraints Ordering-Relations))
	  (SETQ Total-Constraints (Compile-Constraints Expanded-Relations))
	  (Generate-Closure-List Total-Constraints Closure-List)
	  (Test-For-Ordering-Cycles Closure-List 
				    "all constraints at this level (including default ordering)"
				    'Do-Ordering)
	  (Test-For-Ordering-Conflicts (loop for R in Ordering-Relations
					    when (Eq (first R)	;(input-constraint-id r) this may not be correct
						     'Order)	;see interlisp version.
					    collect R)
				       'Do-Ordering)
	  (SETQ Sequences (Top-Order-Search Total-Constraints
					    (Compile-Constraints Adjacency-constraints)
					    Terminals Ordering-Dump-Flag))
	  (PROG (orderings)
		(cond
		  ((Not Sequences)
		   (Warning 
		     "No valid sequences...big trouble!")
		   (error "No valid sequences"))
		  (T (SETQ orderings
			   (loop for Sequence in Sequences
				collect (Cons (loop for Fn in Sequence collect (Find-Conflation Fn))
					      (cond
						(Word-Pairings
						 (loop for Fn in Sequence
						      collect
						      (cond
							((Second (assoc Fn Word-Pairings)))
							(T (Feature-Pack (Find-Conflation
									   Fn))))))))))
						;First-Ordering is global, set up for 
						;comparison work
		     
		       (when Result-Flag
			(printwindow :display-pane `(" " " " ,(format nil "~a" message)))
			(Print-Orderings orderings))
		     (SETQ Final-Value (CAR orderings))
		     (SETQ First-Ordering (CDR Final-Value)))))
	  (RETURN Final-Value))))


;;;
;;; From systemic-networks/tests.lisp
;;;

(defun DEFAULT-ORDERING-LOOPS-TEST ()
  (PROG (Closures Closure-Loops Mentioned-Fns Constraints)
	(SETQ Constraints 
	      (loop for Order in (ml-default-orderings)
		   collect (loop for Fn in Order
				do (PushNew fn  Mentioned-Fns )
				collect (list Fn))))
	(SETQ Closures (loop for Fn in Mentioned-Fns collect (list Fn)))
	(Generate-Closure-List Constraints Closures)
	(cond
	  ((SETQ Closure-Loops (Analyze-Loops Closures))
	   (format t "~%!! The following cycles exist in default ordering: ~A" Closure-Loops)
	   (loop for Cycle in Closure-Loops do ( Order? Cycle))))))


;;; ======================================================================

;;; P.S.
;;; ----------------------------------------------------------------------
;;; Surely this exists somewhere??? But until we find it again...
;;; 2.0.7 
;;; 3.2->4.0: yes, it does, and it was called MICROFUNCTION-NAME which
;;;           is defined in structure.lisp. The name here is more
;;;           descriptive, so the other function is changed in structure.lisp
;;;           to use this name and the definition from here moves there.
;;;           The only difference in the definition is that the other
;;;           uses a simple call to string rather than to symbol-name
;;;           anyway.
;;; ----------------------------------------------------------------------

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

