(in-package "KPML")

;;; File: waiting-generate.lisp
;;; Documentation for use at: http://purl.org/net/kpml/bbox.htm
;;;
;;;         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;          Black box generator capability for KPML
;;;         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;;
;;;               Windows Lispworks 4.1 + 5.0 ONLY !!!
;;;
;;; Author: John Bateman, Feb 2000.
;;; Updates:              Feb 2002 (more control), Jun 2002 (html added)
;;;                       Dec 2004 (bit more control + KPML4)
;;;                       Jun 2006 (minor control bugs fixed)
;;;
;;; TODO: get the other forms of passing inputs and outputs up and
;;;       running, currently only allows IO through files.
;;; 
;;; ====================================================
;;; This is a slightly more complex version of the blackbox skeleton
;;; ocasionally used elsewhere as an example.
;;;
;;; Defines a simple function that goes into a loop waiting for input
;;; to appear in a particular file.  When the input (as SPL) appears
;;; there, it generates with the currently loading linguistic
;;; resources and places the output in a specified output file.  When
;;; *waiting-verbose* is set, you get a bunch of tracing messages to
;;; see what is going on. Interaction is assumed to be as follows:
;;; (1) some program makes an SPL specification for a sentence and
;;; writes it to the input file; (2) the black box generator sees this
;;; and writes the generated string to the output file; (3) some program
;;; (possibly the same as in (1)) detects that a string has appeared
;;; in the output file and does something with it; (4) go back to (1).
;;; In order to stop the entire process, the single item ":stop" must
;;; be placed in the input file.
;;;
;;; One easy way of using this is to load up KPML, load some linguistic
;;; resources for generating, and then to make a standalone executable
;;; image. The application function for starting up the image should
;;; be the WAITING-GENERATE function defined below. A trivial delivery
;;; call example for Lispworks could be:
;;; 
;;;            (lispworks::deliver 
;;;                  'kpml::waiting-generate "kpml4-bbox" 0
;;;                  :multiprocessing T :keep-clos T :keep-eval T)
;;; 
;;; Better would be something more space-efficient, etc. but this would
;;; minimally do the job.
;;;
;;; Update: Feb 2002. A little more functionality is added here
;;;                   to make the resulting blackbox a bit more useful.
;;;                   In addition, we generate only in strict monolingual
;;;                   mode for faster generation. This shows how the
;;;                   the blackbox might be extended for particular
;;;                   clients. We also add an attempt at supporting DDE
;;;                   interprocess communication and allow the KPML
;;;                   configuration file to be reloaded on demand. This
;;;                   latter actually allows us to change any KPML
;;;                   internal flags during running of the blackbox.
;;;         Dec 2004. Two new control line flags added: (i) :domain, 
;;;                   for just adding domain files and (ii) :text 
;;;                   for electing to process all the SPLs in a file
;;;                   one after the other rather than just the first.
;;;                   Also an in-file command :vars for showing the current
;;;                   state of all control variables.
;;;         Dec 2007. Socket-based communication added, plus update
;;;                   for Lispworks 5.
;;;
;;; ======================================================================

  ;; ----------------------------------------------------------------------
  ;; Determine where the input comes from, where the output goes, and
  ;; a few other aspects of the generator's behaviour...
  ;; ----------------------------------------------------------------------
  ;;
(defvar *spls-input-file* "C:\\tmp\\spls-in.lisp")
(defvar *kpml-output-file* "C:\\tmp\\kpml-out.txt")
(defvar *config-init-file* nil)

(defvar *waiting-language* :english) 
     ;; change this if other language resources
     ;; are loaded

(defvar *waiting-verbose* nil)  ;; tracing on/off
(defvar *html-mode* nil)        ;; output responds to HTML annotations in input

(defvar *poling-frequency* 2) ;; should be more than zero if any other
                              ;; processes are going to get a look-in.

(defvar *dde-activated* nil)  ;; when true, input and output goes via DDE
                              ;; (not yet implemented: low priority)

(defvar *text-mode* nil)      ;; when true, process all the SPLs in a file
(defvar *domain-file* nil)    ;; when set, loads the domain file identified
(defvar *port-number* nil)  ;; when set, initiates socket driven interaction
(defvar *generated-text* nil) ;; collects generated results for output

(setf *editing-protocol* nil) ;; no point in allowing this for a blackbox

  ;; ----------------------------------------------------------------------
  ;; The main looping function itself...
  ;; ----------------------------------------------------------------------
  ;;
