(in-package "KPML")

;;; File: generation-results.lisp
;;;
;;; John:Brisbane:Apr95.
;;; ---------------------------
;;; 
;;; Contains definition of the linguistic object: generated strings.
;;;
;;; 2.0
;;; Fairly vanilla methods for adding SGML-style markup to a generated string
;;; are now included. Nothing fancy, users can extend as required...
;;; Methods are provided that many be specialized for style and language.
;;; 
;;; 4.0 xml support for annotations added, with more comfortable passing
;;;       over of attributes as standard.
;;;     additional slots added to the printable structure for carrying 
;;;       glosses and transliterations, and also the classify/inflectify
;;;       features which can now be stored to the example record. This
;;;       information was not previously available in the example record.
;;;

(defstruct printable-constituent 
  "Presentation structure for generated strings"
  (id nil)
  (concept nil)
  (spelling nil)
  (gloss nil)                 ;;; 4.0
  (translit nil)              ;;; 4.0
  (features nil)              ;;; 4.0
  (lexeme nil)                ;;; 4.0
  (node-type nil)
  (annotation nil)            ;;; added for KPML 0.8
  (functions nil)             ;;; added for KPML 0.8
  )

;;; This brings the structure for presentation management that is
;;; generated along side the generation of strings up to date. It
;;; makes use of the original mouseable sentence code I put into
;;; Penman in 1989 or so, which is also now moved here. 
;;; It is updated so that that it is the
;;; *final* string that is now mouseable, not the pre-final one
;;; which had not yet undergone `phonological' processing and
;;; consisted mainly of stems. The default behavior of KPML will
;;; be that *all* constituents in the string are mouse sensitive
;;; and that the normal operations available from graphing that
;;; structure are supported. The presentation structure will also
;;; include a slot that can be filled directly by the user by
;;; an annotation in the SPL. 
;;; ----------------------------------------------------------------------

;;; Basic method is to set up a level of indirection between the
;;; string itself and the structure pointing to the string, so that
;;; we can keep track of changes to the string by changing the 
;;; indirection pointers rather than the structure.

(defstruct PTR-TO-STRING
  (start 0)
  (end   0))

(defun INITIAL-LEAF-STRING-POINTERS (length)
  (let ((pointers (make-hash-table :size (max length 1))))
    (loop for n from 0 to length do 
	  (setf (gethash n pointers) n))
    pointers))


;;; Following function takes the printable-constituent structure that
;;; is built up during generation and builds an initial generated
;;; string from that structure. As a side-effect, the substrings
;;; present in the structure are replaced by pointers to the the
;;; relevant substrings in the string.
;;;
(defun CREATE-STRING-FROM-PRINTABLE-CONSTITUENT (printable-constituent)
  (let ((working-string "")(working-length 0))
    (labels 
     ((update-string-from-structure
       (printable-constituent)
       (let ((added-string "")(added-length 0))
	 (setf (printable-constituent-spelling printable-constituent)
	       (loop for subcomp in (printable-constituent-spelling 
				     printable-constituent)
		     collect
		     (if (typep subcomp 'printable-constituent)
			 (update-string-from-structure subcomp)
		       (progn
			 (setf working-length (length working-string))
			 (setf added-string
			       (if (typep subcomp 'symbol)
				   (concatenate
				       'string
				     " [" (string subcomp) "] ")
				 subcomp))
			 (setf added-length (length added-string))
			 (setf working-string
			   (concatenate
			       'string
			     working-string added-string))
			 (make-ptr-to-string :start working-length
					     :end (+ working-length 
						     added-length))))))
	 printable-constituent)))
     (update-string-from-structure printable-constituent)
     working-string)))


;;; Following function makes a string from the presentation structure
;;; respecting the indirection that has been set up in `pointers'. 
;;; (IT IS NOT DEBUGGED, AND MAY NOT EVEN BE NECESSARY: IF 
;;;  REQUIRED IT CAN BE CHANGED ALONG THE LINES OF THE FUNCTION
;;;  REMOVE-INDIRECTION-FROM-INDIRECT-PRINTABLE-CONSTITUENT, WHICH
;;;  IS DEBUGGED.)
(defun CREATE-STRING-FROM-INDIRECT-PRINTABLE-CONSTITUENT 
  (printable-constituent string pointers)
  (let ((working-string nil)
	(right-edge 0))
    (dolist (subcomp (printable-constituent-spelling printable-constituent))
      (cond ((typep subcomp 'printable-constituent)
	     (setf working-string 
		   (concatenate 'string 
		    working-string
		    (create-string-from-indirect-printable-constituent 
		     subcomp string pointers))))
	    (t
	     (let ((start (gethash (ptr-to-string-start subcomp)
				   pointers))
		   (end (gethash (ptr-to-string-end subcomp)
				 pointers)))
	       (setf right-edge (max end right-edge))
	       (setf working-string 
		 (concatenate 'string
		   working-string 
		   (subseq string
			   (max start right-edge)
					    right-edge)))))))
    working-string))

;;; ----------------------------------------------------------------------
;;; Following function replaces the indirect references in the
;;; printable constituent structure by the corresponding strings.
;;;
 ;; 3.2.61
 ;;  following function was not getting the results distributed
 ;;  properly, even though the string has been changed correctly.
 ;;  This was due to a thinko in the use of the 'special' formal
 ;;  parameter which was meant to make sure that slack elements
 ;;  are moved over. They were not being moved over and so elements
 ;;  of the string were being repeated. 

(defun REMOVE-INDIRECTION-FROM-INDIRECT-PRINTABLE-CONSTITUENT 
  (printable-constituent string pointers &optional (right-edge 0))
  (let ((*right-edge* right-edge))
    (declare (special *right-edge*))
    (rifipc printable-constituent string pointers)))
  
(defun RIFIPC (printable-constituent string pointers)
  (let ((length (length string)))
    (declare (special *right-edge*))
    (setf (printable-constituent-spelling printable-constituent)
	  (remove 
	   ""
	   (loop for subcomp in 
		 (printable-constituent-spelling printable-constituent)
		 collect
		 (cond ((typep subcomp 'printable-constituent)
			(rifipc subcomp string pointers))
		       ((typep subcomp 'ptr-to-string)
			(let* ((start (gethash (ptr-to-string-start subcomp)
					       pointers))
			       (end (gethash (ptr-to-string-end subcomp)
					     pointers))
			       (indirected 
				(if (< start end)
				    ;; KPML4 : be very cautious here... and make doubly
				    ;;         sure that we do not bump beyond the edge
				    ;;         of the string
				    (let ((local-start (min
							(max start *right-edge*)
							length))
					  (local-end (min 
						      (max end *right-edge*)
						      length)))
				      (if (< local-start local-end)
					  (subseq string local-start local-end)
					""))
				  (progn
				    (setf *right-edge* start)
				    ""))))
			  (setf *right-edge* (max end *right-edge*))
			  indirected))
		       (t
			(error "Something ugly in the printable constituent")
			"ERROR"))
		 )
	   :test #'(lambda (x y)(and (stringp x)(stringp y)(string= x y)))))
    printable-constituent))

;;; ----------------------------------------------------------------------
;;; Makes a convenient list structure recording the constituency
;;; structure of the printable-constituent. For use in pretty
;;; printing (particularly when a window interface is not
;;; present).

(defun PRINTABLE-CONSTITUENT-TO-STRUCTURE-TREE (printable-constituent)
  (cons 
   (printable-constituent-functions printable-constituent)
   (if (eq (printable-constituent-node-type printable-constituent)
	   :terminal)
       (printable-constituent-spelling printable-constituent)
     (loop for i in (printable-constituent-spelling printable-constituent)
	   when (printable-constituent-p i)
	   collect (printable-constituent-to-structure-tree i)))))

  ;; ----------------------------------------------------------------------
  ;; 4.0 Similarly, but collects the gloss and translit slots instead
  ;;     of functions.
  ;; ----------------------------------------------------------------------

(defun MAKE-CONSTITUENT-LIST-WITH-INTERLINEARS (printable-constituent &optional (marker nil))
  (if (eq (printable-constituent-node-type printable-constituent)
	  :terminal)
      (let ((info (list 
		   (printable-constituent-spelling printable-constituent)
		   (printable-constituent-gloss printable-constituent)
		   (printable-constituent-translit printable-constituent))))
	(if marker
	    `(,marker ,@info)
	  info))
    (loop for i in (printable-constituent-spelling printable-constituent)
	  when (printable-constituent-p i)
	  collect (make-constituent-list-with-interlinears i marker))))




;;;----------------------------------------------------------------------
;;; All `grapho/phonological' operations on the string prior to
;;; finalization must now be made using the following function. 
;;; This effects substition of `count' occurrences of the `old'
;;; substring by the `new' substring, side-effecting `pointers'
;;; so that pointers to any substring keep pointing to the
;;; possibly re-located or transformed substring.
;;;

(defun SUBSTITUTE-PRESERVING-PTRS 
  (new old working-string pointers &key count)
  (if (and (numberp count)
	   (<= count 0))
      working-string
    (let* ((start-in-working  (search old working-string))
	   (old-len (length old))
	   (new-len (length new))
	   (len-diff (- new-len old-len)))
      (do ((i 1 (1+ i))) ((not start-in-working) working-string)
	  (if (= new-len old-len)
	      (replace working-string new 
		       :start1 start-in-working
		       :end1 (+ start-in-working old-len))
	    (progn
	      (setq working-string (concatenate 
				    'string
				    (subseq working-string 
					    0 start-in-working)
				    new
				    (subseq working-string 
					    (+ start-in-working old-len))))
	      (update-string-ptrs (find-start-in-original 
				   start-in-working pointers)
				  old-len new-len len-diff pointers)))

	  (if (or (not count)
		  (< i count))
	      (setf start-in-working
		      (search old working-string
			      :start2 (+ start-in-working new-len)))
	    (setf start-in-working nil)))
      )
    ))

;;; We use the above so often in grapho/phonological processing that
;;; it has a nickname:
;;;
(defmacro SUB (&rest args) `(substitute-preserving-ptrs ,@args))

;;; Unwinds the indirection to find where we have to start changing
;;; pointers...
;;; 1.1 the mapping value to key is one-to-many. Following changed so
;;;     that it looks at all possible values and chooses the highest one.
;;;     We'll have to check whether this gives the desired behaviour in
;;;     all cases.
;;; 2.0 when no candidate found, return NIL for noop 
;;;     in update-string-pointers.

(defun FIND-START-IN-ORIGINAL (start-in-working pointers)
  (let ((candidates nil))
    (maphash #'(lambda (key value)
		 (when (eq value start-in-working)
		       (push key candidates)))
	     pointers)
    (if candidates
	(apply #'max candidates)
      nil)))


;;; Following has to transform the pointers so that all pointer pairs
;;; that would have picked out a string will still pick out the
;;; corresponding string in the modified string... Need to know how
;;; many characters are in the new form as well as how many were in
;;; the old form in order to fill out unused positions with values
;;; that make sense.

;;; 1.1 Occasionally we lose the start of the replacement, this is
;;;     probably due to an unfortunate indeterminism in the pointers
;;;     hashtable in the mapping from value to key. Needs to be fixed.
;;;     For now, when a null start comes through, just do a noop to make
;;;     sure that this never breaks on the user. 
;;;     Cf. also find-start-in-original which has been modified.
;;; 2.0 yet another fix...
;;;
(defun UPDATE-STRING-PTRS (start old-len new-len diff pointers)
  (when start
	(let ((length (1- (hash-table-count pointers))))
	  (cond ((> diff 0)
		 (loop for i from (1+ start) to length do
		       (let ((new-ptr (+ (gethash i pointers) diff)))
			 (setf (gethash i pointers)
			       (if (< new-ptr 0) 0
				 new-ptr)))))
	  ((< diff 0)
	   (let ((lost-chars (gethash (+ start new-len) pointers)))
;;; 0.8.30 was not guaranteeing getting to the overlapped character.
;;; 2.0    but was clobbering one too many of the characters following
;;;        the string to be replaced (unless new-len is 0... yuck).
	     (loop for j from 1 
		 to (if (zerop new-len) old-len (1- old-len))
		 as i from (+ start new-len 1)
		 do
		   (setf (gethash i pointers) lost-chars))
;;; 0.8.30 but was sometimes hitting the same character twice...
	     (loop for i from (+ start old-len 1) to length
		   do
		   (let ((new-ptr (+ (gethash i pointers) diff)))
		     (setf (gethash i pointers)
		       (if (< new-ptr 0) 0
			     new-ptr))
		     ))
	     ))
	  (t
	   nil)))))

;;; ----------------------------------------------------------------------
;;; Following function is allowed to make arbitrary changes to the
;;; string *as long as no positions are altered*. This is only used
;;; for one case at present. Something about different languages
;;; should happen more sensibly...

;;; 2.0 as a complete hack, I'm adding for the present a list of
;;;     languages which do not like having their initial letters
;;;     of clauses capitalized.... (John:Edinburgh:May98)
;;; 4.0 added Chinese to the default, although this is also
;;;     now settable in the resource definitions...
;;;
(defvar *languages-with-no-sentence-initial-capitalization*
    '(:japanese :chinese))
;;;
;;;     as well as a disabling flag that turns this behaviour off
;;;     as well (used in the Coder).
(defvar *capitalize-sentence?* T)

(defun POSITION-PRESERVING-GRAPHOLOGICAL-PROCESSING (string)
  ;; capitalize first word. Done here...
  ;; 1.1 which requires skipping over any quotation marks, brackets, etc.
  ;;      that may precede...
  ;; 4.0 and, actually, any spaces that precede in case they have not
  ;;      not yet been trimmed... not sure why and when actually that
  ;;      can happen, but it does sometimes...
  ;;

  (unless (or (string= string "") 	
	      (not *capitalize-sentence?*))
    (unless 
	(member curlan *languages-with-no-sentence-initial-capitalization*)
      (loop for s from 0 
	  while (< s (length string))
	  when (not (member (char string s) *opening-punctuation-bag*))
	  do
	    (setf (char string s) (char-upcase (char string s)))
	    (return-from POSITION-PRESERVING-GRAPHOLOGICAL-PROCESSING
	      string))))
  string)
  


;;; ----------------------------------------------------------------------

;;; The top-level mouseable string algorithm...
;;;
;;; Produces two values: the final string that is the result of
;;; generation and a presentational structure for that string.
;;; On exit from `say' and `say-spl' the presentational
;;; structures are left in the globals *mouseable-sentence*
;;; and *mouseable-sentences*.
;;; 
;;; The input is an original printable-constituent as produced from
;;; a complete set of traversals of the grammar. This first undergoes
;;; `phonological processing' that does a number of simple changes
;;; based on the presentation structure itself. The phonological
;;; processing routine side-effects the structure given as argument.
;;;
;;; Following this, we create the first string representation and the
;;; indirection pointers to this string. The string is returned to
;;; initial-string and the indirection pointers are side-effected into
;;; the structure given as argument.
;;;
;;; Then we perform the `graphological processing' on this string,
;;; preserving pointers to substrings so that changes do not leave
;;; mouseable presentations hanging. Graphological processing 
;;; includes very simple capitalization, removal of errors 
;;; introduced by the structural approach to punctuation embodied
;;; in all-orderings and the punctuation rules, etc. The
;;; structure returned already includes the *finalized* 
;;; string: that is, there is nothing more to do with this
;;; string apart from print it out.
;;; 
;;; 2.0 added language to phonological-processing call, since this
;;;     is now defined as a method and can be conditionalized by
;;;     language.
;;; 4.0 add a flag for stopping the side-effect of capitalising
;;;     whatever string happens to come in...

(defun MOUSEABLE-PROCESSED-STRING-FROM-PRINTABLE-CONSTITUENT
  (printable-constituent &key (no-changes-p nil))
  (let ((*capitalize-sentence?* (if no-changes-p nil *capitalize-sentence?*)))
    (declare (special *capitalize-sentence?*))
    (let* ((phonological-processing-performed?
	    (phonological-processing printable-constituent curlan))
	   (initial-string
	    (create-string-from-printable-constituent printable-constituent))
	   (pointers (initial-leaf-string-pointers (length initial-string)))
	   (middle-string (graphological-processing initial-string pointers))
	   (final-string (position-preserving-graphological-processing
			  middle-string)))
    
      (remove-indirection-from-indirect-printable-constituent 
       printable-constituent
       final-string
       pointers)
    
      (values
       (printable-constituent-to-printable-list printable-constituent)
       printable-constituent))))


  ;; ----------------------------------------------------------------------
  ;; 4.0 addition that helps provide more information for the
  ;;     printable constituents and probably elsewhere too.
  ;;
  ;; Mapper from grammatical function to metafunction. The basic
  ;; assumption is that the metafunction of the system inserting
  ;; the function defines its metafunction. This is not quite right
  ;; in Nigel so massage it...
  ;;
(defun GRAMMATICAL-FUNCTION-to-METAFUNCTION (f)
  (let* ((bare-f (remove-fn-tag f))
	 (raw-mf (fetch-system-metafunction (caar (who-can-insert bare-f)))))
    (if raw-mf
	(case raw-mf
	      (blend 'unifying)
	      (experiential 'ideational)
	      (otherwise raw-mf))
      'unknown)))




;;; ----------------------------------------------------------------------
;;; DEBUGGING AIDS...


;;; ----------------------------------------------------------------------
;;; Place calls to this function whenever the current skewing of the
;;; indirection pointers is to be checked...
;;; Tracing substitute-preserving-ptrs also demarcates the following
;;; output well. 


(defun DEBUG-POINTERS (pointers)
  (let ((ptrs nil))
    (maphash #'(lambda (key value) 
		 (unless (eq key value)
		   (push (list key value) ptrs)))
	     pointers)
    (format 
     t "Changed character indirection pointers: ~{~{~%key: ~S -> value: ~S~}~}"
     (sort ptrs #'< :key #'car))))

;;; This function just prints the string along with the character
;;; positions for ease of reference during debugging.

(defvar *s* "" "For holding strings for debugging")

(defun STRING-POINTERS (string)
  (setf *s* string)
  (format t "~%~A~%" string)
  (loop for i from 0 to (length string) by 10
      do (loop for j from 0 to 9 do (format t "~A" j)))
  (format t "~%")
  (loop for i from 0 to (/ (length string) 10)
      do (format t "~A         " i)))

;;; ----------------------------------------------------------------------

(defun PRINTABLE-CONSTITUENT-TO-STRUCTURED-LIST (printable-constituent)
  (let ((working-list nil))
    (dolist (subcomp (printable-constituent-spelling printable-constituent))
      (cond ((typep subcomp 'printable-constituent)
	     (setf working-list (append working-list 
					(list (printable-constituent-to-structured-list subcomp)))))
	    (t
	     (setf working-list (append working-list (list subcomp))))))
    working-list))


(defun PRINTABLE-CONSTITUENT-TO-PRINTABLE-LIST (printable-constituent)
  (let ((working-list nil))
    (dolist (subcomp (printable-constituent-spelling printable-constituent))
      (cond ((typep subcomp 'printable-constituent)
	     (setf working-list (append working-list 
					(printable-constituent-to-printable-list subcomp))))
	    (t
	     (setf working-list (append working-list (list subcomp))))))
    working-list))

;;; ----------------------------------------------------------------------
;;; 2.0 and the markup makers...
;;;
;;; The following is made a bit more complex by our making sure that
;;; only the outermost occurrence of a particular semantic entity
;;; receives mark-up. This is suitable for HTML, but perhaps needs
;;; parameterization for other forms of markup that could be
;;; envisaged.

(defun PRINTABLE-CONSTITUENT-TO-MARKED-UP-STRING (printable-constituent)
  (let ((semantics-occurs-check (make-hash-table :test #'equal)))
    (labels ((process (printable-constituent)
	       (let ((tag nil)(ctag nil)(done? nil)
		     (annotation 
		      (printable-constituent-annotation printable-constituent))
		     (sem 
		      (printable-constituent-concept printable-constituent)))
		 (if (gethash sem semantics-occurs-check)
		     (setf done? T)
		   (setf (gethash sem semantics-occurs-check) T))
		 (when (kpml-string-markup-p annotation curlan *markup-style*)
		   (multiple-value-bind (ob cb) 
		       (kpml-make-markup annotation curlan *markup-style*)
		     (setf tag ob ctag cb)))
		 (append
		  (if done? nil tag)
		  (loop for subcomp 
		      in (printable-constituent-spelling printable-constituent)
		      when (typep subcomp 'printable-constituent)
		      append (process subcomp)
		      else append (list subcomp))
		  (if done? nil ctag)))))
      (process printable-constituent))))

(defmethod KPML-STRING-MARKUP-P (annotation lg style)
  (declare (ignore annotation lg style))
  nil)

(defmethod KPML-MAKE-MARKUP (html-annotation lg style)
  (declare (ignore html-annotation lg style))
  (values nil nil))

;;; These methods may be specialized for individual languages and styles by 
;;; statements of the form:

(defmethod KPML-STRING-MARKUP-P (annotation lg (style (eql :html)))
  (and annotation
       (consp annotation)
       (or (eq (first annotation) :html)
	   (eq (first annotation) :xml)      ;; 4.0
	   )))

;;; ----------------------------------------------------------------------
;;; 3.2.5
;;;
;;; Add the following html annotation behaviours: 
;;;   (i) an annotation (:html em) inserts <em> and </em> tags
;;;  (ii) an annotation (:html "<em>" "<me>") inserts <em> ... <me> tags
;;;
;;; Note that it is important that in variety (ii) strings are given.
;;; These strings must be complete in their own right: e.g.,
;;;         (:html "<ui><li>"  "</li></ul>")
;;; The second element may be a null string, and if so, it may be 
;;; ommitted.
;;;
;;; 4.0
;;; 
;;; Made more comfortable for HTML/XML mark up by providing the
;;; facility of using attributes. Also XML added as a synonym for
;;; HTML, since we don't actually check to see if we are really
;;; doing HTML. The only difference being that the XML style enforces
;;; closing tags. More fancy XML attributes or tags
;;; with namespaces and the like must be given with escaped Lisp
;;; symbols in the usual way, e.g., :|ns:attr|. 
;;;
;;; Form of an xml tag is:
;;;   (:xml tag :attr1 val1 :attr2 val2 ... :attrN valN)
;;;
;;; values are coerced to strings if they are not strings already.
;;; A closing </tag> is supplied automatically and obligatorily.
;;; Syntax errors are not corrected, just reported and the annotation
;;; fails with the information accumulated so far. In all cases
;;; the opening and closing metatags "<" and ">" are supplied 
;;; automatically.
;;; ----------------------------------------------------------------------

(defmethod KPML-MAKE-MARKUP (html-annotation lg (style (eql :html)))
  (let ((style (first html-annotation))
	(tag1  (second html-annotation))
	(attrs (cddr html-annotation)))
    (case style
	  (:html
	   (if (symbolp tag1)
	       (values
		(list (concatenate 'string "<" (string tag1) ">"))
		(list (concatenate 'string "</" (string tag1) ">")))
	     (if (stringp tag1)
		  (let ((tag2 (if (third html-annotation)
				  (third html-annotation)
				"")))
		    (values (list tag1)(list tag2)))
	       (warning "Ill-formed HTML tag: " html-annotation "."))))
	  (:xml
	   (make-xml-markup tag1 attrs))
	  (otherwise
	   (warning "Unsupported tag style: " style)))))


  ;; 4.0 addition
  ;;
(defun MAKE-XML-MARKUP (tag1 attrs)
  (let* ((xml-annotation (format nil "~S" attrs))
	 (attr-val-pairs nil)
	 (tag0 
	  (typecase tag1
		    (string tag1)
		    (symbol (string tag1))
		    (otherwise
		     (warning "Ill-formed XML tag: " tag1 ".")
		     "tagerror")))
	 (tag 	  (concatenate 'string "<" tag0)))

    (when attrs
      (setf attr-val-pairs
	    (loop for attr on attrs by #'cddr
		  for val = (cadr attr)
		  when (and (keywordp (car attr)) val)
		  collect (string-append
			   " "
			   (string (car attr)) 
			   "="
			   (format nil "\"~A\"" val))
		  else do (if val 
			      (warning "Ill-formed XML attribute at "
				       (car attr) " in: " 
				       xml-annotation ".")
			    (warning 
			     "Ill-formed XML attribute list in: " 
			     xml-annotation ".")))))
    (values
     (list (concatenate 
	    'string tag 
	    (if attr-val-pairs 
		(reduce 'string-append attr-val-pairs)
	      "")
	    ">"))
     (list
      (concatenate 'string "</" tag0 ">"))
     )))

;;; ----------------------------------------------------------------------
;;; This makes the following straightforward to define for example...
;;;
(defun HTML-SAY (input &key
		       (preselections nil)
		       (language NIL)
		       (morphology NIL))
  (labels ((string-append (s1 s2) (concatenate 'string s1 s2)))
    (let ((*markup-style* :html))
      (declare (special *markup-style*))
      (reduce
       #'string-append
       (printable-constituent-to-marked-up-string
	(surface-structure input 
			   :preselections preselections 
			   :language language
			   :morphology morphology))))))

  ;; ----------------------------------------------------------------------
  ;; 4.0 and while we are at it, this is a good place to put
  ;; the following:
  ;; ----------------------------------------------------------------------

(defvar *server-failure-string* "huh?")

(defmacro IRON-PLATED-XML-SAY (example)
  `(unwind-protect
       (multiple-value-bind
	(value error)
	(ignore-errors
	 (let ((*demo-mode* T)
	       (example-runner-flag T))
	   (declare (special example-funner-flag *demo-mode*))
	   (concatenate 'string
			"<utterance>"
			(html-say ,example)
			"</utterance>")))
	(progn
	  (if error
	      (progn
		(setf *serious-failure-count* (1+ *serious-failure-count*))
		(push ,example *serious-failures*)
		*server-failure-string*)
	    value)))))

  ;; 4.1 addition...
  ;;
(defmacro IRON-PLATED-SIMPLE-SAY (example)
  `(unwind-protect
       (multiple-value-bind
	(value error)
	(ignore-errors
	 (let ((*demo-mode* T)
	       (example-runner-flag T))
	   (declare (special example-funner-flag *demo-mode*))
           (html-say ,example)))
         (progn
	  (if error
	      (progn
		(setf *serious-failure-count* (1+ *serious-failure-count*))
		(push ,example *serious-failures*)
		*server-failure-string*)
	    value)))))

  ;; ----------------------------------------------------------------------
  ;; 3.2.37
  ;;   Printing printing for generated structures independent of
  ;;   of a window interface (this is probably already there
  ;;   somewhere!)
  ;; ----------------------------------------------------------------------

(defun PPRINT-MOUSEABLE-STRUCTURE 
  (result
   &key
   (indent 0)
   (stream T))
  (labels ((pprint-mouseable-structure-intern
	    (mouseable-structure constit indent)
	    (format stream "~%")
	    (format stream "~VT [~{~A~^/~}]" indent (first constit))
	    (cond ((stringp (second constit))
		   (format stream ".. = ~S" (second constit)))
		  (t
		   (loop for sub in (cdr constit) do
			 (setf indent (+ indent 4))
			 (pprint-mouseable-structure-intern
			  mouseable-structure sub indent)
			 (setf indent (- indent 4)))))))

	  (format stream "~%Function Structure: ")
	(pprint-mouseable-structure-intern
	 result
	 (kpml::printable-constituent-to-structure-tree result)
	 indent)))