(in-package "KPML")

;;; File: modification-specification.lisp
;;; John Bateman: IPSI: 24.1.96
;;; 
;;; The inquiry modification-specification-id is called at least
;;; at the beginning of each cycle through the network. Its main
;;; function is to check whether any logical or textual reorganizations
;;; of the experiential content are to be undertaken prior to
;;; generation. It can, therefore, add in additional material
;;; to make a referentially and textually adequate nominal group,
;;; or calculate that a referent is sufficiently prominent to
;;; be referred to only with a pronoun. The inquiry is the hook in
;;; the inquiry semantics for effecting changes dynamically according to
;;; textual positioning and is thus a proper part or way in to 
;;; the discourse semantics.
;;;
;;; The code of this inquiry was traditionally kept alongside
;;; the other inquiry implementations and it grew somewhat
;;; wildly over its first ten years or so of use. In this file
;;; we start organizing its use and definition more carefully,
;;; since the ability to reorganize specifictions of what is to
;;; be generated dynamically is a very important functionality
;;; that should be used extensively during the final phases
;;; of planning and sentence generation. The first step is as
;;; with the pseudo-inquiry term-resolve-id, we replace the
;;; inquiry definition that occurs in inquiry files with a
;;; call to a special function that does all the work. All
;;; inquiry implementation files for languages using this facility
;;; should contain a definition of the following form:

(defun MODIFICATION-SPECIFICATION-ID-CODE (position hub)
  (specification-modification position hub))

;;; This is the inquiry definition that should appear in
;;; particular inquiry-implementation files. Now an additional variable

(defvar *mod-spec-ops* nil)

;;; can be used to contain a list of additional operations that are
;;; to be performed on the presentation specification. All of the 
;;; operations on the list should take a symbol that evaluates to 
;;; a term-graph as parameter (or a number!), and produce a similar symbol
;;; evaluating to a  term-graph as result. They are used one before the
;;; other successively operating from the back of the list to the
;;; front.

;;; There appears to be still some mismatches in intended function
;;; of the modification specification in the Nigel choosers. Occasionally
;;; it appears to be used just to fill in a value of the modification spec.
;;; This is problematic if we are relying on the calls to specification
;;; modification to be the places where textual information is decided.
;;; Hack for present: make sure we can access the where-am-i value
;;; in order to help us through. Better solution: replace the calls
;;; to modication-specification-id with another inquiry.

(defvar *current-where-am-i* nil)
(defvar *newly-consumed* nil)

;;; ----------------------------------------------------------------------
;;; First rewrites simply clean-up the original definition as it
;;; cannot yet be changed until we have made sure that all its effects
;;; are being covered... Original comment was
;  "Return the hub, unless plan modification is required:
;   filling in global information for atomic terms
;   and reorganizing plans structured by rhetorical realtions."

