;;; Basic functionality for stratified resource traversal, including
;;; sensitivity to external field features.
;;;
(in-package :penman)

(defvar *current-stratum* nil)
(defvar *generated-strings* "")

;;;================================================================================
;;; following function allows for the selective realization by traversal of
;;; a selected stratum network... Interfaces also for the time being
;;; between oldstyle (ISI-)Penman type internal structures and the
;;; linguistically more transparent structures of KOMET-PENMAN. Can either
;;; constrain the traversal by giving a list of features to act as
;;; preselections, or by giving a full constraint as a partially actualized
;;; inter-axis-relation (or a list of such relations: in which case,
;;; multiple traversals are carried out).  This latter should be made
;;; compatible with Licheng's `Penman without choosers' at some stage. Note
;;; that, when we have a constraint, we DO NOT try to intervene at the
;;; appropriate time in the (ISI-)Penman internal multiple traversal of the
;;; network to add in the constraints specified (which is tricky to say the
;;; least, although probably not impossible). INSTEAD, we rely fully on the
;;; generalized realizations and how they work.

;;; (N.B. for a different treatment of complexes of constraints coming in,
;;;  see the function TRAVERSE-WITH-POSSIBLE-COMPLEX defined below.)
;;; Note that constraints is always assumed to be a *list* of constraints,
;;; in this case, a list of inter-axis-relations. For a single constraint
;;; a singleton set must be given. The function, similarly, *always* returns
;;; a list of resultant actualisations (inter-axis-relations). Also, when
;;; an incoming constraint includes syntagmatic details, we try and pick
;;; up some of the paradigmatic consequences of those details as additional
;;; preselections on the traversal. This is  very limited, since
;;; we do not go over to a full feature logic for resolving constraints.

