;;; File: finalfix.lisp
;;; This file contains the code for the new realization statements and the
;;;    modification of the function DO-ORDERING
;;; Susan Williams, May, 1995
;;;
;;; Note: If this file is loaded on top of an already existing version of
;;;   Penman, there will be warning messages that the functions DO-ORDERING
;;;   and compute-hash-table-of-all-functions are being redefined.

(in-package :penman)

;;;--------------------------------------------------------------------
;;; Global variables to save components to be moved

(defvar *second-to-be-moved-list* nil)
(defvar *first-to-be-moved-list* nil)

(setq *second-to-be-moved-list* nil)
(setq *first-to-be-moved-list* nil)

;;;--------------------------------------------------------------------
;;; New realization statements

(defun order-anchor-first (fn1 fn2)
  (order fn1 fn2)
  (push fn2 *second-to-be-moved-list*))

(defun order-anchor-second (fn1 fn2)
  (order fn1 fn2)
  (push fn1 *first-to-be-moved-list*))

;;;--------------------------------------------------------------------
;;; Helper functions for the modificaiton to DO-ORDERING

(defun is-found-second (x list)
  "Did we decide to move this?"
  (cond ((null list) nil)
	(t (or (eq x (first (second (first list))))
	       (is-found-second x (rest list))))))

(defun is-found-first (x list)
  "Did we decide to move this?"
  (cond ((null list) nil)
	(t (or (eq x (first (first (first list))))
	       (is-found-first x (rest list))))))

(defun remove-recursive (x l)
  "Remove x from any level of l"
  (cond ((atom l) l)
	((equal (first l) x) (remove-recursive x (rest l)))
	(t (cons (remove-recursive x (first l))
		 (remove-recursive x (rest l))))))

;;;--------------------------------------------------------------------
;;; The modified version of DO-ORDERING

;;; replaced this version of Do-Ordering with a new version from 
;;; KPML 1.0 with Susan's patch.  - Jon 21/01/97

(defun DO-ORDERING (&OPTIONAL Message Result-Flag &REST IGNORE)
;;; 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 
	    (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 
	    (for Node in Blackboard
		 when (And (value-if-listp Node)
			   (Eq (first Node) ;(expanded-object-id node)
			       'Expanded-Object))
		 collect (cdr Node)))
	  (setq Conflations 
	    (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 
		(for Ex in Expansions collect (first Ex))) 
	  ;;(expansion-parent ex)
	  (SETQ Terminal-Conflations 
		(for C in Conflations
		     unless (remove-duplicates (intersection C Expand-Parents))
		     collect C))
	  (SETQ Simple-Terminals 
		(for Node in Blackboard
		     when (And (ATOM Node)
			       (Not (member Node Expand-Parents)))
		     collect Node))
	  (SETQ Terminals 
		(append (for C in Terminal-Conflations
			     collect (first C)) ;(conflation-alias c)
			Simple-Terminals))
	  (SETQ Non-Terminals 
		(for Ex in Expansions
		     collect 
		     (Cons (first Ex)	;(expansion-parent ex)
			   (for Fn in (cdr Ex) 
				;;(expansion-offspring ex)
				bind 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 
	    (for R in Expanded-Relations
		 when (Eq (first R)	;(input-constraint-id r) ?
			  'Order)
		 collect R))
	  ;; end of added code.
	  ;;-----------------------------------------------------------
	  ;; Start of Susan's inserted code
	  ;;-----------------------------------------------------------
	  ;; This is what was replaced:
	  ;; (Add-Order-Defaults (Compile-Constraints Expanded-Relations)
	  ;;                     (Compile-Defaults Fragment-Order-Lsts)
	  ;; 	 	         Ordering-Dump-Flag)
	  ;; (Add-Order-Defaults (Compile-Constraints Expanded-Relations)
	  ;;		      (Compile-Defaults (Ml-Default-Orderings))
	  ;;		      Ordering-Dump-Flag)
	  (let ((compiled (Compile-Constraints Expanded-Relations))
		(new-default-list (compile-defaults (Ml-Default-Orderings)))
		(new-move-list1
		 (mapcar #'(lambda (x)
			     (cons x
				   (expand-non-terminal x non-terminals
							terminals)))
			 *second-to-be-moved-list*))
		(new-move-list2
		 (mapcar #'(lambda (x)
			     (cons x
				   (expand-non-terminal x non-terminals
							terminals)))
			 *first-to-be-moved-list*)))
	    (for move in new-move-list1
		 do (when (is-found-second (second move) compiled)
			  (setq new-default-list
				(remove-recursive
				 nil (remove-recursive (second move)
						       new-default-list)))
			  (setq *second-to-be-moved-list*
				(remove (first move)
					*second-to-be-moved-list*))))
	    (for move in new-move-list2
		 do (when (is-found-first (second move) compiled)
			  (setq new-default-list
				(remove-recursive
				 nil (remove-recursive (second move)
						       new-default-list)))
			  (setq *first-to-be-moved-list*
				(remove (first move)
					*first-to-be-moved-list*))))
	    (Add-Order-Defaults compiled
				new-default-list
				Ordering-Dump-Flag))
	  ;;-----------------------------------------------------------
	  ;; End of Susan's inserted code
	  ;;-----------------------------------------------------------
	  ;; end of inserted code.
	  ;; end of inserted code.

	  (SETQ Closure-List (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 
	   (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
			(for Sequence in Sequences
			     collect 
			     (Cons (for Fn in Sequence 
					collect (Find-Conflation Fn))
				   (cond
				    (Word-Pairings
				     (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))))


;;; This function has been changed to include my 2 new realization statements

;;; replaced this function with version from KPML 1.0 with Susan's new 
;;; realization statements.  -  Jon 21/01/97

#-kpml(defun compute-hash-table-of-all-functions ()
  (clrhash hash-table-of-all-functions)
  (dolist 
      (system  systems)
    (dolist 
	(outputs (fetch-system-outputs system))
      (dolist 
	  (realization (cddr outputs))
	;;(format *standard-output* "~%~s" realization)
	#+TI(when (equal (car realization) 'sys:displaced) 
	      ;;avoid loss from really gross TI macro bug -rna
	      (setq realization (second realization)))
	(case (car realization)
	  (*)
	  ((lexify insert orderatend orderatfront preselect inflectify
	    classify outclassify  realize-lexicalization
	    ;;> plus leo's...
	    ecd-insert 
	    ;;> plus the morphology realizations...
	    preselect-substance weaken strengthen chop)
	   (setf  (gethash (second realization) hash-table-of-all-functions)
	     (second realization)))
	  ((order conflate partition order-anchor-first order-anchor-second )
	   (setf  (gethash (second realization) hash-table-of-all-functions)
	     (second realization))
	   (setf  (gethash (third realization) hash-table-of-all-functions)
	     (third realization)))
	  (expand
	   (setf  (gethash (second realization) hash-table-of-all-functions)
	     (second realization))
	   (setf  (gethash (third realization) hash-table-of-all-functions)
	     (third realization))
	   (setf  (gethash (fourth realization) hash-table-of-all-functions)
	     (fourth realization)))
	  (otherwise
	   (warning "Unknown realization " realization " in system " system 
		    " ,unable to compute hash-table-of-all-functions")))))))

