;;; -*- Package: PENMAN; Mode: LISP -*-
(in-package "PENMAN")

;;;======================================================================
;;; Here we define the realization statements for generic structure
;;; building... These are the actual statements that appear in 
;;; systems at the genre stratum. They contain pointers on to 
;;; further functions where the actually work should be done.
;;; Stubs for these functions are provided below: these should be
;;; overwritten as necessary.
;;;
;;;                                 First version: John, October 93, IPSI
;;;======================================================================

(define-realization-operators 
  stage 
  stage-order 
  instantiate
  inter-preselect-feature
  inter-bias
  stage-unify 
  initial 
  final
  refine 
  generic-participant)


(defun stage (stage-to-insert)
 "Adds a generic stage, GSP equivalent to insert"
 (add-to-current-gsp stage-to-insert))

(defun stage-order (stage1 stage2)
  "GSP equivalent to order"
  (gsp-order-constraint stage1 stage2))

(defun instantiate (stage constraints)
  "Set the constraints for field selection for a given stage (inter-preselect-synt)"
  (gsp-instantiate-stage-from-field stage constraints))

(defun inter-preselect-feature (unit feature)
  "Preselect unit across strata for specified feature"
  (gsp-inter-preselect-feature unit feature))

(defun inter-bias (feature)
  "Generalized preselect of feature to hold across the entire genre"
  (gsp-inter-bias feature))

(defun stage-unify (stage1 stage2)
  "Collapses two stages to a single pool of constraints"
  (gsp-unify stage1 stage2))

(defun initial (stage)
  "Orders stage initially"
  (gsp-initial stage))

(defun final (stage)
  "Orders stage finally"
  (gsp-final stage))

(defun refine (stage1 stage2)
  "Refines a stage to a more specific variety"
  (gsp-refine stage1 stage2))


;;;------------------------------------------------------------
;;; Stubbs.... Functions for generic structures; these point 
;;; at present on to the new generalized structure building
;;; operations.

(defun add-to-current-gsp (stage-to-insert)
  (generalized-insert stage-to-insert)
  )

(defun gsp-order-constraint (stage1 stage2)
  (generalized-order stage1 stage2)
  )

(defun gsp-final (stage)
  (generalized-final stage)
  )

(defun gsp-initial (stage)
  (generalized-initial stage)
  )

(defun gsp-unify (stage1 stage2)
  (generalized-conflate stage1 stage2)
  )

(defun gsp-refine (stage1 stage2)
  (generalized-expand stage1 stage2)
  )

;;;================================================================================
;;; Following are not yet simple extensions of the generalized syntagm
;;; building mechanisms...


;;;----------------------------------------------------------------------
;;;  General skewing of registerial possibilities...

(defvar *registerial-biases* nil)

(defun GSP-INTER-BIAS (feature)
  (pushnew feature *registerial-biases*))


;;;================================================================================
;;; Realizations to do with field instantiations...

(defvar *gsp-participant-list* nil)