(defun WAITING-GENERATE ()
  (let ((socket-stream nil)
	(input-data-list nil)
	)
    (setf example-runner-flag T)
    (print-welcome-lines *trace-output*)
    ;; first time round, check the command line for flags and commands.
    ;; this may return some
    ;; commands to be done...
    (setf input-data-list (process-any-command-arguments))

    (cond (*port-number*
	   ;;
	   ;; generation is running over the socket, no need
	   ;; to do any more here...
	   ;;
	   (format *trace-output* 
		   "~%;;; Generation over socket at port: ~S" 
		   *port-number*)
	   nil
	   )
	  (t
	   (loop for input-data-list = (get-input-from-file)
		 do
		 (sleep *poling-frequency*)
		 ;; ----------------------------------------
		 ;; more tracing...
		 ;; ----------------------------------------
		 (when *waiting-verbose*
		   (format *trace-output* 
			   "~%;;; Following read: ~S" input-data-list))
		 (process-input-line)
		 (with-open-file (stream *kpml-output-file*
					 :direction :output
					 :if-exists :new-version)
				 (format stream "~{~A ~}" 
					 (reverse *generated-text*)))))
	  )))


  ;; ----------------------------------------------------------------------
  ;; Main line processing ...
  ;; ----------------------------------------------------------------------
  ;;
(defmacro PROCESS-INPUT-LINE ()
  ;; ----------------------------------------
  ;; when something found, check if it is an action, if not
  ;; actually do some generating... 
  ;; ----------------------------------------
  '(when input-data-list
     
     ;; get rid of the input file (if still there) and get ready
     ;; to accumulate generated sentences, etc.
     ;;
     (when (and (not *port-number*)
		(probe-file *spls-input-file*))
       (delete-file *spls-input-file*))
     (setf *generated-text* nil)
     
     ;; ------------------------------
     ;; run through the interaction
     ;; possibilities... (now can be a list of SPLs (not commands!))
     ;; ------------------------------
     (loop for input-data in input-data-list
       do
       (case input-data
	     ;; see if we are done...
	     (:stop 
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Stop found. Exiting..."))
	      (when *port-number* (close socket-stream))
	      (return-from WAITING-GENERATE T))

	     ;; toggle verbosity...
	     (:verbose
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Toggling verbosity..."))
	      (setf *waiting-verbose* (not *waiting-verbose*)))

	     ;; toggle strict monolinguality... use this only when
	     ;; you have resources that do not involve any language
	     ;; conditionalization. Generation is then faster.
	     (:mono
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Toggling strict monolinguality..."))
	      (setf *rigidly-monolingual* (not *rigidly-monolingual*)))
	      
	     ;; toggle html output mode...
	     ((:html :xml)
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Toggling HTML/XML output mode..."))
	      (setf *html-mode* (not *html-mode*)))

	     ;; toggle html output mode...
	     (:text
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Toggling text output mode..."))
	      (setf *text-mode* (not *text-mode*)))

	     ;; toggle dde interaction for input/output...
	     (:dde
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Toggling dde io..."))
	      (setf *dde-activated* (not *dde-activated*)))

	     ;; see if we are to reload the configuration file...
	     (:configure
	      (kpml::load-kpml-configuration-file))

	     ;; redo the initializations on demand...
	     (:init
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Reinitializing..."))
	      (kpml::do-all-kpml-initializations))

	     (:language
	      (format *trace-output* "~%;;; Current language is '~S'" kpml::curlan))

	     ;; reports which version of the blackbox is running...
	     (:version
	      (kpml::describe-kpml))

	     ;; load lexicon of selected language anew...
	     (:lexicon
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Loading lexicons..."))
	      (kpml::load-lexicons *waiting-language* :clear nil))

	     (:domain
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; Loading domains..."))
	      (kpml::load-domains *waiting-language* :clear nil))
	      
	     (:vars
	      (report-var-values *trace-output*))

	     (:break-for-debug
	      (when *waiting-verbose*
		(format *trace-output* "~%;;; breaking for debug...")
		(break)))

	     (t
	      ;; if the input is a single nonrecognized keyword, it
	      ;; may be a language resource that we should
	      ;; attempt to load... e.g., :english, :french, etc.
	      ;; check for this and do it if possible, otherwise
	      ;; ignore...
	      (cond ((keywordp input-data)
		     (cond ((language-variety-loadable-p input-data)
			    (when *waiting-verbose*  ;; tracing
			      (format *trace-output* 
				      "~%;;; Attempting reload of: ~S" input-data))
			    
			    (setf kpml::curlan input-data)
			    (when *rigidly-monolingual*
			      (setf kpml::all_languages (list input-data)))
		     
			    (kpml::load-linguistic-resources input-data)
			    (kpml::do-all-kpml-initializations)
			    (setf *waiting-language* input-data))
			   (t
			    (format *trace-output* 
				    "~%;;; Unrecognised command: ~S" input-data))))
		    (t
		     
		     ;; if none of the commands, then try and generate it...
		     (when *waiting-verbose*  ;; tracing
		       (format *trace-output* "~%;;; Something found: ~S" input-data))

		     ;; ----------------------------------------
		     ;; Generation...
		     ;; ----------------------------------------
		     (let ((result
			    (unwind-protect
				;; ----------------------------------------
				;; Again be very cautious about anything 
				;; blowing up during generation...
				;; ----------------------------------------
				(multiple-value-bind
				    (value error)
				 (ignore-errors
				  (let ((result :nothing))
				    ;; ----------------------------------------
				    ;; if we needed user interaction during generation
				    ;; then the SPL was not specific enough, report that
				    ;; too...
				    ;; ----------------------------------------
				    (catch 'erunner
				      (setf result 
					    (if *html-mode*
						(html-say input-data :language *waiting-language*)
					      (say input-data :language *waiting-language*))))
				    (if (equal result :nothing)
					(format 
					 *trace-output* "~%;;; Generation required user interaction."))
				    result))
				 (progn
				   (when error
				     ;; ----------------------------------------
				     ;; If we get here, then generation failed...
				     ;; ----------------------------------------
				     (setf value nil)
				     (format 
				      *trace-output* "~%;;; Generation failure.")
				     (when *waiting-verbose*
				       (format *trace-output* "~%;;; Error: ~S" error))
				     (format 
				      *trace-output* "~%;;; SPL was ~S" input-data))

				   ;; ----------------------------------------
				   ;; Otherwise we were fine
				   ;; ----------------------------------------
				   ;;
				   value)))))
		       
		       ;; ----------------------------------------
		       ;; Collect the generated result (if anything)
		       ;; to the generated-text record
		       ;; ----------------------------------------		       
		       (when (and result (not (equal result :nothing)))
			 (when *waiting-verbose*  ;; tracing
			   (format 
			    *trace-output* "~%;;; Something generated: ~S" result))
			 (setf *generated-text* (cons result *generated-text*)))
		       
		       ))))))))

  ;; ----------------------------------------------------------------------
  ;; Get the input data from the named file...
  ;; ----------------------------------------------------------------------