(defun SPECIFICATION-MODIFICATION (position hub)
  (let ((result hub) range)
    ;; Reorganize plan, for certain rhetorical relations
    (setf *current-where-am-i* position)
    (when (and (term-type-p hub 'rhetorical-relation)
	       (setq range (fetch-subc-feature 'range hub))
	       (not (fetch-subc-feature 'domain hub)))
      (reorganize-spec-for-rst hub range result))
    
    ;; Fill in global information, if this is first mention.
    (if (or (term-type-p result nil nil)
	    (and (symbolp result)(boundp result)
		 (typep (symbol-value result) 'term-graph)
		 (not (expressed-p result))
		 (equal (term-graph-type (symbol-value result)) '(thing))))
	(fill-global-info-in-spec result))

    (if (and (symbolp result) (boundp result) 
	     (typep (symbol-value result) 'term-graph) 
	     (not (expressed-p result))
	     (KB-entity? (term-graph-symbol (symbol-value result)))
	     (null (term-graph-features (symbol-value result))))
	(NP-Specify result))  ;;; <=====very rarely goes in here!!! 
                              ;;;       in spl/np.lisp NP planning
    (setf result (logical-sequencing result))
    (if *stratification?* 
	(setf result (discourse-semantics-reference-check result)))
    (push result *consumed-terms*)
    (loop for f in (reverse *mod-spec-ops*)
	do (setf result (apply f (list result))))
    result))


;;; ----------------------------------------------------------------------
;;; Following breaks out of modification-specification the rearrangements
;;; that are made when an RST relation is to be expressed. Essentially
;;; the change is that a conjunction of relations is rearrangements to
;;; to represent a hypotactic relationship. 

(defun REORGANIZE-SPEC-FOR-RST (hub range result)
  (when (term-type-p range nil nil)
    (setq range (first (get-top-level-terms range))))
  (push (cons 'rhetorical-relation
	      (symbol-value
	       (term-to-graph `(,(term-graph-symbol (symbol-value hub)) 
				/ 
				,(term-graph-type (symbol-value hub))))))
	(term-graph-features (symbol-value range))) 
  (setf (term-graph-parent 
	 (symbol-value (fetch-feature 'rhetorical-relation range)))
    range)
  (setf (term-graph-parent (symbol-value range)) nil)
  (when (eq *plan* hub)
    (setq *plan* range))
  (setq result range))


(defun FILL-GLOBAL-INFO-IN-SPEC (result)
  (let ((top-term (dolist (g-term (get-top-level-terms result))
		    (if (term-graph-type (symbol-value g-term))
			(return g-term)))))
    (if top-term
	(progn
	  (setf (term-graph-type (symbol-value result))
	    (term-graph-type (symbol-value top-term)))
	  (if (not (expressed-p result)) 
	      (progn 
		(setf (term-graph-features (symbol-value result))
		  (nconc (term-graph-features (symbol-value result))
			 (term-graph-features (symbol-value top-term))))
		(dolist (feature (term-graph-features (symbol-value result)))
		  (if (typep (rest feature) 'term-graph)
		      (setf (term-graph-parent (rest feature)) result))))))
      (let ((glob-term (dolist (g-term (get-global-terms result))
			 (if (term-graph-type (symbol-value g-term))
			     (return g-term)))))
	(if glob-term
	    (setf (term-graph-type (symbol-value result))
	      (term-graph-type (symbol-value glob-term)))
	  (if (KB-entity? (term-graph-symbol (symbol-value result)))
	      (NP-Specify result)
	    (warning "SPL variable with no type: " 
		     (term-graph-symbol (symbol-value result)))))))))


;;; ----------------------------------------------------------------------
;;; First extensions...
;;;   discourse-semantics-reference-check : only used in stratification
;;;   logical-sequencing : head selection
;;; Note: this below is all experimental and is more a set of working notes
;;; during the construction of a proper textual representation for the
;;; developing discourse and the addition of proper logical organization
;;; to the SPL. 


(defvar *logical-relations* nil) ;; e.g. '((= e2 e3)(> b e1)(> e2 b)))

(defun LOGICAL-SEQUENCING (spec)
  (when (numberp spec) (return-from logical-sequencing spec))
  (unless 
      (and (symbolp (term-graph-symbol (symbol-value spec)))
	   (rmember (term-graph-symbol (symbol-value spec)) 
		    *logical-relations*))
    (return-from logical-sequencing spec))
  (format t "~%   ...examining sentence-internal logical dependencies")
  (format t "~%   ...spec= ~A" spec)
  (logical-subordinates spec))



(defun LOGICAL-SUBORDINATES (var)
  (let* ((term (term-graph-symbol (symbol-value var)))
	 (deps (loop for rel in *logical-relations*
		   when (and (eq (first rel) '>)
			     (eq (second rel) term))
		   collect (third rel)))
	 (dep-graphs
	  (remove-duplicates
	   (remove-empty-variables
	    (loop for d in deps 
		append (loop for p in *plan-graphs*
			   when (eq d (term-graph-symbol (symbol-value p)))
			   collect p)))
	   :test #'(lambda (x y)
		     (equal (term-graph-features (symbol-value x))
			    (term-graph-features (symbol-value y)))))))
    (cond (dep-graphs
	   (print "found following dependents")
	   (print dep-graphs)
	   (format t "~%   ...specification was: ~W" (term-graph-features 
						      (symbol-value var)))
	   (print "expressed-p of var is")(print (expressed-p var))
	   (print "member of consuemd terms?")
	   (print (member var *consumed-terms*))
	   (if (not (member (term-graph-symbol (symbol-value var))
			   *newly-consumed*))
	       (let ((modified-spec (intern (gensym "TERM-") "KPML")))
		 (set modified-spec
		      (make-term-graph
		       :symbol var
		       :id modified-spec
		       :features (cons
				  (cons 'process 
					(symbol-value (first dep-graphs)))
				  (term-graph-features (symbol-value var)))
		       :parent (term-graph-parent (symbol-value var))))
		 (push modified-spec *plan-graphs*)
		 (push (term-graph-symbol (symbol-value var)) *newly-consumed*)
		 (format t "~%   ...specification becomes: ~W" 
			 (term-graph-features (symbol-value modified-spec)))
		 modified-spec)
	     var))
	  (t var))))
		  

(defun REMOVE-EMPTY-VARIABLES (term-list)
  (loop for term in term-list
      when (term-graph-features (symbol-value term)) collect term))


;;; ----------------------------------------------------------------------
;;; Modification specification utilities...

;;; Following was in the inquiry-implementation file under Penman!

(defun EXPRESSED-P (term)
  (dolist (old-term *consumed-terms*)
    (if (term-eq-p term old-term)(return t))))

;;; ----------------------------------------------------------------------
;;; Certain of the stratification discourse semantics checks are now
;;; also moved here as well as the remaining remnants of the original
;;; Penman NP-planner...

(defun DISCOURSE-SEMANTICS-REFERENCE-CHECK (term-label)
  (when (numberp term-label)
	(return-from discourse-semantics-reference-check term-label))

  (let* ((term (symbol-value term-label))
	 (type-or-types (term-graph-type term))
	 (types (if (listp type-or-types) type-or-types
		  (list type-or-types))))
    (when (intersection *discourse-individuals*
			types)
      (format 
       t "~% Discourse Semantics:  an individual is being referred to: ~A"
       types)
      (when (individual-expressed-p term-label)
	(format 
	 t 
	 "~% Already mentioned locally; dynamically changing reference strategy.")
	(add-features-to-spl-term term-label 
				  '(:identifiability-q identifiable 
				    :empty-number-q empty 
				    :empty-gender-multiplicity-q empty))))
    (push term-label *consumed-terms*)
    term-label
    ))


(defun INDIVIDUAL-EXPRESSED-P (term)
  (when (intersection (term-graph-type (symbol-value term))
		      *macro-themes*)
	(return-from INDIVIDUAL-EXPRESSED-P t))
  (dolist (old-term *consumed-terms*)
	  (if (and (equal
		    (term-graph-type (symbol-value term))
		    (term-graph-type (symbol-value old-term)))
		   (not
		    (equal term old-term)))
	      (return t))))

(defun ADD-FEATURES-TO-SPL-TERM (term list-of-features)
  "Input is a symbol which evaluates to a term-graph structure and a 
   list of feature/value pairs; this function returns the symbol with
   its feature list altered as a side effect."
  (setf (term-graph-features (symbol-value term)) 
    (process-features list-of-features term)))


;;; ----------------------------------------------------------------------
;;; Stub for NP-planning...

(defun NP-SPECIFY (instance)
 instance)

;;; ----------------------------------------------------------------------
;;; Utilities...

;;; ----------------------------------------------------------------------
;;; Recursive member.

(defun RMEMBER (x list)
  (loop for ele in list
      thereis 
	(cond ((listp ele)
	       (rmember x ele))
	      (t
	       (eq ele x)))))


