(in-package "KPML")

(defvar *actualized-text-list* nil "The cumulative text being generated")
(defvar *show-register-profiles* nil "Show register profiles when ready")
(defvar *grammaticize* t "Control is passed on to the lexicogrammar")

(defvar *export-text-result* nil)

(defun DESIGN-TEXT (&key (constraints nil))

  (setf *registerial-biases* nil
	*pattern-preselection-pairs* nil
	*resolved-semantic-sequence* nil
	*generated-strings* "")


  (let* 
;;; only one text result here...
      ((text (first (traverse :at 'genre :preselects constraints))) 
       (stages nil))

;;; now process the constraints on field... This is clean up following traversal:
;;; each type of traversal should probably have parameterized initialization and
;;; clean-up... 

    (resolve-order (inter-axis-relation-synt text))

    (setf stages (syntagmatic-configuration-units
		  (inter-axis-relation-synt text)))


    (format t "~2%FOLLOWING DOCUMENT STRUCTURE GENERATED: ~%~
--------------------------------------------------------------
                 ~A 
--------------------------------------------------------------~2%" (synt))
    (setf *the-text* *top*)
    (proceed-or-break)

    (process-generic-participant-constraints)
    (resolve-registerial-constraints stages)

;;; proceed to cycles for register...

    (setf *inter-stratal-relations* nil)
    (realize-generic-stages stages)

;;; pairings of stage and registerial inter-axis-relations 
;;; have now been placed on the *inter-stratal-relations* list,
;;; this gives detailed stage profiles for passing onto the
;;; discourse semantics. Possibly useful for the discourse
;;; workbench, we here display a survey of the stage profiles...

    (when *show-register-profiles*
	  (dolist (s *inter-stratal-relations*) (stage-profile s)))

;;; proceed to the discourse semantics...
    (dolist (s *inter-stratal-relations*)
	    (traverse :at 'semantics :root s))

;;; spit out the text... Need to bring in the global constraints to this list...
    (dolist (seq *resolved-semantic-sequence*)
	    (unless *fragment-discourse-history* (setf *consumed-terms* nil))
	    (dolist (s seq)
		    (cond ((informationally-empty-p s)
			   (warning "Contentless semantic specification created."))
			  (t
			   (when *semantic-output-stream*
				 (pprint s *semantic-output-stream*))
			   (when *grammaticize*
				 (grammaticize-with-local-context s))
			   ))))
    (push text *actualized-text-list*)
    (format t  "~%Generated text is: ~2%")
    (when *export-text-result* 
	  (common-lisp-user::send-text-to-sfk *generated-strings*)
	  (common-lisp-user::send-termination))
    (pp *generated-strings*)
    ))


(defun RESOLVE-REGISTERIAL-CONSTRAINTS (stages)
  (mapcar #'(lambda (stage)
	      (format t "~% resolving constraints for stage: ~A"
		      (syntagmatic-unit-labels (label-deref stage)))
	      (cond ((syntagmatic-unit-children (label-deref stage))
		     (resolve-registerial-constraints 
		      (syntagmatic-unit-children (label-deref stage))))
		    (t
		     (setf (syntagmatic-unit-inter-stratal-constraints-below
			    (label-deref stage))
			   (process-generic-stage-constraints 
			    (syntagmatic-unit-inter-stratal-constraints-below
			     (label-deref stage))))
		     )))
	  stages))


;;(defun REALIZE-GENERIC-STAGES (stages)
;;  "Leaves of the generic structure are realized registerially."
;;  (mapcar #'(lambda (stage)
;;	      (cond ((syntagmatic-unit-children (label-deref stage))
;;		     (REALIZE-GENERIC-STAGES
;;		      (syntagmatic-unit-children (label-deref stage))))
;;		    (t
;;		     (realize-generic-stage stage)
;;		     )))
;;	  stages))

(defun REALIZE-GENERIC-STAGES (stages)
  "Leaves of the generic structure are realized registerially."
  (process-leaves-of-syntagmatic-unit stages #'realize-generic-stage))

(defun REALIZE-GENERIC-STAGE (stage-label)
  (let ((stage (label-deref stage-label)))
    
;;; one major component is now obtaining the instances from the actual
;;; field (which in the present experiment is maintained in SFK external
;;; to our systemic resources). For this, we send any constraints that hold
;;; for the current generic stage off to SFK to retrieve compatible
;;; instances... This is handled by the generic external resource functions.
;;; It is, however, important that matches obtained during instantiation
;;; remain active for further instantiation (particularly for generic
;;; participants). This must also be ensured by the external resource
;;; handling functions...
    
    (setf *stage-constraints* nil
	  *semantic-image* nil
	  *macro-theme-list* nil)
    
    (format t "~2%=====================================================================
                   REALIZING GENERIC STAGE ~A REGISTERIALLY ~2%" 
	    (syntagmatic-unit-labels stage))
    
    (cond ((syntagmatic-unit-inter-stratal-constraints-below stage)
	   (setf *inter-stratal-relations*
		 (append *inter-stratal-relations*
			 (list (make-inter-stratal-relation
				:upper stage
				:lower 
				(flatten
				 (mapcar 
				  #'(lambda (c)
				      (let ((actualization (traverse-register c)))
					(setf (syntagmatic-unit-inter-stratal-constraints-general stage)
					      *stage-constraints*)
					actualization))
				  (syntagmatic-unit-inter-stratal-constraints-below stage)))))))))))



(defun TRAVERSE-REGISTER (constraint)
  "Recursively traverse the register network until a full register instance is created."
  (let ((externally-instantiateds
	 (instantiate-from-external-resources 
	  (gethash constraint *inter-axis-relation-futures*)
	  constraint))
	(result-list nil))
    (dolist (externally-instantiated externally-instantiateds)
	    (let ((subordinate-constraints
		   (if externally-instantiated
		       (syntagmatic-configuration-units
			(inter-axis-relation-synt externally-instantiated))
		     nil))
		  (actualization-list 
		   (traverse 
		    :at 'register
		    :constraints externally-instantiated
		    :preselects (append *registerial-biases*
					(cond ((assoc constraint ;; this is only for external sfk patterns!
						      *pattern-preselection-pairs*)   
					       (cdr (assoc 
						     constraint *pattern-preselection-pairs*)))
					      (t nil))))))
	      (dolist (actualization actualization-list)
		      (let ((subordinate-units
			     (syntagmatic-configuration-units
			      (inter-axis-relation-synt actualization))))
			
			(match-constraints-by-microfunction 
			 subordinate-constraints subordinate-units actualization)
			
			(push actualization result-list)))))
    result-list))


;;;----------------------------------------------------------------------
;;; Following function finds matches of microfunction labels in the
;;; subordinate constraints and the subordinate syntagmatic-units, and
;;; completes realization of the subordinate units adding in the
;;; appropriate constraints... A unit partially constrained by a previous
;;; traversal through the network is called a PARTIAL; a unit constrained
;;; by whatever cause (e.g., externally by instantiation) is called a
;;; UNIT-CONSTRAINT). The realization of a UNIT-CONSTRAINT (i.e., what
;;; is found in its exponent slot), is called its CONSTITUENT-CONSTRAINTS.
;;;
;;; Registerial biases get added into each traversal regardless
;;; (possibly problematic, if different ranks are required).  It is
;;; also assumed that no actual traversal preselects a *complex*,
;;; although it can occur (from external constraints) that a complex
;;; is present. This means that the intra-stratally preselected
;;; constraints from an actual traversal are added into *each* of the
;;; traversals subsequently started upon to match with those external
;;; constraints.  (This is an interesting approach to the mismatch
;;; between preselections into complexes ueberhaupt!!!!!)
;;;
(defun MATCH-CONSTRAINTS-BY-MICROFUNCTION (constraints partials parent)
  "Checks to see if the constraints are already matched partially, if so fills
them in, if not adds them to parent."
  (let ((partials-to-do-list (copy-list partials)))
    (dolist (c-label constraints)
	  (let* ((unit-constraint (label-deref c-label))
		 (exponents (syntagmatic-unit-exponent unit-constraint)))
	    (block find-matching-partials
		   (dolist (p-label partials)
			   (let ((partial (label-deref p-label)))
			     (when (intersection
				    (syntagmatic-unit-labels unit-constraint)
				    (syntagmatic-unit-labels partial))
				   (dremove p-label partials-to-do-list)
				   (setf (syntagmatic-unit-exponent partial) ;; need unification here!
					 (recursively-descend-with-constraints
					  :at 'register
					  :constraints exponents
					  :preselects
					   (append
					    *registerial-biases*
					    (syntagmatic-unit-intra-stratal-constraints 
					     partial))))
				   (return-from find-matching-partials nil))))
		   (add-to-parent 
		    (recursively-descend-with-constraints
		     :at 'register
		     :constraints exponents
		     :preselects *registerial-biases*)
		    parent
		    unit-constraint)
		   )))

;; ...complete the realization of unconstrained partials    
    (dolist (p-label partials-to-do-list)   
	    (let ((partial (label-deref p-label)))
	      (setf (syntagmatic-unit-exponent partial)
		    (when (syntagmatic-unit-intra-stratal-constraints partial)
			  (recursively-descend-with-constraints
			   :at 'register
			   :constraints nil
			   :preselects 
			   (append
			    *registerial-biases*
			    (syntagmatic-unit-intra-stratal-constraints 
			     partial)))))))))



(defun RECURSIVELY-DESCEND-WITH-CONSTRAINTS
  (&key at (root nil)(constraints nil)(preselects nil))
  (let ((normalized-constraints 
	 (if (consp constraints) constraints
	   (list constraints)))
	(actualizations nil))
    (dolist (constraint normalized-constraints)
	    (let ((derefed-constraint (gethash constraint *inter-axis-relation-futures*)))
	      (cond ((canned-text-realization-p derefed-constraint)
		     (push (canned-text-realization-text derefed-constraint)
			   actualizations))
		    (t
		     (let* ((subordinate-constraints 
			     (if constraint
				 (syntagmatic-configuration-units
				  (inter-axis-relation-synt 
				   (gethash constraint *inter-axis-relation-futures*)))
			       nil))
			    (actualization-list
			     (traverse-with-possible-complex 
			      :at at :root root :constraints constraint 
			      :preselects preselects)))
		       (dolist (actualization actualization-list)
			       (let ((subordinate-units
				      (syntagmatic-configuration-units
				       (inter-axis-relation-synt actualization))))
				 
				 (match-constraints-by-microfunction 
				  subordinate-constraints subordinate-units actualization)
				 
				 (push actualization actualizations))))))))
    actualizations))
	    


(defun ADD-TO-PARENT (inter-axis-relation parent constraints)
  "When a constituent is constrained to appear, but is not already part
of the parent structure, add the new constituent to the parent."
  (push (make-labelled-syntagmatic-unit-instance
	 :parent '*TOP*
	 :intra-stratal-constraints 
	    (syntagmatic-unit-intra-stratal-constraints constraints)
	 :inter-stratal-constraints-above
	    (syntagmatic-unit-inter-stratal-constraints-above constraints)
         :inter-stratal-constraints-below
	    (syntagmatic-unit-inter-stratal-constraints-below constraints)
	 :labels 
	    (syntagmatic-unit-labels constraints)
	 :exponent
	    inter-axis-relation
	 :stratum 
	    (syntagmatic-unit-stratum constraints))
	(syntagmatic-configuration-units
	 (inter-axis-relation-synt parent))))



;;;================================================================================
;;; Profile of a generic stage...

(defun stage-profile (stage-realization-pair)
  (let ((stage (inter-stratal-relation-upper stage-realization-pair))
	(list-of-realizations (inter-stratal-relation-lower stage-realization-pair)))
    (format t "~10% REGISTERIAL PROFILE FOR GENERIC STAGE: ~A ~
              ~% ===================================== ~2%"
	    (syntagmatic-unit-labels stage))

    (format t "~%~5T Following general constraints hold on realizations of this stage: ~%")
    (pprint (syntagmatic-unit-inter-stratal-constraints-general stage))

    (format t "~2%~5T Semantic image created for this stage includes:
~{ ~{~10T concept:~25A is a subconcept of concept:~25A ~%~}~}" *semantic-image*)

    (format t "~% ~5T Following registerial instances selected:~%")
    (dolist (r list-of-realizations)
	    (let ((para (inter-axis-relation-para r))
		  (synt (inter-axis-relation-synt r)))
	      (format t "~%----------------------------------------------------------------
Unit with:
~10T syntagmatic structure: ~%~10T ~A"
		      (syntagmatic-configuration-to-list synt))
	      (format t "~%~10T with selection expression: ~%~10T")
	      (pprint (paradigmatic-unit-selection-expression para))
	      (format t "~%~10T with substructure: ")
	      (dolist (subunits (syntagmatic-configuration-units synt))
		      (pprint (label-deref subunits)))))
    (proceed-or-break)))

  

(defun ACTIVATE-GRAMMAR-CONSTRAINTS (c)
  (format t "~% Contextualizing grammar according to:")
  (pprint c))

(defvar *interactive* t)

(defun PROCEED-OR-BREAK ()
  (when *interactive*
	(cond ((y-or-n-p "Ready to proceed?")
	       t)
	      ((y-or-n-p "Want to break?")
	       (break))
	      (t (common-lisp-user::abort)))))


;;;----------------------------------------------------------------------
;;; Following just collects together the semantic specifications
;;; and leaves them somewhere for subsequent generation...

(defun DESIGN-TEXT-SEMANTICS  (&key (constraints nil)
				    (path "/home/teich/SEMANTIC-SPECS"))  
  (with-open-file 
   (semantic-output-stream (pathname path)
			   :direction :output :if-exists :supersede)
   
   (setf *semantic-output-stream* semantic-output-stream)
   (setf *generated-strings* "")
   (design-text :constraints constraints)
   (setf *semantic-output-stream* nil)
   (print "SEMANTICS SPECIFIED.")))


;;;----------------------------------------------------------------------
;;; Following does the first part of design-text; used for selective
;;; generation... (e.g., from the interface)

(defun DESIGN-GSP (&key (constraints nil))

  (setf *registerial-biases* nil
	*pattern-preselection-pairs* nil
	*resolved-semantic-sequence* nil
	*generated-strings* "")


  (let* 
;;; only one text result here...
      ((text (first (traverse :at 'genre :preselects constraints))) 
       (stages nil))

;;; now process the constraints on field... This is clean up following traversal:
;;; each type of traversal should probably have parameterized initialization and
;;; clean-up... 

    (resolve-order (inter-axis-relation-synt text))

    (format t "~2%FOLLOWING DOCUMENT STRUCTURE GENERATED: ~%~
--------------------------------------------------------------
                 ~A 
--------------------------------------------------------------~2%" (synt))
    (setf *the-text* *top*)
    ))


;;; Following function takes an identified stage as argument,
;;; and precedes with the generation only for that stage....
(defun REALIZE-STAGE (stage)

    (process-generic-participant-constraints)
    (resolve-registerial-constraints (list stage))

;;; proceed to cycles for register...

    (setf *inter-stratal-relations* nil)
    (realize-generic-stages (list stage))

;;; pairings of stage and registerial inter-axis-relations 
;;; have now been placed on the *inter-stratal-relations* list,
;;; this gives detailed stage profiles for passing onto the
;;; discourse semantics. Possibly useful for the discourse
;;; workbench, we here display a survey of the stage profiles...

    (when *show-register-profiles*
	  (dolist (s *inter-stratal-relations*) (stage-profile s)))

;;; proceed to the discourse semantics...
    (dolist (s *inter-stratal-relations*)
	    (traverse :at 'semantics :root s))

;;; spit out the text... Need to bring in the global constraints to this list...
    (dolist (seq *resolved-semantic-sequence*)
	    (unless *fragment-discourse-history* (setf *consumed-terms* nil))
	    (dolist (s seq)
		    (cond ((informationally-empty-p s)
			   (warning "Contentless semantic specification created."))
			  (t
			   (when *semantic-output-stream*
				 (pprint s *semantic-output-stream*))
			   (when *grammaticize*
				 (grammaticize-with-local-context s))
			   ))))

    (format t  "~%Generated stage is: ~2%")
    (when *export-text-result* 
	  (common-lisp-user::send-text-to-sfk *generated-strings*)
	  (common-lisp-user::send-termination))
    (pp *generated-strings*)
    )

