(in-package "KPML")

;;; File: generate.lisp

;;; Original copyright (file: penman-exec.lisp,  USC/ISI)
;;; File now incorporates multilingual extensions from ML-Penman as
;;; well as extensions up to KPML 2.0. Copyright GMD/IPSI, John Bateman,
;;; and lots of other folks I expect.

;;; ----------------------------------------------------------------------
;;; 1.0.16 : omm
;;; Although not documented, it might have been expected that one could
;;; run KPML examples in Penman's `deimplemented mode'; i.e., taking 
;;; inquiry responses direct from the example structure from a previous
;;; generation and not from an SPL. This was in fact not supported. 
;;; This patch adds this functionality back in. The following flag needs
;;; to be set to kpml::deimplemented in order to allow generation in
;;; deimplemented mode. 

(defvar *GENERATION-MODE* *general-inquiry-mode*) 

;;; Then all inquiries have to have their implementation
;;; mode set to deimplemented in the standard Penman manner, i.e.,
;;; by means of the function call (set-inquiry-mode-deimplemented).
;;; Note that it is then necessary to explicitly reset the implementation
;;; modes and the flag in order to resume normal SPL generation.
;;; Deimplemented generated examples support all of the KPML extended
;;; resource debugging tools.
;;;
;;; Note that it does not make sense to try and run deimplemented when
;;; the *clean-example-records* flag is set! Since this becomes complicated
;;; to remember,  functions are provided at the bottom of this patch for
;;; toggling implemented/deimplemented generation mode.
;;; ----------------------------------------------------------------------

(defvar *speaker*)
(defvar *hearer*)
(defvar *speakingtime*)
(defvar *speakingplace*)
(defvar *consumed-terms* nil "Terms having had a turn as ONUS.")

;;; ----------------------------------------------------------------------
;;; KPML generalized function for starting generation...
;;; ... the default options that no information is given apart from
;;;     the string generated; keywords call for more information.
;;;
;;; 0.9.12 wrap a catch around the body to provide a well defined place
;;;        for landing up when bad errors or serious aborts occur.
;;;
;;; 1.1    This was the original say function. It is now only called
;;;        from a new API-function say, which wraps possible actions
;;;        before and after generation. This is defined in 
;;;        generation-actions.lisp. This function may be called directly
;;;        if no actions are required.
;;;        Preselections added.
  ;; 3.2.47
  ;;  Added parameterized control of the example names that are created
  ;;  automatically whenever generation is of an SPL. Also added is
  ;;  control over whether we keep on accumulating new SPLs whenever
  ;;  we generate (which can then accumulate huge numbers of SPLs if
  ;;  we are running in an application) or whether we reuse SPLs so
  ;;  as not to grow huge lists. These are added as parameters to both
  ;;  SAY and ONLY-SAY. The defaults for these parameters come from 
  ;;  the following two new globals which should be added into variables.lisp
;;; ----------------------------------------------------------------------

(defun CREATE-SPL-NAME (default-spl-name reuse-spl)
  (let ((name (if default-spl-name default-spl-name "SPL")))
    (if reuse-spl name (gentemp name))))