(defun GSP-INSTANTIATE-STAGE-FROM-FIELD (stage constraints)
  (when *show-genre-realizations* 
	(format t "~% Instantiate stage or participant ~A according to constraint: ~% ~A"
		stage constraints))
  (cond ((assoc stage *gsp-participant-list*)
	 (rplacd (assoc stage *gsp-participant-list*) constraints))
	(t
	 (let ((stage-exist? (force-function-to-exist stage)))
	   (push (cons 'pre-inter-axis-relation constraints)
		 (syntagmatic-unit-inter-stratal-constraints-below (micro-fn stage)))))))


(defun GSP-INTER-PRESELECT-FEATURE(stage feature)
  (when *show-genre-realizations* 
	(format t "~% Inter-stratally preselect stage ~A for feature: ~A"
		stage feature))
  (let ((stage-exist? (force-function-to-exist stage)))
	   (pushnew (cons 'inter-preselect feature)
		    (syntagmatic-unit-inter-stratal-constraints-below (micro-fn stage))
		    :test #'equal)))

(defun GENERIC-PARTICIPANT (participant)
  "Creates a generic participant for the generic structure"
  (unless (assoc participant *gsp-participant-list*)
	  (pushnew (cons participant nil) *gsp-participant-list* :test #'equal)))

;;;================================================================================
;;; 
;;; Processing of inter-stratal constraints from genre on register (particularly
;;; field)... Needs to be performed only when the genre network has been traversed,
;;; so that complete information has been guaranteedly collected. This function
;;; is therefore called prior to traversing at register stratum for each generic
;;; stage that is to realized.

(defun PROCESS-GENERIC-PARTICIPANT-CONSTRAINTS ()
  "Uses the necessarily unique participant label as the variable of the constraint"
  (setf *gsp-participant-list*
	(mapcar #'(lambda (participant-constraints)
		    (let ((participant (car participant-constraints))
			  (constraints (cdr participant-constraints)))
		      (cons
		       participant
		       (process-generic-constraint
			(cons participant (cdr constraints))))))
		*gsp-participant-list*)))


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

(defvar *inter-axis-relation-futures* (make-hash-table))


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

(defun SHOW-CYCLES (list)
  (mapcar #'(lambda (x) (format t "~2% Cycle: ~A" x)
	      (pprint (gethash x  *inter-axis-relation-futures*)))
	  list))

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

(defun PROCESS-GENERIC-STAGE-CONSTRAINTS (constraint-list)
  "Process the complete set (including pre-inter-axis-relations and types)
of constraints for a single generic stage"
  (let ((constraint-collection nil)
	(selection-expression-constraints nil))
    (dolist (c constraint-list)
	    (cond ((eq (car c) 'pre-inter-axis-relation)
		   (push (process-generic-constraint (cdr c)) constraint-collection))
		  ((eq (car c) 'inter-preselect)
		   (push (cdr c) selection-expression-constraints))
		  ((eq (car c) 'external-constraint-pattern)
		   (push (cdr c) constraint-collection))
		  (t
		   (warning "The constraint list of a generic stage contained " 
			    c
			    " -- which is neither a pre-inter-axis-relation nor a set
of features to be inter-stratally preselected"))))
    (unify-in-types constraint-collection selection-expression-constraints)))

(defvar *consumed-constraints* nil)
(defvar *unresolved-constraints* nil)

(defun PROCESS-GENERIC-CONSTRAINT (c)
  (setf *unresolved-constraints* nil
	*consumed-constraints*   nil)
  (let ((processed-constraint (process-generic-constraint-first-pass c)))
    (when *unresolved-constraints*
	  (process-generic-constraint-second-pass processed-constraint))
    processed-constraint))




(defun PROCESS-GENERIC-CONSTRAINT-FIRST-PASS (c)
  "Process individual constraints for a single generic stage; returns the cycle label
if processable, else just returns the constraint unprocessed."
  (cond ((listp c)
	 (let ((var (first c))
	       (types 
		(remove-duplicates-and-nil
		 (if (listp (third c)) (third c) (list (third c)))))
	       (restrictions (cdddr c))
	       (inter-axis-label (make-cycle-instances-record "FUTURE-CYCLES-"))
	       (current-cycle *current-cycle*))
	   (pushnew (cons var inter-axis-label) *consumed-constraints*)
	   (setf *current-cycle* inter-axis-label)
	   (setf (gethash inter-axis-label *inter-axis-relation-futures*)
		 (make-inter-axis-relation
		  :para
		  (make-paradigmatic-unit
		   :selection-expression types :stratum 'register)
		  :synt
		  (make-syntagmatic-configuration
		   :units (process-generic-stage-restrictions restrictions)
		   :stratum 'register)
		  :stratum 'register))
	   (setf *current-cycle* current-cycle)
	   inter-axis-label))
	(t
	 c)))


(defun PROCESS-GENERIC-CONSTRAINT-SECOND-PASS (c)
  "Goes over the future cycle c replacing unresolved references to other future cycles"
  (dolist (unit 
	   (mapcar #'label-deref 
		   (syntagmatic-configuration-units
		    (inter-axis-relation-synt
		     (gethash c *inter-axis-relation-futures*)))))
	  (let* ((exp-or-exps (syntagmatic-unit-exponent unit))
		 (exps (if (listp exp-or-exps) exp-or-exps
			 (list exp-or-exps))))
	    (setf (syntagmatic-unit-exponent unit)
		  (list-or-atom
		   (mapcar 
		    #'(lambda (exp)
			(cond ((member exp *unresolved-constraints*)
			       (cond
				((assoc exp *consumed-constraints*)
				 (cdr (assoc exp *consumed-constraints*)))
				((stringp exp)
				 (create-canned-cycle exp))
				(t
				 (format t "~% Ill-formed inter-stratal constraint: ~A"
					 exp)
				 nil)))
			      (t
			       (process-generic-constraint-second-pass exp))))
		    exps)))))
  c)


(defun create-canned-cycle (canned-text)
  (let ((label (gentemp "CANNED" 'penman)))
    (setf (gethash label *inter-axis-relation-futures*)
	  (make-canned-text-realization :text canned-text))
    label))



(defun REMOVE-DUPLICATES-AND-NIL (list)
  (remove nil (remove-duplicates list)))


;;;----------------------------------------------------------------------
;;; Processes the syntagmatic restrictions on a given cycle of constraint,
;;; returning a list of instance labels bound at the cycle at which the
;;; function was called. Each role mentioned in the restriction corresponds
;;; to a cycle through the appropriate network; embedded roles therefore
;;; have to be defined relative to separate cycles. Moreover, whenever
;;; reference is made to a generic participant, its constraints are also
;;; added into the collection indirectly, by referring to its register 
;;; cycle (maintained in the list *gsp-participant-list*).
;;;
(defun PROCESS-GENERIC-STAGE-RESTRICTIONS (restrictions)
  "Process the syntagmatic restrictions on a given cycle of constraints"
  (let ((role-list nil))
    (dolist (r (reparse-generic-stage-features restrictions))
	    (let* ((role (first r))
		   (arg (second r))
		   (role-instance-label (micro-fn-label role *current-cycle*)))
	      (push role-instance-label role-list)
	      (setf (micro-fn role)
		    (make-syntagmatic-unit 
		     :labels (list role)
		     :exponent 
		       (cond ((sif-p arg)
			      (process-role-filler arg))
			     ((listp arg)
			      (mapcar #'process-role-filler arg))
			     ((assoc arg *gsp-participant-list*)
			      (process-role-filler arg))
			     ((assoc arg *consumed-constraints*)
			      (cdr (assoc arg *consumed-constraints*)))
			     (t
			      (pushnew arg *unresolved-constraints*)
			      arg))
		     :stratum 'register))))
    role-list))

(defun PROCESS-ROLE-FILLER (role-filler)
  (cond ((assoc role-filler *gsp-participant-list*)
	 (cdr (assoc role-filler *gsp-participant-list*)))
	(t 
	 (process-generic-constraint-first-pass role-filler))))

(defun SIF-P (arg)
  "test whether arg is in short-interaxis-form (e.g., spl)"
  (and
   (listp arg)
   (eq (second arg) '/)))

;;;----------------------------------------------------------------------
;;; Takes a list of inter-axis-relations and a list of features, and adds
;;; those features into the paradigmatic description of the inter-axis-relation.
;;; Used for handling inter-stratal preselection... If a nonprocessable
;;; constraint is found in the constraint collection, it is returned as is.
;;;
;;; N.B. note that if it is an external pattern, then there is not yet a
;;; future cycle to store the preselection information!!! So as a short
;;; term solution, this is added into a completely separate alist. SHould
;;; be fixed up at some stage.
;;;
(defun UNIFY-IN-TYPES (constraint-collection selection-expression-constraints)
  (mapcar #'(lambda (constraint-label)
	      (let ((constraint 
		     (gethash constraint-label *inter-axis-relation-futures*)))
		(cond (constraint
		       (dolist (f selection-expression-constraints)
			      (pushnew f (paradigmatic-unit-selection-expression
					  (inter-axis-relation-para constraint)))))

		      ((member constraint-label *external-patterns*)
		       (setf *pattern-preselection-pairs*
			    (acons constraint-label selection-expression-constraints
				   *pattern-preselection-pairs*))))
		constraint-label))
	  constraint-collection))

(defvar *pattern-preselection-pairs* nil)


;;;----------------------------------------------------------------------
;;; following function adapted from the SPL processing in spl-macros.lisp 
;;; (function reparse-features).   
;;; -- no longer worries about keywords...

(defun REPARSE-GENERIC-STAGE-FEATURES (list)
  (let (feature-list)
    (mapl #'(lambda (tail)
	      (when (register-role-p (first tail))
		    (setq feature-list
			  (nconc (list (list
				  (first tail)
				  (second tail)
				  ))
				 feature-list))))
	  list)
    feature-list))


;;; Following function need to recognize acceptable roles, i.e.,
;;; microfunctions, from the stratum at issue: here, register.
(defun REGISTER-ROLE-P (role)
  (member role *register-micro-functions*))

(defvar *register-micro-functions* nil)


;;;================================================================================
;;; following is experimental trial of retrieving, for example from
;;; SFK in the KOMET-PAVE experiment, by use of pre-defined
;;; patterns... This work at present just by pushing the name of the 
;;; pattern onto the inter-stratal constraints (identified as an
;;; external-constraint-pattern). This is then passed to the external
;;; resource handler, which has to recognize it as a pattern and
;;; take appropriate action.

(define-realization-operators instantiate-by-pattern)


(defun INSTANTIATE-BY-PATTERN (stage constraints)
  (when *show-genre-realizations* 
	(format t "~% Instantiate generic stage or participant ~A according to ~
external retrieval pattern: ~A"
	  stage constraints))
  (cond ((assoc stage *gsp-participant-list*)
	 (rplacd (assoc stage *gsp-participant-list*) constraints))
	(t
	 (let ((stage-exist? (force-function-to-exist stage)))
	   (push (cons 'external-constraint-pattern constraints)
		 (syntagmatic-unit-inter-stratal-constraints-below 
		  (micro-fn stage)))))))




