(in-package "KPML")

;;;--------------------------------------------------------------------------------
;;; Function for getting an spl+local discourse context from a file...
;;;
;;; The file must consists of entries of the following form, one after
;;; the other. The ordering is already significant.
;;;
;;; form:  ( constraints spl)
;;;        
;;;        constraints is an alist with keys 'constraints, 'macro-themes
;;;        spl is passed directly to say-spl.
;;;

(defvar *show-semantic-input* t)

(defun say-spls-from-file (&optional (spl-file "/home/bateman/out"))
  (let ((instance+context nil))
    (setf *generated-strings* "")
    (with-open-file 
     (instance-source (pathname spl-file)
		      :direction :input)

     (format t "~% fetching spls from: ~A" instance-source)
     (in-package "KPML")
     (block read-instances
	    (loop
	     (setf instance+context (read instance-source nil '*eof*))
	     (when (eq instance+context '*eof*) 
		   (return-from read-instances t))
	     (grammaticize-with-local-context instance+context)))

    (format t "Generated text: ~2%")
    (pp *generated-strings*))))


(defvar *fragment-discourse-history* nil)

(defun GRAMMATICIZE-WITH-LOCAL-CONTEXT (instance+context)
  (let* ((instance (second instance+context))
	 (temp "")
	 (spl (cond ((null instance) nil)                    ;; this is to handle the
		    ((eq (length instance) 1) instance)  ;; rather unpleasant way that
		    (t                                       ;; spl signals complexes...
		     (cdr instance+context)))))
    (set-local-context (first instance+context))
    (when *fragment-discourse-history*  (setf *consumed-terms* nil))

    (when *show-semantic-input* 
	  (format t "~%Semantic input to lexicogrammar:~%")
	  (pprint spl))
    (setf temp (say-spl spl))
    (setf *generated-strings* 
      (concatenate 'string  *generated-strings*  temp " -- "))
    (reset-local-context)
    ))



;;; BEWARE!!! IS THE FOLLOWING STILL UP TO DATE WITH RESPECT TO THE
;;; FUNCTIONS FROM WHICH IT BORROWS??? E.G. SAY-PLAN, ETC.??

(defun INTERFACING-WITH-PENMAN-INTERNALS (plan)
  (let ((name (gentemp "N-SPL")))
    (example-1 `(:name ,name :logicalform ,plan :englishform ""))
    (unless (say-entry-control) (return-from interfacing-with-penman-internals nil))
    (setq *plan-graphs* nil)
    (setq *consumed-terms* nil)
    (setf (example-rootnode (gethash name penexamples)) 
      (setq *plan* 
	(make-plan-term-graph 
	 (fetch-example-info name 'logicalform))))
    (setf (example-verbalizationgraph 
	   (gethash name penexamples)) *plan-graphs*)
    (setq *speaker* (discourse-context-speaker 
		     (example-discoursecontext 
		      (gethash name penexamples))))
    (setq *hearer* (discourse-context-hearer 
		    (example-discoursecontext 
		     (gethash name penexamples))))
    (setq *speakingtime* (discourse-context-speaking-time 
			  (example-discoursecontext 
			   (gethash name penexamples))))
    (setq *speakingplace* (discourse-context-realm-of-speech 
			   (example-discoursecontext 
			    (gethash name penexamples))))))
  






;;;================================================================================
;;; Set local semantic environment for generation...

(defvar *active-register-motivated-grammar-defaults* nil)
(defvar *maintained-discourse-individuals* nil)
    
(defun SET-LOCAL-CONTEXT (constraints)
  (format t "~2% Setting local context according to constraints:")
  (pprint constraints)
  (when (second (assoc 'constraints constraints))
	(CREATE-AND-ACTIVATE-SPL-ENVIRONMENT 
	 (second (assoc 'constraints constraints))))
  (when (second (assoc 'macro-themes constraints))
	(setf *macro-themes*
	      (append *macro-themes*
		      (second (assoc 'macro-themes constraints)))))
  (when (second (assoc 'disc-individuals constraints))
	(setf *discourse-individuals*
	      (append
	       *maintained-discourse-individuals*
	       (second (assoc 'disc-individuals constraints))))))


(defun CREATE-AND-ACTIVATE-SPL-ENVIRONMENT (inquiry-constraints)
  (push (gentemp "local-environment-" 'kpml) 
	*active-register-motivated-grammar-defaults*)
  (define-default-env 
    (first *active-register-motivated-grammar-defaults*)
    (process-features (reduce #'append inquiry-constraints) nil))
  (begin-default-env (first *active-register-motivated-grammar-defaults*)))
    

(defun RESET-LOCAL-CONTEXT ()
  (dolist (e *active-register-motivated-grammar-defaults*)
	  (end-default-env e))
  (setf *active-register-motivated-grammar-defaults* nil)
  (setf *discourse-individuals* nil)
  (setf *maintained-discourse-individuals*
	(pick-out-themes *macro-themes* *consumed-terms*))
  (setf *macro-themes* nil))

(defun PICK-OUT-THEMES (macro-themes introduced-terms)
  (let ((list-of-type-lists (mapcar #'(lambda (x)(term-graph-type (eval x)))
			       introduced-terms))
	(result nil))
    (loop for x in macro-themes
	  do (loop for y in list-of-type-lists
		   when (consp y)
		   do (when (member x y)(pushnew x result))))
    result))




;;;--------------------------------------------------------------------------------
;;; user model.... :-)

(defvar *domain-identifiables* 
  '(hightensionplant turbinefactory worker embassy art-school
		     sezession))



;;;--------------------------------------------------------------------------------
;;; Output should be prettier...

(defun pp (string)
  (format t "~{~%       ~A~}"
	  (justify-string 40 string)))