(defmacro SAFE-READ (listp)
  ;; This just wraps enough condition handlers and error squashers
  ;; around the reading phase that it does not matter what gets
  ;; passed in or fails to get passed in.
  ;;
  `(unwind-protect
       (multiple-value-bind
	   (value error)
	   (ignore-errors 
	     (let ((*package* (find-package "KPML")))
	       (read stream :eof-error-p nil)))
	 (progn
	   (when error
	     (setf value nil)
	     (when *waiting-verbose*
	       (format *trace-output* "~%;;; SPL read error: ~S." error)))
	   ,(if listp '(list value)
	      'value)))))

(defun GET-INPUT-FROM-FILE ()
  (with-open-file (stream *spls-input-file* :direction :input
			  :if-does-not-exist nil)
     (when (streamp stream)
       (when *waiting-verbose*
	 ;; ----------------------------------------
	 ;; provide the tracing information for debugging and
	 ;; seeing what is going on...
	 ;; ----------------------------------------
	 (format *trace-output* 
		 "~%;;; SPL input file found, loading..."))
	      
       (let ((input-data-list
	      ;; ----------------------------------------
	      ;; be nice and cautious about failures to 
	      ;; read some SPL, i.e., including
	      ;; garbage input...
	      ;; ----------------------------------------
	      (if *text-mode*
		  (loop for s = (safe-read nil) while s collect s)
		(safe-read T)
		)))
	 input-data-list))))

  ;; ---------------------------------------------------------------------
  ;; Following not yet supported. 

  ;; ----------------------------------------------------------------------
  ;; Send the generated result via a Windows DDE conversation...
  ;; ----------------------------------------------------------------------

(defun GET-INPUT-FROM-DDE-CONVERSATION ()
  (format *trace-output* "~%;;; DDE interaction not yet supported.")
  nil)

  ;; ----------------------------------------------------------------------
  ;; Send the generated result via a Windows DDE conversation...
  ;; ----------------------------------------------------------------------

(defun SEND-GENERATED-OUTPUT-VIA-DDE (result)
  nil)


  ;; ----------------------------------------------------------------------
  ;; small utility for portability...
  ;;
(defun GET-COMMAND-LINE ()
  (let ((input #+lispworks4 (cdr (io::io-get-command-line-arguments))
	       #+lispworks5  
	       (string-append 
		(win32::get-command-line)
		" ")))
    #+lispworks4 input
    #+lispworks5
    (loop with j = 0 
	  for i from 0 to (1- (length input))
	  when (char= (char input i) #\space)
	  collect (prog1 (subseq input j i)(setf j (1+ i))))))

  ;; ----------------------------------------------------------------------
  ;; Make the initial settings of the various flags settable by command
  ;; line parameters. All are optional. A command may be returned for
  ;; initial performance via the :first flag. Note that this must
  ;; be returned as a keyword symbol to be recognised appropriately
  ;; in the course of normal processing.
  ;;
  ;; parameters are:
  ;;   :in       sets the default SPL input file
  ;;   :out      sets the default generated result output file
  ;;   :first    sets the first command to be performed
  ;;   :poling   sets poling frequency
  ;;   :mono     if present sets the strictly monolingual mode
  ;;   :verbose  if present sets verbosity on
  ;;   :html     if present puts us in HTML IO mode
  ;;   :text     if present always processes all the SPLs in the input file
  ;;   :with-domain  loads the identified file as a domain model
  ;;   :with-lexicon  loads the identified file as a lexicon file
  ;;   :port     if present, goes for socket-based communication
  ;; ----------------------------------------------------------------------

(defun PROCESS-ANY-COMMAND-ARGUMENTS ()
  (let* ((command-line (get-command-line))
	 (position nil)
	 (length (1- (length command-line)))
	 (first nil))
    (when (>= length 0)
      (when (member ":verbose" command-line :test #'string=)
	(setf *waiting-verbose* T))
      (when *waiting-verbose*
	(format *trace-output* "~%;;; Command line was: ~S" command-line))
      (when (member ":mono" command-line :test #'string=)
	(setf *rigidly-monolingual* T))
      (when (setf position (position ":poling" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (let ((pf (read-from-string (elt command-line (1+ position)))))
	  (setf *poling-frequency* 
		(if (and (integerp pf)(> pf 0))
		    pf
		  1)))))
      (when (member ":html" command-line :test #'string=)
	(setf *html-mode* T))
      (when (member ":xml" command-line :test #'string=)
	(setf *html-mode* T))
      (when (member ":text" command-line :test #'string=)
	(setf *text-mode* T))
      (when (setf position (position ":in" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *spls-input-file* (elt command-line (1+ position)))))

      ;; the following requires additional action, as we immediately
      ;; reconfigure according to the argument given...
      (when (setf position 
		  (position ":confile" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *config-init-file* (elt command-line (1+ position)))
	  (when (probe-file *config-init-file*)
	    (process-configuration-file *config-init-file*))))

      ;; similarly for this option, but we just use the default
      ;; configuration file mechanisms...
      (when (setf position 
		  (position ":configure" command-line :test #'string=))
	(kpml::load-kpml-configuration-file))

      (when (setf position (position ":out" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *kpml-output-file* (elt command-line (1+ position)))))

      (when (setf position (position ":port" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *port-number* 
		(read-from-string (elt command-line (1+ position))))
	  (if (numberp *port-number*)
	      (cl-user::start-kpml-server *port-number*)
	    (progn
	      (format *trace-output* 
		      "~%;;; Bad port number given: ~S!" *port-number*)
	      (setf *port-number* nil)))))

      (when (setf position (position ":with-domain" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *domain-file* (elt command-line (1+ position)))
          (if (probe-file *domain-file*)
	      (load *domain-file*)
	    (format *trace-output* 
		    "~%;;; Requested domain file: ~S did not exist!" 
		    *domain-file*))))

      (when (setf position (position ":with-lexicon" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf *domain-file* (elt command-line (1+ position)))
          (if (probe-file *domain-file*)
	      (load *domain-file*)
	    (format *trace-output* 
		    "~%;;; Requested lexicon file: ~S did not exist!" 
		    *domain-file*))))

      (when (setf position (position ":first" command-line :test #'string=))
	(unless (> (1+ position) length)
	  (setf first (elt command-line (1+ position)))
	  (if (stringp first)
	      (setf first 
		    (intern
		     (string-upcase
		      (if (char= (char first 0) #\:) 
			  (subseq first 1)
			first))
		     "KEYWORD"))
	    (setf first nil))
	  )))
    (list first)))

;;; ----------------------------------------------------------------------
;;; Utilities/extras...
;;; ......................................................................

(defun REPORT-VAR-VALUES (stream)
  (format stream "~{~%;;;    ~{~30A = ~S~}~}"
	  `(("SPLs input file" ,*spls-input-file*)
	    ("Generated output file" ,*kpml-output-file*)
	    ("Configuration file" ,*config-init-file*)
	    ("Current language" ,*waiting-language*)
	    ("HTML mode" ,*html-mode*)
	    ("Poling frequency" ,*poling-frequency*)
	    ("DDE activated (should be NIL)" ,*dde-activated*))))