(defun TRAVERSE (&key at (root nil)(constraints nil)(preselects nil))
  (let ((constraints-list (if (consp constraints) constraints
			    (list constraints)))
	(actualization-results nil))
    (dolist (c constraints-list)
	    (let ((penman-style-sentence-tree nil)
		  (collected-preselects
		   (if c (get-predictable-features c preselects)
		     preselects)))
	      (cond 
	       ((not (member at (fetch-output-features 'stratification)))
		(warning "Unknown stratum requested: " at))
	       (t
		(new-cycle at)
		(clear-externally-instantiated-instances)
		(setf penman-style-sentence-tree
		      (pass-penman-style-initial-structure-to-penman At Root collected-preselects))
		(Unwind-Passes penman-style-sentence-tree)
		(setf (paradigmatic-unit-selection-expression
		       (inter-axis-relation-para *top*))
		      (constituent-pass-selection-expression penman-style-sentence-tree))
		(if (eq at 'lexicogrammar)
		    (setf *generated-strings*
			  (concatenate 'string
			   *generated-strings* " -- "
			   (graphology penman-style-sentence-tree) )))
		(push *top* actualization-results)))))
    actualization-results))


;;;----------------------------------------------------------------------
;;; before actualizing structure, we have to begin a new actualization
;;; cycle at a specified rank... e.g., (new-cycle 'genre). After this,
;;; structure can be created using the generalized structure building
;;; mechanisms or their stratum-specific specializations. Could use this
;;; for holding the parameterized start-ups for a traversal...

(defun new-cycle (stratum)
  (setf *current-cycle*                  (make-cycle-instances-record)
	*expanded-not-yet-inserted-list* nil
	*gsp-participant-list*           nil
	*current-stratum*                  stratum
	*top*                            (make-inter-axis-relation
					  :synt (make-syntagmatic-configuration
						 :units nil
						 :stratum stratum)
					  :para (make-paradigmatic-unit
						 :stratum stratum)
					  :stratum stratum)
	*parent*                         '*TOP-UNIT*))



;;;--------------------------------------------------------------------------------
;;; Following function attempts to pick off as many entailed preselections as
;;; it can without falling back on generalized feature logic... This works
;;; at present as follows. All features which are candidates for being
;;; externally constrained by syntagmatic specifications are defined as
;;; output features of `external-systems'. Then, if we get a syntagmatic
;;; unit which is inserted by a feature which is the output feature of one
;;; of these external features, then that feature is added to the preselection
;;; list.

(defun GET-PREDICTABLE-FEATURES (constraint preselections)
  (append 
   preselections
   (paradigmatic-unit-selection-expression
    (inter-axis-relation-para constraint))
   (get-features-entailed-by-microfunctions 
    (syntagmatic-configuration-units
     (inter-axis-relation-synt constraint)))))

(defun GET-FEATURES-ENTAILED-BY-MICROFUNCTIONS (units)
  (let ((present-microfunctions 
	 (flatten
	  (mapcar #'(lambda (unit)
		      (syntagmatic-unit-labels (label-deref unit)))
		  units)))
	(entailed-features nil))
    (dolist (mf present-microfunctions)
	    (when (where-inserted mf)
		  (dolist (f (where-inserted mf))
			  (when (member f *externally-constrained-features*)
				(push f entailed-features)))))
    (when (and *show-function-feature-entailments* entailed-features)
	  (format t "~% features ~A entailed by units: ~A"
		  entailed-features present-microfunctions))
    (augment-preselections entailed-features)))



;;;--------------------------------------------------------------------------------
;;; Interfaces between new code and old (ISI-)Penman code... Passing this 
;;; contorted structure to All-Parts0 causes Penman to continually traverse
;;; the network, recursively building structure, until no further preselections
;;; are outstanding.

(defun PASS-PENMAN-STYLE-INITIAL-STRUCTURE-TO-PENMAN (At Root Constraints)
;;; set the horrible Penman global variables...

  (setf kb (copy-tree '(NIL)))  ;;; N.B. WHEN THESE ARE NOT RESET WE GET (INTERESTING?)
  (setf tp (copy-tree '(NIL)))  ;;;      HANGINGS ON OF INFORMATION ACROSS REALIZATIONS...
  (setq *consumed-terms* nil)   ;;; *never* reset *plan-graphs* here!!!

  (setq alias-function-stack nil)
  (SETQ Constituent-Index 0)
  (setq associations nil)
  (clrhash show-pass-hash-table)
  (when window-interface-flag
	(printwindow :clear-item-list-for-show-pass-menu))
       
  (All-Parts0 (make-Whiteboard-Elt
	       :id  'Preselect
	       :aliasfn  '-top-
	       :featurelist  (cons at Constraints)
	       :hub  Root)
	      (make-Brownboard-Elt
	       :functionlist  (make-conflation
			       :alias '-top-
			       :othernodes nil)
	       :featurespecs (List (make-Selection-Def
				    :id  'Preselect
				    :fn  '-top-
				    :features  Constraints)))))


;;; following taken from the function all-parts0
;;; (nigel/process/allparts.lisp) and express.  should be changed for
;;; placing the result somewhere more general than just printing it
;;; out... 
;;;
;;; N.B. KPML NOW DOES NOT DO ITS STRING OUTPUT AND PREPARATION OF 
;;;      FINAL RESULTS IN THE SAME WAY AS WAS THE CASE HERE. THE
;;;      FOLLOWING FUNCTION CALLS THE OUTDATED FUNCTION GENERATED-STRING
;;;      WHICH IS NOW INCLUDED FOLLOWING THIS FUNCTION BELOW. WHEN
;;;      THIS CODE IS REACTIVATED ANYWHEN IT SHOULD ALSO BE BROUGHT
;;;      BACK INLINE WITH CURRENT KPML DEFINITIONS...

(defun GRAPHOLOGY (penman-style-lexicogrammatical-structure)
  (let ((orderings (all-orderings penman-style-lexicogrammatical-structure))
	(result-string ""))
    (setf *mouseable-sentence* (cdr (first orderings)))
    (phonological-processing 	*mouseable-sentence* curlan)	      
    (setq final-orderings 
	  (mapcar #'(lambda (ordering)
		      (cons (first ordering)
			    (printable-constituent-to-printable-list (cdr ordering))))
		  orderings))
    (setf result-string (generated-string nil))
    (pprint result-string)
    result-string))
  
;;; Following function now out of date and not in tune with the rest
;;; of KPML, included here so that the above function works, but it
;;; should be revamped whenever used again. Outputs a reminder if ever
;;; it is called.

(defvar *structural-conjunction* "and")

(defun GENERATED-STRING (&optional (print-results t))
  "Either prints the generated string(s) or returns the last generated string, depending if return-string-only is NIL or T"
  (format *trace-output* "~%NOTE: the function GENERATED-STRING has been called
 in the file stratified-traversal.lisp. This is an out of date function
 that is no longer handling the final string in the way that multilingual
 KPML does. The stratification code using this function should be changed
 to be brought back in line with final string preparation.")
  (let ((result nil))
    (dolist (one-ordering final-orderings)
      (cond ((null (cdr one-ordering))
	     (setq result ">>>NULL ORDERING<<<"))
	    (t
	     (SETQ result (unify-string (cdr one-ordering)))

;;; the following cross structural boundaries...
;;; maybe can be improved on since now we have the structure available...
	     (setq result (string-substitute "," " & *[*" result))	; it is necessary to take account of
	     (setq result (string-substitute "," "&*[*" result))
	     (setq result (string-substitute ""  "*[* " result))	; structure in order to replace
	     (setq result (string-substitute ""  "*[*" result))
	     (setq result (string-substitute *structural-conjunction*
					     "&" result))	; and's by commas in lists appropriately.

;;; the following is global and only done once...
	     (setf (char result 0) (char-upcase (char result 0)))	; capitalize first word.

;;; the following can safely be done within constituents... 
	     (setq result (string-substitute "/" " / " result))	; spaces out in dates.
	     (setq result (string-substitute "," ",," result))
	     (setq result (string-substitute "." ",." result))
	     (setq result (string-substitute "." ".," result))	; this is a hack to deal with the
	     (setq result (string-substitute "?" "?." result))	; occasional multiple punctuation
	     (setq result (string-substitute "!" "!." result))  ; that occurs due to embedding.
;;;> and some of the things that arise from the morphological and word ranks...
	     (setq result (string-substitute "." " ." result))
	     (setq result (string-substitute "," " ," result))
	     (setq result (string-substitute " " "  " result))
	     (setq result (string-substitute " " " ?" result))
	     (setq result (string-substitute " " " !" result))

	     (remove-spaces-between-numerals-and-compass-points result)))	;destructive replacement    

      (when print-results
	(printwindow :display-pane " ")
	(printwindow :display-pane (indent-and-fill "Generated string:  "))
	(printwindow :display-pane (indent-and-fill result))))
    (if print-results
	(values )
	(values result)
	)))

  
;;;--------------------------------------------------------------------------------  
;;; following function, defined originally in spl/penman-exec.lisp, is
;;; now altered to send control through the new traverse function...
;;; Function is regularly called by say-spl, etc.
;;
;;; NOTE: DOESNOT APPEAR ANY DIFFERENT TO THE FUNCTION IN PENMAN-EXEC!!!
;;;       COMMENTED OUT TO SEE IF ANYTHING HAPPENS!
  
;  (defun SAY-PLAN (plan print-results)
;    "Convert the list-structured plan into term-graph structures, set global parameters,
;   and invoke Express."
;    (unless (say-entry-control) (return-from say-plan nil))
;    (setq *plan-graphs* nil)
;    (setq *consumed-terms* nil)
;    (setf (example-rootnode (gethash plan penexamples)) 
;	  (setq *plan* 
;		(make-plan-term-graph 
;		 (example-logicalform (gethash plan penexamples)))))
;    (setf (example-verbalizationgraph (gethash plan penexamples)) *plan-graphs*)
;    (setq *speaker* (discourse-context-speaker 
;		     (example-discoursecontext 
;		      (gethash plan penexamples))))
;    (setq *hearer* (discourse-context-hearer 
;		    (example-discoursecontext 
;		     (gethash plan penexamples))))
;    (setq *speakingtime* (discourse-context-speaking-time 
;			  (example-discoursecontext 
;			   (gethash plan penexamples))))
;    (setq *speakingplace* (discourse-context-realm-of-speech 
;			   (example-discoursecontext 
;			    (gethash plan penexamples))))
;    (Express plan print-results))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;================================================================================
;;; Different treatment of lists/complexes of constraints, relying on 
;;; future-cycles being named in the list of constraints and not being
;;; given as direct structures... Returns a list of the resultant
;;; inter-axis-relation lists which then needs to be flattened.

(defun TRAVERSE-WITH-POSSIBLE-COMPLEX (&key at (root nil)(constraints nil)(preselects nil))
  "Alternative treatment of traversal with complexes"
  (let ((constraint-list (if (consp constraints) constraints
			   (list constraints))))
    (flatten
     (mapcar #'(lambda (exponent)
		 (traverse :at at
			   :constraints (gethash exponent *inter-axis-relation-futures*)
			   :preselects preselects
			   :root root))
	     constraint-list))))