(defun ONLY-SAY (example-or-plan 
		 &key
		 (details nil)
		 (full-structure NIL)
		 (preselections nil)
		 (language NIL)
		 (morphology NIL)
		 (default-spl-name *default-created-spl-name*) ;; 3.2.47
		 (reuse-spl *reuse-created-spls*)              ;; 3.2.47
		 )
  
  "KPML internal generalized start of generation function"
  (let* ((plan-name (if (symbolp example-or-plan)
		       example-or-plan
		     (let ((name 
			    ;; 3.2.47
			    (create-spl-name default-spl-name reuse-spl)))
		       ;; 0.9 make sure that current language prevails
		       (clear-region-and-language-defaults)
		       (example-1 
			`(:name ,name :logicalform 
				,example-or-plan :targetform ""))
		       name)))
	(sentence "")
	(structure nil)
	(example-ls-set (fetch-example-info plan-name 'ls-set))
	(desired-language (if language language
			    (if (eq (length example-ls-set) 1)
				(first example-ls-set)
			      curlan)))
	(curlan desired-language))
    (cond ((example-p plan-name)
	   (unwind-protect
	       (multiple-value-bind
		   (generated-sentence generated-structure)
		   (catch 'kpml-say-error  ;;; 0.9.12
		     (say-plan plan-name details morphology preselections))
		 (setf sentence generated-sentence
		       structure generated-structure))
	     (say-exit-control))
	   (if full-structure
	       (values sentence structure)
	     (values sentence)))
	  (t
	   (warning "Undefined input to say")))))


   ;; ----------------------------------------------------------------------
   ;; 3.2.32 ML-say added again for convenience.
   ;; ----------------------------------------------------------------------

(defun ML-SAY (input &key
		     (details nil)
		     (neat nil)
		     (full-structure NIL)
		     (preselections nil)
		     (language NIL)
		     (morphology NIL))
  (if neat
      (loop for l in language
	    do
	    (format t "~%~20A: ~A" l  (say input 
				       :details details
				       :full-structure full-structure
				       :preselections preselections
				       :language l
				       :morphology nil)))
    (loop for l in language
	  collect (say input 
		       :details details
		       :full-structure full-structure
		       :preselections preselections
		       :language l
		       :morphology nil))))

;;; ----------------------------------------------------------------------
;;; 0.9.12 -- on errors...
;;; 2.1    -- parameterized failure string...
;;;           and clear out the mouseable sentences...
;;; ----------------------------------------------------------------------

(defun ABANDON-GENERATION ()
  (format *trace-output* "~%;;; Generation aborted.")
  (setf *mouseable-sentences* nil)
  (throw 'kpml-say-error
    (values *failure-string* nil)))

;;; ----------------------------------------------------------------------
;;; 2.1 a check on whether we generated ok or not...
;;; ----------------------------------------------------------------------

(defun GENERATION-COMPLETED-P (string)
  (not (string= string *failure-string*)))

;;; ----------------------------------------------------------------------
;;; Following function now also updates the generatedform slot
;;; of the examples (which used to be called penexample)
;;; structure (John:IPSI:Nov94).

;;; KPML 0.8: return structure completely changed. Gives back two
;;; values, the first is the string generated, the second is
;;; the list of mouseable, marked-up structures corresponding to
;;; all strings generated (i.e., multiple if there are multiple
;;; orderings). This structure can then be used by the window
;;; interface in order to display the generated strings in a
;;; mouse-sensitive fashion, or by an application program that
;;; wants to provide some further options than just presenting
;;; the string.                           (John:IPSI:May95)
;;; 1.1 top level preselections added     (John:Edi:Feb98)

(defun SAY-PLAN (plan print-results 
		 &optional (morphology NIL)(preselections nil))
  "Convert the list-structured plan into term-graph structures, set global parameters,
   and invoke Express."

  ;; ----------------------------------------------------------------------
  ;; first stuff just sets up the environment for a traversal of the
  ;; grammar for generation...
  ;; ----------------------------------------------------------------------
  (let ((generation-results nil)
	(ex (gethash plan penexamples))
	(first-string ""))
    (unless (say-entry-control) (return-from say-plan nil))
    (reset-defaults-if-necessary)
    (setq *plan-graphs* nil)
    (setq *consumed-terms* nil)

    ;; 4.0 -- the following was accumulating information across
    ;;        entire sessions by default, which was a lot of
    ;;        information... Usually now turned off.
    ;;
    (when *reinitialize-cumulative-associations*
      (setf cumulative-associations nil))

    ;; 1.0.16 Following clause used to deactivate
    ;; deimplemented running from example records...
    (cond ((equal *generation-mode* 'deimplemented)
	   (setf *plan* (example-rootnode ex)))
	  (t
	   (setf (example-rootnode ex) 
	     (setq *plan* 
	       (make-plan-term-graph 
		(fetch-example-info plan 'logicalform))))))

    (setf (example-verbalizationgraph ex) *plan-graphs*)
    (setq *speaker* (discourse-context-speaker (example-discoursecontext ex)))
    (setq *hearer* (discourse-context-hearer (example-discoursecontext ex)))
    (setq *speakingtime* (discourse-context-speaking-time 
			  (example-discoursecontext ex)))
    (setq *speakingplace* (discourse-context-realm-of-speech 
			   (example-discoursecontext ex)))

    ;; ----------------------------------------------------------------------
    ;; >> this is where we descend into the repeated traversal process of
    ;; >> generation...
    ;; ......................................................................
    ;;
    (setf generation-results 
	  (express plan print-results morphology preselections))
    ;;
    ;; ......................................................................
    ;; << and this is where we come back with results accumulated.
    ;; ----------------------------------------------------------------------

    (setf first-string (car (first generation-results)))
    (setf (fetch-example-info plan 'generatedform curlan)
	  (clean-up-final-string first-string))
    (when store-to-environment-flag 
      (replace-example-info plan 'structure *mouseable-sentences* curlan)
      ;; 4.0
      (replace-example-info plan 'expansions (extract-pass-expansion-info) curlan)
      )
    (values 
     first-string
     generation-results))
  )

;;; ----------------------------------------------------------------------
;;; KPML 0.8: for compatibility with old Penman function, explicitly 
;;;    disregards the second structured result of say-plan.
;;;    No additional functionality available.

(defun SAY-SPL (plan &optional (print-results nil))
  "Terminal i/o from Express with spl input."
  (let ((name (gentemp "SPL")))
    (example-1 `(:name ,name :logicalform ,plan :englishform ""))
    (unwind-protect
	(values (say-plan name print-results))
    (say-exit-control))))

;;; ----------------------------------------------------------------------
;;; KPML 0.8: this function has the functionality of the old Penman
;;; SAY function; it explicitly disregards the second structured
;;; result of say-plan.  For full structure use new function:
;;; SAY defined below.

(defun SAY-EXAMPLE (simble &optional (print-results t) &key priorrefs)
  (unwind-protect
      (values (say-plan SIMBLE print-results))
    (say-exit-control)))

;;; 2.0 Following triviality is sometimes nice to have around...
;;;
(defun SAY-AGAIN () (say *most-recent-example*))

;;; 2.0 This is not bad either...
(defun SAY-EXSET (name &optional (printflag T))
  (let ((exlist
	 (sort (loop for x in examples
		   when (equal (fetch-example-info (first x) 'set-name) name)
			;; 2.0.25 ordering relation changed.
		   collect (first x)) #'numbered-name-lessp)))
    (if printflag
	(loop for ex in exlist do (print (say ex)))
      (loop for ex in exlist do (say ex)))))

;;; ----------------------------------------------------------------------
;;; 1.0.16

(defun DEIMPLEMENTED-GENERATION-MODE ()
  (set-inquiry-mode-deimplemented)
  (setf *clean-example-records* nil)
  (setf *generation-mode* 'deimplemented))

(defun IMPLEMENTED-GENERATION-MODE ()
  (set-inquiry-mode-implemented)
  (setf *clean-example-records* T)
  (setf *generation-mode* 'implemented))

;;; ----------------------------------------------------------------------
;;; Print-results causes a bunch of further information to be printed
;;; in addition to the final string that used to be returned in
;;; Penman. SAY used to call with print-results T, and SAY-SPL with
;;; print-results, NIL. Both functions call SAY-PLAN which in turn
;;; calls EXPRESS. This print-results flag still has this effect.
;;; 
;;; There are a number of other changes in KPML 0.8+ in what is
;;; returned described below.

;;; 1.0.17 patch cleans out the example record information when updating
;;;        of example records is on and the clean example record flag is set.
;;;(Old Penman comments:
;;;  EXPRESS: Environment-Conversion-Flag used now as global. 
;;;  NIL allows conversion from old environment form. NON-NIL 
;;;  prevents reference to old form.)
;;; ML-Penman extension folded in here.
;;; 2.0 was not using multilingual access functions for examples still.

(defun EXPRESS (Exam-Identifier 
		&optional 
		(print-results t)
		(morphology NIL)
		(preselections nil))

  ;; ----------------------------------------------------------------------
  ;; get ready for generation... down to the nitty gritty before traversal
  ;; ----------------------------------------------------------------------
  (reset-network-if-necessary)
  (setf *activate-word-rank-and-below*
	(if morphology morphology
	  (second (assoc curlan *language-morphology-profiles*))))
  (unwind-protect
      (block 
       nil
       (unless (express-entry-control) (return nil))
       (setq Default-Inquiry-Mode 
	     (if say-lock 'implemented 'deimplemented))
       (unless say-lock (setq *plan* nil))
       ;;  an express without a say has no expanded plan.
       (set-inquiry-mode-implemented 'where-am-i-id) ;always implemented
       (SETQ *Most-Recent-Example* Exam-Identifier)
       (setq example-identifier  Exam-Identifier)
       (PROG 
	((Default-Selector 'Choice-Master)
	 (Old-Warning-Count Warning-Count)
	 KB TP)
	(cond
	 ((Example-P Exam-Identifier)                            
	  (let ((instance (gethash Exam-Identifier penexamples)))
	    (when (and Store-To-Environment-Flag 
		       *clean-example-records*)                     ;; 1.0.17
	      (setf (fetch-example-info exam-identifier 'includedhubs) nil)
	      (setf (fetch-example-info exam-identifier 'selectionexpressions)
		nil)
	      (setf (fetch-example-info exam-identifier 'preselections) nil))
	    (SETQ KB (cond 
		      (*clean-example-records* (copy-tree '(NIL)))  ;; 1.0.17
		      ((Example-KBenvironment instance))
		      (T (copy-tree '(NIL)))))
	    (SETQ TP (cond
		      (*clean-example-records* (copy-tree '(NIL)))  ;; 1.0.17
		      ((Example-TPenvironment instance))
		      (T (copy-tree '(NIL)))))))
	 ((atom  Exam-Identifier)
	  (Example-1 (list :name Exam-Identifier))    
	  (SETQ KB (copy-tree '(NIL)))
	  (SETQ TP (copy-tree '(NIL))))
	 (t
	  (warning "The specified or generated example name ("
		   Exam-Identifier ") must be atomic.")
	  (return-from express NIL)))

	(when 
	 (Not (fetch-example-info exam-identifier 'targetform))
	 (Get-Example-English Exam-Identifier))

	(if window-interface-flag
	    (printwindow :target-text-pane
			 (justify-string 
			  55 
			  (fetch-example-info exam-identifier 
					      'targetform)))
	  (when print-results (Display-English-Example Exam-Identifier)))
	
	;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
	;; all that was just preliminary to the following function call,
	;; which does the actual generation...

	;; 0.8 CHANGES...
	;; The result of calling all-parts is that the sentence is generated
	;; resulting in a complex structure left in SENTENCE-TREE. The final
	;; action of all-parts is that ALL-ORDERINGS is called on this structure
	;; to produce linearized strings from the ordered structures. These
	;; include punctuation and phonological processing. In KPML 0.8
	;; we change the kind of information given back at this point. This
	;; has the following motivations:
	;; i. if we are using morphology then the previous list of grammatical
	;;    functions that was returned usually just now looks like a long
	;;    list of HEADs or STEMs and is not very informative! It is in
	;;    any case better to provide some indication of the structure;
	;; ii. we want in any case to provide for mouse sensitivity in both
	;;    grammatical structure and string;
	;; iii. we want to keep some of this information in the example
	;;    record following generation.
	;; Rely now on *mouseable-sentences* rather than any other curious
	;; structures. (Although we might want to pick up the function
	;; structure from SENTENCE-TREE at some stage! KPML4: now more or 
	;; less included in the returned printable structure).
	;; 1.1 added preselections at toplevel:  preselections
	
	(All-Parts preselections (Find-root-node Exam-Identifier))
	
	;; ... then back to information presentation...
	;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
	(when (and (not window-interface-flag)  print-results)
	      (Display-English-Example Exam-Identifier)
	      (Display-TTY-Generated-Structure)
	      (Display-TTY-Warning-Report old-warning-count))
	
	;; The following is now the structure returned by EXPRESS:
	;; a list of pairs consisting of a car of the string produced
	;; and a cdr of the printable-constituent structure corresponding
	;; to the string. The former supports old Penman-style returning
	;; of strings, the latter supports KPML-style returning of
	;; marked-up mouseable strings.
	
	(return
	 (mapcar #'(lambda (printable-constituent)
		     (cons 
		      (unify-string
		       (printable-constituent-to-printable-list 
			printable-constituent))
		      printable-constituent))
		 *mouseable-sentences*))))

    (express-exit-control)))

;;; ----------------------------------------------------------------------
(defun whereamiidcode (&optional dummy)
  "always implemented, gives unique id used by modification-specification-id"
  dummy
  (let ((result nil))
    (dolist (x  alias-function-stack)
      (let ((item (symbol-name x)))
	(setq result 
	  (concatenate 
	      'string (subseq item 0 (position #\# item)) "-" result))))
    (intern result (find-package "KPML"))))

(DEFUN Display-English-Example (ITEM)
  (let ((english-form (fetch-example-info item 'targetform)))
    (cond
      ((and english-form (not (equal english-form "")))
       (printwindow :display-pane " ")
       (printwindow :display-pane (indent-and-fill "The intended text is: "))
       (printwindow :display-pane (indent-and-fill english-form)))
      (english-form)
      (T (Get-Example-English ITEM)))))


;;; ----------------------------------------------------------------------
(DEFUN Find-root-node (&OPTIONAL ExampleName &REST IGNORE)
  (cond
   ((example-rootnode (gethash examplename penexamples)))
   (T (setf (example-rootnode (gethash examplename penexamples)) 
	(Elicit-root-node ExampleName)))))

(DEFUN Elicit-root-node (&OPTIONAL ITEM &REST IGNORE)
  (let ((GOTTEN)(RESULT))
    (loop
      (printwindow
       :display-pane
       (indent-and-fill
	(format nil "An SPL term (i.e., a variable that holds 
an appropriate term graph) is needed for generating example ~a. This is normally some variable specified in the SPL. Please supply an S-expression which when evaluated will yield the right form." item )))
      (setq gotten (askwindow :value "Enter S-expression for term: "))
      (SETQ RESULT (kpml-eval GOTTEN))
      (let ((message (format nil "The evaluated result is ~a.
Is that satisfactory?" result)))
	(printwindow :display-pane (indent-and-fill message))
	(when (askwindow :yes-or-no message)
	  (return-from Elicit-root-node result))))))


;;; ----------------------------------------------------------------------
(defun RESULTS ()
  (when *accumulate-used-features*
    (setf *features-used* (union *features-used* feature-selections)))
  (when show-selection-expression-flag
    (printwindow :display-pane " ")
    (printwindow :display-pane "The resulting feature selection expressions are: ")
    (printwindow :display-pane (pretty   feature-selections)))
  (when display-association-flag
    (printwindow :display-pane " ")
    (print-fat))
  (when (and pledges show-pledges-flag)
    (printwindow :display-pane " ")
    (printwindow :display-pane "The following pledges were made:")
    (printwindow :display-pane (pretty pledges)))
  (when conflate-demons
    (Warning "There are waiting conflations: " Conflate-demons ", waiting on the functions: "
;	     (remove-duplicates (for d in conflate-demons
;				 join (for f inside d
;					   unless (insert-p blackboard f)
;					   collect f)) :test #'equal)
	     ))
  (when no-function-realization
    (warning "The following function bundles could not be realized:" no-function-realization)
    (incf warning-count (length (cdr no-function-realization)))
    (printwindow :display-pane (pretty  no-function-realization))))