(defun PRINT-WELCOME-LINES (stream)
  (format stream "~%;;; KPML Version 4.0")
  (format stream "~%;;;       Multilingual Natural Language Generation System")
  (format stream "~%;;;       for systemic-functional grammars")
  (format stream "~2%;;; Copyright (C) 1999-2007, John Bateman, University of Bremen.")
  (format stream "~%;;; KPML comes with no warranty and use is at your own risk.")
  (format stream "~%;;; Commercial use is prohibited; contact the author for licensing.")
  (format stream "~2%;;; This version of KPML is running with:")
  (format stream "~%;;;      Lispworks (www.lispworks.com), Loom (www.isi.edu), ")
  (format stream "~%;;;      and is file- or socket-based for input and output. ")
  (kpml::describe-kpml)
  (format stream "~%;;; Loaded grammar details (if any): ~{~%;;;    ~A~}"
	  (third 
	   (assoc *waiting-language* kpml::*language-description-profiles*)))
  (format stream "~%;;;~%;;; [~A processing ~%;;;        ~A -> ~A ...]" 
	  (time-stamp) *spls-input-file* *kpml-output-file*)
  )

;;;
;;; The following can be added into the main code in any case....
;;;

(defun LANGUAGE-VARIETY-LOADABLE-P 
  (variety-designation &optional 
		       &key
		       (root-directory common-lisp-user::*root-of-resources*))
  (and 
   (symbolp variety-designation)
   (let* ((lg-name (string variety-designation))
	  (lg-root-directory 
	   (pathname
	    (concatenate 
	     'string 
	     (namestring root-directory) lg-name (string *directory-delimiter*)))))
     (lg-directory-p (pathname lg-root-directory)))))

