(in-package "KPML")

;;; File: xml-printing.lisp
;;; John, September 2003
;;;
;;; Collects the various output methods for writing out resources 
;;; as XML files compatible with the KPML-given XML schemas. 
;;;
;;; Update: October-December 2003, now following Ted's schemas.
;;;
;;; The schemas are given in the KPML XSD directory. Here are
;;; examples of what the objects look like in XML.
;;;
;;; Systems...
;;; =========
#||
  <SYSTEM>
      <SYSTEM-TYPE>SYSTEM</SYSTEM-TYPE>
      <NAME>CAUSE-POINT-OF-ELABORATION</NAME>
      <INPUTS><and><s>CAUSE</s><s>CIRCUMSTANCE-ELABORATION</s></and></INPUTS>
      <OUTPUTS>
          <out>
              <probability>0.5</probability>
              <feature>CAUSE-ELABORATION</feature>
              <realization><order><a>CAUSE</a><b>ELABORATION</b></order></realization>
          </out>
          <out>
              <probability>0.5</probability>
              <feature>NONCAUSE-ELABORATION</feature>
          </out>
      </OUTPUTS>
      <CHOOSER>CAUSE-POINT-OF-ELABORATION-CHOOSER</CHOOSER>
      <REGION>ELABORATION</REGION>
      <METAFUNCTION>LOGICAL</METAFUNCTION>
  </SYSTEM>
||#

;; ----------------------------------------------------------------------
;; Basic root function ... Based on the nonansi output function
;; for ascii output. The context of this function call is that
;; standard output is reset to the string that is to be returned
;; back up to callers. So to have any effect, this function must
;; write its string to standard output. 
;; 
;; The original output functions could afford to follow the Lisp
;; s-expression form fairly straightforwardly, but for the XML will
;; need to pick out the slots of the various objects as we need them,
;; therefore break out the various slots and deal with them rather
;; than passively following the input list...
;;
;; First we break out according to object types. When these stabilise
;; they can probably be recombined somewhat.
;;
(defun PRINT-XML-LINGUISTIC-OBJECT (list language-set multilingual-mode)
  (declare (ignore language-set))
  (when multilingual-mode
    (warning "Attempting to write linguistic object as XML in multilingual mode. Not supported!")
    (return-from PRINT-XML-LINGUISTIC-OBJECT nil))
  (let ((stream *standard-output*)
	(object-type (pop list))
	(slot-type nil)
	(slot-value nil)
	(lg-restrictions (extract-lg-restrictions list)))
    (case object-type
	  ((system gate)
	   (print-system-as-xml list language-set stream))
	  (chooser
	   (print-chooser-as-xml list language-set stream))
	  ((askoperator identifyoperator)
	   (print-inquiry-as-xml list language-set stream))
	  (lexical-item
	   (print-lexeme-as-xml list language-set stream))
	  (example
	   (print-example-as-xml list language-set stream))
	  (otherwise
	     ;;
	     ;; if we have not headed the object-type off at the pass, do
	     ;; some xml-ish trivial representation of the Lisp data
	     ;; structure. These fall throughs will disappear as the
	     ;; object types are filled in...
	     ;;
	     (format stream "~%<")
	     (format stream "~S" object-type)
	     (format stream "~%")
	     
	     (loop named L
		   while list
		   do (setf slot-type (pop list))
		   (setf slot-value (pop list))
		   (unless (or (null slot-value)
			       (and (stringp slot-value)(string= slot-value ""))
			       (equal slot-type :source-file)
			       (member slot-type *shadowed-slots*))
	  
		     (format stream "    ~A= " slot-type)
		     (case slot-type
			   (:name
			    (if *no-ml-conditionalization*
				(format stream "\"~S\"" 
					(if (symbolp slot-value) 
					    slot-value
					  (first (last slot-value))))
			      (format stream "~S" slot-value)))
			   (:preselectionguidance 
			    (format stream "~A"
				    (xml-pprint-preselection-guidance slot-value)))
			   ((:gloss :english)
			    (if (equal object-type :inquiry)
				(format stream "~A"
					(xml-pprint-inquiry-gloss slot-value))
			      (format stream "~S" slot-value)))
			   (:logicalform
			    (format stream "~%~A"
				    (xml-pprint-spl-logical-form slot-value)))
			   (:semantics
			    (format stream "~A"
				    (xml-pprint-lexical-item-semantics slot-value)))
			   (:operatorcode
			    (if *file-writing*
				(format stream "~A"
					(xml-pprint-operatorcode
					 (if *no-ml-conditionalization* nil
					   multilingual-mode)
					 slot-value lg-restrictions))
			      (format stream "~S" slot-value)))
			   (otherwise
			    (format stream "~S" slot-value)))
		     
		     (format stream "~%")))
	     (format stream "~%</~S>" object-type)
	     ))))


