(in-package "KPML")

;;; File: generation-actions.lisp
;;; John:Edinburgh:Oct97.
;;; 
;;; Provides an interface for defining operations to be performed on 
;;; input and output of generation. Provides a clean and standardized
;;; place for, e.g., putting HTML-wrappers, postprocessors of various
;;; kinds, etc. Also some of the KPML tools make use of this feature
;;; to set up various flags for collecting information that they
;;; need for their operation.

(defvar *before-generation-actions* nil)
(defvar *after-generation-actions* nil)

;;; The main KPML API-entry function...
;;;      :KPML-3.2.15 "Added direct control of example set allocation"

(defun SAY (input &key
		  (details nil)
		  (full-structure NIL)
		  (preselections nil)
		  (language NIL)
		  (morphology NIL)
		  (ex-set nil)                                  ;; 3.2.15
		  (default-spl-name *default-created-spl-name*) ;; 3.2.47
		  (reuse-spl *reuse-created-spls*)              ;; 3.2.47
		  )
  (let ((result "")
	(structure nil)
	;; 3.2.15
	(*default-example-set* (if ex-set ex-set *default-example-set*)))
    (declare (special *default-example-set*))
    (loop for (id . action) in *before-generation-actions*
	  do (setf input (funcall action input)))
    (multiple-value-bind
	(generated-sentence generated-structure)
	(only-say input :details details :full-structure T
		  :language language :morphology morphology
		  :preselections preselections)
      (setf result generated-sentence
	    structure generated-structure))
    (loop for (id . action) in *after-generation-actions*
	do (multiple-value-bind 
	       (generated-sentence generated-structure)
	       (funcall action result structure)
	     (setf result generated-sentence
		   structure generated-structure)))
    (if full-structure
	(values result structure)
      (values result))))


;;; 2.0 Following API function returns just the first printable
;;;     structured result returned by generation...
;;;
(defun SURFACE-STRUCTURE (input &key
				(preselections nil)
				(language NIL)
				(morphology NIL))
  (multiple-value-bind (s r)
      (say input :preselections preselections
	   :language language
	   :morphology morphology
	   :full-structure T)
    (cdr (first r))))

;;; 4.0 Following API function just generates according to
;;;     specified list of features (may already be present
;;;     somewhere)

(defun GENERATE (features)
  (say `(um / um-thing :features ,features)))


;;; ----------------------------------------------------------------------
;;; Generation action API...
;;;
;;; Add actions with:
;;;  (add-generation-action 'action :both :id 1)
;;;  (add-generation-action 'action :before :id 3)
;;; etc.
;;; Remove actions with:
;;;  (remove-generation-action 3 :after)
;;;

(defmacro ADD-GENERATION-ACTION (fn when &key (id nil))
  (let ((before? (member when '(:before :both)))
	(after?  (member when '(:after  :both))))
    (if (and id (or before? after?))
	`(progn
	   ,(when before?
	      `(push (cons ,id ,fn) *before-generation-actions*))
	   ,(when after?
	      `(push (cons ,id ,fn) *after-generation-actions*)))
      (warning "Badly formed generation action addition: " fn args))))
      
(defmacro REMOVE-GENERATION-ACTION (id when)
  (if (and id (member when '(:both :after :before)))
      `(progn
	 ,(when (member when '(:both :before))
	    `(setf *before-generation-actions*
	       (remove-if #'(lambda (e) (equal (car e) ,id))
			  *before-generation-actions*)))
	 ,(when (member when '(:both :after))
	    `(setf *after-generation-actions*
	       (remove-if #'(lambda (e) (equal (car e) ,id))
			  *after-generation-actions*))))
    (warning "Badly formed generation action removal: " id when)))
    
;;; ----------------------------------------------------------------------
;;; Example of a before action...

(defun CLEAR-COREF-MEMO (input)
  (clrhash *coreferentials*)
  input)

(add-generation-action 'CLEAR-COREF-MEMO :before :id (gensym))