#|| Following not yet ready for use... needs some more docu about how
    these things work or fail to work with LWW4.1

    The method definitions unclear and so does not run.

  ;; ----------------------------------------------------------------------
  ;; Get the input data from a Windows DDE conversation...
  ;;
  ;; Interaction:
  ;;   The black box functions as a server. It handles messages 
  ;;   that may be sent from other processes via the DDE link.
  ;;   Examples of how to do that are limited here to other Lisp
  ;;   processes.
  ;;  
  ;; Client setup:
  ;;   (defclass kpml-bb-conversation (win32::dde-client-conversation)())
  ;;   (define-dde-client :kpml-bb :class kpml-bb-conversation)
  ;;
  ;; Client interaction request:
  ;;       (win32::dde-request* :KPMLBLACKBOX '|KPML_BB_exec| "<message>")
  ;;
  ;; i.e., Service: KPMLBLACKBOX, Topic: KPML_BB_exec
  ;;
  ;; The <message> corresponds exactly to the input items expected
  ;; in the data-file communication mode. A number of requests can
  ;; be sent in the same conversation by using with-dde-conversation.
  ;; ----------------------------------------------------------------------

(defun INIT-DDE-INTERACTION ()
  ;; create a server class that has the service name KPMLBLACKBOX...
  (win32::define-dde-server kpml-bb-dde-class "KPMLBLACKBOX")

  ;; 
  (win32::define-dde-server-function 
   (kpml-bb-fn :server kpml-bb-dde-class :topic-class |KPML_BB_exec|  :result-type string)
   :request
   ()
   (format t "~%~S" "hello"))

  ;; start the server...
  (win32::start-dde-server 'kpml-bb-dde-class)
  )

||#