;; ----------------------------------------------------------------------
;; XML print methods for the various object types...
;; 
;; Since we now need to control what information is picked out and
;; when, rather than just following the data structure, we now
;; reuse the parameter passing mechanisms developed for
;; standalone image object definition processing. Particularly:
;; extract-keyword. We define a slightly tailored version
;; of this function below for our own purposes here.
;; I suppose the real Lisp way of doing this would be to 
;; locally redefine macros for the object types and just
;; evaluate the lists that come in... Yeah well, next
;; time round.
;; ----------------------------------------------------------------------

(defun PRINT-SYSTEM-AS-XML (list language-set stream)
  (format stream "~2%<SYSTEM>")
  
  (let ((name            (extract-keyword :name list))
	(inputs          (extract-keyword :inputs list))
	(outputs         (extract-keyword :outputs list))
	(chooser         (extract-keyword :chooser list))
	(region          (extract-keyword :region list))
        (metafunction    (extract-keyword :metafunction list)))
    
    (format stream "~%  <SYSTEM-TYPE>~S</SYSTEM-TYPE>" 
	    (if (= (length outputs) 1) 'gate 'system))

    (format stream "~%  <NAME>~S</NAME>" name)
    (format stream "~%  <INPUTS>~A</INPUTS>" 
	    (apply #'string-append 
		   (flatten (entry-conditions-2-xml inputs))))
	    
    (format stream "~%  <OUTPUTS>")
    (loop for (prob f . rss) in outputs
	  do
	  ;; for the moment, just ditch comments...
	  (let ((rssc (remove-if #'(lambda (x) (equal (first x) '*)) rss)))
	    (format stream "~%      <out>")
	    (format stream "~%        <probability>~A</probability>" prob)
	    (format stream "~%        <feature>~A</feature>" f)
	  
	    (when rssc
	      (format stream "~%       <realization>")
	      (loop for rs in rssc do (xmlify-realization rs stream))
	      (format stream "~%       </realization>"))
	    (format stream "~%      </out>")
	    ))
	      
    (format stream "~%  </OUTPUTS>")

    (format stream "~%  <CHOOSER>~S</CHOOSER>" chooser)
    (format stream "~%  <REGION>~S</REGION>" region)
    (format stream "~%  <METAFUNCTION>~S</METAFUNCTION>" metafunction)
    (format stream "~%</SYSTEM>")
))

  ;; Converts realizations to XML. The XML variants
  ;; assume pairwise relations to be specified. If the
  ;; realization statement contains more then these
  ;; are broken out here into separate realization
  ;; statements...
  ;;
(defvar kpml2xml-rs-mappings '((orderatfront . order-at-front)
			       (orderatend   . order-at-end)))

(defun XMLIFY-REALIZATION (rs &optional (stream T))
  ;;		<order><a>CAUSE</a><b>ELABORATION</b></order></realization>
  ;;
  (let* ((frs (first rs))
	 (type (if (assoc frs kpml2xml-rs-mappings)
		   (cdr (assoc frs kpml2xml-rs-mappings))
		 (first rs)))
	 (open (format nil "<~(~A~)>" type))
	 (close (format nil "</~(~A~)>" type)))
    (if (= (length rs) 2)
	(format 
	 stream 
	 "~%          ~A<a>~A</a>~A" 
	 open (second rs) close)
      (loop for args on (cdr rs)
	    when (> (length args) 1)
	    do
	    (format stream "~%          ~A<a>~A</a><b>~A</b>~A" open (first args)(second args) close)
	    )
      )))

(defun ENTRY-CONDITIONS-2-XML (ec)
  (let (opener closer)
    (typecase ec
	      (cons
	       (if (equal (first ec) 'and) 
		   (setf opener "<and>" closer "</and>")
		 (setf  opener "<or>" closer "</or>"))
	       (list
		opener
		(loop for i in (cdr ec)
		      collect (entry-conditions-2-xml i))
		closer))
	      (otherwise
	       (list "<s>" ec "</s>")
	       ))))


;;; ----------------------------------------------------------------------
;;; Choosers...
;;; ----------------------------------------------------------------------

(defun PRINT-CHOOSER-AS-XML (list language-set stream)
  (format stream "~2%<CHOOSER>")
  
  (let ((name          (extract-keyword :name list))
	(definition    (extract-keyword :definition list))
	(comments      (extract-keyword :comments list))
	(editor        (extract-keyword :editor list))
	(date          (extract-keyword :date list)))
    
    (format stream "~%  <NAME>~S</NAME>" name)

    ;; definition

    (format stream "~%  <DEFINITION>")
    (chooser-definition-as-xml definition stream)
	      
    (format stream "~%  </DEFINITION>")

    (format stream "~%  <COMMENTS>~S</COMMENTS>" comments)
    (format stream "~%  <EDITOR>~S</EDITOR>" editor)
    (format stream "~%  <DATE>~S</DATE>" date)
    (format stream "~%</CHOOSER>")
))

  ;; Expand the definition part of the chooser. This code is a
  ;; reworked version of Chooser-eval in generation/inquiry-interaction.lisp
  ;; with the Clisp replaced by more Common Lisp destructuring.

(defun CHOOSER-DEFINITION-AS-XML (Operator-Calls &optional (stream T))
  (loop for ((op arg1 . rest) . tail) on Operator-Calls
	do 
	(case op
	      (ask
	       (format stream "~%<ask>")
	       (format stream "~%  <q>")
	       (format stream "~%  <qName>~A</qName>" (first arg1))
	       (format stream "~{~%  <qArg>~A</qArg>~}" (cdr arg1))
	       (format stream "~%  </q>")

	       ;; the elements of rest contain the branches...
	       ;; car of each is the choice... 
	       ;; cdr of each is a subtree of the chooser...
	       ;; position of comments may be odd here...

	       (loop for (feature . branch) in rest
		     when feature
		     do 
		     (format stream "~%~8T<qRslt>")
		     (format stream "~%~10T<feature>~A</feature>" feature)
		     (format stream "~%~10T<outcome>")
		     (if branch
			 (chooser-definition-as-xml branch)
		       (format stream "~%<comment>empty branch</comment>"))
		     (format stream "~%~10T</outcome>")
		     (format stream "~%~8T</qRslt>")
		     )
	       (format stream "~%</ask>"))

	      (identify
	       ;; identified is in arg1
	       ;; (car rest) is the operator call with args...
	       
	       (format stream "~%<identify>")
	       (format stream "~%  <feature>~A</feature>" arg1)
	       (format stream "~%  <using>")
	       (format stream "~%    <idName>~A</idName>" (caar rest))
	       (if (cdar rest)
		   (format stream "~{~%    <idArg>~A</idArg>~}" (cdar rest))
		 (format stream "~%    <idArg>--NULL--</idArg>"))
	       (format stream "~%  </using>")
	       (format stream "~%</identify>"))
	      
	      ;; rest are trivial...
	      (copyhub
	       ;;   ** COPYHUB : ONUS : (HEAD)
	       (format stream "~%<copyhub><from>~A</from><to>~A</to></copyhub>" arg1 (car rest)))
	      
	      (pledge
	       (format 
		t "~%<pledge><feature>~A</feature><when>~A</when></pledge>" arg1 (car rest)))
	      
	      (termpledge
	       (format 
		t "~%<termpledge><feature>~A</feature><when>~A</when></termpledge>" 
		arg1 (car rest)))

	      (choose
	       (format stream "~%<choose>~A</choose>" arg1))

	      (defaultchoose
	       (format stream "~%<defaultchoose>~A</defaultchoose>" arg1))

	      ((agreement classify conflate expand inflectify insert
			  lexify order orderatend orderatfront 
			  outclassify partition preselect)
	       
	       ;; realizations can occur here too in old grammars...
	       (xmlify-realization (cons op (cons arg1 rest)) stream))
	      
	      (*
	       (format stream "~%<comment>~S ~S</comment>" arg1 rest))

	      (t 
	       (format stream "~2%** NOT YET HANDLED! ~S : ~S : ~S" op arg1 rest)
	       nil))))


;;; ----------------------------------------------------------------------
;;; Inquiries next...
;;; these are relatively simple, as they have very little internal
;;; structure.
;;; ----------------------------------------------------------------------

(defun PRINT-INQUIRY-AS-XML (list language-set stream)
  (let ((name                      (extract-keyword :name list))
	(domain                    (extract-keyword :domain list))
	(parameters                (extract-keyword :parameters list))
	(english                   (extract-keyword :english list))
	(operatorcode              (extract-keyword :operatorcode list))
	(parameterassociationtypes (extract-keyword :parameterassociationtypes list))
	(createdassociationtype    (extract-keyword :createdassociationtype list))
	(answerset                 (extract-keyword :answerset list))
	(preselectionguidance      (extract-keyword :preselectionguidance list))
	(trivialdefault            (extract-keyword :trivialdefault list)))
    
  (if (branching-inquiry-p name)
      (format stream "~2%<ASKOPERATOR>")
    (format stream "~2%<IDENTIFYOPERATOR>"))

  (format stream "~%  <NAME>~S</NAME>" name)
  (format stream "~%  <DOMAIN>~S</DOMAIN>" domain)
  (format stream "~%  <PARAMETERS>")
  (loop for p in parameters 
	as pt in parameterassociationtypes
	do (format stream "~%     <p><name>~S</name><t>~S</t></p>" p pt))
  (format stream "~%  </PARAMETERS>")
  (format stream "~%  <ENGLISH>")
  (loop for part in english
	if (symbolp part)
	do (format stream "~%           <param>~S</param>" part)
	else 
	do (format stream "~%           <text>~A</text>" (string-trim '(#\space) part)))
  (format stream "~%  </ENGLISH>")
			   
  (format stream "~%  <OPERATORCODE><package>~A</package><name>~A</name></OPERATORCODE>" 
	  (package-name (symbol-package operatorcode))
	  (symbol-name operatorcode))
  (cond ((branching-inquiry-p name)
	 (format stream "~%  <ANSWERSET>~{<a>~S</a>~}</ANSWERSET>" answerset)
	 (xml-pprint-preselection-guidance preselectionguidance stream)
	 (format stream "~%  <TRIVIALDEFAULT>~S</TRIVIALDEFAULT>" trivialdefault)
	 (format stream "~%</ASKOPERATOR>"))
	(t
	 (format stream "~%  <CREATEDASSOCIATIONTYPES><t>~S</t></CREATEDASSOCIATIONTYPES>" 
		 createdassociationtype)
	 (format stream "~%</IDENTIFYOPERATOR>")))
))

;; ......................................................................
;; hacked nonansi variants for the XML forms...
;; ......................................................................

(defun XML-PPRINT-PRESELECTION-GUIDANCE (guidances stream)
  (when guidances
    (let ((guidance nil))
      (format stream "~%  <PRESELECTIONGUIDANCE>")
      (loop
       while guidances 
       do
       (setf guidance (pop guidances))
       (typecase guidance
		 (symbol (format T "What is this? ~S" guidance))
		 (preselection-guide
		  (format stream "~%   <preselect>")
		  (format stream "~%~15T<selection>~S</selection><answer>~S</answer>"
			  (preselection-guide-selection guidance)
			  (preselection-guide-answer guidance))
		  (format stream "~%   </preselect>"))))
      (format stream "~%  </PRESELECTIONGUIDANCE>")
      )))


;;; ----------------------------------------------------------------------
;;; Lexical items are also relatively simple,
;;;  as they have very little internal structure, etc.
;;; ----------------------------------------------------------------------

(defun PRINT-LEXEME-AS-XML (list language-set stream)
  (let ((name                      (extract-keyword :name list))
	(spelling                  (extract-keyword :spelling list))
	(stem                      (extract-keyword :stem list))
	(gloss                     (extract-keyword :gloss list))
	(translit                  (extract-keyword :translit list))
	(sample-sentence           (extract-keyword :sample-sentence list))
	(features                  (extract-keyword :features list))
	(properties                (extract-keyword :properties list))
	(comments                  (extract-keyword :comments list))
	(editor                    (extract-keyword :editor list))
	(date                      (extract-keyword :date list))
	(semantics                 (extract-keyword :semantics list)))

    (format stream "~2%<lexicalItem>")
    (format stream "~%  <name>~S</name>" name)
    (format stream "~%  <spelling>~A</spelling>" spelling)
    (format stream "~%  <sampleSentence>~A</sampleSentence>" sample-sentence)
    (format stream "~%  <features>")
    (loop for p in features 
	  do (format stream "~%     <f>~S</f>" p))
    (format stream "~%  </features>")
    (format stream "~%  <properties>")
    (loop for (p . r) in properties 
	  do (format stream 
		     "~%     <property><feature>~S</feature>~{<value>~S</value>~}</property>" 
		     p r))
    (format stream "~%  </properties>")
    (format stream "~%  <comments>~A</comments>" comments)
    (format stream "~%  <editor>~A</editor>" editor)
    (format stream "~%  <date>~A</date>" date)
    (format stream "~%  <semantics>~S</semantics>" (remove-duplicates semantics))
    (format stream "~%</lexicalItem>")
    ))


;; ----------------------------------------------------------------------
;; Examples are being made progressively more complex. The following 
;; function produces first phase representations that still assume
;; a single backbone structure that all the metafunctions must 
;; respect. This is OK for KPML, as this is the only kind of structure
;; that can be produce; it is only a subclass of the possible structures
;; that SFL requires in general however. The XML produced is being
;; progressed towards being a strict substructure of the more general
;; case.
;; ----------------------------------------------------------------------

(defun PRINT-EXAMPLE-AS-XML (list language-set stream)
  (let ((name                      (extract-keyword :name list))
	(generated                 (extract-keyword :generatedform list))
	(target                    (extract-keyword :targetform list))
	(gloss                     (extract-keyword :gloss list))
	(logicalform               (extract-keyword :logicalform list))
	(structures                (extract-keyword :structure list))
	(expansions                (extract-keyword :expansions list))
	(selexps                   (extract-keyword :selectionexpressions list))
	(preselections             (extract-keyword :preselections list))
	(setname                   (extract-keyword :set-name list))
	)

    (format stream "~2%<example>")
    (format stream "~%  <name>~S</name>" name)
    (format stream "~%  <generatedForm>~A</generatedForm>" generated)
    (format stream "~%  <targetForm>~A</targetForm>" target)
    (format stream "~%  <gloss>~A</gloss>" gloss)

    (format stream "~%  ~A" (xml-pprint-spl-logical-form logicalform))
    
    (format stream "~%  <structures>")
    (when structures
      (unless (consp structures)(setf structures (list structures)))
      (loop for s in structures
	    do (xml-pprint-printable-constituent s stream)))
    (format stream "~%  </structures>")

    (format stream "~%  <expansions>")
    (loop for (cycle parent . children ) in expansions
	  do (format 
	      stream 
	      "~%      <expansion cycle=\"~S\"><parent>~S</parent>~{<child>~S</child>~}</expansion>"
	      cycle parent children))
    (format stream "~%  </expansions>")

    (format stream "~%  <selectionexpressions>")
    (loop for (hub unit . selexp ) in selexps
	  do (format 
	      stream 
	      "~%      <selexp sem=\"~S\"><unit>~S</unit>~{<f>~S</f>~}</selexp>"
	      hub unit selexp))
    (format stream "~%  </selectionexpressions>")

    (format stream "~%  <preselections>")
    (loop for (unit . pres ) in preselections
	  do (format 
	      stream 
	      "~%      <preselection><unit>~S</unit>~{<f>~S</f>~}</preselection>"
	      unit pres))
    (format stream "~%  </preselections>")

    (format stream "~%  <setname>~A</setname>" setname)
    (format stream "~%</example>")
    ))

  

;; ----------------------------------------------------------------------
;; Working result for printable-structures...
;; This is one of the few XML printing methods that actually gets a proper
;; Lisp structure as argument. This is because the printable-constituent
;; form was only meant for internal use: the XML version is therefore the
;; first occasion for exporting this information. Despite this, the 
;; printable-constituent information is actually one of the more useful
;; data structures and so its export is long due.
;; ----------------------------------------------------------------------
;;
;; Sep04: John: we often do not want the cycle tags appearing in the XML form
;;              on the function names. Make this a flag for present, with
;;              default setting off. We will need, however, to add in
;;              appropriate cycle information as an attribute in some
;;              places in order to preserve unique reference.
;;
                (defvar *SHOW-FUNCTION-CYCLE-TAGS-IN-XML* nil)
;;

(defun XML-PPRINT-PRINTABLE-CONSTITUENT (structure &optional (stream nil))
  (format stream "<constituent id=\"~A\" semantics=\"~A\">"
	  (printable-constituent-id structure)
	  (printable-constituent-concept structure))
  (possibly-empty-xml-tag :|transliteration| (printable-constituent-translit structure) stream)
  (possibly-empty-xml-tag :|gloss| (printable-constituent-gloss structure) stream)
  (possibly-empty-xml-tag :|lexeme| (printable-constituent-lexeme structure) stream)
  
  (possibly-empty-xml-tag-list :|functions| :|function|
                               (if *show-function-cycle-tags-in-xml*
			           (printable-constituent-functions structure)
                                 (mapcar #'remove-fn-tag 
                                         (printable-constituent-functions structure)))
                               stream
			       :attrib #'grammatical-function-to-metafunction
			       :attrib-name :|metafunction|)

  (possibly-empty-xml-tag-list :|features| :|f|
			       (printable-constituent-features structure) stream)

  (format stream "~%  <subconstituents>")
  (loop for s in (printable-constituent-spelling structure)
	if (stringp s)
	do (format stream "<string>~A</string>" s)
	else 
	do (xml-pprint-printable-constituent s stream))
  (format stream "~%  </subconstituents>")
  
  (format stream "~%  </constituent>")

  nil)

(defun XML-PPRINT-SPL-LOGICAL-FORM (lf &optional (stream T))
  (cond (lf
	 (format stream "<logicalForm>")
	 ;; 
	 ;; it is easier to produce the structured representation from an internal
	 ;; term-graph structure than to bother reparsing the list form of the SPL
	 ;; some other way, so do this first...
	 ;;
	 (termgraph-to-xml (symbol-value (make-plan-term-graph lf)) stream)
	 (format stream "</logicalForm>"))
	(t 
	 (format stream "<logicalForm/>"))))


(defun TERMGRAPH-TO-XML (termgraph &optional (stream T))
  (cond ((term-graph-p termgraph)
	 (format stream "~%<spl>")
	 (format stream "~%  <identifier>~A</identifier>" (term-graph-id termgraph))
	 (format stream "~%  <symbol>~A</symbol>" (term-graph-symbol termgraph))  
	 (format stream "~%  <type>~A</type>" (term-graph-type termgraph))
	 (loop for (attrib . value) in (term-graph-features termgraph)
	       do  
	       (format stream "~%   <attributeValuePair>")
	       (format stream "~%      <attribute>~A</attribute>" attrib)
	       (format stream "~%      <value>")
	       (termgraph-to-xml value)
	       (format stream "~%      </value>")
	       (format stream "~%    </attributeValuePair>"))
	 (format stream "~%</spl>"))
	(t
	 (format stream "~%<literal>~S</literal>" termgraph))))



;; ----------------------------------------------------------------------
;; Version of extract-keyword broken out of the KPML-EVAL function
;; defined in: initialization/utilities.lisp. This version is
;; different in that nil keys are always allowed and return
;; nil. This is such an obvious function that there is probably
;; a CommonLisp function for it anyway but I cannot be bothered
;; to look just now.

(defun EXTRACT-KEYWORD (key form)
  (let ((p (position key form))
	(res nil))
    (cond ((and (numberp p) (< p (length form)))
	   (setf res (nth (1+ p) form))
	   (if res 
	       (return-from EXTRACT-KEYWORD 
			    (if (and (consp res)
				     (eq (first res) 'quote))
				(second res)
			      res))
	     (return-from EXTRACT-KEYWORD nil)))
	  (t (return-from EXTRACT-KEYWORD nil))
	  )))

;;
;; utilities...
;;

(defun POSSIBLY-EMPTY-XML-TAG (tag content stream)
  (if content
      (format stream "~%  <~A>~A</~A>" tag content tag)
    (format stream "~%   <~A/>" tag)))

(defun POSSIBLY-EMPTY-XML-TAG-LIST 
  (tag1 tag2 content stream &key (attrib nil)(attrib-name nil))
  (if content
      (if attrib-name
	  (format stream 
	      "~%   <~A>~{~{~%     <~A ~A=\"~A\">~A</~A>~}~}</~A>" 
	      tag1 
              (if (consp content)
	          (mapcar #'(lambda (x) (list tag2 attrib-name (funcall attrib x) x tag2)) content)
                (list (list tag2 attrib-name (funcall attrib content) content tag2)))
	      tag1)
	(format stream 
		"~%   <~A>~{~{~%      <~A>~A</~A>~}~}</~A>" 
		tag1 
                (if (consp content)
                    (mapcar #'(lambda (x) (list tag2 x tag2)) content) 
                  (list (list tag2 content tag2)))
                tag1))
    (format stream "~%   <~A/>" tag1)))




  ;; ----------------------------------------------------------------------
  ;;  The following was spacing out and formatting comments nicely, but
  ;;  this is no good if we are writing to a file to be read in at some
  ;;  later stage! Conditionalize. 
  ;;  Note also that need to be explict that only one gloss is allowed.
  ;;  This is not good, already there are more than one in the Czech glosses.
  ;; 
  ;; NOT CURRENTLY USED!!!!!!!
  ;; ----------------------------------------------------------------------

(defun XML-PPRINT-INQUIRY-GLOSS (inquiry-gloss)
  (let ((element nil))
    (with-output-to-string (stream)
      (format stream "(~%")
      (loop named L
	  while inquiry-gloss
	  do
	    (setf element (pop inquiry-gloss))
	    (write-char #\space stream)
	    (typecase element
	      (symbol 
	       (format stream "~10T~S~%" element))
	      (string
	       (if *file-writing*
		   (format t "~S" element)
		 (let ((strings 
			(justify-string (- *tty-right-margin* 24) element)))
		   (loop named gloss-parts
			 while strings
			 do (format stream "~10T~S~%" (pop strings))))))))
      (format stream "~10T)"))))


(defun XML-PPRINT-LEXICAL-ITEM-SEMANTICS (concept-list)
  (format nil "<SEMANTICS>~S</SEMANTICS>"
	  (mapcar #'(lambda (element)
		      (cond ((or (lg-designator-p element)
				 (equal element '&))
			     element)
			    (t
			     (kb-getconceptname element))))
		  concept-list)))

