(in-package "KPML")

(defvar *theme-type* nil)
(defvar *um-temporal-relations*  '(:follow :temporal-locating))
(defvar *complex-sentences* nil) ;; default: avoid complex clauses...
(defvar *no-thematization* nil)

;;; The main function here takes an inter-stratal relation between
;;; genre and register and further resolves this towards the
;;; lexicogrammar. Pool breaks down into an upper component,
;;; containing the generic stage syntagmatic structure, and a lower
;;; component, containing a list of register stratum
;;; inter-axis-relations. This list has to be consumed and converted
;;; into semantic instances appropriate for submitting to the
;;; lexicogrammar via the inquiries of the lexicogrammar. It is to be
;;; expected that this function should be gradually and step-wise
;;; replaced by genuine discourse semantics networks as they become
;;; available.

(defun resolve-discourse-semantics (pool)
  (let* ((thematic-development? (assoc 'thematic-development
				       (syntagmatic-unit-inter-stratal-constraints-general 
					(inter-stratal-relation-upper pool))))
	 (thematic-development
	  (if thematic-development? (cdr thematic-development?)
	    'simple)))

    (contextualize-lexicogrammar pool)
    (setf *consumed-terms* nil)

    (format t "~2%....Aggregating according to thematic development type: ~A"
	    thematic-development)
    
    (case thematic-development
	  (temporal-circumstances
	   (setf *theme-type* 'temporal)
	   (aggregate-by-time 
	    (inter-stratal-relation-lower pool)))
	  (temporally-sequenced
	   (setf *theme-type* 'temporally-sequenced)
	   (aggregate-by-time
	    (inter-stratal-relation-lower pool)))
	  (simple
	   (setf *theme-type* 'simple)
	   (aggregate-as-they-come 
	    (inter-stratal-relation-lower  pool)))
	  (otherwise
	   (setf *theme-type* 'very-simple)
	   (aggregate-as-they-come 
	    (inter-stratal-relation-lower pool))))
    ))

(defun aggregate-by-time (pool)
  (let ((resolved-ordered-semantics
	 (temporal-order-of-complex (aggregate-as-they-come pool))))
    resolved-ordered-semantics))


(defun aggregate-as-they-come (pool)
  (mapcar #'semanticize pool))

(defun SEMANTICIZE (instances)
  "very basic inter-axis-relation to SIF/SPL conversion"
  (let ((normalized-instances 
	 (if (listp instances) instances
	   (list instances)))
	(result nil))
    (dolist (instance normalized-instances)
	    (let ((selexpr (paradigmatic-unit-selection-expression
			    (inter-axis-relation-para instance)))
		  (roles   (syntagmatic-configuration-units
			    (inter-axis-relation-synt instance)))
		  (semantic-form nil)
		  (semantic-type nil))
	      (dolist (role roles)
		      (let ((constraints (syntagmatic-unit-inter-stratal-constraints-below 
					  (label-deref role))))

			(when (assoc 'role-preselect constraints)
			      (multiple-value-bind 
			       (role-consequences filler-consequences)
			       (semanticize-functions constraints role)
			       (unless (informationally-empty-p filler-consequences)
				       (push role-consequences semantic-form)
				       (push filler-consequences semantic-form))))

			(when (assoc 'inter-preselect constraints)
			      (multiple-value-bind
			       (type-consequences role-consequences)
			       (semanticize-features constraints role)
			       (setf semantic-type (append type-consequences semantic-type))
			       (dolist (e role-consequences)
				       (push e semantic-form))))
			      
			(when (assoc 'function-feature constraints)
			      (let ((preselected-ffs (assocs 'function-feature constraints)))
				(dolist (preselected-ff preselected-ffs)
					(push (first preselected-ff) semantic-form)
					(push (second preselected-ff) semantic-form))))))
	      
	      (push 
	       `(,(gentemp "V-" 'kpml) / ,semantic-type
		 ,@(reverse semantic-form))
	       result)))
    (possible-complex-aggregation result)))




(defun SEMANTICIZE-FUNCTIONS (constraints role)			       
  (let* ((spl-role (cdr (assoc 'role-preselect constraints)))
	 (exps (syntagmatic-unit-exponent (label-deref role)))
	 (role-filler 
	  (cond ((stringp (first exps))
		 (intern (first exps) "KPML"))
		(exps
		 (SEMANTICIZE 
		  (syntagmatic-unit-exponent (label-deref role))))
		(t
		 '*register-unconstrained-thing*))))

    (cond ((eq spl-role :embedding) ;; for structure changes
	   (values (get-embedded-type role-filler) 
		   (get-embedded-filler role-filler)))
	  (t
	   (values spl-role role-filler)))))


(defun GET-EMBEDDED-FILLER (sif-instance)
  "an embedded filler needs to be passed upwards; may be a complex!"
  (cond ((sif-p sif-instance)
	 (cond ((position :embedded sif-instance)
		(elt sif-instance (1+ (position :embedded sif-instance))))
	       (t
		(warning "Embedding/embedded mismatch!" sif-instance)
		'(bad-spec / um-thing))))
	((listp sif-instance)
	 (mapcar #'get-embedded-filler sif-instance))
	(t
	 (warning "Very misformed register specification embedded!" sif-instance)
	 '(bad-spec / um-thing))))
	 

(defun GET-EMBEDDED-TYPE (sif-instance)
  "an embedded type needs to be passed upwards; may be a complex!"
  (cond ((sif-p sif-instance)
	 (first (third sif-instance)))
	((listp sif-instance)
	 (first (third (first sif-instance))))  ;; should unify types, but...
	(t
	 (warning "Very misformed register specification embedded!" sif-instance)
	 ':lex)))


(defun SEMANTICIZE-FEATURES (constraints role)
  (let ((types 	(assocs 'inter-preselect constraints))
	(roles nil))
    (cond ((intersection types *action-types*)
	   (dolist (s (intersection types *action-types*))
		   (setf roles
			 (append
			  (apply (cdr
				  (assoc s *action-type-actions*))
				 (list role types))
			  roles)))
	   (values types roles))
	  (t
	   (values types nil)))))


(defun INFORMATIONALLY-EMPTY-P (instance)
  (and
   (sif-p instance)
   (or (equal (third instance) '(um-thing))
       (null (third instance)))))






(defun ASSOCS (key alist)
  (remove-duplicates-and-nil
   (mapcar #'(lambda (pair)
	       (when (eq (car pair) key)
		     (cdr pair)))
	   alist)))




(defun POSSIBLE-COMPLEX-AGGREGATION (stuff)
  (let ((result stuff))
    (when (> (length stuff) 1) 
	  (when *show-complexing-decisions*
		(format t "~% NOTE: following information can be combined using resources for ~%   ~
                          complexing and rhetorical organization... ")
		(pprint stuff))
	  (setf result (remove-if #'informationally-empty-p result))
	  (setf result
		(sort stuff #'(lambda (x y) (< (length x) (length y))))) ;; heavy NPs shift!
	  (when *show-complexing-decisions*
		(format t "~% Result of combination:")
		(pprint result)))
    (list-or-atom result)))


;;;--------------------------------------------------------------------------------
;;; Special actions during spl construction...


(defvar  *action-types* '(named-object))
(defvar *action-type-actions* '((named-object . NAMING-ACTION)))

(defun NAMING-ACTION (role types)
  (dolist (type types)
	  (let ((lexeme (gethash type lexicon)))
	    (when (and lexeme
		       (member 'proper-noun (lexical-item-features lexeme)))
		  (pushnew type *discourse-individuals*)
		  (return-from NAMING-ACTION `(:name ,type))))))



;;;WORKING---------------------------------------------------------------------------

(defun proto-aggregate (pool)
  (let ((field-instance-table (make-sequence 'inter-axis-relation (length pool)))
	(n 0))
    (dolist (i pool) 
	    (setf (elt field-instance-table n) i) 
	     ;; this was (+1 n), MAF, 4/1/95
	    (setf n (1+ n)))))
    
		      
    


(defun FACTOR-OUT-COMMON-TYPES (instances)
  (let ((result-list nil))
  
    (dolist (e instances)
	    (let ((types-of-e (first e))
		  (body (second e)))
	      (cond ((null types-of-e) nil)
		    ((assoc (first types-of-e) result-list)
		     (push (cons (cdr types-of-e)
				 (list body))
			   (cdr (assoc (first types-of-e) result-list))))
		    (t
		     (push (cons (first types-of-e)
				 (list
				  `(,(cdr types-of-e)
				    ,body)))
			   result-list)))))
     result-list))


(defun GROUP-BY-FACTORED-TYPES (instances)
  (let ((alist (factor-out-common-types instances)))
    (dolist (e alist)
	    (let ((still-to-factor (cdr e))
		  (factored nil))
	      (dolist (f still-to-factor)
		      (when (null (first f))
			    (push (second f) factored)))
	      (cond (factored
		     (rplacd e (list (GROUP-BY-FACTORED-TYPES (cdr e))
				     factored)))
		    (t
		     (rplacd e (GROUP-BY-FACTORED-TYPES (cdr e)))))))
    alist))

(defun REMOVE-COMMON-TYPES (factored-instances)
  (cond ((eq (length factored-instances) 1)
	 (remove-common-types (cdr (first factored-instances))))
	(t
	 factored-instances)))

(defun FILL-IN-FULL-TYPES (instances)
  (mapcar #'(lambda (instance)
	      (cond ((sif-p instance)
		     (let* ((most-specific (loom::find-concept
					   (intern
					    (string
					     (first (sort (third instance) #'kb-superp)))
					    (kb-package))))
			    (types
			     (reverse
			      (cons most-specific
				    (loom::all-super-concepts most-specific)))))
		       (cons types (list instance))))
		    (t
		     (cons 'complex (list instance)))))
	  instances))


(defun REGROUP-INSTANCES (complex)
  (let ((running-result nil))
    (setf running-result (fill-in-full-types complex))
    (format t "~% filling in complete types:")(pprint running-result)
    (setf running-result 
	  (sort 
	    running-result
	    #'(lambda (x y) (loom::subconcept-p x y)) :key #'caar))
    (format t "~% sorting by type:" )(pprint running-result)
    (setf running-result (group-by-factored-types running-result))
    (format t "~% factoring by types: ")(pprint running-result)
    (setf regrouped (remove-common-types running-result))
    (format t "~% common types removed:")(pprint regrouped)
    (remove-full-types regrouped)))


(defun REMOVE-FULL-TYPES (l)
  (mapcar #'(lambda (e)
	      (cond ((second e) 
		     `(,(gentemp "V-" 'kpml) / rhetorical-subtype
		       :domain ,(first (third e))
		       :range ,(REMOVE-FULL-TYPES (second e))))
		    (t
		     (first (third e)))))
	  l))


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

(defvar *lexicogrammar-contextualization* nil)
(defvar *macro-theme-list* nil)

(defun UNCONTEXTUALIZE-LEXICOGRAMMAR ()
  (setf *lexicogrammar-contextualization* nil)
  (setf *macro-theme-list* nil))

(defun CONTEXTUALIZE-LEXICOGRAMMAR (pool)
  "add general constraints from field-activity (should be speech function but...)"
  (let* ((general-constraints (syntagmatic-unit-inter-stratal-constraints-general 
			       (inter-stratal-relation-upper pool)))
	 (lexicogrammatical-constraints 
	  (assocs 'lexicogrammar general-constraints))
	 (macro-themes 
	  (assocs 'macro-theme general-constraints)))
    (dolist (constraint lexicogrammatical-constraints)
	    (push constraint *lexicogrammar-contextualization*))
    (dolist (constraint macro-themes)
	    (let ((unit (label-deref constraint)))
	      (when (and unit
			 (eq (length (syntagmatic-unit-exponent unit)) 1))
		    (let* ((types (paradigmatic-unit-selection-expression
				  (inter-axis-relation-para
				   (first (syntagmatic-unit-exponent unit)))))
			   (intersect?
			    (intersection *discourse-individuals* types)))
		      (when intersect?
			    (setf *macro-theme-list*
				  (append intersect?  *macro-theme-list*)))))))))


;;;================================================================================
;;; Following is current hook for semantics...
;;;
;;; The function is called from the first inquiry in the discourse semantics
;;; network. Currently, there is  only one discourse semantic system! The
;;; rest is in code....

(defvar *resolved-semantic-sequence* nil)
(defvar *resolved-semantic-stage* nil)

(defun resolve-discourse-semantics-code (pool)
  (let ((resolved-semantics nil))
    (when *show-intermediate-results*
	  (format t "~3%==========================================================
     COMMENCING DISCOURSE SEMANTIC RESOLUTION ON RELATION: ~2%")
	  (pprint pool))
    (setf resolved-semantics (resolve-discourse-semantics pool))
    (setf resolved-semantics (remove-if #'informationally-empty-p resolved-semantics))
    (consider-clause-complexing resolved-semantics *theme-type*)
    (setf *resolved-semantic-sequence* (append *resolved-semantic-sequence*
					       (cons *resolved-semantic-stage* nil)))
    (setf *resolved-semantic-stage* nil)
    (uncontextualize-lexicogrammar)
    'resolved))

   


;;;--------------------------------------------------------------------------------
;;; Control of clause complexing...


(defun CONSIDER-CLAUSE-COMPLEXING (resolved-semantics theme-type)
  (cond ((equal (length resolved-semantics) 1)
	 (let ((thematic-contextualization nil))
	   (case theme-type
		 (temporal
		  (setf thematic-contextualization
			(calculate-theme-constraint-for-time resolved-semantics))))
	   (when thematic-contextualization
			 (setf resolved-semantics 
			       (thematize-spl resolved-semantics thematic-contextualization)))
	   (setf *resolved-semantic-stage*
		 (append  *resolved-semantic-stage*
			  (list `(
				  ((constraints ,*lexicogrammar-contextualization*)
				   (macro-themes ,(remove-duplicates-and-nil
						   *macro-theme-list*))
				   (disc-individuals ,*discourse-individuals*)) 
				  ,resolved-semantics))))))
	
	((and (not *complex-sentences*)
	      (> (length resolved-semantics) 1))
	 (format t "~% Complex of clauses for realization; dividing")
	 (let ((thematic-contextualization nil))
	   
	   (dolist (r resolved-semantics)
		   (case theme-type
			 (temporal
			  (setf thematic-contextualization
				(calculate-theme-constraint-for-time r))))
		   (when thematic-contextualization
			 (setf r (thematize-spl r thematic-contextualization)))
		   (setf *resolved-semantic-stage*
			 (append *resolved-semantic-stage*
				 (list `(
					 ((constraints ,*lexicogrammar-contextualization*)
					  (macro-themes ,(remove-duplicates-and-nil
							  *macro-theme-list*))
					  (disc-individuals ,*discourse-individuals*)) 
					 ,(list r))))))))
	(t
	 (format t "~% Complex of clauses for realization; aggregating")
	 (let ((thematic-contextualization nil))
	   
	   (dolist (r (basic-chunker resolved-semantics *clause-complexity*))
		   (when (eq (length r) 1)
			 (setf r (first r)))
		   (case theme-type
			 (temporal
			  (setf thematic-contextualization
				(calculate-theme-constraint-for-time r))))
		   (when thematic-contextualization
			 (setf r (thematize-spl r thematic-contextualization)))
		   (setf *resolved-semantic-stage*
			 (append *resolved-semantic-stage*
				 (list `(
					 ((constraints ,*lexicogrammar-contextualization*)
					  (macro-themes ,(remove-duplicates-and-nil
							  *macro-theme-list*))
					  (disc-individuals ,*discourse-individuals*)) 
					 ,(list r))))))))
	 ))

(defvar *clause-complexity* 2)


(defun TEMPORAL-ORDER-OF-COMPLEX (resolved-semantics)
  (when *show-complexing-decisions*
	(format t "~%Attempting to order temporally; following times are recognized:")
	(format t "~{~%~A~}" (mapcar #'get-spl-time resolved-semantics)))
  (sort resolved-semantics 
	#'(lambda (s1 s2)
	    (string< 
	     (get-spl-time s1)        ;; better to work on the term-graphs...
	     (get-spl-time s2)))))

(defun get-spl-time (s)
  (let* ((filler nil)
	 (time 
	  (coerce-to-date
	   (cond ((setf filler (get-spl-slot-filler :follow s))
		  (get-spl-slot-filler :name filler))
		 ((setf filler (get-spl-slot-filler :temporal-locating s))
		  (get-spl-slot-filler :name filler))))))
    (if time time
      0)))

(defun get-spl-time-var (s)
  (or (first (get-spl-slot-filler :follow s))
      (first (get-spl-slot-filler :temporal-locating s))))


	
(defun get-spl-slot-filler (slot spl)
  (cond ((sif-p spl)
	 (if (position slot spl)
	     (elt spl (1+ (position slot spl)))
	   nil))
	((listp spl)
	 (mapcar #'get-embedded-filler spl))
	(t
	 (warning "Very misformed SPL specification" spl)
	 nil)))

(defun coerce-to-date (date-symbol)
  (let ((string (string date-symbol)))
    (cond ((position #\- string)
	   (subseq string 0 (1- (position #\- string))))
	  (t
	   string))))


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

(defun CALCULATE-THEME-CONSTRAINT-FOR-TIME (semantics)
  (if (sif-p semantics)
      `(:theme ,(get-spl-time-var semantics))
    (mapcar #'CALCULATE-THEME-CONSTRAINT-FOR-TIME semantics)))


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

(defun THEMATIZE-SPL (spl theme)
  (let ((single-spl (list-or-atom spl))
	(single-theme (list-or-atom theme)))
    (cond (*no-thematization*
	   single-spl)
	  ((sif-p single-spl)
	   (if (second single-theme)
	       (append
		`(
		  ,(first single-spl)
		  ,(second single-spl)
		  ,(third single-spl)
		  ,@single-theme)
		(cdddr single-spl))
	     single-spl))
	  (t
	   (warning "Thematization attempt for non-SPL:" spl)
	   spl))))




(defun BASIC-CHUNKER (list size)
  (let ((result nil)
	(interims nil)
	(count 0))
    (dolist (x list)
	    (push x interims)
	    (setf count (1+ count))
	    (when (eq count size)
		  (push (reverse interims) result)
		  (setf interims nil)
		  (setf count 0)))
    (when interims (push interims result))
    (reverse result)))

