;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10; Readtable: augmented-readtable -*-

;;;; XLE-Web users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

;;;; Author: Paul Meurer (paul.meurer@aksis.uib.no)
;;;; Aksis, Unifob, University of Bergen, Norway
;;;; http://www.aksis.uib.no

;; Using graph-id in hidden field makes sure that no two sessions accidentally access the same graph.

(in-package :XLE)

(defparameter *url-base* (or (and (boundp 'cl-user::*url-base*)
				  cl-user::*url-base*)
			     #+kartuli "kartuli" #+pargram "pargram" #+xle-web "xle-web" #+treebank "trepil"
	      #-(or pargram xle-web treebank) "logon"))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (setf lxml::*newline-after-endtag-p* nil))

#+test
(net.aserve::shutdown)
#+test
(net.aserve::start :port 8000)
#+test
(net.aserve::debug-on :notrap)
#+test
(net.aserve::debug-on :xmit)
#+test
(net.aserve::debug-off :notrap)
#+test
(net.aserve::debug-off :xmit)

(defparameter *documentation-url* "http://maximos.aksis.uib.no/Aksis-wiki/XLE-Web")

;; populated in xle-startup.lisp
(defvar *grammar-authorizer*
  (make-instance 'password-authorizer
		 :allowed '()
		 :realm "XLE"))

(defvar *print-extras-p* t) ;; whether to print variable features in MRSs

;; use of get-universal-time() ensures that ids from different server sessions don't clash
(defvar *graph-id* (get-universal-time))

(defparameter *show-projection-ids-p* #+xle-web t #-xle-web nil)

(defvar *submatches* nil)
(defvar *variable-names* nil)

(defvar *annotator* "-")

(defparameter *middle-anchor-p* t)

(defmethod graph::write-node-svg-text ((node c-node) &key left bottom width stream &allow-other-keys)
  (with-slots (projection-fs-ids graph::graph graph::value xle-graph) node
    ;;(print (list :xle-graph xle-graph))
    (let* ((language (when (grammar xle-graph) (intern (string-upcase (language (grammar xle-graph))) :keyword)))
	   (x-center (graph::node-x-center node (graph::graph-layout-style graph::graph)))
	   (match-pos nil)
	   (submatch nil)
	   (base-class
	    (if (setf submatch
		      (position-if
		       (lambda (submatch-list)
			 (setf match-pos
			       (position (cdr graph::value) submatch-list
					 :key (lambda (pair) (and (eq (car pair) :c-node) (cadr pair))))))
		       *submatches*))
		"match"
		(string-downcase (symbol-name (node-type node)))))
	   (text-x (- x-center (* (length (node-label node)) 4))) ;; workaround for WebKit SVG bug; not necessary any more
	   (var (when match-pos (aref *variable-names* match-pos)))
	   (var (unless (eq (search "my" var) 0) var)))
      #m(rect/ :class "text-box"
	       :x #s(if *middle-anchor-p* x-center text-x)
	       :y #s (- bottom 4 14)
	       :height 18
	       :width #s (+ width 0))
      #m((text :class #s base-class
	       :id #s(when (node-children node) (format nil "fs~{~d~^:~}" projection-fs-ids))
	       :node-id #s(cdr graph::value)
	       :style #s(when (eq (node-type node) :surface-form)
			  (case language
			    (:ara "font-family: Geeza Pro; font-size: 14pt")
			    (:geo "font-family: Amirani; font-size: 13pt")
			    (otherwise "font-family: Lucida Grande")))
	       :base-class #s base-class
	       :text-anchor #s(when *middle-anchor-p* "middle")
	       :onmouseover
	       #s(when (and projection-fs-ids (node-children node))
		   (format nil (concatenate 'string "hiliteProjectingNodes(evt.target, true); "
				       "~{ var fs = window.parent.document.getElementById(~d); fs.className = 'fs-projection';~}")
			   projection-fs-ids))
	       :onmouseout
	       #s(when (and projection-fs-ids (node-children node))
		   (format nil (concatenate 'string "hiliteProjectingNodes(evt.target, false); "
				       "~{ var fs = window.parent.document.getElementById(~d); fs.className = 'fs';~}")
			   projection-fs-ids))
	       :onclick
	       #s(format nil "getCstructure(evt.target,~a)" (display-node-id node))
	       #+orig
	       #s(format nil (concatenate 'string "var id = window.parent.document.getElementById('node-id'); "
					  "id.value = ~d; "
					  "var form = window.parent.document.getElementById('form'); form.submit()")
			 (display-node-id node)
			 #+old ;; use this for inspector!! fixme!!
			 (cdr graph::value))
	       :x #s(if *middle-anchor-p* x-center text-x)
	       :y #s(- bottom 4))
	 #s(node-label node)
	 #L(when (and *show-projection-ids-p* (node-children node) (not var)) ;
	     #m((tspan :dy "3" :fill "red" :font-size "8px" :font-style "normal")
		#s (format nil "~{~d~^:~}" projection-fs-ids)))
	 #L(when var
	     #m((tspan :dy "3" :fill "magenta" :font-size "10px" :font-style "normal")
		#s (if (cdr *submatches*)
		       (format nil "~a.~d" var (1+ submatch))
		       var)))))))

(define-javascript-writer js/svg (stream)
  #j(
     (defun hilite-projecting-nodes (node hilite)
       (let* ((doc node.owner-document)
	      (proj-nodes (doc.get-elements-by-tag-name "text"))
	      (n-i 0))
	 (for ((< n-i proj-nodes.length) (incf n-i))
	   (let ((pnode (proj-nodes.item n-i)))
	     (when (= pnode.id node.id)
	       (if (= hilite true)
		   (pnode.set-attribute "class" "node-focus")
		   (pnode.set-attribute "class" (pnode.get-attribute "base-class"))))))))
     
     (defun get-cstructure (node node-id)
       (let* ((doc window.parent.document)
	      (cstructure-td (doc.get-element-by-id "cstructure"))
	      (grammar (doc.get-element-by-id "grammar"))
	      (xle-graph-id (doc.get-element-by-id "xle-graph-id"))
	      (session-id (doc.get-element-by-id "session-id"))
	      (req (new (XMLHttpRequest))))
	 
	 (if (= xle-graph-id null)
	     (req.open "get" (+ #L(concatenate 'string "/" *url-base* "/js/cstructure.xml?session-id=")
				session-id.value
				"&node-id=" node-id)
		       false)
	     (req.open "get" (+ #L(concatenate 'string "/" *url-base* "/js/cstructure.xml?grammar=")
				grammar.value
				"&xle-graph-id=" xle-graph-id.value
				"&node-id=" node-id)
		       false))
	 (req.send "")
	 (when (not (= req.responseText "")) ;; do nothing when c-structure object has expired
	   (setf cstructure-td.innerHTML req.responseText))))))

(defmethod fs-cstructure-xml ((request http-request) entity)
  #+debug(print (cons :fs-cstructure-xml (request-query request)))
  (with-xml-response (request entity stream (grammar xle-graph-id session-id node-id)
			      :xsl #'js-cstructure-xsl
			      :force-xslt :sablotron)
    (let* ((xle-graph-id (when xle-graph-id (parse-integer xle-graph-id :junk-allowed t)))
	   (session-id (when session-id (parse-integer session-id :junk-allowed t)))
	   (grammar (utf-8-decode grammar))
	   (*grammar* (find-grammar grammar))
	   (graph-table (when *grammar* (graph-table *grammar*)))
	   (graph.sentence (when *grammar* (gethash xle-graph-id graph-table)))
	   (graph (car graph.sentence))
	   (node-id (when node-id (parse-integer node-id :junk-allowed t))))
      (cond (graph
	     (multiple-value-bind (var-array c-structure)
		 (get-current-packed-solution graph)
	       (declare (ignore var-array))
	       (toggle-tri-node c-structure node-id)
	       (setf (c-structure-svg-string graph)
		     (with-output-to-string (svg-stream)
		       (multiple-value-bind (width height)
			   (display-c-structure c-structure :stream svg-stream
						;;:partial-nodes-p partial-nodes
						;;:sublexical-nodes-p sublexical-nodes
						)
			 #m((parse :object-element "object" ;; change!
				   :xle-graph-id #s xle-graph-id
				   :grammar #s grammar)
			    ((c-structure :width #s width
					  :height #s height
					  ))))))))
	    (session-id
	     (let ((c-structure (car (gethash session-id *svg-string-table*))))
	       (when c-structure
		 (toggle-tri-node c-structure node-id)
		 (setf (cdr (gethash session-id *svg-string-table*))
		       (with-output-to-string (svg-stream)
			 (multiple-value-bind (width height)
			     (display-c-structure c-structure :stream svg-stream
						  ;;:partial-nodes-p partial-nodes
						  ;;:sublexical-nodes-p sublexical-nodes
						  )
			   #m((parse :object-element "object" ;; change!
				     :treebank "mrs"
					;:xle-graph-id #s xle-graph-id
					;:grammar #s grammar
				     )
			      ((c-structure :width #s width
					    :height #s height
					    :session-id #s session-id
					    )))))))))
	    ))))

(defstylesheet js-cstructure-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     ((xsl:template :match "/parse")
      ;;((td :style "vertical-align: top" :id "cstructure" :name "cstructure")
      ((div :class "title") "C-structure")
      ((xsl:element :name "form")
       ((xsl:attribute :name "method") "get")
       ((xsl:attribute :name "id") "c-structure")
       ((div)
	(xsl:choose
	 ((xsl:when :test "@object-element='object'")
	  ((xsl:element :name "object")
	   ((xsl:attribute :name "name") "svg")
	   ((xsl:attribute :name "type") "image/svg+xml")
	   ((xsl:attribute :name "data")
	    (xsl:choose
	     ((xsl:when :test "/parse/@treebank")
	      #s(concatenate 'string "/" *url-base* "/treebank-c-structure.svg?session-id=")
	      (xsl:value-of/ :select "c-structure/@session-id"))
	     (xsl:otherwise
	      #s(concatenate 'string "/" *url-base* "/xle-c-structure.svg?graph-id=")
	      (xsl:value-of/ :select "/parse/@xle-graph-id")
	      "&amp;grammar="
	      ;;(xsl:value-of/ :select "/parse/@encoded-grammar-name")
	      (xsl:value-of/ :select "/parse/@grammar"))))
	    ((xsl:attribute :name "width") (xsl:value-of/ :select "/parse/c-structure/@width"))
	    ((xsl:attribute :name "height") (xsl:value-of/ :select "/parse/c-structure/@height"))
	    "C-Structure"))
	  (xsl:otherwise
	   ((xsl:element :name "embed")
	    ((xsl:attribute :name "src")
	     (xsl:choose
	      ((xsl:when :test "/parse/@treebank")
	       #s(concatenate 'string "/" *url-base* "/treebank-c-structure.svg?sentence-id=")
	       (xsl:value-of/ :select "/parse/@sentence-id")
	       "&amp;treebank="
	       (xsl:value-of/ :select "/parse/@treebank"))
	      (xsl:otherwise
	       #s(concatenate 'string "/" *url-base* "/xle-c-structure.svg?graph-id=")
	       (xsl:value-of/ :select "/parse/@xle-graph-id")
	       "&amp;grammar="
	       (xsl:value-of/ :select "/parse/@grammar"))))
	    ((xsl:attribute :name "type") "image/svg+xml")
	    ((xsl:attribute :name "name") "CStructure")
	    ((xsl:attribute :name "pluginspace") "http://www.adobe.com/svg/viewer/install/")
	    ((xsl:attribute :name "width") (xsl:value-of/ :select "/parse/c-structure/@width"))
	    ((xsl:attribute :name "height") (xsl:value-of/ :select "/parse/c-structure/@height"))))))))))

(publish :path (concatenate 'string "/" *url-base* "/js/cstructure.xml")
	 :class 'xml/html-entity
	 :function #'fs-cstructure-xml)

(defmethod display-c-structure ((node t) &key stream &allow-other-keys)
  (values 0 0))

(defparameter *partial-nodes-p* nil)
(defparameter *sublexical-nodes-p* t)

(defmethod display-c-structure ((node c-node) &key stream submatches variable-names
				partial-nodes-p sublexical-nodes-p &allow-other-keys)
  (let ((graph (make-instance 'c-graph
		 :roots (list node)
                 ;;:node-onclick-fn (lambda (node) (declare (ignore node)) "clickNode(evt)")
		 ))
	(*submatches* submatches)
	(*variable-names* variable-names)
	(*partial-nodes-p* partial-nodes-p)
	(*sublexical-nodes-p* sublexical-nodes-p))
    (graph::set-node-graph node graph)
    (graph::write-nodes-svg graph (graph::graph-layout-style graph) stream)
    (values (graph::width graph) (graph::height graph))))

#+graph
(defmethod graph::write-arc-svg ((from-node c-node) (to-node c-node)
				 (layout graph::top-down-layout) stream)
  (let ((x-center (graph::node-x-center from-node layout))
        (bottom (graph::node-bottom from-node layout)))
    (if (node-triangled-p from-node)
	#m(path/ :d #s(format nil "M ~d ~d L ~d ~d L ~d ~d L ~d ~d"
			      x-center (1+ bottom) ;; add a minimal triangle width!
			      (- (graph::node-right to-node layout) 8) (1+ (graph::node-top to-node layout))
			      (+ (graph::node-left to-node layout) 8) (1+ (graph::node-top to-node layout))
			      x-center (1+ bottom))
		 :stroke #-BW "gray" #+BW "black"
		 :fill "none")
	#m(path/ :d #s(format nil "M ~d ~d L ~d ~d"
			      x-center (1+ bottom)
			      (graph::node-x-center to-node layout) (1+ (graph::node-top to-node layout)))
		 :stroke #-BW "gray" #+BW "black"
		 :fill "none"))
    #+test
    #m(path/ :d #s(format nil "M ~d ~d L ~d ~d"
			  x-center (1+ bottom)
			  (graph::node-x-center to-node layout) (1+ (graph::node-top to-node layout))
			  ;; x-center (+ (graph::node-top from-node layout) 10)
			  ;; (graph::node-x-center to-node layout) (+ (graph::node-top to-node layout) 10)
			  )
	     ;;:fill "none"
	     :opacity "0.2"
	     :stroke-linecap "round"
	     :stroke "magenta"
	     :stroke-width "10")))

(defmethod c-structure-svg ((request http-request) entity)
  (with-xml-response (request entity stream (grammar sentence graph-id)
			      :write-xml-header-p t)
    ;;(print (request-query request))
    (let* ((grammar (utf-8-decode grammar))
	   (*grammar* (find-grammar grammar)))
      #+debug(print (list :grammar grammar :c-structure-svg-grammar *grammar*)) 
      (if *grammar*
	  (let* ((graph-table (graph-table *grammar*))
		 (graph.sentence (gethash (parse-integer graph-id :junk-allowed nil) graph-table))
		 (graph (progn
			  (when (parser (car graph.sentence))
			    (setf (last-access (parser (car graph.sentence))) (get-universal-time)))
			  (car graph.sentence)))
		 (c-structure (current-c-structure graph)))
	    (graph-c-structure-svg graph stream))))))

(defmethod graph-c-structure-svg ((graph xle-graph) stream)
  (graph-c-structure-svg (c-structure-svg-string graph) stream))

(defmethod graph-c-structure-svg ((svg-string string) stream)
  #m(!DOCTYPE "svg PUBLIC '-//W3C//DTD SVG 20010904//EN' "
	      "'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'")
  #+test
  #m(!DOCTYPE "svg PUBLIC '-//W3C//DTD SVG 1.1//EN' " "'http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd'")
  #m((svg :contentScriptType "text/javascript" :xmlns "http://www.w3.org/2000/svg")
     ((style :type "text/css")
      (!CDATA
       (CSS-STYLE
	 ;;(path :stroke "gray")
	 (text :font-family "Lucida Grande, Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica"
	       :font-size "12px" :cursor "pointer"  :font-style "normal")
	 (text.node-focus :fill "red"
			  ;;:font-weight "bold"
			  )
	 (text.match :fill "green") ;; :font-weight "bold")
	 (text.data :fill "black") ;;:text-align "center" :font-style "normal")
	 (text.data-active :fill "red")	;; :stroke "black")
	 ;;(text.data-multidtree :fill "red") ;; :stroke "black")
	 #+ARABxx
	 (text.surface-form :font-weight "bold" :fill #-BW "#004499" #+BW "black" #+ignore "blue"
			    :font-style "normal" :font-family "Geeza Pro" :font-size "14pt")
	 #-KARTULIxx
	 (text.surface-form :font-weight "bold"
			    :fill #-BW "#004499" #+BW "black"
			    :font-style "normal")
	 #+KARTULIxx
	 (text.surface-form :fill #-BW "#004499" #+BW "black" #+ignore "blue"
			    :font-style "normal"
			    :font-family "Amirani"
			    :font-size "18px"
			    )
	 
	 (text.surface-form-active :fill #-BW "#004499" #+BW "black" :font-weight "bold") ;; :stroke "green")
	 (text.context :fill #-BW "green" #+BW "black")
	 (text.context-active :fill #-BW  "green" #+BW "black"
			      ;;:stroke "red"
			      )
	 (text.child-context :fill #-BW "green" #+BW "black") ;;"magenta")
	 (text.child-context-active ;;:fill "red"
	  :fill #-BW  "green" #+BW "black" ;;:stroke "magenta"
	  )
	 (text.phi-id :fill "red" :font-size "8pt" :text-align "right")
	 (rect.text-box	;;:stroke "blue"
	  :fill "none"
	  ;;:stroke-width "1"
	  :opacity "0")
	 (rect.text-box-focused :stroke "blue"
				:fill "none"
				:stroke-width "2"
				:opacity "0.5")
	 (text.count :fill "green" :font-size "6pt")
	 (path.triangle :fill-opacity "0.2")
	 (path.triangle\:hover :fill-opacity "0.8")
	 ;;(text.sexp :opacity "0.4")
	 ;;(text.sexp\:hover :opacity "0.8")
	 )))
     ((g :id "graph")
      ((script :type "text/javascript" :language "javascript") 
       (!CDATA #L(js/svg stream)))
      ((rect :x "0" :y "0":fill "#ffeeff" :opacity "0.0"))
      #L(write-string svg-string stream))))

#+copy
(grammar sentence graph-id show-features next-solution same-solution
	 previous-solution m-projection disable-OT
	 cg-preparse-on-fragment-analysis cg-preparse disjunction-choice)

(defmethod c-structure-xml ((request http-request) entity)
  (xle-xml request entity :c-structure-p t :f-structure-p nil))

;;; ---- new for pargram

(defclass multipart-buffer ()
  ((request :initform nil :initarg :request)
   (buffer :initform (make-array 4096 :element-type 'character))
   (index :initform 0 :accessor buffer-index)
   (size :initform 0 :accessor buffer-size)))

(defclass prefilled-multipart-buffer (multipart-buffer)
  ((lines :initform :empty :accessor multipart-lines)))

;; debug
(defparameter *request* nil)

(defmethod read-next-line ((stream multipart-buffer))
  (let ((line :eof))
    (with-slots (request buffer index size) stream
      (setf *request* request)
      (labels ((read-chunk ()
		 (cond ((null size)
			:eof)
		       ((= size index)
			(setf size (get-multipart-sequence request buffer)
			      index 0)
			(if size
			    (read-chunk)
			  line))
		       (t
			(when (eq line :eof) (setf line ""))
			(let* ((nl-pos (position-if (lambda (c)
						      (member c '(#\Newline #\Return)))
						    buffer :start index :end size))
			       (pos (or nl-pos size)))
			  (setf line (concatenate 'string line
					     (subseq buffer index
						     (if (and (> pos index)
							      (char= (char buffer (1- pos))
								     #\Return))
							 (1- pos)
						       pos)))
				index (if nl-pos (1+ nl-pos) size))
			  (if nl-pos
			      line
			    (read-chunk)))))))
	(read-chunk)))))

(defmethod read-next-line ((stream prefilled-multipart-buffer))
  (when (eq (multipart-lines stream) :empty)
    (setf (multipart-lines stream)
      (loop for line = (call-next-method)
	  collect line
	  until (eq line :eof)))
    (format t "~d lines read.~%" (length (multipart-lines stream))))
  (pop (multipart-lines stream)))

(defun extract-form-data (header)
  (let* ((cd (cdr (find :content-disposition header :key #'car)))
	 (par (cddr (find :param cd :key #'car)))
	 (name (cdr (find "name" par :key #'car :test #'string-equal)))
	 (filename (cdr (find "filename" par :key #'car :test #'string-equal))))
    (values name filename)))

(defun upload-grammar (stream &key grammar-path)
  #+test(print (list :upload-grammar grammar-path))
  (let* ((temp-name (concatenate 'string "tmp" (write-to-string (get-universal-time)) ".lfg"))
	 (file (concatenate 'string grammar-path temp-name))) ;; OBS: document-path could contain wildcards!?!
    (let ((success-p nil))
      (unwind-protect
	   (progn
	     #+debug(print (list :temp-file file))
	     (with-open-file (out-stream file :direction :output :if-exists :supersede)
	       (loop for line = (read-next-line stream)
		     until (eq line :eof)
		     do
		     #+debug(print line)
		     (write-line line out-stream)))
	     #+debug(print (list :temp-file file))
	     (setf success-p t))
	(unless success-p
	  (when (probe-file file) (delete-file file))))
      #+debug(print (list :file file)))
      file))

(defun check-authentication (&optional (user "paul"))
  (search user
	  (with-output-to-string (out-stream)
	    (let ((stream (#+allegro excl::run-shell-command #+sbcl sb-ext:run-program
			   "ssh-add -l"
			   :wait nil :output :stream :error-output :output)))
	      (loop for line = (read-line stream nil nil)
		    while line
		    do (write-line line out-stream))))))

(defun update-from-cvs (grammar-path)
  (when (check-authentication)
    (let ((stream (#+allegro excl::run-shell-command #+sbcl sb-ext:run-program
		   (format nil "cd ~a; cvs update"
			   (let ((slash-pos (position #\/ (grammar-path *grammar*) :from-end t)))
			     (subseq (grammar-path *grammar*) 0 slash-pos)))
		   :wait nil :output :stream :error-output :output)))
      (loop for line = (read-line stream nil nil)
	    while line
	    collect line))))

;;(print (check-authentication))

;;; ----

;; to do: change this!
(defun super-user-p (user-id)
  (find user-id '(list "paul" "helge") :test #'string-equal))

(defparameter *grammar-dir* "testgrammars/")

(defmethod encode-sentence ((language t) sentence font)
  (declare (ignore font))
  sentence)

(defmethod decode-sentence ((language t) sentence font)
  (declare (ignore font))
  sentence)

;; Language specific >>>>>>

(defmethod decode-sentence ((language (eql :tur)) sentence font)
  (declare (ignore font))
  ;;(print (list :sentence (map 'list #'char-code sentence)))
  (convert-turkish-encoding sentence :unicode :latin-5))

(defmethod encode-sentence ((language (eql :tur)) sentence font)
  (declare (ignore font))
  (convert-turkish-encoding sentence :latin-5 :unicode))

(defmethod decode-sentence ((language (eql :ara)) sentence font)
  (declare (ignore font))
  (utf-8-encode sentence))

(defmethod encode-sentence ((language (eql :ara)) sentence font)
  (declare (ignore font))
  (utf-8-decode sentence))

(defmethod decode-sentence ((language (eql :slv)) sentence font)
  (declare (ignore font))
  (utf-8-encode sentence))

(defmethod encode-sentence ((language (eql :slv)) sentence font)
  (declare (ignore font))
  (utf-8-decode sentence))

(defmethod decode-sentence ((language (eql :ava)) sentence font)
  (declare (ignore font))
  (utf-8-encode sentence))

(defmethod encode-sentence ((language (eql :ava)) sentence font)
  (declare (ignore font))
  (utf-8-decode sentence))

(#+sbcl defparameter #-sbcl defconstant +turkish-unicode+
  (map 'vector #'code-char #(231 287 305 351)))

(#+sbcl defparameter #-sbcl defconstant +turkish-latin-5+
  (map 'vector #'code-char #(231 240 253 254)))

(defun convert-turkish-encoding (string from-encoding to-encoding)
  (if (or (eq from-encoding to-encoding)
	  (null from-encoding)
	  (null to-encoding))
      string
      (let* ((from-vector
	      (ecase from-encoding
		(:unicode +turkish-unicode+)
		(:latin-5 +turkish-latin-5+)))
	     (to-vector
	      (ecase to-encoding
		(:unicode +turkish-unicode+)
		(:latin-5 +turkish-latin-5+)))
	     (result (copy-seq string)))
	(loop for c across result for i from 0
	      do (let ((pos (position c from-vector)))
		   (when pos (setf (char result i) (aref to-vector pos)))))
	result)))

(defmethod graph::node-string-width ((node c-surface-node))
  (let ((lang nil)
	(factor 0.85))
    (with-slots (xle-graph) node
      (when xle-graph
	(with-slots (grammar) xle-graph
	  (when grammar
	    (setf lang (language grammar))))))
    (cond ((equal lang "geo")
	   (setf factor 1)))
    (* factor (call-next-method))))

;; Language specific <<<<

(defmethod toggle-tri-node ((node c-node) node-id)
  (when node-id
    (let ((seen-nodes ())
	  (temp nil))
      (if (= node-id (display-node-id node))
	  ;; reset tri-nodes
	  (labels ((walk (node)
		     (unless (find node seen-nodes)
		       (when (node-triangled-p node)
			 (setf (node-triangled-p node) nil
			       temp (node-inactive-children node)
			       (node-inactive-children node) (node-children node)
			       (node-children node) temp))
		       (push node seen-nodes)
		       (mapc #'walk (node-children node)))))
	    (walk node))
	  (labels ((walk (node)
		     (unless (find node seen-nodes)
		       #+debug(print (list node (node-value node) node-id (display-node-id node)))
		       (when (= (display-node-id node) node-id)
			 (unless (and (not (node-triangled-p node))
				      (or (null (node-children node))
					  (and (null (cdr (node-children node)))
					       (eq (node-type (car (node-children node))) :surface-form))))
			   (setf (node-triangled-p node)
				 (case (node-triangled-p node)
				   (:tri :dot)
				   (:dot nil)
				   (otherwise :tri)))
			   (case (node-triangled-p node)
			     (:tri
			      (setf temp (node-inactive-children node)
				    (node-inactive-children node) (node-children node)
				    (node-children node)
				    (cond (temp
					   (setf (slot-value (car temp) 'graph::x-size) nil)
					   temp)
					  (t
					   (list (make-instance 'c-surface-node
								:display-node-id (display-node-id node)
								:xle-graph (xle-graph node)
								:context (node-context node) 
								:surface-string (format nil "~{~a~^ ~}" (node-surface-string node))
								:type :surface-form
								:label (format nil "~{~a~^ ~}" (node-surface-string node))))))
				    (node-surface-string (car (node-children node)))
				    (format nil "~{~a~^ ~}" (node-surface-string node))
				    (node-label (car (node-children node)))
				    (format nil "~{~a~^ ~}" (node-surface-string node))))
			     (:dot
			      (let ((tri-node (car (node-children node))))
				(setf (node-surface-string tri-node) "[ ... ]"
				      (node-label tri-node) "[ ... ]"
				      (slot-value tri-node 'graph::x-size) nil)))
			     (otherwise
			      (setf temp (node-inactive-children node)
				    (node-inactive-children node) (node-children node)
				    (node-children node) temp)))
			   #+orig
			   (setf (node-triangled-p node) (not (node-triangled-p node))
				 temp (node-inactive-children node)
				 (node-inactive-children node) (node-children node)
				 (node-children node)
				 (or temp
				     (list (make-instance 'c-surface-node
							  ;; :value (cons (car labels) id)
							  :display-node-id (display-node-id node)
							  :xle-graph (xle-graph node)
							  :context (node-context node) 
							  :surface-string (format nil "~{~a~^ ~}" (node-surface-string node))
							  :type :surface-form
							  :label (format nil "~{~a~^ ~}" (node-surface-string node))
							  )))))
			 (return-from toggle-tri-node))
		       (push node seen-nodes)
		       (mapc #'walk (node-children node)))))
	    (walk node))))))

(defmethod test-xml ((request http-request) entity)
  #-debug(print (list :request-query (request-query request)))
  (with-xml-response (request entity stream (grammar))
    (print grammar)
    #m(lolo)))
				
(publish :path (concatenate 'string "/" *url-base* "/test.xml")
	 :content-type "text/xml"
	 :function #'test-xml)

(define-url-function xle-xml (request (grammar sentence xle-graph-id previous-solution next-solution
					       disable-OT m-projection cg-preparse-on-fragment-analysis
					       cg-preparse disjunction-choice discriminant-choice
					       complementp f-structure-only show-all-fs-discs
					       same-solution show-features
					       show-c-structure	;; nil nil :local)
					       show-f-structure	;; nil nil :local)
					       show-mrs	;; nil nil :local)
					       show-discriminants ;; nil nil :local)
					       show-disjunctions suppress-complex-categories
					       parse-sentence unload-parse-sentence unload-check-parse-sentence
					       parse packed previous-packed from-mrs non-top-f-structures ranking font
					       inspect partial-nodes sublexical-nodes node-id dtree edge
					       previous-subtree suppress-check preds-only
					       morph-chart chart default-root-cat-only)
			      :uri (eq :get (request-method request))
			      :post (not (eq :get (request-method request)))
			      :path (concatenate 'string "/" *url-base* "/xle.xml")
			      :xsl #'xle-xsl)
  ;;(print (list :sentence sentence))
  #-debug(setf ranking nil)
  #+debug(print (list :request-query (request-query request)))
  ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
  (cond ((null (request-query request))
	 (setf show-c-structure "true" show-f-structure "true" show-discriminants "true" packed "true" suppress-check "true"))
	(show-mrs
	 (setf show-discriminants nil packed nil)))
  (let ((user-id (get-basic-authorization request))
	(grammar (utf-8-decode grammar))
	(colon-marks-root-cat-p (not default-root-cat-only))
	(node-id (when node-id (parse-integer node-id :junk-allowed t)))
	(show-all-fs-discs-p (equal show-all-fs-discs "true"))
	(*print-extras-p* (if show-features t nil))
	(*suppress-complex-categories-p* suppress-complex-categories)
	(*seen-nodes* ())
	#+ignore(complementp (unless (equal complementp "") complementp)))
    #+debug(print (list user-id grammar))
    (when (null (request-query request)) ;; upload-grammar
      (let ((filename nil)
	    (temp-file nil)
	    (error-p nil)
	    (file nil)
	    (grammar-path (concatenate 'string *pargram-path* *grammar-dir*))
	    (mp-header-p nil)
	    #+test(concatenate 'string *pargram-path* "norwegian/bokmal"))
	(labels ((remove-path (filename) ;; workaround for bug in MSIE which sends path + filename as filename
		   (let ((bs-pos (position #\\ filename :from-end t)))
		     (if bs-pos
			 (subseq filename (1+ bs-pos))
			 filename))))
	  (loop for header = (get-multipart-header request)
		while header
		do
		(setf mp-header-p t)
		(multiple-value-bind (input-name input-filename) (extract-form-data header)
		  (let ((in-stream (make-instance 'multipart-buffer :request request))
			(file-found-p nil))
		    #+debug(print (list :input-name input-name :input-filename input-filename))
		    (setf input-filename (if (equal input-filename "") nil input-filename))
		    (cond (input-filename
			   (setf filename (if (equal filename "") nil (remove-path (utf-8-decode input-filename))))
			   (setf grammar (or grammar filename))
			   (setf temp-file (upload-grammar in-stream :grammar-path grammar-path))
			   #+debug(print (list :temp-file temp-file)))
			  ((string-equal input-name "upload-grammar-name")
			   (loop for line = (print (read-next-line in-stream))
				 until (eq line :eof)
				 do (setf grammar (remove-path (utf-8-decode line)))))
			  (t
			   (loop for line = (read-next-line in-stream)
				 until (eq line :eof))))))))
	(when mp-header-p
	  #+debug(print (list :file file :grammar grammar :temp-file temp-file :user-id user-id))
	  (rename-file temp-file (concatenate 'string user-id "." grammar))
	  (setf grammar (concatenate 'string user-id "." (subseq grammar 0 (position #\. grammar))))
	  (let ((grammar-obj (find-grammar grammar :default nil :common-if-not-found-p nil)))
	    #+debug(print (list :grammar grammar :grammar-obj grammar-obj))
	    (if grammar-obj
		(unload-grammar grammar-obj)
		(progn (setf (gethash grammar *grammars*)
			     (make-instance
			      'grammar
			      :name grammar
			      :owner user-id
			      :grammar-path (concatenate 'string *pargram-path* *grammar-dir* grammar ".lfg")
			      :max-parsers 1
			      :graph-class 'xle-graph
			      :morphology-type :fst-morphology))
		       (write-grammar-definition-file)))))))
    (let ((*grammar* (find-grammar grammar :owner user-id)))
      #+debug(print (list :grammar grammar *grammar*))
      (cond (*grammar*
	     (when (or unload-parse-sentence unload-check-parse-sentence) 
	       (unload-grammar *grammar*))
	     (let* ((graph-table (graph-table *grammar*))
		    (xle-graph-id (or (parse-integer (or xle-graph-id "") :junk-allowed t) (incf *graph-id*)))
		    (graph.sentence (gethash xle-graph-id graph-table))
		    (decoded-sentence (decode-sentence (when *grammar* (intern (string-upcase (language *grammar*)) :keyword))
						       (utf-8-decode sentence)
						       font))
		    (sentence (print (if sentence
					 (string-trim '(#\Space #\Tab #\Linefeed #\Newline) decoded-sentence)
					 (or (cdr graph.sentence)
					     (default-sentence *grammar*)
					     ""))))
		    (disjunction-choice (when disjunction-choice (parse-integer disjunction-choice)))
		    (discriminant-choice (when discriminant-choice (parse-integer discriminant-choice)))
		    (colon-pos (when colon-marks-root-cat-p (position #\: sentence)))
		    (space-pos (position #\space sentence))
		    (root-cat (when (and colon-pos (or (not space-pos) (< colon-pos space-pos)))
				(subseq sentence 0 colon-pos)))
		    (graph (get-graph *grammar*
				      :parse-p (or parse-sentence )
				      :sentence (cond ((eq :get (request-method request)) "")
						      ((and colon-pos (or (not space-pos) (< colon-pos space-pos)))
						       (subseq sentence (1+ colon-pos)))
						      (t sentence))
				      :root-cat root-cat
				      :xle-graph-id xle-graph-id
				      :next-solution next-solution
				      :same-solution (or same-solution ;; show-c-structure
							 node-id)
				      :previous-solution previous-solution
				      :disable-OT disable-OT
				      :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis
				      :cg-preparse cg-preparse
				      :disjunction-choice (or disjunction-choice discriminant-choice)
				      :error-on-fatal-grammar-error-p nil
				      :ranking-p ranking
				      :check-generator-p unload-check-parse-sentence
				      :force-p t
				      :inspect-p inspect))
		    (graph-null-p (or (null graph)
				      (and (not (null (parser graph)))
					   (zerop (parser-address (parser graph)))))))
	       #+debug(Print (list :graph graph :parser (parser graph)))
	       (with-slots (solution-nr graph-address unknown-word statistics) graph
		 (when (and packed #+ignore from-mrs) (setf solution-nr nil))
		 (multiple-value-bind (var-array c-structure mrs count pos)
		     (cond ((null graph)
			    nil)
			   (graph-null-p
			    nil)
			   (inspect
			    (inspect-chart graph
					   :previous-p (or previous-solution (equal dtree "previous"))
					   :next-p (or next-solution (equal dtree "next"))
					   :node-id (when node-id (parse-integer node-id))
					   :edge (when edge (parse-integer edge))
					   :chartp chart
					   ;;:partial-nodes-p partial-nodes
					   ;;:sublexical-nodes-p sublexical-nodes
					   ;;:previous-p previous-subtree
					   ))
			   (t
			    #+debug(print (list :same-solution same-solution :node-id node-id))
			    ;;(when (and (not packed) (null solution-nr)) (setf solution-nr -1))
			    (if (or same-solution
				    node-id
				    (and packed previous-packed (not (or disjunction-choice discriminant-choice parse-sentence))))
				(get-current-packed-solution graph)
				(get-packed-solution graph
						     :valid-only-p nil
						     :build-c-structure-p t
						     :build-f-structure-p t
						     :disjunction-choice disjunction-choice
						     :discriminant-choice discriminant-choice
						     :complementp complementp
						     :get-mrs-p (not packed)
						     :previous-p previous-solution
						     :next-p next-solution
						     :ranking-p ranking))))
		   (declare (ignore mrs))
		   ;;(print (list :current node-id c-structure mrs count pos))
		   (when node-id (toggle-tri-node c-structure node-id))
		   #+debug(print (list :v var-array :c c-structure mrs count pos))
		   #m(?xml-stylesheet :type "text/xsl" :href #s(concatenate 'string "/" *url-base* "/xle.xsl"))
		   #m((parse :grammar #s (name *grammar*)
			     :lang #s (language *grammar*)
			     :owner #s (owner *grammar*)
			     :f-structure-only #s f-structure-only
			     :user #s user-id
			     :super-user #s (when (super-user-p user-id) "yes")
			     ;; workaround
			     :object-element
			     #s (if (search "MSIE" (net.aserve::header-slot-value request :user-agent))
				    "embed" "object")
			     :morphology-type #s(string-downcase (morphology-type *grammar*))
			     :f-structure-p "yes" ;;#s(when f-structure-p "yes")
			     :c-structure-p "yes" ;;#s(when c-structure-p "yes")
			     :mrs-p #s (when (graph-has-mrs-p graph) "yes")
			     :sentence #s(encode-sentence
					  (intern (string-upcase (language *grammar*)) :keyword)
					  sentence font)
			     :statistics #s statistics
			     :font #s font
			     :xle-graph-id #L xle-graph-id
			     :count #s count
			     :unoptimal-count #S (unless nil ;;disable-OT
						   (- (unoptimal-solutions-count graph)
						      (restricted-solutions-count graph)))
			     :pos #L pos
			     :m-projection #L m-projection
			     ;;:show-features #s(if *print-extras-p* "true")
			     :packed #s(if packed "true")
			     :previous-packed #s(if packed "true")
			     :disable-OT #s(when disable-OT "true")
			     :cg-preparse-on-fragment-analysis #s cg-preparse-on-fragment-analysis
			     :non-top-f-structures #s non-top-f-structures
			     :ranking #s ranking
			     :cg-preparse #s cg-preparse
			     :grammar-loaded-p #s(if graph-null-p "no" "yes")
			     :unknown-word #s unknown-word
			     :inspect #s inspect
			     :partial-nodes #s partial-nodes
			     :sublexical-nodes #s sublexical-nodes
			     :morph-chart #s morph-chart
			     :chart #s chart
			     :suppress-check #s suppress-check
			     :preds-only #s (when preds-only "true")
			     :show-c-structure #s show-c-structure
			     :show-f-structure #s show-f-structure
			     :show-mrs #s show-mrs
			     :show-features #s show-features
			     :show-discriminants #s show-discriminants
			     :show-disjunctions #s show-disjunctions
			     :suppress-complex-categories #s (when suppress-complex-categories "true"))
		      #L(when (messages *grammar*)
			  #m(messages
			     #L(dolist (line (messages *grammar*))
				 #m(line #s line))
			     #L(setf (messages *grammar*) nil)))
		      #L(when (errors *grammar*)
			  #m(errors
			     #L(dolist (line (errors *grammar*))
				 #m(line #s line))
			     #L(setf (errors *grammar*) nil)))
		      (grammars
		       #L(dolist (grammar.obj (grammar-list))
			   (destructuring-bind (grammar . obj) grammar.obj
			     #m((grammar :short-name #s grammar 
					 :name #s (name obj)
					 :owner #s (owner obj))))))
		      #L(when (and #+ignore f-structure-p (or show-f-structure show-discriminants) var-array)
			  ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
			  (f-structure-xml graph stream :sentence sentence :count count :pos pos
					   :var-array (unless inspect var-array)
					   :graph-addr (when inspect var-array)	;; rename!
					   :grammar grammar :xle-graph-id xle-graph-id
					   :m-projection m-projection :disable-OT disable-OT
					   :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis
					   :cg-preparse cg-preparse
					   :packed packed
					   :suppress-check-p suppress-check
					   :preds-only-p preds-only
					   :top-f-structure-only-p (not non-top-f-structures)))
		      #L(when (and c-structure show-c-structure)
			  (setf (c-structure-svg-string graph)
				(with-output-to-string (svg-stream)
				  (multiple-value-bind (width height)
				      (display-c-structure c-structure :stream svg-stream
							   :partial-nodes-p partial-nodes
							   :sublexical-nodes-p sublexical-nodes)
				    #m((c-structure :width #L width :height #L height))))))
		      #L(when (and packed show-discriminants)
			  (discriminants-xml graph stream
					     :disjunctions-tree-p show-disjunctions
					     :equivalences-p nil
					     :show-all-fs-discs-p show-all-fs-discs-p))
		      #L(when (and #+ignore f-structure-p inspect (or chart morph-chart) (morphology-tree graph))
			  ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
			  (chart-tree-xml graph stream :chartp chart))
		      #s(when show-mrs mrs))))))
	    (t
	     #m(?xml-stylesheet :type "text/xsl" :href #s(concatenate 'string "/" *url-base* "/xle.xsl"))
	     #m((parse :user #s user-id)))))))

#+obsolete
(defmethod xle-xml ((request http-request) entity &key (c-structure-p t) (f-structure-p t))
  (let ((uri-p (eq :get (request-method request))))
    (%with-xml-response (request entity stream (grammar (sentence nil t string :local)
							xle-graph-id previous-solution next-solution
							disable-OT m-projection cg-preparse-on-fragment-analysis
							cg-preparse disjunction-choice discriminant-choice
							complementp f-structure-only show-all-fs-discs
							same-solution show-features
							show-c-structure show-f-structure show-mrs show-discriminants show-disjunctions
							parse-sentence unload-parse-sentence unload-check-parse-sentence
							parse packed previous-packed from-mrs non-top-f-structures ranking font
							inspect partial-nodes sublexical-nodes node-id dtree edge
							previous-subtree suppress-check preds-only
							morph-chart chart default-root-cat-only)
				 :name xle-xml
				 :uri uri-p
				 :post (not uri-p)
				 :xsl #'xle-xsl
				 :force-xslt :sablotron)
      (print (list :sentence sentence))
      #-debug(setf ranking nil)
      #+debug(print (list :request-query (request-query request)))
      ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
      (cond ((null (request-query request))
	     (setf show-c-structure "true" show-f-structure "true" show-discriminants "true" packed "true" suppress-check "true"))
	    (show-mrs
	     (setf show-discriminants nil packed nil)))
      (let ((user-id (get-basic-authorization request))
	    (grammar (utf-8-decode grammar))
	    (colon-marks-root-cat-p (not default-root-cat-only))
	    (node-id (when node-id (parse-integer node-id :junk-allowed t)))
	    (show-all-fs-discs-p (equal show-all-fs-discs "true"))
	    (*print-extras-p* (if show-features t nil))
	    (*seen-nodes* ())
	    #+ignore(complementp (unless (equal complementp "") complementp)))
	#+debug(print (list user-id grammar))
	(when (null (request-query request)) ;; upload-grammar
	  (let ((filename nil)
		(temp-file nil)
		(error-p nil)
		(file nil)
		(grammar-path (concatenate 'string *pargram-path* *grammar-dir*))
		(mp-header-p nil)
		#+test(concatenate 'string *pargram-path* "norwegian/bokmal"))
	    (labels ((remove-path (filename) ;; workaround for bug in MSIE which sends path + filename as filename
		       (let ((bs-pos (position #\\ filename :from-end t)))
			 (if bs-pos
			     (subseq filename (1+ bs-pos))
			     filename))))
	      (loop for header = (get-multipart-header request)
		    while header
		    do
		    (setf mp-header-p t)
		    (multiple-value-bind (input-name input-filename) (extract-form-data header)
		      (let ((in-stream (make-instance 'multipart-buffer :request request))
			    (file-found-p nil))
			#+debug(print (list :input-name input-name :input-filename input-filename))
			(setf input-filename (if (equal input-filename "") nil input-filename))
			(cond (input-filename
			       (setf filename (if (equal filename "") nil (remove-path (utf-8-decode input-filename))))
			       (setf grammar (or grammar filename))
			       (setf temp-file (upload-grammar in-stream :grammar-path grammar-path))
			       #+debug(print (list :temp-file temp-file)))
			      ((string-equal input-name "upload-grammar-name")
			       (loop for line = (print (read-next-line in-stream))
				     until (eq line :eof)
				     do (setf grammar (remove-path (utf-8-decode line)))))
			      (t
			       (loop for line = (read-next-line in-stream)
				     until (eq line :eof))))))))
	    (when mp-header-p
	      #+debug(print (list :file file :grammar grammar :temp-file temp-file :user-id user-id))
	      (rename-file temp-file (concatenate 'string user-id "." grammar))
	      (setf grammar (concatenate 'string user-id "." (subseq grammar 0 (position #\. grammar))))
	      (let ((grammar-obj (find-grammar grammar :default nil :common-if-not-found-p nil)))
		#+debug(print (list :grammar grammar :grammar-obj grammar-obj))
		(if grammar-obj
		    (unload-grammar grammar-obj)
		    (progn (setf (gethash grammar *grammars*)
				 (make-instance
				  'grammar
				  :name grammar
				  :owner user-id
				  :grammar-path (concatenate 'string *pargram-path* *grammar-dir* grammar ".lfg")
				  :max-parsers 1
				  :graph-class 'xle-graph
				  :morphology-type :fst-morphology))
			   (write-grammar-definition-file)))))))
	(let ((*grammar* (find-grammar grammar :owner user-id)))
	  #+debug(print (list :grammar grammar *grammar*))
	  (cond (*grammar*
		 (when (or unload-parse-sentence unload-check-parse-sentence) 
		   (unload-grammar *grammar*))
		 (let* ((graph-table (graph-table *grammar*))
			(xle-graph-id (or (parse-integer (or xle-graph-id "") :junk-allowed t) (incf *graph-id*)))
			(graph.sentence (gethash xle-graph-id graph-table))
			(decoded-sentence (decode-sentence (when *grammar* (intern (string-upcase (language *grammar*)) :keyword))
							   (utf-8-decode sentence)
							   font))
			(sentence (print (if sentence
					     (string-trim '(#\Space #\Tab #\Linefeed #\Newline) decoded-sentence)
					     (or (cdr graph.sentence)
						 (default-sentence *grammar*)
						 ""))))
			(disjunction-choice (when disjunction-choice (parse-integer disjunction-choice)))
			(discriminant-choice (when discriminant-choice (parse-integer discriminant-choice)))
			(colon-pos (when colon-marks-root-cat-p (position #\: sentence)))
			(space-pos (position #\space sentence))
			(root-cat (when (and colon-pos (or (not space-pos) (< colon-pos space-pos)))
				    (subseq sentence 0 colon-pos)))
			(graph (get-graph *grammar*
					  :parse-p (or parse-sentence )
					  :sentence (cond (uri-p "")
							  ((and colon-pos (or (not space-pos) (< colon-pos space-pos)))
							   (subseq sentence (1+ colon-pos)))
							  (t sentence))
					  :root-cat root-cat
					  :xle-graph-id xle-graph-id
					  :next-solution next-solution
					  :same-solution (or same-solution ;; show-c-structure
							     node-id)
					  :previous-solution previous-solution
					  :disable-OT disable-OT
					  :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis
					  :cg-preparse cg-preparse
					  :disjunction-choice (or disjunction-choice discriminant-choice)
					  :error-on-fatal-grammar-error-p nil
					  :ranking-p ranking
					  :check-generator-p unload-check-parse-sentence
					  :force-p t
					  :inspect-p inspect))
			(graph-null-p (or (null graph)
					  (and (not (null (parser graph)))
					       (zerop (parser-address (parser graph)))))))
		   #+debug(Print (list :graph graph :parser (parser graph)))
		   (with-slots (solution-nr graph-address unknown-word statistics) graph
		     (when (and packed #+ignore from-mrs) (setf solution-nr nil))
		     (multiple-value-bind (var-array c-structure mrs count pos)
			 (cond ((null graph)
				nil)
			       (graph-null-p
				nil)
			       (inspect
				(inspect-chart graph
					       :previous-p (or previous-solution (equal dtree "previous"))
					       :next-p (or next-solution (equal dtree "next"))
					       :node-id (when node-id (parse-integer node-id))
					       :edge (when edge (parse-integer edge))
					       :chartp chart
					       ;;:partial-nodes-p partial-nodes
					       ;;:sublexical-nodes-p sublexical-nodes
					       ;;:previous-p previous-subtree
					       ))
			       (t
				#+debug(print (list :same-solution same-solution :node-id node-id))
				;;(when (and (not packed) (null solution-nr)) (setf solution-nr -1))
				(if (or same-solution
					node-id
					(and packed previous-packed (not (or disjunction-choice discriminant-choice parse-sentence))))
				    (get-current-packed-solution graph)
				    (get-packed-solution graph
							 :valid-only-p nil
							 :build-c-structure-p t
							 :build-f-structure-p t
							 :disjunction-choice disjunction-choice
							 :discriminant-choice discriminant-choice
							 :complementp complementp
							 :get-mrs-p (not packed)
							 :previous-p previous-solution
							 :next-p next-solution
							 :ranking-p ranking))))
		       (declare (ignore mrs))
		       ;;(print (list :current node-id c-structure mrs count pos))
		       (when node-id (toggle-tri-node c-structure node-id))
		       #+debug(print (list :v var-array :c c-structure mrs count pos))
		       #m(?xml-stylesheet :type "text/xsl" :href #s(concatenate 'string "/" *url-base* "/xle.xsl"))
		       #m((parse :grammar #s (name *grammar*)
				 :lang #s (language *grammar*)
				 :owner #s (owner *grammar*)
				 :f-structure-only #s f-structure-only
				 :user #s user-id
				 :super-user #s (when (super-user-p user-id) "yes")
				 ;; workaround
				 :object-element
				 #s (if (search "MSIE" (net.aserve::header-slot-value request :user-agent))
					"embed" "object")
				 :morphology-type #s(string-downcase (morphology-type *grammar*))
				 :f-structure-p #s(when f-structure-p "yes")
				 :c-structure-p #s(when c-structure-p "yes")
				 :mrs-p #s (when (graph-has-mrs-p graph) "yes")
				 :sentence #s(encode-sentence
					      (intern (string-upcase (language *grammar*)) :keyword)
					      sentence font)
				 :statistics #s statistics
				 :font #s font
				 :xle-graph-id #L xle-graph-id
				 :count #s count
				 :unoptimal-count #S (unless nil ;;disable-OT
						       (- (unoptimal-solutions-count graph)
							  (restricted-solutions-count graph)))
				 :pos #L pos
				 :m-projection #L m-projection
				 ;;:show-features #s(if *print-extras-p* "true")
				 :packed #s(if packed "true")
				 :previous-packed #s(if packed "true")
				 :disable-OT #s(when disable-OT "true")
				 :cg-preparse-on-fragment-analysis #s cg-preparse-on-fragment-analysis
				 :non-top-f-structures #s non-top-f-structures
				 :ranking #s ranking
				 :cg-preparse #s cg-preparse
				 :grammar-loaded-p #s(if graph-null-p "no" "yes")
				 :unknown-word #s unknown-word
				 :inspect #s inspect
				 :partial-nodes #s partial-nodes
				 :sublexical-nodes #s sublexical-nodes
				 :morph-chart #s morph-chart
				 :chart #s chart
				 :suppress-check #s suppress-check
				 :preds-only #s (when preds-only "true")
				 :show-c-structure #s show-c-structure
				 :show-f-structure #s show-f-structure
				 :show-mrs #s show-mrs
				 :show-features #s show-features
				 :show-discriminants #s show-discriminants
				 :show-disjunctions #s show-disjunctions)
			  #L(when (messages *grammar*)
			      #m(messages
				 #L(dolist (line (messages *grammar*))
				     #m(line #s line))
				 #L(setf (messages *grammar*) nil)))
			  #L(when (errors *grammar*)
			      #m(errors
				 #L(dolist (line (errors *grammar*))
				     #m(line #s line))
				 #L(setf (errors *grammar*) nil)))
			  (grammars
			   #L(dolist (grammar.obj (grammar-list))
			       (destructuring-bind (grammar . obj) grammar.obj
				 #m((grammar :short-name #s grammar 
					     :name #s (name obj)
					     :owner #s (owner obj))))))
			  #L(when (and f-structure-p (or show-f-structure show-discriminants) var-array)
			      ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
			      (f-structure-xml graph stream :sentence sentence :count count :pos pos
					       :var-array (unless inspect var-array)
					       :graph-addr (when inspect var-array) ;; rename!
					       :grammar grammar :xle-graph-id xle-graph-id
					       :m-projection m-projection :disable-OT disable-OT
					       :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis
					       :cg-preparse cg-preparse
					       :packed packed
					       :suppress-check-p suppress-check
					       :preds-only-p preds-only
					       :top-f-structure-only-p (not non-top-f-structures)))
			  #L(when (and c-structure show-c-structure)
			      (setf (c-structure-svg-string graph)
				    (with-output-to-string (svg-stream)
				      (multiple-value-bind (width height)
					  (display-c-structure c-structure :stream svg-stream
							       :partial-nodes-p partial-nodes
							       :sublexical-nodes-p sublexical-nodes)
					#m((c-structure :width #L width :height #L height))))))
			  #L(when (and packed show-discriminants)
			      (discriminants-xml graph stream
						 :disjunctions-tree-p show-disjunctions
						 :equivalences-p nil
						 :show-all-fs-discs-p show-all-fs-discs-p))
			  #L(when (and f-structure-p inspect (or chart morph-chart) (morphology-tree graph))
			      ;;(let ((stream (make-broadcast-stream stream *standard-output*)))
			      (chart-tree-xml graph stream :chartp chart))
			  #s(when show-mrs mrs))))))
		(t
		 #m(?xml-stylesheet :type "text/xsl" :href #s(concatenate 'string "/" *url-base* "/xle.xsl"))
		 #m((parse :user #s user-id)))))))))

(defmethod discriminants-xml ((graph xle-graph) stream &key disjunctions-tree-p equivalences-p 
			      show-all-fs-discs-p disc-sorting discriminant-statistics &allow-other-keys)
  (with-slots (disjunctions-tree discriminants equivalences solution-count) graph
    (when disjunctions-tree-p
      (labels ((write-dis (dis stream)
		 (destructuring-bind (name node-id summand . sub-nodes) (cdr dis)
		   #m((packed-disjunction ;; change name!!
		       :name #s(when (and name (symbolp name))
				 (string-downcase (symbol-name (or name '*))))
		       :node-id #s node-id
		       :summand #s summand)
		      #L(cond ((null sub-nodes)
			       nil)
			      ((cdr sub-nodes)
			       #m(packed-conjunction ;; change name!!
				  #L(mapc (lambda (dis) (write-con dis stream)) sub-nodes)))
			      (t
			       (write-con (car sub-nodes) stream))))))
	       (write-con (dis stream)
		 (destructuring-bind (name node-id summand . sub-nodes) (cdr dis)
		   #m((packed-disjunction ;; change name!!
		       :name #s(when (and name (symbolp name)) (string-downcase (symbol-name (or name '*))))
		       :node-id #s node-id
		       :summand #s summand)
		      #L(cond ((null sub-nodes)
			       nil)
			      ((cdr sub-nodes)
			       (mapc (lambda (dis) (write-dis dis stream)) sub-nodes))
			      (t
			       (write-dis (car sub-nodes) stream)))))))
	#+debug(print (list :disjunctions-tree disjunctions-tree
			    :equivalences equivalences))
	(when disjunctions-tree
	  (write-dis disjunctions-tree stream))))
    (when (and equivalences equivalences-p)
      (let ((*package* (find-package :xle)))
	#m(equivalences
	   #L(loop for (abb term) on equivalences by #'cddr
		   do #m(equivalence/ :abb #s abb :term #s (write-to-string term))))))
    (when discriminants
      (discriminants-xml discriminants stream :solution-count solution-count :show-all-fs-discs-p show-all-fs-discs-p
			 :disc-sorting disc-sorting :discriminant-statistics discriminant-statistics))))

(defmethod display-discriminant-p ((disc discriminant) &key &allow-other-keys)
  (or (discriminant-valid-p disc)
      (discriminant-chosen-p disc)))

(defmethod display-discriminant-p ((disc constituent-discriminant) &key &allow-other-keys)
  (or (call-next-method)
      (with-slots (discriminants-array) (discriminants disc)
	(find-if (lambda (id) (discriminant-chosen-p (aref discriminants-array id))) (rules disc)))))

(defmethod display-discriminant-p ((disc f-structure-discriminant) &key show-all-fs-discs-p)
  (and (call-next-method)
       (or show-all-fs-discs-p
	   (with-slots (right-anchor) disc
	     (and right-anchor (not (eql right-anchor -1)))))))

(defun filter-discriminants (disc-list &key show-all-fs-discs-p)
  (loop for disc in disc-list
	when (display-discriminant-p disc :show-all-fs-discs-p show-all-fs-discs-p)
	collect disc))

(defmethod discriminant-frequency ((disc discriminant) discriminant-statistics)
  (or (cadr (dat:string-tree-get discriminant-statistics (discriminant-string disc))) 0))

(defmethod discriminant-frequency ((disc constituent-discriminant) discriminant-statistics)
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (max (call-next-method)
	   (reduce #'max (rules disc)
	       :key (lambda (rule-id)
		      (discriminant-frequency (aref (discriminants-array discriminants) rule-id) discriminant-statistics))
	       :initial-value 0)))))

(defmethod discriminative-power ((disc discriminant))
  (let* ((discriminants (discriminants disc))
	 (reduced-context (reduced-context (s-context disc) (s-context discriminants))))
    (if (or (discriminant-chosen-p disc)
	    (eq reduced-context 1))
	10000000
	(let ((1-count (count 1 reduced-context)))
	  (min 1-count (- (length reduced-context) 1-count))))))

(defmethod discriminative-power ((disc constituent-discriminant))
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (min (call-next-method)
	   (reduce #'min (rules disc)
	       :key (lambda (rule-id)
		      (discriminative-power (aref (discriminants-array discriminants) rule-id)))
	       :initial-value 10000000)))))

(defmethod discriminants-xml ((discriminants discriminants) stream
			      &key solution-count show-all-fs-discs-p
			      disc-sorting
			      discriminant-statistics ;; string-tree: disc-str -> type.count
			      &allow-other-keys)
  (unless disc-sorting (setf disc-sorting :type))
  (with-slots (discriminants-s-context discriminants-array constituent-discriminants lex-discriminants
				       morph-discriminants) discriminants
    #+debug(setf disc-sorting :frequency)
    #+debug(print (list :show-all-fs-discs-p show-all-fs-discs-p))
    #+debug(print (list :disc-sorting disc-sorting :context discriminants-s-context :array discriminants-array))
    (let ((*package* (find-package :xle))
	  (show-really-all-fs-discs-p
	   (or show-all-fs-discs-p
	       ;; show all if there are no valid pred-pred discriminants left
	       (not (loop for disc in (f-structure-discriminants discriminants)
			  when (with-slots (right-anchor valid-p chosen-p) disc
				 (and valid-p
				      (not chosen-p)
				      (and right-anchor (not (eql right-anchor -1)))))
			  do (return t))))))
      #m((discriminants :chosen #s (if (eq discriminants-s-context 1)
				       solution-count ;; "all"
				       (count 1 discriminants-s-context))
			:chosen-bv #s (format nil "~a" discriminants-s-context)
			:show-all-fs-discs #s (if show-all-fs-discs-p "true")
			:disc-sorting #s (string-downcase disc-sorting))
	 #L(case disc-sorting
	     (:type
	      (dolist (disc (sort (filter-discriminants constituent-discriminants)
				  (lambda (x y) (if (and x y) (< x y) nil))
				  :key #'discriminant-anchor))
		(discriminant-xml disc stream))
	      (dolist (disc (sort (filter-discriminants lex-discriminants)
				  (lambda (x y) (if (and x y) (< x y) nil))
				  :key #'discriminant-anchor))
		(discriminant-xml disc stream))
	      (dolist (disc (sort (filter-discriminants morph-discriminants)
				  (lambda (x y) (if (and x y) (< x y) nil))
				  :key #'discriminant-anchor))
		(discriminant-xml disc stream))
	      (dolist (disc (sort (filter-discriminants (f-structure-discriminants discriminants)
							:show-all-fs-discs-p show-really-all-fs-discs-p)
				  (lambda (x y) (if (and x y) (< x y) nil))
				  :key #'discriminant-anchor))
		(discriminant-xml disc stream)))
	     (:discriminating-power
	      (dolist (disc (stable-sort (append (filter-discriminants constituent-discriminants)
						 (filter-discriminants lex-discriminants)
						 (filter-discriminants morph-discriminants)
						 (filter-discriminants (f-structure-discriminants discriminants)
								       :show-all-fs-discs-p show-really-all-fs-discs-p))
					 (lambda (x y)
					   (cond ((and x y)
						  (< x y))
						 (t
						  nil)))
					 :key #'discriminative-power))
		;;(print (list disc (discriminative-power disc)))
		(discriminant-xml disc stream :top-p nil)))
	     (:frequency
	      ;;(print (list :freq discriminant-statistics))
	      (let* ((filtered-discs
		      (append (filter-discriminants constituent-discriminants)
			      (filter-discriminants lex-discriminants)
			      (filter-discriminants morph-discriminants)
			      (filter-discriminants (f-structure-discriminants discriminants)
						    ;; we have to keep all because some of them might be top frequent and shown unconditionally
						    :show-all-fs-discs-p t #+ignore show-really-all-fs-discs-p)))
		     (frequency-sorted-discs
		      (stable-sort filtered-discs
				   (lambda (x y)
				     (cond ((and x y)
					    (> x y))
					   (x
					    t)
					   (t
					    nil)))
				   :key (lambda (disc) (discriminant-frequency disc discriminant-statistics)))))
		;;(print (mapcar (lambda (disc) (discriminant-frequency disc discriminant-statistics)) frequency-sorted-discs))
		(loop for rest on frequency-sorted-discs
		      for i from 0
		      while (cond ((and (< i 10)
					(discriminant-frequency (car rest) discriminant-statistics)
					(> (discriminant-frequency (car rest) discriminant-statistics) 1))
				   (discriminant-xml (car rest) stream :top-p t)
				   t)
				  (t
				   (dolist (disc (sort rest
						       (lambda (x y) (if (and x y) (< x y) nil))
						       :key #'discriminant-anchor))
				     (when (or show-really-all-fs-discs-p
					       (display-discriminant-p disc))
				       (discriminant-xml disc stream)))
				   nil))))))))))

(defparameter *show-weights-p* nil)

(defmethod discriminant-xml ((disc constituent-discriminant) stream &key top-p)
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (when t #+ignore(or (discriminant-valid-p disc)
		(discriminant-chosen-p disc)
		(find-if (lambda (id) (discriminant-chosen-p (aref discriminants-array id))) (rules disc)))
	(let ((reduced-context (reduced-context (s-context disc) (s-context discriminants))))
	  #m((segmentation :segments #s (constituents disc)
			   :anchor #s (unless (eql (discriminant-anchor disc) -1)
					(discriminant-anchor disc))
			   :id #s (discriminant-id disc)
			   :top #s (when top-p "yes")
			   :valid #s (if (discriminant-valid-p disc) "yes" "no")
			   :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
			   :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
			   :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
			   :context #s(write-to-string reduced-context)
			   :reduction #s(unless (or (discriminant-chosen-p disc)
						    (eq reduced-context 1))
					  (count 1 reduced-context)))
	     #L(dolist (disc-id (rules disc))
		 (if disc-id
		     (let ((disc (aref discriminants-array disc-id)))
		       (when (or (discriminant-valid-p disc) (discriminant-chosen-p disc))
			 #+debug(print (list disc :valid (discriminant-valid-p disc) :chosen (discriminant-chosen-p disc)))
			 (let ((reduced-context (reduced-context (s-context disc) (s-context discriminants))))
			   #m((discriminant :type "rule-discriminant"
					    :id #s (discriminant-id disc)
					    :valid #s(if (discriminant-valid-p disc) "yes" "no")
					    :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
					    :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
					    :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
					    :context #s(write-to-string reduced-context)
					    :reduction #s(unless (or (discriminant-chosen-p disc)
								     (eq reduced-context 1))
							   (count 1 reduced-context))
					    :weight #s(let* ((grammar (grammar discriminants))
							     (weights (when grammar (weight-table grammar))))
							(when (and *show-weights-p* weights)
							  (dat:string-tree-get weights (discriminant-string disc) 0))))
			      (rule #s (rule disc))))))
		     (warn "Rule is 'nil' in ~s" (rules disc))))))))))

(defmethod discriminant-xml ((disc lex-discriminant) stream &key top-p)
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (when t;(or (discriminant-valid-p disc) (discriminant-chosen-p disc))
	(let ((reduced-context (reduced-context (s-context disc) (s-context discriminants))))
	  #m((discriminant :type "lex-discriminant"
			   :id #s (discriminant-id disc)
			   :anchor #s (unless (eql (discriminant-anchor disc) -1)
					(discriminant-anchor disc))
			   :valid #s(if (discriminant-valid-p disc) "yes" "no")
			   :top #s (when top-p "yes")
			   :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
			   :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
			   :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
			   :context #s(write-to-string reduced-context)
			   :reduction #s(unless (or (discriminant-chosen-p disc)
						    (eq reduced-context 1))
					  (count 1 reduced-context))
			   :weight #s(let* ((grammar (grammar discriminants))
					    (weights (when grammar (weight-table grammar))))
					 (when (and *show-weights-p* weights)
					   (dat:string-tree-get weights (discriminant-string disc) 0))))
	     (rule #s (rule disc))))))))

(defmethod discriminant-xml ((disc morph-discriminant) stream &key top-p)
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (when t;(or (discriminant-valid-p disc) (discriminant-chosen-p disc))
	(let ((reduced-context (reduced-context (s-context disc) (s-context discriminants))))
	  #m((discriminant :type "morph-discriminant"
			   :id #s (discriminant-id disc)
			   :anchor #s (unless (eql (discriminant-anchor disc) -1)
					(discriminant-anchor disc))
			   :valid #s(if (discriminant-valid-p disc) "yes" "no")
			   :top #s (when top-p "yes")
			   :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
			   :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
			   :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
			   :context #s(write-to-string reduced-context)
			   :reduction #s(unless (or (discriminant-chosen-p disc)
						    (eq reduced-context 1))
					  (count 1 reduced-context))
			   :weight #s(let* ((grammar (grammar discriminants))
					    (weights (when grammar (weight-table grammar))))
					 (when (and *show-weights-p* weights)
					   (dat:string-tree-get weights (discriminant-string disc) 0))))
	     (morph-features #s (morph-features disc))))))))

(defmethod discriminant-xml ((disc f-structure-discriminant) stream &key top-p)
  (let ((discriminants (discriminants disc)))
    (with-slots (discriminants-array) discriminants
      (with-slots (path-segment anchor right-anchor context valid-p chosen-p) disc
	(when t #+ignore(and (or valid-p chosen-p)
		   (or show-all-fs-discs-p
		       (and right-anchor (not (eql right-anchor -1)))))
	  (let ((reduced-context (reduced-context context (s-context discriminants))))
	    #m((discriminant :type "f-structure-discriminant"
			     :id #s (discriminant-id disc)
			     :valid #s(if valid-p "yes" "no")
			     :top #s (when top-p "yes")
			     :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
			     :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
			     :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
			     :context #s(write-to-string reduced-context)
			     :reduction #s(unless (or (discriminant-chosen-p disc)
						      (eq reduced-context 1))
					    (count 1 reduced-context))
			     :anchor #s(unless (eql anchor -1) anchor)
			     :right-anchor #s(unless (eql right-anchor -1) right-anchor)
			     :weight #s(let* ((grammar (grammar discriminants))
					      (weights (when grammar (weight-table grammar))))
					 (when (and *show-weights-p* weights)
					   (dat:string-tree-get weights (discriminant-string disc) 0))))
	       (path-segment #s path-segment))))))))

(defstylesheet xle-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")     
     ((xsl:template :match "/parse")
      ((html xmlns:tool "urn:schemas-microsoft-com:tool")
       (head
        (title "XLE Web Interface"
	       ((xsl:if :test "@user")
		" [" (xsl:value-of/ :select "@user") "]"))
        ((style :type "text/css")
	 (!CDATA
	  (CSS-STYLE
	    (div :margin "16"
		 :color #-BW "#004499" #+BW "black"
		 :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	    (div.title :font-size "18" :font-weight "bold" :text-align "center")
	    (div.link :font-size "12");; :font-weight "bold" :text-align "center")
	    (a :text-decoration "none" :color #-BW "#004499" #+BW "black")
	    (a\:hover :text-decoration "underline")
	    (div.label :font-size "12")
	    (div.text :font-size "8pt" :color "black" :margin-left "2px" :margin-bottom "2px")
	    (div.error :font-size "8pt" :color "red" :margin-left "2px" :margin-bottom "2px")
	    (span.error :font-size "10pt" :color "red" :font-weight "normal")
	    (div.error-title :font-size "10pt" :color "red" :margin-left "2px" :margin-bottom "2px" :font-weight "bold")
	    (div.message :font-size "8pt" :color "green" :margin-left "2px" :margin-bottom "2px")
	    (div.message-title :font-size "10pt" :color "green" :margin-left "2px" :margin-bottom "2px" :font-weight "bold")
	    (div.justification :font-size "8pt" :color "black" :margin-left "2px" :margin-bottom "2px" :font-weight "bold")
	    (span.sentence :font-size "14" :color "black")
	    (span.text :color "black" :font-weight "normal"); :font-weight "bold")
	    (table :padding "0pt" :font-size "8pt" :border-collapse "collapse" ;; ??
		   :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	    (table.fs :border-collapse "separate")
	    (td.misc :margin "0pt" :padding "0pt" :border "none")
	    (td.just :margin "0pt" :padding "0pt" :border "1px red solid")
	    (td.disc-type :margin "10px" :padding "10px" :border "none" :color #-BW "#004499" #+BW "black"
			  :font-weight "bold" :font-size "8pt")
	    (span.morph :color "black")
	    (table.morph :border-collapse "collapse")
	    #-BW
	    (td.morph :vertical-align "top" :margin "0px" :padding "2px" :border "0px gray solid" :cursor "pointer")
	    (td.morph-hilite :vertical-align "top" :margin "0px" :padding "2px" :border "1px gray solid"
			     :cursor "pointer" :background "magenta")
	    (td.morph-box :margin "0px" :padding "0px" :border "0px green solid")
	    #-BW
	    (td.disc :margin "0px" :padding "3px" :border "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.disc-anchor :margin "0px" :padding "3px" :border "2px gray solid" :text-align "right")
	    #-BW
	    (td.reduction :text-align "right" :margin "0px" :padding "3px" :border "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.seg-disc :margin "0px" :padding "3px" :border-left "2px gray solid" :border-top "2px gray solid" :border-right "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.seg-disc-anchor :margin "0px" :padding "3px" :border-left "2px gray solid" :border-top "2px gray solid" :border-right "2px gray solid" :text-align "right")
	    #-BW
	    (td.rule-disc :margin "0px" :padding "3px" :border-left "2px gray solid" :border-right "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.rule-disc-anchor :margin "0px" :padding "3px" :border-left "2px gray solid" :border-right "2px gray solid" :text-align "right")
	    #-BW
	    (td.last-rule-disc :margin "0px" :padding "3px" :border-bottom "2px gray solid" :border-left "2px gray solid" :border-right "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.last-seg-disc :margin "0px" :padding "3px" :border "2px gray solid" :cursor "pointer")
	    #-BW
	    (td.last-seg-disc-anchor :margin "0px" :padding "3px" :border "2px gray solid" :text-align "right")
	    #-BW
	    (td.last-seg-disc-hilite :margin "0px" :padding "3px" :border "2px gray solid" :cursor "pointer" :background "magenta")
	    #-BW
	    (td.disc-hilite :margin "0px" :padding "3px" :border "2px gray solid" :background "magenta" :cursor "pointer":cursor "pointer")
	    #-BW
	    (td.seg-disc-hilite :margin "0px" :padding "3px" :border-left "2px gray solid" :border-top "2px gray solid" :border-right "2px gray solid" :cursor "pointer"
				:background "magenta")
	    #-BW
	    (td.rule-disc-hilite  :margin "0px" :padding "3px" :border-left "2px gray solid" :border-right "2px gray solid" :cursor "pointer" :background "magenta")
	    #-BW
	    (td.last-rule-disc-hilite  :margin "0px" :padding "3px"
				       :border-bottom "2px gray solid" :border-left "2px gray solid" :border-right "2px gray solid"
				       :cursor "pointer" :background "magenta")
	    #-BW
	    (td.fs :padding "2px" ;; :padding-left "3px" :padding-right "1px"
		   :margin "1px" :border-left "2px gray solid" :border-right "2px gray solid")
	    
	    #+BW
	    (td.disc :margin "0px" :padding "3px" :border "1px black solid" :cursor "pointer")
	    #+BW
	    (td.seg-disc :margin "0px" :padding "3px" :border-left "1px black solid" :border-top "1px black solid" :border-right "1px black solid" :cursor "pointer")
	    #+BW
	    (td.rule-disc :margin "0px" :padding "3px" :border-left "1px black solid" :border-right "1px black solid" :cursor "pointer")
	    #+BW
	    (td.last-rule-disc :margin "0px" :padding "3px" :border-bottom "1px black solid" :border-left "1px black solid" :border-right "1px black solid" :cursor "pointer")
	    #+BW
	    (td.last-seg-disc :margin "0px" :padding "3px" :border "1px black solid" :cursor "pointer")
	    #+BW
	    (td.last-seg-disc-hilite :margin "0px" :padding "3px" :border "1px black solid" :cursor "pointer" :background "magenta")
	    #+BW
	    (td.disc-hilite :margin "0px" :padding "3px" :border "1px black solid" :background "magenta" :cursor "pointer":cursor "pointer")
	    #+BW
	    (td.seg-disc-hilite :margin "0px" :padding "3px" :border-left "1px black solid" :border-top "1px black solid" :border-right "1px black solid" :cursor "pointer"
				:background "magenta")
	    #+BW
	    (td.rule-disc-hilite  :margin "0px" :padding "3px" :border-left "1px black solid" :border-right "1px black solid" :cursor "pointer" :background "magenta")
	    #+BW
	    (td.last-rule-disc-hilite  :margin "0px" :padding "3px"
				       :border-bottom "1px black solid" :border-left "1px black solid" :border-right "1px black solid"
				       :cursor "pointer" :background "magenta")
	    #+BW
	    (td.fs :padding "2px" :margin "1px" :border-left "1px black solid" :border-right "1px black solid")


	    (td.fs-focus :padding "2px" ;; :padding-left "3px" :padding-right "1px"
			 :margin "1px" :border "2px red solid")
	    (td.fs-projection :padding "2px" ;; :padding-left "3px" :padding-right "1px"
			      :margin "1px" :border "2px red solid" :background "lightgray")
	    (td.attribute :color #-BW "#004499" #+BW "black" :font-weight "bold")
	    (td.var :color #-BW "red" #+BW "black" :vertical-align "bottom" :font-size "6pt")
	    (tr.seg :cursor "pointer")
	    (.c-disc
	     :cursor "pointer")
	    (.c-disc-hilite
	     :background "lightgray"
	     :cursor "pointer")
	    (.c-seg
	     :color #-BW "blue" #+BW "black"
	     :cursor "pointer")
	    (.c-seg-redundant
	     :color #-BW "gray" #+BW "black")
	    (.c-seg-chosen
	     :color "black")
	    (.c-seg-invalid
	     :color #-BW "red" #+BW "black")
	    (.c-seg-hilite
	     :background "lightgray"
	     :cursor "pointer")
	    (.fs-disc
	     :cursor "pointer")
	    (.fs-disc-hilite
	     :background "lightgray"
	     :cursor "pointer")
	    (tr.dis-border :border #-BW "1px gray solid" #+BW "1px black solid")
	    (td.dis :color #-BW "green" #+BW "black" :cursor "pointer");; :vertical-align "top")
	    (td.dis-chosen :color #-BW "red" #+BW "black" :font-weight "bold" :cursor "pointer");; :vertical-align "top")
	    (span.attribute :color #-BW "#004499" #+BW "black" :font-weight "bold")
	    (.ctx :color #-BW "green" #+BW "black" :font-weight "bold" :cursor "pointer"
		  :font-size "7pt" :vertical-align "sub")
	    (span.pointer :color #-BW "red" #+BW "black")
	    (span.pointer-focus :background "red" :color "white")
	    ;; MRS
	    (span.qeq :color #-BW "#004499" #+BW "black")
	    (span.qeq-focus :color "white" :background "gray")
	    (span.attribute :color #-BW "#004499" #+BW "black" :font-weight "bold")
	    (span.handle :color "black")
	    (span.handle-label :color "white" :background "blue")
	    (span.harg :color "white" :background "red")
	    (span.larg :color "white" :background "blue")
	    (span.handle-arg :color "white" :background "red")
	    (span.pointer :color #-BW "red" #+BW "black")
	    (span.pointer-focus :background "red" :color "white")
	    ;;(a :text-decoration "none" :color "black")
	    #+ignore
	    (td :color "green"))))
	((SCRIPT :type "text/javascript" :language "javascript") 
         (!CDATA #L(js/xle stream))))
       ((body :style "font-family: Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	(xsl:choose
	 ((xsl:when :test "@f-structure-only")
	  (xsl:apply-templates/ :select "projections"))
	 (xsl:otherwise
	  ((div :class "link") ((a :href #s *documentation-url* #+old(concatenate 'string "/" *url-base* "/xle-web-documentation.xml")) "Documentation"))
	  ((div :class "title") "XLE Web Interface")
	  ((table :width "600px")
	   #L(when *email-suffixes*
	       #m((xsl:if :test "@user")
		  (tr
		   (td
		    ((form :method "post" :id "upload-form"
			   :enctype "multipart/form-data")
		     "Upload grammar: "
		     (input/ :type "file" :name "upload-grammar-name" ;;:size "40"
			     :value "Choose grammar file ...")
		     (input/ :type "submit" :name "upload-grammar" :value "Upload")
		     )))))
	   ((xsl:if :test "@grammar")
	    (tr
	     (td
	      ((form :method "post" :id "form")
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "hidden")
		((xsl:attribute :name "name") "xle-graph-id")
		((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id")))
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "hidden")
		((xsl:attribute :name "name") "disjunction-choice")
		((xsl:attribute :name "id") "disjunction-choice")
		((xsl:attribute :name "value") (xsl:value-of/ :select "@disjunction-choice")))
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "hidden")
		((xsl:attribute :name "name") "node-id")
		((xsl:attribute :name "id") "node-id")
		((xsl:attribute :name "value") ""))
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "hidden")
		((xsl:attribute :name "name") "dtree")
		((xsl:attribute :name "id") "dtree")
		((xsl:attribute :name "value") ""))
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "hidden")
		((xsl:attribute :name "name") "edge")
		((xsl:attribute :name "id") "edge")
		((xsl:attribute :name "value") ""))
	       #L(parse-input-area stream :type :c-structure))))
	    (tr
	     (td
	      (table
	       (tr
		(td ((xsl:element :name "form")
		     ((xsl:attribute :name "method") "post")
		     ((xsl:attribute :name "name") "discriminant-form")
		     ((xsl:attribute :name "id") "discriminant-form")
		     #+ignore((xsl:attribute :name "action")
		      "/" #s *url-base*
		      (xsl:choose
		       ((xsl:when :test "not(@f-structure-p)")
			"/xle-c-structure.xml")
		       (xsl:otherwise "/xle.xml")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "xle-graph-id")
		      ((xsl:attribute :name "id") "xle-graph-id")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "grammar")
		      ((xsl:attribute :name "id") "grammar")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@grammar")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "sentence")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@sentence")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "font")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@font")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "disable-OT")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@disable-OT")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "packed")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@packed")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "previous-packed")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@previous-packed")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "cg-preparse")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse-on-fragment-analysis")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "disjunction-choice")
		      ((xsl:attribute :name "id") "disjunction-choice")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@disjunction-choice")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "discriminant-choice")
		      ((xsl:attribute :name "id") "discriminant-choice")
		      ((xsl:attribute :name "value") "" #+test (xsl:value-of/ :select "@discriminant-choice")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "complementp")
		      ((xsl:attribute :name "id") "complementp")
		      ((xsl:attribute :name "value") ""))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "non-top-f-structures")
		      ((xsl:attribute :name "id") "non-top-f-structures")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@non-top-f-structures")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "ranking")
		      ((xsl:attribute :name "id") "ranking")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@ranking")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "inspect")
		      ((xsl:attribute :name "id") "inspect")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@inspect")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "partial-nodes")
		      ((xsl:attribute :name "id") "partial-nodes")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@partial-nodes")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "sublexical-nodes")
		      ((xsl:attribute :name "id") "sublexical-nodes")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@sublexical-nodes")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "suppress-check")
		      ((xsl:attribute :name "id") "suppress-check")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@suppress-check")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "preds-only")
		      ((xsl:attribute :name "id") "preds-only")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@preds-only")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "show-all-fs-discs")
		      ((xsl:attribute :name "id") "show-all-fs-discs")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "discriminants/@show-all-fs-discs")))
		     
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "show-discriminants")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-discriminants")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "show-disjunctions")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-disjunctions")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "show-c-structure")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-c-structure")))
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "hidden")
		      ((xsl:attribute :name "name") "show-f-structure")
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-f-structure")))
		     ((xsl:if :test "@mrs-p")
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "show-mrs")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-mrs")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "show-features")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@show-features"))))
		     
		     ((xsl:if :test "not(@inspect or @count=0 or @count=1)")
		      ((xsl:if :test "@pos")
		       (input/ :style "font-size: 8pt"
			       :type "submit" :name "previous-solution" :value "Previous")
		       (input/ :style "font-size: 8pt"
			       :type "submit" :name "next-solution" :value "Next")))))
		#+obsolete?
		((xsl:if :test "@mrs-p and not(@inspect)")
		 (td ((form :method "post" :action #s (concatenate 'string "/" *url-base* "/xle-mrs.xml"))
		      ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id"))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "xle-graph-id")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "grammar")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@grammar")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "sentence")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@sentence")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "disable-OT")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@disable-OT")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "packed")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@packed")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "previous-packed")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@previous-packed")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "cg-preparse")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse-on-fragment-analysis")))
		      (input/ :style "font-size: 8pt"
			      :type "submit" :name "same-solution" :value "Show MRS"))))
		#+obsolete
		((xsl:if :test "not(@f-structure-p)")
		 (td ((form :method "post" :action #s (concatenate 'string "/" *url-base* "/xle-f-structure.xml"))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "xle-graph-id")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "grammar")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@grammar")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "sentence")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@sentence")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "disable-OT")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@disable-OT")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "packed")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@packed")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "previous-packed")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@previous-packed")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "cg-preparse")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse")))
		      ((xsl:element :name "input")
		       ((xsl:attribute :name "type") "hidden")
		       ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		       ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse-on-fragment-analysis")))
		      (input/ :style "font-size: 8pt"
			      :type "submit" :name "same-solution" :value "Show F-structure"))))))
	      #+ignore
	      ((div :class "label")
	       "Parsed sentence: "
	       ((span :class "sentence")
		(xsl:value-of/ :select "@sentence")))
	      ((xsl:if :test "not(@inspect)")
	       ((div :class "text")
		(xsl:choose
		 ((xsl:when :test "@statistics")
		  ((xsl:if :test "@pos and @count>1")
		   "Solution " (xsl:value-of/ :select "1 + @pos") " of ")
		  (xsl:value-of/ :select "@statistics"))
		 ((xsl:when :test "@count=0")
		  "No solution was found.")
		 ((xsl:when :test "@pos")
		  "Solution " (xsl:value-of/ :select "1 + @pos")
		  " of " (xsl:value-of/ :select "@count") ":")
		 ((xsl:when :test "@count=1")
		  "1 solution:")
		 #+test
		 (xsl:otherwise
		  (xsl:value-of/ :select "@count") " solutions:")
	     
		 ((xsl:when :test "@count = 1")
		  "One solution "
		  ((xsl:if :test "@unoptimal-count and @unoptimal-count>0")
		   " (+ " (xsl:value-of/ :select "@unoptimal-count") " unoptimal solution(s)) ")
		  " was found. ")
		 (xsl:otherwise
		  (xsl:value-of/ :select "@count")
		  ((xsl:if :test "@unoptimal-count and @unoptimal-count>0")
		   " (+ " (xsl:value-of/ :select "@unoptimal-count") " unoptimal)")
		  " solutions: "))
		((xsl:if :test "@unoptimal-count and @unoptimal-count>0")
		 " (Only optimal solutions are shown.)")))
	      (table
	       (tr
		#-PARGRAM
		((xsl:if :test "discriminants")
		 ((xsl:element :name "input")
		  ((xsl:attribute :name "type") "hidden")
		  ((xsl:attribute :name "name") "show-all-fs-discs")
		  ((xsl:attribute :name "id") "show-all-fs-discs")
		  ((xsl:attribute :name "value") (xsl:value-of/ :select "discriminants/@show-all-fs-discs")))
		 ((td :style "vertical-align: top")
		  (table (tr (td ((div :class "title")
				  "Discriminants")
				 ((xsl:element :name "div")
				  ((xsl:attribute :name "title") (xsl:value-of/ :select "discriminants/@chosen-bv"))
				  (nobr "Selected solutions: " (xsl:value-of/ :select "discriminants/@chosen")
					" of " (xsl:value-of/ :select "@count")))
				 ((table :style "margin: 5pt" :id "discriminants")
				  ((xsl:if :test "discriminants/discriminant[@type='lex-discriminant']")
				   (tr ((td :class "disc-type" :colspan "4") "Lexical discriminants"))
				   (xsl:apply-templates/ :select "discriminants/discriminant[@type='lex-discriminant']"))
				  ((xsl:if :test "discriminants/discriminant[@type='morph-discriminant']")
				   (tr ((td :class "disc-type" :colspan "4") "Morphological discriminants"))
				   (xsl:apply-templates/ :select "discriminants/discriminant[@type='morph-discriminant']"))
				  ((xsl:if :test "discriminants/segmentation")
				   (tr ((td :class "disc-type" :colspan "4") "C-structure discriminants"))
				   (xsl:apply-templates/ :select "discriminants/segmentation")); :mode "c-structure"))
				  ((xsl:if :test "discriminants/discriminant[@type='f-structure-discriminant']")
				   (tr ((td :class "disc-type" :colspan "4")
					(nobr "F-structure discriminants"
					      ((span :class "text")
					       " | show all "
					       ((xsl:element :name "input")
						((xsl:attribute :name "type") "checkbox")
						((xsl:attribute :name "name") "show-all-fs-discs")
						((xsl:if :test "discriminants/@show-all-fs-discs")
						 ((xsl:attribute :name "checked") "yes"))
						((xsl:attribute :name "onclick")
						 "displayDiscriminants('"
						 (xsl:value-of/ :select "discriminants/@show-all-fs-discs")
						 "')"))))))
				   (xsl:apply-templates/ :select "discriminants/discriminant[@type='f-structure-discriminant']")))
				 ;;(br/)
				 )))))
		((xsl:if :test "packed-disjunction")
		 ((td :style "vertical-align: top" :id "disjunctions" :name "disjunctions")
		  ((div :class "title") (nobr "Disjunctions"))
		  (table (xsl:apply-templates/ :select "packed-disjunction"))
		  ((xsl:if :test "equivalences")
		   (div "Equivalences:")
		   (table (xsl:apply-templates/ :select "equivalences")))))
		
		((xsl:if :test "chart-tree")
		 ((td :style "vertical-align: top")
		  ((div :class "title") "Morphology")
		  (xsl:apply-templates/ :select "chart-tree")))
		
		((xsl:if :test "c-structure")
		 ((td :style "vertical-align: top" :id "cstructure" :name "cstructure")
		  ((div :class "title") (nobr "C-structure"))
		  ((xsl:element :name "form")
		   ((xsl:attribute :name "method") "get")
		   ((xsl:attribute :name "id") "c-structure")
		   ((div)
		    (xsl:choose
		     ((xsl:when :test "/parse/@object-element='object'")
		      ((xsl:element :name "object")
		       ((xsl:attribute :name "name") "svg")
		       ((xsl:attribute :name "type") "image/svg+xml")
		       ((xsl:attribute :name "data")
			(xsl:choose
			 ((xsl:when :test "/parse/@treebank")
			  #s(concatenate 'string "/" *url-base* "/treebank-c-structure.svg?sentence-id=")
			  (xsl:value-of/ :select "/parse/@sentence-id")
			  "&amp;treebank="
			  (xsl:value-of/ :select "/parse/@treebank"))
			 (xsl:otherwise
			  #s(concatenate 'string "/" *url-base* "/xle-c-structure.svg?graph-id=")
			  (xsl:value-of/ :select "/parse/@xle-graph-id")
			  "&amp;grammar="
			  ;;(xsl:value-of/ :select "/parse/@encoded-grammar-name")
			  (xsl:value-of/ :select "/parse/@grammar"))))
		       ((xsl:attribute :name "width") (xsl:value-of/ :select "/parse/c-structure/@width"))
		       ((xsl:attribute :name "height") (xsl:value-of/ :select "/parse/c-structure/@height"))
		       "C-Structure"))
		     (xsl:otherwise
		      ((xsl:element :name "embed")
		       ((xsl:attribute :name "src")
			(xsl:choose
			 ((xsl:when :test "/parse/@treebank")
			  #s(concatenate 'string "/" *url-base* "/treebank-c-structure.svg?sentence-id=")
			  (xsl:value-of/ :select "/parse/@sentence-id")
			  "&amp;treebank="
			  (xsl:value-of/ :select "/parse/@treebank"))
			 (xsl:otherwise
			  #s(concatenate 'string "/" *url-base* "/xle-c-structure.svg?graph-id=")
			  (xsl:value-of/ :select "/parse/@xle-graph-id")
			  "&amp;grammar="
			  (xsl:value-of/ :select "/parse/@grammar"))))
		       ((xsl:attribute :name "type") "image/svg+xml")
		       ((xsl:attribute :name "name") "CStructure")
		       ((xsl:attribute :name "pluginspace") "http://www.adobe.com/svg/viewer/install/")
		       ((xsl:attribute :name "width") (xsl:value-of/ :select "/parse/c-structure/@width"))
		       ((xsl:attribute :name "height") (xsl:value-of/ :select "/parse/c-structure/@height")))))))))

		;; F-structure
		((xsl:if :test "@show-f-structure")
		 ((td :style "vertical-align: top" :id "fstructure" :name "fstructure")
		  (xsl:apply-templates/ :select "projections")))
		
		;; MRS
		((xsl:if :test "@show-mrs")
		 
		 ((td :style "vertical-align: top; left-margin: 5em" :id "mrs" :name "mrs")
		  ((div :class "title") (nobr "MRS"))
		  ((div :style "left-margin: 5em")
		   (xsl:apply-templates/ :select "psoa"))))

		((td :style "vertical-align: top")
		 (nobr (div/ :id "sexp" :name "sexp")))))))))
	  ;;#+(OR XLE-WEB PARGRAM)
	  ((div :class "link")
	   (hr/ :size "1" :color "black")
	   ((a :href "http://www.aksis.uib.no") "Aksis, Unifob") "; "
	   ((a :href "http://www.aksis.uib.no") "LLE, University of Bergen")
	   ", " #s(u::now :format :year) " (administrator: "
	   ((a :href "mailto:paul.meurer@aksis.uib.no") "Paul Meurer")")"))))))
     
     ((xsl:template :match "line")
      (xsl:value-of/ :select "text()") (br/))

     ((xsl:template :match "grammar")
      ((xsl:if :test "not(@owner) or @owner = /parse/@user or /parse/@super-user")
       ((xsl:element :name "option")
	((xsl:attribute :name "value") (xsl:value-of/ :select "@name"))
	((xsl:if :test "@name=/parse/@grammar")
	 ((xsl:attribute :name "selected") "true"))
	(xsl:value-of/ :select "@short-name"))))

     #L(discriminant-templates stream)
     
     ((xsl:template :match "equivalence")
      (nobr (xsl:value-of/ :select "@abb") " = " (xsl:value-of/ :select "@term"))
      (br/))
     
     ((xsl:template :match "packed-disjunction")
      ((xsl:element :name "tr")
       #+test
       ((xsl:attribute :name "class")
	(xsl:choose
	 ((xsl:when :test "../../packed-disjunction|../../packed-conjunction")
	  "dis-border")
	 (xsl:otherwise
	  "dis")))
       ((xsl:element :name "td")
	((xsl:attribute :name "class")
	 (xsl:choose
	  ((xsl:when :test "@chosen='yes'") "dis-chosen")
	  (xsl:otherwise "dis")))
	((xsl:attribute :name "onclick")
	 "chooseDisjunction('" (xsl:value-of/ :select "@node-id") "')")
	;;(xsl:value-of/ :select "@summand") ":"
	(xsl:value-of/ :select "@name"))
       ((xsl:element :name "td")
	(table (xsl:apply-templates/)))))

     ((xsl:template :match "packed-conjunction")
      ((xsl:element :name "tr")
       ((xsl:attribute :name "class")
	(xsl:choose
	 ((xsl:when :test "../../packed-disjunction|../../packed-conjunction")
	  "dis-border")
	 (xsl:otherwise
	  "dis")))
       (td "&amp;")
       ((xsl:element :name "td")
	(table (xsl:apply-templates/)))))
     
     #L(f-structure-templates stream)
     #L(chart-tree-templates stream)
     #L(mrs-templates stream)))

(defun discriminant-templates (stream)
  
  #m((xsl:template :match "segmentation")
     ((xsl:element :name "tr")
      ((xsl:attribute :name "class") "seg")
      ((xsl:element :name "td")
       (xsl:choose
	((xsl:when :test "@chosen='yes'")
	 ((xsl:attribute :name "class") "last-seg-disc-anchor"))
	(xsl:otherwise
	 ((xsl:attribute :name "class") "seg-disc-anchor")))
       ((xsl:attribute :name "title") "Anchor")
       (xsl:value-of/ :select "@anchor"))
      ((xsl:element :name "td")
       (xsl:choose
	((xsl:when :test "@chosen='yes'")
	 ((xsl:attribute :name "class") "last-seg-disc")
	 ((xsl:attribute :name "onmouseover")
	  "this.className = 'last-seg-disc-hilite'")
	 ((xsl:attribute :name "onmouseout")
	  "this.className = 'last-seg-disc'")
	 ((xsl:attribute :name "onclick")
	  "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
	(xsl:otherwise
	 ((xsl:attribute :name "class") "seg-disc")
	 ((xsl:if :test "(@valid='yes' or @chosen='yes') and @redundant='no'")
	  ((xsl:attribute :name "onmouseover")
	   "this.className = 'seg-disc-hilite'")
	  ((xsl:attribute :name "onmouseout")
	   "this.className = 'seg-disc'")
	  ((xsl:attribute :name "onclick")
	   "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))))
       ((xsl:element :name "span")
	((xsl:attribute :name "class")
	 (xsl:choose
	  ((xsl:when :test "@chosen='yes'") "c-seg-chosen")
	  ((xsl:when :test "@redundant='yes'") "c-seg-redundant")
	  ((xsl:when :test "@valid='yes'") "c-seg")
	  (xsl:otherwise #+ignore "c-seg-invalid" "c-seg-redundant")))
	((xsl:attribute :name "style")
	 ((xsl:if :test "@chosen='yes'") "font-weight: bold"))
	((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	;;(xsl:value-of/ :select "@anchor") ":"
	(xsl:value-of/ :select "@segments")))
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "reduction")
       ((xsl:attribute :name "title") "# of solutions after discriminant application")
       (xsl:value-of/ :select "@reduction"))
      #L(discriminant-complement-xsl stream)
      ((xsl:if :test "@weight")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: gray")
	   (nobr (xsl:value-of/ :select "@weight"))))
      ((xsl:if :test "@top='yes'")
       ((xsl:element :name "td")
	((xsl:attribute :name "class") "disc")
	((xsl:attribute :name "style") "color: blue")
	"C")))
     (xsl:apply-templates/))

  #m((xsl:template :match "discriminant[@type='rule-discriminant']")
     (tr ((xsl:element :name "td")
	  ((xsl:attribute :name "class")
	   (xsl:choose
	    ((xsl:when :test "not(following-sibling::*)") "last-rule-disc")
	    (xsl:otherwise "rule-disc-anchor"))))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class")
	   (xsl:choose
	    ((xsl:when :test "not(following-sibling::*)") "last-rule-disc")
	    (xsl:otherwise "rule-disc")))
	  ((xsl:if :test "@valid='yes' or @chosen='yes'")
	   ((xsl:attribute :name "onmouseover")
	    (xsl:choose
	     ((xsl:when :test "not(following-sibling::*)") "this.className = 'last-rule-disc-hilite'")
	     (xsl:otherwise "this.className = 'rule-disc-hilite'")))
	   ((xsl:attribute :name "onmouseout")
	    (xsl:choose
	     ((xsl:when :test "not(following-sibling::*)") "this.className = 'last-rule-disc'")
	     (xsl:otherwise "this.className = 'rule-disc'")))
	   ((xsl:attribute :name "onclick")
	    "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
	  ((xsl:element :name "span")
	   ((xsl:if :test "@type='rule-discriminant'")
	    ((xsl:attribute :name "style") "margin-left: 10pt"))
	   (nobr
	    ;;((span :style "color: red") (xsl:value-of/ :select "@id")) (xsl:text " ")
	    ((xsl:element :name "span")
	     ((xsl:attribute :name "class") "c-disc")
	     ((xsl:attribute :name "style")
	      (xsl:choose
	       ((xsl:when :test "@chosen='yes'") "color: black")
	       (xsl:otherwise "color: black"))
	      ((xsl:if :test "@chosen='yes'") "; font-weight: bold"))
	     ((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	     (xsl:value-of/ :select "rule")
	     (xsl:value-of/ :select "morph-features")))))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "reduction")
	  ((xsl:attribute :name "title") "# of solutions after discriminant application")
	  (xsl:value-of/ :select "@reduction"))
	 #L(discriminant-complement-xsl stream)
	 ((xsl:if :test "@weight")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: gray")
	   (nobr (xsl:value-of/ :select "@weight"))))
	 ((xsl:if :test "../@top='yes'")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: green")
	   "R"))))
  
  #m((xsl:template :match "discriminant[@type='f-structure-discriminant']") ; :mode "f-structure")
     ((tr)
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "disc-anchor")
       ((xsl:attribute :name "title") "Anchor")
       (xsl:value-of/ :select "@anchor")
       ((xsl:if :test "@right-anchor")
	":" (xsl:value-of/ :select "@right-anchor")))
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "disc")
       ((xsl:if :test "@valid='yes' or @chosen='yes'")
	((xsl:attribute :name "onmouseover")
	 "this.className = 'disc-hilite'")
	((xsl:attribute :name "onmouseout")
	 "this.className = 'disc'")
	((xsl:attribute :name "onclick")
	 "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
       (nobr
	((xsl:element :name "span")
	 ((xsl:attribute :name "class") "fs-disc")
	 ((xsl:attribute :name "style")
	  (xsl:choose
	   ((xsl:when :test "@redundant='yes'") "color: gray")
	   ((xsl:when :test "@valid='yes'") "color: black")
	   (xsl:otherwise "color: black"))
	  ((xsl:if :test "@chosen='yes'") "; font-weight: bold"))
	 ((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	 (xsl:value-of/ :select "path-segment"))))
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "reduction")
       ((xsl:attribute :name "title") "# of solutions after discriminant application")
       (xsl:value-of/ :select "@reduction"))
      #L(discriminant-complement-xsl stream)
      ((xsl:if :test "@weight")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: gray")
	   (nobr (xsl:value-of/ :select "@weight"))))
      ((xsl:if :test "@top='yes'")
       ((xsl:element :name "td")
	((xsl:attribute :name "class") "disc")
	((xsl:attribute :name "style") "color: red")
	"F"))))
  
  #m((xsl:template :match "discriminant[@type='morph-discriminant']")
     (tr ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "disc-anchor")
	  ((xsl:attribute :name "title") "Anchor")
	  (xsl:value-of/ :select "@anchor"))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "disc")
	  ((xsl:if :test "@valid='yes' or @chosen='yes'")
	   ((xsl:attribute :name "onmouseover")
	    "this.className = 'disc-hilite'")
	   ((xsl:attribute :name "onmouseout")
	    "this.className = 'disc'")
	   ((xsl:attribute :name "onclick")
	    "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
	  ((xsl:element :name "span")
	   ((xsl:attribute :name "class") "c-disc")
	   (nobr
	    ;;((span :style "color: red") (xsl:value-of/ :select "@id")) (xsl:text " ")
	    ((xsl:element :name "span")
	     ((xsl:attribute :name "class") "c-disc")
	     ((xsl:attribute :name "style")
	      (xsl:choose
	       ((xsl:when :test "@chosen='yes'") "color: black")
	       (xsl:otherwise "color: black"))
	      ((xsl:if :test "@chosen='yes'") "; font-weight: bold"))
	     ((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	     (xsl:value-of/ :select "morph-features")))))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "reduction")
	  ((xsl:attribute :name "title") "# of solutions after discriminant application")
	  (xsl:value-of/ :select "@reduction"))
	 #L(discriminant-complement-xsl stream)
	 ((xsl:if :test "@weight")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: gray")
	   (nobr (xsl:value-of/ :select "@weight"))))
	 ((xsl:if :test "@top='yes'")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: orange")
	   "M"))))

  #m((xsl:template :match "discriminant[@type='lex-discriminant']")
     (tr ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "disc-anchor")
	  ((xsl:attribute :name "title") "Anchor")
	  (xsl:value-of/ :select "@anchor"))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "disc")
	  ((xsl:if :test "@valid='yes' or @chosen='yes'")
	   ((xsl:attribute :name "onmouseover")
	    "this.className = 'disc-hilite'")
	   ((xsl:attribute :name "onmouseout")
	    "this.className = 'disc'")
	   ((xsl:attribute :name "onclick")
	    "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
	  ((xsl:element :name "span")
	   ((xsl:attribute :name "class") "c-disc")
	   (nobr
	    ((xsl:element :name "span")
	     ((xsl:attribute :name "class") "c-disc")
	     ((xsl:attribute :name "style")
	      (xsl:choose
	       ((xsl:when :test "@chosen='yes'") "color: black")
	       (xsl:otherwise "color: black"))
	      ((xsl:if :test "@chosen='yes'") "; font-weight: bold"))
	     ((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	     (xsl:value-of/ :select "rule")))))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "reduction")
	  ((xsl:attribute :name "title") "# of solutions after discriminant application")
	  (xsl:value-of/ :select "@reduction"))
	 #L(discriminant-complement-xsl stream)
	 ((xsl:if :test "@weight")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: gray")
	   (nobr (xsl:value-of/ :select "@weight"))))
	 ((xsl:if :test "@top='yes'")
	  ((xsl:element :name "td")
	   ((xsl:attribute :name "class") "disc")
	   ((xsl:attribute :name "style") "color: magenta")
	   "L"))
	 )))

#+obsolete
(publish :path (concatenate 'string "/" *url-base* "/xle.xml")
	 :class 'xml/html-entity
	 #+(and (or :paul :xle-web) (not :pargram) (not :gisle) (not :helge)) :authorizer
	 #+(and (or :paul :xle-web) (not :pargram) (not :gisle) (not :helge)) *grammar-authorizer*
	 :function #'xle-xml)

(publish :path (concatenate 'string "/" *url-base* "/xle-c-structure.xml")
	 :class 'xml/html-entity
	 #+(and (or :paul :xle-web) (not :pargram) (not :gisle) (not :helge)) :authorizer
	 #+(and (or :paul :xle-web) (not :pargram) (not :gisle) (not :helge)) *grammar-authorizer*
	 :function #'c-structure-xml)

(publish :path (concatenate 'string "/" *url-base* "/xle-c-structure.svg")
         :content-type "text/xml"
         :function #'c-structure-svg)

(publish :path (concatenate 'string "/" *url-base* "/xle-c-structure.xsl")
	 :content-type "text/xml"
	 :function #'xle-xsl)

(publish :path (concatenate 'string "/" *url-base* "/xle.xsl")
	 :content-type "text/xml"
	 :function #'xle-xsl)

(defmethod f-structure-xml ((request http-request) entity &key &allow-other-keys)
  (with-xml-response (request entity stream (grammar xle-graph-id m-projection previous-solution next-solution
						     disable-OT cg-preparse-on-fragment-analysis cg-preparse packed
						     non-top-f-structures ranking)
			      :force-xslt :sablotron
			      :xsl #'f-structure-xsl)
    #+debug(print (request-query request))
    (let* ((grammar (utf-8-decode grammar))
	   (*grammar* (find-grammar grammar)))
      (if *grammar*
	  (let* ((graph-table (graph-table *grammar*))
		 (graph.sentence (gethash (or (and xle-graph-id (parse-integer xle-graph-id :junk-allowed t))
					      (incf *graph-id*))
					  graph-table))
		 (graph (progn (when (parser (car graph.sentence))
				 (setf (last-access (parser (car graph.sentence)))
				       (get-universal-time)))
			       (car graph.sentence)))
		 (sentence (cdr graph.sentence)))
	    (multiple-value-bind (var-array c-structure mrs count pos)
		(if packed
		    (if (or previous-solution next-solution)
			(get-packed-solution graph
					     :valid-only-p nil
					     :prefetch-p t
					     :build-c-structure-p t
					     :build-f-structure-p t
					     ;;:disjunction-choice disjunction-choice
					     :previous-p previous-solution
					     :ranking-p nil ;; ranking
					     )
			(get-current-packed-solution graph))
		    (if (or previous-solution next-solution)
			(get-solution graph
				      :valid-only-p nil
				      :max-solutions nil
				      :prefetch-p t
				      :build-c-structure-p t
				      :build-f-structure-p t
				      :previous-p previous-solution)
			(get-current-solution graph)))
	      (declare (ignore mrs c-structure))
	      #m(?xml-stylesheet :type "text/xsl" :href #s (concatenate 'string "/" *url-base* "/xle-f-structure.xsl"))
	      (f-structure-xml graph stream :sentence sentence :count count :pos pos
			       :var-array var-array :grammar grammar :xle-graph-id xle-graph-id
			       :m-projection m-projection :disable-OT disable-OT
			       :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis
			       :cg-preparse cg-preparse :packed t :discriminants-p nil
			       :top-f-structure-only-p (not non-top-f-structures))))))))


#+test
(let ((*seen-nodes* nil)
      (*seen-fs-nodes* nil))
  (print-object-xml *inspect-fs* *standard-output* :top-p t))

(defparameter *preds-only-p* nil)

(defmethod print-object-xml ((fs fs) stream &key top-p (top-fs-p t) pointerp set-elt-p &allow-other-keys)
  (with-slots (var context expanded-context ctx-string pred av-pairs context-set fs-set) fs
    #+debug(print (list :fs fs :pointerp pointerp :top-p top-p :fs-set fs-set))
    (cond (pointerp
	   (let ((pred-val "")
		 (seen-nodes ()))
	     (labels ((pred-value (av-pair)
			#+debug(print (list :av-pair av-pair))
			(cond ((find av-pair seen-nodes)
			       nil)
			      ((null av-pair)
			       nil)
			      ((null (value av-pair))
			       nil)
			      ((stringp (value av-pair))
			       (warn "The value of an AVP should not be a string: ~s." (value av-pair))
			       nil)
			      ((subtypep (type-of (value av-pair)) 'semform)
			       #+debug(print (list :var (var av-pair) :pred-val pred-val :lem (lemma (value av-pair))))
			       (cond ((null pred-val)
				      nil)
				     ((equal pred-val "")
				      (setf pred-val (lemma (value av-pair))))
				     ((not (stringp (lemma (value av-pair))))
				      #+debug(print (lemma (value av-pair))) ;; this is e.g. '[125]<[26],[31]>'. Discriminants have to be fixed for this!
				      nil)
				     ((string= pred-val (lemma (value av-pair)))
				      nil)
				     (t
				      (setf pred-val nil))))
			      (t
			       (push av-pair seen-nodes)
			       (mapc #'pred-value (context-set (value av-pair)))
			       (pred-value (pred (value av-pair)))))))
	       (mapc #'pred-value context-set)
	       (pred-value pred))
	     #m(pointer/ :var #s var :semform #s (unless (equal pred-val "") pred-val))))
	  ((find var *seen-fs-nodes*)
	   #m(pointer/ :var #s var))
	  (top-p
	   (push var *seen-fs-nodes*)
	   #m((projection :type "F-structure" :var #s var)
	      #L(when (justifications fs)
		  #m(justifications
		     #L(dolist (just (justifications fs))
			 #m(justification #s just))))
	      #-KARTULI
	      #L(when pred #m#s pred)
	      #+KARTULI
	      #L(when pred
		  (let ((*lexids* (get-path-value fs :path '("MORPH-SYNT" "LEXID") :ctx context)))
		    #m#s pred))
	      #L(dolist (av-pair av-pairs)
		  (when (or (not *preds-only-p*) (has-sub-pred-p av-pair))
		    #m#s av-pair))
	      #L(cond ((null context-set)
		       nil)
		      ((cdr context-set)
		       #m((ctx-list :ctx-list "yes"
				    :disjunctive
				    #s(when (find-if-not (lambda (av-pair) (eq (context av-pair) 1)) context-set) "yes"))
			  #L(dolist (av-pair context-set)
			      #m#s av-pair)))
		      (t
		       #m#s(car context-set)))
	      #L(when fs-set
		  ;; (car fs) is context!
		  #m(set #L(dolist (fs fs-set)
			     (when (or (not *preds-only-p*) (has-sub-pred-p (cdr fs)))
			       #m((set-elt :ctx #s(unless (eq (caar fs) 1) (cdar fs))) #s (cdr fs))))))))
	  (t
	   (push var *seen-fs-nodes*)
	   #m((fs :var #s var :expanded-ctx #s expanded-context :ctx #s ctx-string ; :set-ctx #s(when set-elt-p (context fs))
		  )
	      #-KARTULI
	      #L(when pred #m#s pred)
	      #+KARTULI
	      #L(when pred
		  (let ((*lexids* (get-path-value fs :path '("MORPH" "LEXID") :ctx context)))
		    #m#s pred))
	      #L(dolist (av-pair av-pairs)
		  (when (or (not *preds-only-p*) (has-sub-pred-p av-pair))
		    #m#s av-pair))
	      #L(cond ((null context-set)
		       nil)
		      ((cdr context-set)
		       #m((ctx-list :ctx-list "yes")
			  #L(dolist (av-pair context-set)
			      #m#s av-pair)))
		      (t
		       #m#s(car context-set)))
	      #L(when fs-set
		  ;; (car fs) is context!
		  #m(set #L(dolist (fs fs-set)
			     ;;(print-object-xml (cdr fs) stream :set-elt-p t)
			     ;;#m#s(cdr fs) #+ignore 
			     (when (or (not *preds-only-p*) (has-sub-pred-p (cdr fs)))
			       #m((set-elt :ctx #s(unless (eq (caar fs) 1) (cdar fs))) #s (cdr fs)))))))))))

;; fixme: not general enough
(defmethod get-path-value ((fs fs) &key path (ctx 1))
  (collecting
    (labels ((gpv (fs path ctx)
	       (cond ((null fs)
		      nil)
		     ((null path)
		      (if (stringp fs)
			  (collect (cons ctx fs))
			  (dolist (av-pair (context-set fs))
			    (let ((i-ctx (context-s-intersection ctx (context av-pair))))
			      (when i-ctx (gpv (value av-pair) path i-ctx))))))
		     (t
		      (dolist (av-pair (av-pairs fs))
			(when (equal (attribute av-pair) (car path))
			  (let ((i-ctx (context-s-intersection ctx (context av-pair))))
			    (when i-ctx (gpv (value av-pair) (cdr path) i-ctx)))))
		      (dolist (av-pair (context-set fs))
			(let ((i-ctx (context-s-intersection ctx (context av-pair))))
			  (when i-ctx (gpv (value av-pair) path i-ctx))))))))
      (gpv fs path ctx))))

;;(untrace print-object-xml)

(defmethod print-object-xml ((av-pair av-pair) stream &key &allow-other-keys)
  (with-slots (var context expanded-context ctx-string attribute value justification has-sub-pred-p) av-pair
    #+debug(print (list :var var :context context))
    (let* ((match-p nil)
	   (positions
	    (collecting
	      (loop for submatch-list in *submatches* and i from 0
		    for match-pos = (position-if (lambda (sml)
						   (destructuring-bind (type v att) sml
						     (and (eq type :f-att) (eq v var) (equal att attribute))))
						 submatch-list)
		    when match-pos
		    do (setf match-p t)
		    (let ((var-name (aref *variable-names* match-pos)))
		      (unless (eq (search "my" var-name) 0)
			(collect var-name)
			(collect i)))))))
      (cond ((not (subtypep (type-of value) 'dag-node))
	     #m(avp/ :attribute #s attribute
		     :match #s (when match-p t)
		     :justification #s(when justification "yes")
		     :variables #s (when positions (format nil "~{~@[~a~]:~d~^,~}" positions)) 
		     :ctx #s ctx-string
		     :expanded-ctx #s expanded-context
		     :has-sub-pred #s (when has-sub-pred-p "true")
		     :value #s value))
	    ((find (var value) *seen-nodes*)
	     #m((avp :attribute #s attribute
		     :match  #s (when match-p t)
		     :justification #s(when justification "yes")
		     :variables #s (when positions (format nil "~{~@[~a~]:~d~^,~}" positions))
		     :has-sub-pred #s (when has-sub-pred-p "true")
		     :ctx #s ctx-string
		     :expanded-ctx #s expanded-context)
		(pointer/ :var #s (var value))))
	    (t
	     (push (var value) *seen-nodes*)
	     #m((avp :var #s (var value)
		     :attribute #s attribute
		     :justification #s(when justification "yes")
		     :match  #s (when match-p t)
		     :variables #s (when positions (format nil "~{~@[~a~]:~d~^,~}" positions))
		     :has-sub-pred #s (when has-sub-pred-p "true")
		     :ctx #s ctx-string
		     :expanded-ctx #s expanded-context)
		#s value))))))

(defmethod print-object-xml ((fs-value fs-value) stream &key &allow-other-keys)
  (with-slots (value) fs-value
    #+debug(print (list :fs-value fs-value :value value))
    #m(val/ :value #s value)))

(defmethod print-object-xml ((semform semform) stream &key &allow-other-keys)
  (with-slots (var context expanded-context lemma sem-var subcat-frame athematic-frame) semform
    #+debug(print (list :var var :lemma lemma :context context))
    #m((semform :expanded-ctx #s expanded-context :ctx #s expanded-context)
       (lemma #L(cond ((stringp lemma)
		       #m#s lemma)
		      ((consp lemma)
		       #m(pointer/ :var #s (cadr lemma)))
		      (t
		       #m(pointer/ :var #s (var lemma)))))
       #L(dolist (subcat subcat-frame)
	   #m(subcat #L(print-object-xml subcat stream :pointerp t)))
       #L(dolist (subcat athematic-frame)
	   #m(athematic-subcat #L(print-object-xml subcat stream :pointerp t))))))

#+test
(print-object-xml *fs* *standard-output* :top-p t)

(defvar *fs*)

(defmethod validate-s-discriminants ((discriminants discriminants) s-context &key recalculate-context-p reset)
  (let ((*package* (find-package :xle))
	(*print-level* nil))
    #+debug(print (list discriminants :s-context s-context :disc-s-context (s-context discriminants)
			:inters (context-s-intersection s-context (s-context discriminants))
			:chosen (chosen-discriminants discriminants)))
    (when reset (setf (chosen-discriminants discriminants) ()))
    (when (or recalculate-context-p reset)	;; recalculate context of valid discriminants
      (setf (s-context discriminants) 1)
      (dolist (disc-id (chosen-discriminants discriminants))
	#+debug(describe (aref (discriminants-array discriminants) disc-id))
	(setf (s-context discriminants)
	      (context-s-intersection (s-context discriminants)
				      (let ((disc (aref (discriminants-array discriminants) disc-id)))
					(if (discriminant-complement-chosen-p disc)
					    (context-s-negation (s-context disc))
					    (s-context disc)))))))
    (setf (s-context discriminants)
	  (context-s-intersection s-context (s-context discriminants))))
  #+debug(print (list :reset reset :s-context (s-context discriminants)))
  (when (null (s-context discriminants))
    (warn "Context intersection of discriminants is empty for ~s. Resetting." discriminants)
    (setf (s-context discriminants) 1
	  reset t))
  (cond (reset
	 (setf (chosen-discriminants discriminants) ())
	 (loop for disc across (discriminants-array discriminants)
	       when disc
	       do (setf (discriminant-valid-p disc) t
			(discriminant-chosen-p disc) nil
			(discriminant-redundant-p disc) nil)))
	(t
	 (dolist (f-structure-disc (f-structure-discriminants discriminants))
	   #+debug(print (list f-structure-disc
			       :s-context (s-context discriminants)
			       :f-s-context (s-context f-structure-disc)
			       :f-s-context-neg (context-s-negation (s-context f-structure-disc))
			       ))
	   (setf (discriminant-valid-p f-structure-disc)
		 (and (context-s-intersection (s-context discriminants) (s-context f-structure-disc))
		      (context-s-intersection (s-context discriminants) (context-s-negation (s-context f-structure-disc)))
		      t)))
	 (dolist (secondary-disc (secondary-discriminants discriminants))
	   (setf (discriminant-valid-p secondary-disc)
		 (and (context-s-intersection (s-context discriminants) (s-context secondary-disc))
		      (context-s-intersection (s-context discriminants) (context-s-negation (s-context secondary-disc)))
		      t)))
	 (dolist (morph-disc (morph-discriminants discriminants))
	   (setf (discriminant-valid-p morph-disc)
		 (and (context-s-intersection (s-context discriminants) (s-context morph-disc))
		      (context-s-intersection (s-context discriminants) (context-s-negation (s-context morph-disc)))
		      t)))
	 (dolist (lex-disc (lex-discriminants discriminants))
	   (setf (discriminant-valid-p lex-disc)
		 (and (context-s-intersection (s-context discriminants) (s-context lex-disc))
		      (context-s-intersection (s-context discriminants) (context-s-negation (s-context lex-disc)))
		      t)))
	 (dolist (disc (constituent-discriminants discriminants))
	   (dolist (rule-disc (rules disc))
	     (let ((rule-disc (aref (discriminants-array discriminants) rule-disc)))
	       (setf (discriminant-valid-p rule-disc)
		     (and (context-s-intersection (s-context discriminants) (s-context rule-disc))
			  (context-s-intersection (s-context discriminants) (context-s-negation (s-context rule-disc)))
			  t))))
	   (setf (discriminant-valid-p disc) ;; simplify!
		 (if (loop for disc in (rules disc)
			   thereis (discriminant-valid-p (aref (discriminants-array discriminants) disc)))
		     t nil)))
	 (dolist (disc-id (chosen-discriminants discriminants))
	   (setf (discriminant-redundant-p (aref (discriminants-array discriminants) disc-id)) nil))
	 (dolist (disc1-id (chosen-discriminants discriminants))
	   (dolist (disc2-id (chosen-discriminants discriminants))
	     (let ((disc1 (aref (discriminants-array discriminants) disc1-id))
		   (disc2 (aref (discriminants-array discriminants) disc2-id)))
	       (when (and (not (eq disc1 disc2))
			  (context-subsumed-p (s-context disc1) (s-context disc2)))
		 (setf (discriminant-redundant-p disc1) t)))))))
  #+debug(print (list discriminants :final-disc-s-context (s-context discriminants))))

;; cluster solutions the discriminants can't distinguish
;; used for extended f-structure discriminants (which are now obsolete b/o anchors)
#+obsolete
(defun non-trivial-solution-clusters (tree length)
  (collecting
    #+debug
    (dat:do-string-tree (string value tree)
      (Print (list value string)))
    (dotimes (i length)
      (let ((cluster 1))
	(dat:do-string-tree (string value tree)
	   (let ((ctx (car value)))
	     (when (and (not (eq ctx 1)) (= (aref ctx i) 1))
	       (setf cluster (context-s-intersection cluster ctx)))))
	(when (or (eq cluster 1) (/= (count 1 cluster) 1))
	  #+debug(print (list :cluster cluster))
	  (collect cluster))))))

(defun disambiguating-context-p (clusters ctx)
  (loop for cluster in clusters
	when (proper-1-context-intersection-p cluster ctx)
	do (return t)))

#+test
(dat:do-string-tree (key value *derived-tree*)
  (destructuring-bind (ctx disc-str anchor right-anchor) value
    (when right-anchor
      (dat:do-string-tree (right-key value *derived-tree* :prefix (format nil "~d:NIL:" right-anchor))
	(destructuring-bind (right-ctx right-disc-str r-anchor r-right-anchor) value
	  (print (list (context-s-intersection ctx right-ctx) disc-str right-disc-str)))))))

#+copy
(dolist (ctx.term (aref var-array id))
  (destructuring-bind (ctx . term) ctx.term
    (when (and (find (car term) '(subtree terminal))
	       (context-s-intersection (context-solutions graph context)
				       (context-solutions graph ctx)
				       global-ctx))
      (collect ctx.term))))

(defmethod f-structure-xml ((graph xle-graph) stream
			    &key sentence count pos var-array graph-addr grammar xle-graph-id m-projection
			    disable-OT cg-preparse-on-fragment-analysis cg-preparse
			    (discriminants-p t) (build-discriminants-p t) 
			    (top-f-structure-only-p t)
			    (context 1) ;; under-construction
			    previous-fstructure-p next-fstructure-p suppress-check-p preds-only-p
			    &allow-other-keys)
  #+debug(print (list :var-array var-array :graph-addr graph-addr))
  #+debug(print (list :top-f-structure-only-p top-f-structure-only-p))
  #+debug(print :f-structure-xml)
  ;;(build-f-structure graph stream :var-array var-array)
  (with-slots (equivalences discriminants phi-list realized-vars
			    tree-solutions-count good-tree-solutions-count tree-solution-id) graph
    (unless (or previous-fstructure-p next-fstructure-p)
      (setf (tree-solution-id graph) 0))
    #+debug(print (list :tree-solution-id (tree-solution-id graph)))
    (setf realized-vars ())
    (let ((*preds-only-p* preds-only-p)
	  (seen-variables ())
	  (seen-eq-vars ())
	  (disc-list ())
	  (disc-tree nil)
	  (secondary-disc-tree nil)
	  (global-context context))  ;; under-construction
      ;; build() is (almost?) obsolete
      (labels ((build (var stream &key (node-ctx 1) set-elt-p parent-var attribute mod-eq-attribute mod-eq-var
			   var-att no-var-att no-xml var-unseen-p)
		 #+debug(print (list :build var node-ctx attribute mod-eq-attribute var-att no-var-att))
		 (let ((term-list (filter-terms graph (aref var-array var) global-context)))
		   #+debug(print (list :terms term-list :seen (getf seen-variables var)))
		   (cond ((and (not var-unseen-p) (getf seen-variables var))
			  (unless (or no-var-att no-xml)
			    (destructuring-bind (&key var semform parent-var attribute) (getf seen-variables var)
			      #m(pointer/ :var #L var
					  :semform #L semform
					  :parent-var #L parent-var
					  :attribute #L attribute)))
			  ;; discriminants
			  
			  (when (and term-list (find-if (lambda (ctx.term) (eq (car (cdr ctx.term)) 'in_set)) term-list))
			    ;; ignore yet sets
			    )
			  (dolist (ctx.term term-list)
			    (destructuring-bind (ctx op left right) ctx.term
			      (ecase op
				(eq
				 (ecase (car left)
				   (attr
				    (let ((attribute (caddr left)))
				      (cond ((find attribute *suppressed-atts* :test #'string=)
					     nil)
					    ((and no-var-att (string= attribute "="))
					     nil)
					    ((and var-att (string/= attribute "="))
					     nil)
					    ((not (consp right))
					     (let ((intersection-or-ctx (if (equal attribute "=")
									    (context-s-intersection (context-solutions graph ctx) node-ctx)
									    (context-solutions graph ctx)))) 
					       (unless (ctx-trivial-p intersection-or-ctx)
						 (push (list (if (equal attribute "=") mod-eq-attribute attribute) :-> var right
							     intersection-or-ctx)
						       (getf disc-list (if (equal attribute "=") mod-eq-var var))))))
					    ((eq (car right) 'semform)
					     (destructuring-bind (lemma sem-var (%br1 . subcat-frame)
									(%br2 &optional val2))
						 (cdr right)
					       (declare (ignore %br1 %br2))
					       (let ((intersection-or-ctx (if (equal attribute "=")
									      (context-s-intersection (context-solutions graph ctx) node-ctx)
									      (context-solutions graph ctx)))) 
						 (when intersection-or-ctx

						   (push (list (if (equal attribute "=") mod-eq-attribute attribute) lemma
							       sem-var (format nil "~a~a~{[~a]~^,~}~a~a"
									       lemma
									       (if subcat-frame "<" "")
									       (mapcar (lambda (sub) (if (stringp sub) sub ""))
										       subcat-frame)
									       (if subcat-frame ">" "")
									       (cond ((null val2)
										      "")
										     ((stringp val2)
										      val2)
										     (t
										      "[]")))
							       intersection-or-ctx)
							 (getf disc-list (if (equal attribute "=") mod-eq-var var)))))))
					    ((eq (car right) 'var)
					     (let* ((term-list (filter-terms graph (aref var-array (cadr right)) global-context))
						    (ctx-values
						     (collecting
						       (dolist (ctx.term term-list)
							 (destructuring-bind (ctx op left right) ctx.term
							   (when (and (eq op 'eq)
								      (eq (car left) 'attr)
								      (string= (caddr left) "="))
							     (collect (cons ctx right))))))))
					       
					       (let ((intersection (context-s-intersection (context-solutions graph ctx) node-ctx)))
						 (unless (or (equal attribute "=") (ctx-trivial-p intersection))
						   (push (list mod-eq-attribute :-> var attribute intersection)
							 (getf disc-list  mod-eq-var)))
						 (when (and (equal attribute "=")
							    (not (find (car right) seen-eq-vars)))
						   (push (car right) seen-eq-vars)
						   (build (cadr right) stream :parent-var var :attribute attribute
							  :mod-eq-var mod-eq-var
							  :mod-eq-attribute (if (equal attribute "=") mod-eq-attribute attribute)
							  :no-xml t
							  :node-ctx (if (equal attribute "=")
									intersection
									(context-solutions graph ctx))))))))))
				   (proj
				    nil)))
				((scopes in_set)
				 nil)))))
			 (t
			  (let ((semform (find-att-value var-array var "PRED"))) ;; semforms have to be fixed!
			    (setf (getf seen-variables var)
				  (if semform
				      (list :var var :semform semform)
				      (list :var var :parent-var parent-var :attribute attribute))))
			  (when (and term-list (find-if (lambda (ctx.term) (eq (car (cdr ctx.term)) 'in_set)) term-list))
			    #m(set
			       #L(dolist (ctx.term term-list)
				   (destructuring-bind (ctx . term) ctx.term
				     (case (car term)
				       (in_set
					(destructuring-bind (left right) (cdr term)
					  (cond ((not (consp left))
						 #m((val :value #s left
							 :ctx #s(format-context graph ctx)
							 :expanded-ctx #s(format-normal-form graph ctx equivalences))))
						(t
						 (let ((var (unless (getf seen-variables (cadr left)) (cadr left))))
						   (when var (push var realized-vars))
						   #m((fs :var #s var
							  :ctx #s(format-context graph ctx)
							  :expanded-ctx #s(format-normal-form graph ctx equivalences))
						      #L(build (cadr left) stream :set-elt-p t :attribute attribute
							       :mod-eq-attribute (if (equal attribute "=") mod-eq-attribute attribute)
							       :mod-eq-var (if (equal attribute "=") mod-eq-var var)
							       :node-ctx
							       (if (equal attribute "=")
								   (context-s-intersection (context-solutions graph ctx) node-ctx)
								   (context-solutions graph ctx))))))))))))))
			  (dolist (ctx.term term-list)
			    #+debug(print (list :var var :va var-att :nva no-var-att :c.t ctx.term))
			    (destructuring-bind (ctx op left right) ctx.term
			      (ecase op
				(eq
				 (ecase (car left)
				   (attr
				    (let ((attribute (caddr left)))
				      (cond ((find attribute *suppressed-atts* :test #'string=)
					     nil)
					    ((and no-var-att (string= attribute "="))
					     nil)
					    ((and var-att (string/= attribute "="))
					     nil)
					    ((not (consp right))
					     (let ((intersection-or-ctx (if (equal attribute "=")
									    (context-s-intersection (context-solutions graph ctx) node-ctx)
									    (context-solutions graph ctx)))) 
					       (unless (ctx-trivial-p intersection-or-ctx)
						 (push (list (if (equal attribute "=") mod-eq-attribute attribute) :-> var right
							     intersection-or-ctx)
						       (getf disc-list (if (equal attribute "=") mod-eq-var var)))))
					     #m(avp/ :attribute #L attribute :value #L right :set-elt #L set-elt-p
						     :ctx #s(format-context graph ctx)
						     :expanded-ctx #s(format-normal-form graph ctx equivalences)))
					    ((eq (car right) 'semform)
					     (destructuring-bind (lemma sem-var (%br1 . subcat-frame)
									(%br2 &optional val2))
						 (cdr right)
					       (declare (ignore %br1 %br2))
					       (let ((intersection-or-ctx (if (equal attribute "=")
									      (context-s-intersection (context-solutions graph ctx) node-ctx)
									      (context-solutions graph ctx)))) 
						 (when intersection-or-ctx
						   (push (list (if (equal attribute "=") mod-eq-attribute attribute) lemma
							       sem-var (format nil "~a~a~{[~a]~^,~}~a~a"
									       lemma
									       (if subcat-frame "<" "")
									       (mapcar (lambda (sub) (if (stringp sub) sub ""))
										       subcat-frame)
									       (if subcat-frame ">" "")
									       (cond ((null val2)
										      "")
										     ((stringp val2)
										      val2)
										     (t
										      "[]")))
							       intersection-or-ctx)
							 (getf disc-list (if (equal attribute "=") mod-eq-var var)))))
					       #m((avp :attribute #L attribute
						       :set-elt #L set-elt-p
						       :ctx #s(format-context graph ctx)
						       :expanded-ctx #s(format-normal-form graph ctx equivalences))
						  ((semform :lemma #L lemma)
						   #L(dolist (sub subcat-frame)
						       (if (stringp sub)
							   #m(subcat #s sub)
							   (let ((pred (find-contexted-att-value graph var-array (cadr sub) "PRED" ctx)))
							     #m(subcat
								(pointer/ :var #L (cadr sub)
									  :parent-var #s parent-var
									  :semform #s(unless (cdr pred) (cdar pred))
									  :attribute #s attribute)))))
						   #L(when val2
						       (if (stringp val2)
							   #m(val2 #s val2)
							   (let ((pred (find-contexted-att-value graph var-array (cadr val2) "PRED" ctx)))
							     #m(val2
								(pointer/ :var #L (cadr val2)
									  :parent-var #L parent-var
									  :semform #s(unless (cdr pred) (cdar pred))
									  :attribute #L attribute)))))))))
					    ((eq (car right) 'var)
					     (let* ((term-list (filter-terms graph (aref var-array (cadr right)) global-context))
						    (ctx-values
						     (collecting
						       (dolist (ctx.term term-list)
							 (destructuring-bind (ctx op left right) ctx.term
							   (when (and (eq op 'eq)
								      (eq (car left) 'attr)
								      (string= (caddr left) "="))
							     (collect (cons ctx right))))))))
					       (unless (or (equal attribute "=")
							   (ctx-trivial-p (context-s-intersection (context-solutions graph ctx) node-ctx)))
						 (push (list mod-eq-attribute :-> var attribute
							     (context-s-intersection (context-solutions graph ctx) node-ctx))
						       (getf disc-list mod-eq-var)))
					       (cond ((cdr ctx-values)
						      (let* ((seen-p (getf seen-variables (cadr right)))
							     (var (unless seen-p (cadr right))))
							(when var (push var realized-vars))
							#m((avp :var #L var
								:attribute #L attribute	;; :set-elt #L set-elt-p
								:ctx #s(format-context graph ctx)
								:expanded-ctx #s(format-normal-form graph ctx equivalences)
								;;:ctx-list "yes"
								)
							   ((ctx-list :ctx-list "yes") ;; att is a hack for xsl
							    #L(build (cadr right) stream :parent-var var :attribute attribute
								     :mod-eq-attribute (if (equal attribute "=") mod-eq-attribute attribute)
								     :mod-eq-var (if (equal attribute "=") mod-eq-var var)
								     :var-att t
								     :node-ctx (if (equal attribute "=")
										   (context-s-intersection (context-solutions graph ctx) node-ctx)
										   (context-solutions graph ctx))))
							   #L(build (cadr right) stream :parent-var var :attribute attribute
								    :mod-eq-attribute (if (equal attribute "=") mod-eq-attribute attribute)
								    :mod-eq-var (if (equal attribute "=") mod-eq-var var)
								    :no-var-att t
								    :var-unseen-p (not seen-p)
								    :node-ctx (if (equal attribute "=")
										  (context-s-intersection (context-solutions graph ctx) node-ctx)
										  (context-solutions graph ctx))))))
						     (t
						      (let ((var (unless (getf seen-variables (cadr right)) (cadr right))))
							(when var (push var realized-vars))
							#m((avp :var #s var
								:attribute #L attribute
								:set-elt #L set-elt-p
								:ctx #s(format-context graph ctx)
								:expanded-ctx #s(format-normal-form graph ctx equivalences))
							   #L(build (cadr right) stream :parent-var var :attribute attribute
								    :mod-eq-attribute (if (equal attribute "=") mod-eq-attribute attribute)
								    :mod-eq-var (if (equal attribute "=") mod-eq-var var)
								    :node-ctx (if (equal attribute "=")
										  (context-s-intersection (context-solutions graph ctx) node-ctx)
										  (context-solutions graph ctx))))))))))))
				   (proj
				    nil)))
				((scopes in_set)
				 nil)))))))))
	(let ((m-vars (when m-projection
			(list (cons 0 (find-projection var-array 0 "m::")))))
	      (scopes (find-scopes var-array))
	      (s-var (find-projection var-array 0 "s::")))
	  (multiple-value-bind (fs semform-lnks)
	      (if graph-addr ;; change!
		  (build-inspect-f-structure graph
					     :previous-fstructure-p previous-fstructure-p
					     :next-fstructure-p next-fstructure-p)
		  (build-f-structure graph
				     :var-array var-array :context global-context
				     :top-f-structure-only-p top-f-structure-only-p
				     :suppress-check-p suppress-check-p))
	    #+debug(setf *fs* fs)
	    (unless (or (null discriminants)
			(not build-discriminants-p)
			(f-structure-discriminants discriminants))
	      (multiple-value-setq (disc-tree secondary-disc-tree)
		(build-discriminants graph (if top-f-structure-only-p fs (car fs))
				     :semform-lnks semform-lnks)))
	    #m((projections :xle-graph-id #S xle-graph-id
			    :grammar #s grammar
			    :language #s(language (grammar graph))
			    :sentence #s sentence
			    :count #s count
			    :unoptimal-count #s (unless disable-OT
						  (- (unoptimal-solutions-count graph)
						     (restricted-solutions-count graph)))
			    :pos #S pos
			    :disable-OT #S disable-OT
			    :cg-preparse-on-fragment-analysis #s cg-preparse-on-fragment-analysis
			    :cg-preparse #s cg-preparse
			    :non-top-f-structures #s (when (not top-f-structure-only-p) "on")
			    :mrs-p #s (when (graph-has-mrs-p graph) "yes")
			    :tree-solutions-count #s tree-solutions-count
			    :good-tree-solutions-count #s good-tree-solutions-count
			    :tree-solution-id #s tree-solution-id)
	       ;;#L(print (list :phi-list phi-list))
	       #L(let ((*seen-nodes* ())
		       (*seen-fs-nodes* ()))
		   (if top-f-structure-only-p
		       (print-object-xml fs stream :top-p t)
		       (dolist (sub-fs fs)
			 (print-object-xml sub-fs stream :top-p t :top-fs-p (eq sub-fs (car fs))))))
	       #L(when m-projection
		   (dolist (m-var m-vars)
		     #m((projection :type "M-projection"
				    :projected-from #L(car m-var)
				    :var #L (cdr m-var))
			#L(build (cdr m-var) stream)))
		   (when scopes
		     #m(scopes
			#L(dolist (scope-rel scopes)
			    #m(scope-rel
			       (harg
				((avp :attribute "rels_el")
				 (pointer/ :var #L (caar scope-rel)))
				((avp :attribute "h-cons_el")
				 (pointer/ :var #L (cdar scope-rel))))
			       (larg
				((avp :attribute "rels_el")
				 (pointer/ :var #L (cadr scope-rel)))
				((avp :attribute "h-cons_el")
				 (pointer/ :var #L (cddr scope-rel))))))))))
	    (when s-var
	      #m((projection :type "S-structure" :var #L s-var) #L(build s-var stream))))))
      (when (and discriminants discriminants-p)
	(unless (or (f-structure-discriminants discriminants)
		    (not build-discriminants-p))
	  (build-f-structure-discriminants graph discriminants disc-tree)
	  #-test
	  (build-secondary-discriminants graph discriminants secondary-disc-tree))))))

(defmethod f-structure-discriminants-xml ((graph xle-graph) stream)
  (with-slots (discriminants) graph
    (when discriminants
      #m(f-structure-discriminants
	 #L(dolist (disc (sort (copy-seq (f-structure-discriminants discriminants))
			       (lambda (x y) (if (and x y) (< x y) nil))
			       :key #'discriminant-anchor))
	     (with-slots (path-segment anchor right-anchor context valid-p chosen-p) disc
	       (when (or valid-p chosen-p)
		 (let ((reduced-context (reduced-context context (s-context discriminants))))
		   #m((f-structure-discriminant
		       :id #s (discriminant-id disc)
		       :valid #s(if valid-p "yes" "no")
		       :chosen #s(if (discriminant-chosen-p disc) "yes" "no")
		       :compl #s(if (discriminant-complement-chosen-p disc) "yes" "no")
		       :redundant #s (if (discriminant-redundant-p disc) "yes" "no")
		       :context #s(write-to-string reduced-context)
		       :reduction #s(unless (or (discriminant-chosen-p disc)
						(eq reduced-context 1))
				      (count 1 reduced-context))
		       :anchor #s(unless (eql anchor -1) anchor)
		       :right-anchor #s(unless (eql right-anchor -1) right-anchor))
		      (path-segment #s path-segment))))))))))

;; should be obsolete
(defstylesheet f-structure-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     
     ;;(xsl:strip-space/ :elements "*")

     ((xsl:template :match "/")
      (html
       ((head)
	(title "F-structure")
	((SCRIPT :type "text/javascript" :language "javascript") 
         (!CDATA #L(js/xle stream)))
	((style :type "text/css")
	 (CSS-STYLE
	  (div :margin "16"
	       :color #-BW "#004499" #+BW "black"
	       :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (div.title :font-size "18" :font-weight "bold" :text-align "center")
	  (div.label :font-size "12")
	  (div.text :font-size "12" :color "black")
	  (span.sentence :font-size "14" :color "black")
	  (table :padding "0pt" :font-size "8pt" :border-collapse "collapse"
		 :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica")
	  (table.fs :border-collapse "separate")
	  (td :margin "0pt" :padding "0pt" :border "none")
	  (td.fs :padding "3px" :margin "1px" :border-left "2px gray solid" :border-right "2px gray solid"
		 )
	  (td.fs-focus :padding "3px" :margin "1px" :border "2px red solid")
	  (td.attribute :color "#004499" :font-weight "bold")
	  (td.var :color "red" :vertical-align "bottom" :font-size "6pt")
	  (span.attribute :color "#004499" :font-weight "bold")
	  (span.ctx :color #-BW "green" #+BW "black")
	  (span.pointer :color "red")
	  (span.pointer-focus :background "red" :color "white")
	  (a :text-decoration "none" :color "black"))))
       ((body)
	((div :class "title") "XLE Web Interface")
	((table :width "600px")
	 (tr
	  (td
	   (table
	    (tr
	     (td ((form :method "post" :action #s (concatenate 'string "/" *url-base* "/xle-f-structure.xml"))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "xle-graph-id")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@xle-graph-id")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "grammar")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@grammar")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "sentence")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@sentence")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "disable-OT")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@disable-OT")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "cg-preparse")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse-on-fragment-analysis")))
		  (input/ :style "font-size: 8pt"
			  :type "submit" :name "previous-solution" :value "Previous")
		  (input/ :style "font-size: 8pt"
			  :type "submit" :name "next-solution" :value "Next")))
	     ((xsl:if :test "projections/@mrs-p")
	      (td ((form :method "post" :action #s (concatenate 'string "/" *url-base* "/xle-mrs.xml"))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "xle-graph-id")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@xle-graph-id")))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "sentence")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@sentence")))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "grammar")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@grammar")))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "disable-OT")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@disable-OT")))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "cg-preparse")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse")))
		   ((xsl:element :name "input")
		    ((xsl:attribute :name "type") "hidden")
		    ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		    ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse-on-fragment-analysis")))
		   (input/ :style "font-size: 8pt"
			   :type "submit" :name "same-solution" :value "Show MRS"))))
	     #+obsolete
	     (td ((form :method "post" :action #s (concatenate 'string "/" *url-base* "/xle-c-structure.xml"))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "xle-graph-id")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@xle-graph-id")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "grammar")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@grammar")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "sentence")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@sentence")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "disable-OT")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@disable-OT")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "cg-preparse")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse")))
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "projections/@cg-preparse-on-fragment-analysis")))
		  (input/ :style "font-size: 8pt"
			  :type "submit" :name "same-solution" :value "Show C-structure")))))
	   ((div :class "label")
	    "Parsed sentence: "
	    ((span :class "sentence")
	     (xsl:value-of/ :select "projections/@sentence")))
	   ((div :class "text")
	    "Solution " (xsl:value-of/ :select "1 + projections/@pos")
	    " of " (xsl:value-of/ :select "projections/@count") ":")
	
	   (div (xsl:apply-templates/ :select "projections"))
	   
	   ))))))
     
     #L(f-structure-templates stream)))

(defun f-structure-templates (stream)
  #m((xsl:template :match "scopes")
     ((table :class "fs")
      (tr
       ((td :class "attribute") "_SCOPES")
       ((td :class "misc" :style "font-size: 18") "{")
       (xsl:apply-templates/ :select "scope-rel")
       ((td :class "misc" :style "font-size: 18") "}"))))
     
  #m((xsl:template :match "scope-rel")
     ((td :class "fs")
      (table
       (tr
	((td :class "misc")
	 ((table :class "fs")
	  (xsl:apply-templates/ :select "harg")))
	((td :class "misc") ((span :class "attribute") " >s "))
	((td :class "misc")
	 ((table :class "fs")
	  (xsl:apply-templates/ :select "larg"))))))
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") (xsl:text ", "))))
       
  #m((xsl:template :match "projections")
     (xsl:apply-templates/ :select "projection"))

  #m((xsl:template :match "justifications")
     (xsl:apply-templates/ :select "justification"))
  
  #m((xsl:template :match "justification")
     ((div :class "justification") (xsl:value-of/ :select "text()")))
  
  #m((xsl:template :match "projection")
     ((xsl:if :test "not(preceding-sibling::*/@type=@type) and not(/parse/@f-structure-only)")
      (p ((div :class "title")
	  #-orig
	  (xsl:value-of/ :select "@type")
	  #+disabled ;; used for pdf output of F-structure alone
	  ((xsl:element :name "a")
	   ((xsl:attribute :name "href")
	    #s(concatenate 'string "/" *url-base* "/xle.xml?same-solution=yes&f-structure-only=yes&xle-graph-id=")
	    (xsl:value-of/ :select "../@xle-graph-id")
	    "&amp;grammar=" (xsl:value-of/ :select "../@grammar"))
	   (xsl:value-of/ :select "@type")))))
     ((xsl:if :test "/parse/@inspect")
      (p "Solution #" (xsl:value-of/ :select "../@tree-solution-id + 1")
	 " [of "
	 (xsl:value-of/ :select "../@good-tree-solutions-count") " valid and "
	 (xsl:value-of/ :select "../@tree-solutions-count - ../@good-tree-solutions-count")
	 " invalid solution(s)]"))
     ((xsl:if :test "0 < ../@tree-solution-id")
      (input/ :style "font-size: 8pt"
	      :type "submit" :name "previous-solution" :value "Previous"
	      :onclick "getPreviousFstructure()"))
     ((xsl:if :test "../@tree-solution-id < ../@tree-solutions-count - 1")
      (input/ :style "font-size: 8pt"
	      :type "submit" :name "next-solution" :value "Next"
	      :onclick "getNextFstructure()"))
     ((xsl:if :test "justifications")
      (p (xsl:apply-templates/ :select "justifications")))
     (p ((table :class "fs")
	 (tr ((td :class "var")
	      ((xsl:if :test "@projected-from")
	       "[" ((xsl:element :name "span")
		    ((xsl:attribute :name "class") "pointer")
		    ((xsl:attribute :name "cursor") "pointer")
		    ((xsl:attribute :name "onmouseover")
		     "putIntoFocus(this, " (xsl:value-of/ :select "@projected-from") ")")
		    ((xsl:attribute :name "onmouseout")
		     "this.className='pointer'; var fs = document.getElementById(" 
		     (xsl:value-of/ :select "@projected-from")
		     "); if (fs) {fs.className='fs'};")
		    (xsl:value-of/ :select "@projected-from"))
	       "] " (br/))
	      (xsl:value-of/ :select "@var"))
	     ((xsl:element :name "td")
	      ((xsl:attribute :name "class") "fs")
	      ((xsl:attribute :name "id") (xsl:value-of/ :select "@var"))
	      ((table :class "fs")
	       (xsl:apply-templates/ :select "avp[semform]")
	       (xsl:apply-templates/ :select "ctx-list")
	       ;;(xsl:apply-templates/ :select "avp[@ctx-list]")
	       (xsl:apply-templates/ :select "avp[not(@value) and not(semform) and not(@ctx-list)]|set|pointer")
	       (tr ((td :class "misc" :colspan "3") ;; toplevel**
		    (xsl:apply-templates/ :select "avp[@value]"))))))))
     ((xsl:if :test "@type='M-projection' and not(preceding-sibling::*/@type=@type)")
      (xsl:apply-templates/ :select "../scopes")))

  #m((xsl:template :match "ctx-list")
     
     (tr ((xsl:if :test "@disjunctive") ((td :class "attribute") "="))
	 ((td :class "misc" :style "font-size: 18") "(")
	 ((td :class "misc" :colspan "1")
	  ((table :class "fs")
	   (xsl:apply-templates/ :select "avp|pointer")))
	 ((td :class "misc" :style "font-size: 18") ")")))
  
  ;; AVP with atomic value
  #m((xsl:template :match "avp[@value and not(@set-elt) and not(../@ctx-list)]")
     (nobr
      ((span :class "attribute")
       ((xsl:if :test "@match")
	((xsl:attribute :name "style") "color: green"))
       (xsl:value-of/ :select "@attribute")
       ((xsl:if :test "@variables")
	((xsl:element :name "span")
	 ((xsl:attribute :name "class") "ctx")
	 ((xsl:attribute :name "style") "color: magenta")
	 (xsl:value-of/ :select "@variables")))
       ((xsl:if :test "@ctx")
	((xsl:element :name "span")
	 ((xsl:attribute :name "class") "ctx")
	 ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
	 (xsl:value-of/ :select "@ctx"))))
      (xsl:text " ")
      ((span :class "value")
       (xsl:value-of/ :select "@value"))
      ((xsl:if :test "following-sibling::*[@value]")
       (xsl:text ","))
      ;; max 4 in one line
      #+test
      ((xsl:if :test "count(preceding-sibling::*) mod 3 = 2")
       (br/)))
     (xsl:text " "))
  
  #m((xsl:template :match "avp[@value and ../@ctx-list]")
     (tr ((td :class "attribute")
	  (nobr
	   (xsl:choose
	    ((xsl:when :test "@ctx")
	     ((xsl:element :name "span")
	      ((xsl:attribute :name "class") "ctx")
	      ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
	      (xsl:value-of/ :select "@ctx")))
	    (xsl:otherwise
	     (xsl:value-of/ :select "@attribute")
	     ))))
	 ((td :class "fs-set")
	  ((table :class "fs")
	   (tr ((xsl:element :name "td")
		((xsl:attribute :name "class")
		 (xsl:choose
		  ((xsl:when :test "@justification")
		   "just")
		  (xsl:otherwise
		   "misc")))
		((span :class "value")
		 (xsl:value-of/ :select "@value"))))))))
  
  #m((xsl:template :match "val" :mode "ctx")
     (tr ((xsl:element :name "td")
	  ((xsl:attribute :name "class") "ctx")
	  ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
	  (xsl:value-of/ :select "@ctx"))
	 ((td :class "misc")
	  ((span :class "value")
	   (xsl:value-of/ :select "@value")))))
  
  #m((xsl:template :match "semform" :mode "ctx")
     (tr ((xsl:element :name "td")
	  #+debug((xsl:attribute :name "style") "background: red")
	  ((xsl:attribute :name "class") "ctx")
	  ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
	  (xsl:value-of/ :select "@ctx"))
	 ((td :class "misc")
	  (xsl:apply-templates/ :select "."))))

  #+test-arab
  #m((xsl:template :match "semform")
     (nobr
      ((xsl:element :name "span")
       ((xsl:attribute :name "style") "font-weight: bold")
       ((xsl:attribute :name "title") (xsl:apply-templates/ :select "trans"))
       "'"
       ((xsl:if :test "//projections/@language='ara'") ;; workaround to get right-to-left embedding right
	((span :style "font-size: 0pt; color: white") "i"))
       (span (xsl:apply-templates/ :select "lemma" :mode "text") )
       ((xsl:if :test "subcat")
        ((xsl:if :test "//projections/@language='ara'")
	 ((span :style "font-size: 0pt; color: white") "i"))
	"&lt;"
	(xsl:apply-templates/ :select "subcat")
	((xsl:if :test "//projections/@language='ara'")
	 ((span :style "font-size: 0pt; color: white") "i"))
	"&gt;")
       (xsl:apply-templates/ :select "athematic-subcat")
       "'")))
  #-orig
  #m((xsl:template :match "semform")
     (nobr
      ((xsl:element :name "span")
        ((xsl:attribute :name "style") "font-weight: bold")
       ((xsl:attribute :name "title") (xsl:apply-templates/ :select "trans"))
       "'"
       (xsl:apply-templates/ :select "lemma" :mode "text")
       ((xsl:if :test "subcat")
	"&lt;"
	(xsl:apply-templates/ :select "subcat")
	"&gt;")
       (xsl:apply-templates/ :select "athematic-subcat")
       "'")))
  
  #+KARTULI
  #m((xsl:template :match "trans")
     (xsl:apply-templates/ :select "ger|geo"))

  #+KARTULI
  #m((xsl:template :match "geo")
     (xsl:text " ")
     (xsl:value-of/ :select "text()")
     #+test
     ((xsl:element :name "span")
      ((xsl:attribute :name "style")
       (xsl:choose
	((xsl:when :test "/paradigms/@font='amirani'")
	 "font-family: Amirani, Verdana; font-size: 14pt")
	((xsl:when :test "/paradigms/@font='titus'")
	 "font-family: TITUS Cyberbit Basic; font-size: 14pt")
	((xsl:when :test "/paradigms/@font='bpg'")
	 "font-family: BPG SanSer UEm; font-size: 12pt")
	((xsl:when :test "/paradigms/@font='geo'")
	 "font-family: Geo_Literaturuli; font-size: 12pt")
	((xsl:when :test "/paradigms/@font='acad'")
	 "font-family: AcadNusx; font-size: 12pt")))
      (xsl:apply-templates/)))

  #+KARTULI
  #m((xsl:template :match "ger")
     (xsl:value-of/ :select ".")
     #+test
     ((xsl:element :name "span")
      ((xsl:attribute :name "style")
       "font-family: Sabon, Amirani, Verdana; font-size: 12pt")
      (xsl:apply-templates/)))

  #m((xsl:template :match "subcat")
     (xsl:apply-templates/ :mode "text")
     ((xsl:if :test "following-sibling::subcat")
      ((xsl:if :test "//projections/@language='ara'")
       ((span :style "font-size: 0pt; color: white") "i" ))
      (xsl:text ", ")))
  
  #m((xsl:template :match "athematic-subcat")
     (xsl:apply-templates/ :mode "text")
     ((xsl:if :test "following-sibling::athematic-subcat")
      (xsl:text ", ")))
  
  ;; AVP with AVP, pointer, set or semform value
  #m((xsl:template :match "avp[not(@value) and not(@ctx-list)]")
     (tr ((td :class "attribute" :style "width: 20%")
	  (nobr
	   ((span :class "attribute")
	    ((xsl:if :test "@has-sub-pred"))
	    ((xsl:if :test "@match")
	     ((xsl:attribute :name "style") "color: green"))
	    ((xsl:if :test "not(../@ctx-list)")
	     (xsl:value-of/ :select "@attribute"))
	    ((xsl:if :test "@variables")
	     ((xsl:element :name "span")
	      ((xsl:attribute :name "class") "ctx")
	      ((xsl:attribute :name "style") "color: magenta")
	      (xsl:value-of/ :select "@variables")))
	    ((xsl:if :test "@ctx")
	     ((xsl:element :name "span")
	      ((xsl:attribute :name "class") "ctx")
	      ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
	      (xsl:value-of/ :select "@ctx"))))))
	 ((xsl:element :name "td")
	  ((xsl:attribute :name "class")
	   (xsl:choose
	    ((xsl:when :test "@justification")
	     "just")
	    (xsl:otherwise
	     "misc")))
	  ((xsl:attribute :name "colspan") "2")
	  ;;(td :class "misc" :colspan "2")
	  ((table :class "fs") ;; :style "background: red")
	   (tr
	    (xsl:choose
	     ((xsl:when :test "semform")
	      ((xsl:element :name "td")
	       ;;((xsl:attribute :name "colspan") "1")
	       ((xsl:attribute :name "class") "var")
	       ((xsl:attribute :name "onmouseout") "this.className='var'")
	       (xsl:value-of/ :select "@var"))
	      ((td :class "misc" :colspan "1") (xsl:apply-templates/ :select "semform")))
	     ((xsl:when :test "pointer")
	      ((td :class "misc"))
	      ((xsl:element :name "td")
	       ((xsl:attribute :name "colspan") "1")
	       ((xsl:attribute :name "id") (xsl:value-of/ :select "@var"))
	       (table
		(xsl:apply-templates/ :select "pointer"))))
	     ((xsl:when :test "set")
	      ((xsl:element :name "td")
	       ((xsl:attribute :name "colspan") "2")
	       ((xsl:attribute :name "id") (xsl:value-of/ :select "@var"))
	       (table
		(xsl:apply-templates/ :select "set"))))
	     (xsl:otherwise
	      ((xsl:element :name "td")
	       ((xsl:attribute :name "class") "var")
	       ((xsl:attribute :name "onmouseout") "this.className='var'")
	       (xsl:value-of/ :select "@var"))
	      ((xsl:element :name "td")
	       ((xsl:if :test "not(set)")
		((xsl:attribute :name "class") "fs"))
	       ((xsl:attribute :name "id") (xsl:value-of/ :select "@var"))
	       ((table :class "fs")
		;;(xsl:apply-templates/ :select "ctx-list")
		(xsl:apply-templates/ :select "fs"))))))))))
  #+orig
  #m((xsl:template :match "set")
     ((tr)
      ;;((xsl:if :test "../@type") (td)) ;; ??
      ((td :class "misc" :colspan "3");; :style "background: magenta")
       (table
	(tr ((td :class "misc" :style "font-size: 18") "{")
	    (xsl:apply-templates/ :select "fs|val|pointer" :mode "set")
	    ((td :class "misc" :style "font-size: 18") "}"))))))

  #m((xsl:template :match "set")
     ((tr)
      ((td :class "misc" :colspan "3")
       (table
	(tr ((td :class "misc" :style "font-size: 18") "{")
	    (xsl:apply-templates/ :select "set-elt")
	    ((td :class "misc" :style "font-size: 18") "}"))))))

  #m((xsl:template :match "set-elt")
     ((xsl:if :test "@ctx")
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "ctx")
       ((xsl:attribute :name "style") "vertical-align: middle")
       ((xsl:attribute :name "title") (xsl:value-of/ :select "@expanded-ctx"))
       (xsl:value-of/ :select "@ctx")))
     (xsl:apply-templates/ :select "fs|val|pointer" :mode "set")
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") ", ")))
  
  #m((xsl:template :match "fs" :mode "set")
     ((td :class "misc")
      ((table :class "fs")
       (tr
	((td :class "var")
	 (xsl:value-of/ :select "@var"))
	((xsl:element :name "td")
	 ((xsl:if :test "avp")
	  ((xsl:attribute :name "class") "fs")
	  ((xsl:attribute :name "id") (xsl:value-of/ :select "@var")))
	 (table
	  (xsl:apply-templates/ :select "ctx-list")
	  (xsl:apply-templates/ :select "avp[semform]")	;; first att is PRED
	  (xsl:apply-templates/ :select "avp[@ctx-list]")
	  (xsl:apply-templates/ :select "avp[not(semform) and not(@value)]|set|pointer")
	  (tr ((td :class "misc" :colspan "3") (xsl:apply-templates/ :select "avp[@value]"))))))))
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") ", ")))
  
  #m((xsl:template :match "val" :mode "set")
     ((td :class "misc" )
      ((span :class "value")
       (xsl:value-of/ :select "@value")))
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") ", ")))
     
  #m((xsl:template :match "fs")
     ((td :class "misc") ;; :style "background: lightgray")
      (table
       (xsl:apply-templates/ :select "ctx-list")
       (xsl:apply-templates/ :select "avp[semform]") ;; first att is PRED
       (xsl:apply-templates/ :select "avp[@ctx-list]")
       (xsl:apply-templates/ :select "avp[not(semform) and not(@value)]|set|pointer")
       (tr ((td :class "misc" :colspan "3") (xsl:apply-templates/ :select "avp[@value]")))))
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") "$ ")))
     
  #m((xsl:template :match "pointer")
     (tr ((td :class "misc" :colspan "3")
	  (xsl:apply-templates/ :select "." :mode "text"))))
     
  #m((xsl:template :match "pointer" :mode "set")
     ((td :class "misc")
      (xsl:apply-templates/ :select "." :mode "text"))
     ((xsl:if :test "following-sibling::*")
      ((td :class "misc") (xsl:text ",&#xa0;"))))
  
  #m((xsl:template :match "pointer" :mode "text")
     (xsl:choose
      ((xsl:when :test "@var")
       "[" ((xsl:element :name "span")
	    ((xsl:attribute :name "class") "pointer")
	    ((xsl:attribute :name "cursor") "pointer")
	    ((xsl:attribute :name "onmouseover")
	     "putIntoFocus(this, " (xsl:value-of/ :select "@var") ")")
	    ((xsl:attribute :name "onclick")
	     "putIntoFocus(this, " (xsl:value-of/ :select "@var") ", true)")
	    #+old
	    ((xsl:attribute :name "onmouseover")
	     "this.className='pointer-focus'; var fs = document.getElementById(" 
	     (xsl:value-of/ :select "@var")
	     "); if (fs) {fs.className='fs-focus'};")
	    ((xsl:attribute :name "onmouseout")
	     "this.className='pointer'; var fs = document.getElementById(" 
	     (xsl:value-of/ :select "@var")
	     "); if (fs) {fs.className='fs'};")
	    (xsl:value-of/ :select "@var"))
       (xsl:choose
	((xsl:when :test "@semform")
	 ":" (xsl:value-of/ :select "@semform") "]")
	(xsl:otherwise
	 "]")))
      (xsl:otherwise
       "[" ((xsl:element :name "span")
	    ((xsl:attribute :name "class") "pointer")
	    ((xsl:attribute :name "cursor") "pointer")
	    ((xsl:attribute :name "onmouseover")
	     "this.className='pointer-focus'; var fs = document.getElementById(" 
	     (xsl:value-of/ :select "@parent-var")
	     "); if (fs) {fs.className='fs-focus'};")
	    ((xsl:attribute :name "onmouseout")
	     "this.className='pointer'; var fs = document.getElementById(" 
	     (xsl:value-of/ :select "@parent-var")
	     "); if (fs) {fs.className='fs'};")
	    (xsl:value-of/ :select "@parent-var"))
       "-" (xsl:value-of/ :select "@attribute") "]")))
  
  #m((xsl:template :match "f-structure-discriminant")
     ((tr)
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "disc-anchor")
       ((xsl:attribute :name "title") "Anchor")
       (xsl:value-of/ :select "@anchor")
       ((xsl:if :test "@right-anchor")
	":" (xsl:value-of/ :select "@right-anchor")))
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "disc")
       ((xsl:if :test "@valid='yes' or @chosen='yes'")
	((xsl:attribute :name "onmouseover")
	 "this.className = 'disc-hilite'")
	((xsl:attribute :name "onmouseout")
	 "this.className = 'disc'")
	((xsl:attribute :name "onclick")
	 "chooseDiscriminant('" (xsl:value-of/ :select "@id") "', '')"))
       (nobr
	((xsl:element :name "span")
	 ((xsl:attribute :name "class") "fs-disc")
	 ((xsl:attribute :name "style")
	  (xsl:choose
	   ((xsl:when :test "@redundant='yes'") "color: gray")
	   ((xsl:when :test "@valid='yes'") "color: black")
	   (xsl:otherwise "color: black"))
	  ((xsl:if :test "@chosen='yes'") "; font-weight: bold"))
	 ((xsl:attribute :name "title") (xsl:value-of/ :select "@context"))
	 (xsl:value-of/ :select "path-segment"))))
      ((xsl:element :name "td")
       ((xsl:attribute :name "class") "reduction")
       ((xsl:attribute :name "title") "# of solutions after discriminant application")
       (xsl:value-of/ :select "@reduction"))
      #L(discriminant-complement-xsl stream))))

(defun discriminant-complement-xsl (stream)
  #m((xsl:element :name "td")
     ((xsl:attribute :name "class") "disc")
     (xsl:choose
      ((xsl:when :test "@redundant='yes'") "")
      ((xsl:when :test "@valid='yes'")
       ((xsl:attribute :name "title") "Choose the complement of the discriminant to the left")
       ((xsl:attribute :name "onmouseover")
	"this.className = 'disc-hilite'")
       ((xsl:attribute :name "onmouseout")
	"this.className = 'disc'")
       ((xsl:attribute :name "onclick")
	"chooseDiscriminant('" (xsl:value-of/ :select "@id") "', true)")
       ((xsl:if :test "@reduction")
	(nobr "compl (" (xsl:value-of/ :select "//discriminants/@chosen - @reduction") ")")))
      ((xsl:when :test "@chosen='yes'")
       ((xsl:if :test "@compl='yes'")
	((xsl:attribute :name "style") "font-weight: bold")
	((xsl:attribute :name "title") "The complement of this discriminant was chosen")
	"compl")))))

(publish :path (concatenate 'string "/" *url-base* "/xle-f-structure.xml")
	 :class 'xml/html-entity
	 :function #'f-structure-xml)

(publish :path (concatenate 'string "/" *url-base* "/xle-f-structure.xsl")
	 :content-type "text/xml"
	 :function #'f-structure-xsl)

(defmethod get-graph ((grammar grammar) &key sentence parse-p root-cat xle-graph-id
		      next-solution same-solution previous-solution disable-OT
		      cg-preparse-on-fragment-analysis cg-preparse disjunction-choice
		      error-on-fatal-grammar-error-p check-generator-p force-p ranking-p inspect-p)
  #-debug(setf ranking-p nil)
  #+debug(print (list
		 xle-graph-id next-solution same-solution previous-solution
		 disjunction-choice))
  (let* ((*grammar* grammar)
	 (graph-table (graph-table *grammar*))
	 (graph.sentence (gethash xle-graph-id graph-table))
	 (previous-graph (car graph.sentence))
	 (graph nil))
    #+debug(print (list :parse-p parse-p :xle-graph-id xle-graph-id :g.s graph.sentence
			:or-xx (or next-solution same-solution previous-solution disjunction-choice)))
    (cond ((and graph.sentence
		(or (null (parser (car graph.sentence)))
		    ;; check if parser has been grabbed by an other process
		    (eq previous-graph (graph (parser previous-graph))))
		(not parse-p)
		#+old
		(or next-solution same-solution previous-solution disjunction-choice))
	   (when (parser (car graph.sentence))
	     (setf (last-access (parser previous-graph))
		   (get-universal-time)))
	   (setf sentence (cdr graph.sentence))
	   #+debug(print (parser (car graph.sentence)))
	   (car graph.sentence))
	  ((or (null graph.sentence)
	       (null (parser previous-graph))
	       (not (parser-active-p (parser previous-graph)))
	       (not (eq previous-graph (graph (parser previous-graph)))))
	   (let ((graph (loop for graph =
			      (make-instance (graph-class *grammar*)
					     :task :www
					     :force-p force-p
					     :sentence sentence
					     :previous-graph previous-graph
					     :disable-OT-p disable-OT
					     :root-cat root-cat
					     :reparse-on-timeout-topcat
					     (reparse-on-timeout-topcat *grammar*)
					     :cg-preparse-on-fragment-analysis-p
					     cg-preparse-on-fragment-analysis
					     :ranking-p ranking-p
					     :cg-preparse-p cg-preparse
					     :check-generator-p check-generator-p
					     :error-on-fatal-grammar-error-p
					     error-on-fatal-grammar-error-p
					     :inspect-p inspect-p)
			      until graph
			      do (sleep 0.5)
			      finally (return graph))))
	     (when (parser graph)
	       (setf (gethash xle-graph-id graph-table)
		     (cons graph sentence)
		     (last-access (parser graph))
		     (get-universal-time)
		     (graph (parser graph)) graph))
	     graph))
	  (t
	   (let* ((parser (parser previous-graph))
		  (graph (loop for graph =
			       (make-instance (graph-class *grammar*)
					      :task :www :force-p nil
					      :parser parser
					      :sentence sentence
					      :previous-graph previous-graph
					      :disable-OT-p disable-OT
					      :root-cat root-cat ;;(or root-cat "")
					      :reparse-on-timeout-topcat
					      (reparse-on-timeout-topcat *grammar*)
					      :cg-preparse-on-fragment-analysis-p
					      cg-preparse-on-fragment-analysis
					      :ranking-p ranking-p
					      :cg-preparse-p cg-preparse
					      :check-generator-p check-generator-p
					      :error-on-fatal-grammar-error-p
					      error-on-fatal-grammar-error-p
					      :inspect-p inspect-p)
			       until graph
			       do (sleep 0.5)
			       finally (return graph)))
		  (parser (parser graph)))
	     (setf (gethash xle-graph-id graph-table)
		   (cons graph sentence)
		   (last-access parser) (get-universal-time)
		   (graph parser) graph)
	     graph)))))

(define-javascript-writer js/xle (stream)
  #j(#+test
     (defun hilite-projecting-nodes (node)
       (alert "hier")
       (alert (doc.get-elements-by-name "svg"))
       (let* ((object (doc.get-elements-by-name "svg"))
	      ;; (doc (document.CStructure.getSVGDocument)) ;; MSIE
	      (doc (object.getSVGDocument))
	      (proj-nodes (doc.get-elements-by-name node.id))
	      (n-i 0))
	 (alert proj-nodes.length)
	 (for ((< n-i proj-nodes.length) (incf n-i))
	   (let ((node (aref proj-nodes n-i)))
	     (setf node.class-name "node-focus")))))
     
     (defun unhilite-handle-label (handle)
       (hilite-handle-label handle "yes"))
     
     (defun hilite-handle-label (handle reset)
       (cond (reset
	      (setf handle.class-name "handle"))
	     (t
	      (setf handle.class-name "handle-label")))
       (let ((handle-e (document.get-elements-by-name (handle.get-attribute "name")))
	     (i 0))
	 (for ((< i handle-e.length) (incf i))
	      (let ((h (aref handle-e i)))
		(cond (reset
		       (setf h.class-name "handle"))
		      (t
		       (setf h.class-name "handle-label")))))))
     
     (defun hilite-qeq (qeq reset)
       (let* ((harg-e (document.get-elements-by-name (qeq.get-attribute "harg-id")))
	      (larg-e (document.get-elements-by-name (qeq.get-attribute "larg-id")))
	      (h-i 0)
	      (l-i 0))
	 (cond (reset
		(setf qeq.class-name "qeq"))
	       (t
		(setf qeq.class-name "qeq-focus")))
	 (for ((< h-i harg-e.length) (incf h-i))
	      (let ((harg (aref harg-e h-i)))
		(setf harg.class-name "harg")
		(cond (reset
		       (setf harg.class-name "handle"))
		      (t
		       (setf harg.class-name "harg")))))
	 (for ((< l-i larg-e.length) (incf l-i))
	      (let ((larg (aref larg-e l-i)))
		(cond (reset
		       (setf larg.class-name "handle"))
		      (t
		       (setf larg.class-name "larg")))))))
          
     (defun unhilite-qeq (qeq)
       (hilite-qeq qeq "yes"))
     
     (defun submit-on-linefeed (event)
       ;(alert event.key-code)
       (when (= event.key-code 13)
	 (let* ((form (document.get-element-by-id "form"))
		(ps (document.get-element-by-id "parse-sentence-hidden")))
	   (setf ps.value "true")
	   ;;(alert form.outerHTML)
	   #+ignore
	   (setf event.key-code nil
		 event.cancel-bubble nil)
	   (form.submit))))
     
     (defun choose-disjunction (dis)
       (let* ((form (document.get-element-by-id "form"))
	      (input (document.get-element-by-id "disjunction-choice")))
	 (setf input.value dis)
	 (form.submit)))

     (defun choose-discriminant (id complementp)
       (let* ((form (document.get-element-by-id "discriminant-form"))
	      (input (document.get-element-by-id "discriminant-choice"))
	      (c-input (document.get-element-by-id "complementp")))
	 (setf input.value id c-input.value complementp)
	 (form.submit)))

     (defun put-into-focus (obj id scroll)
       (setf obj.class-name "pointer-focus")
       (let ((fs (document.get-element-by-id id)))
	 (when fs
	   (when scroll
	     (fs.scroll-into-view))
	   (setf fs.class-name "fs-focus")
	   )))
     
     ;; Inspector
     (defun get-previous-fstructure ()
       (let* ((fstructure-td (document.get-element-by-id "fstructure"))
	      (grammar (document.get-element-by-id "grammar"))
	      (xle-graph-id (document.get-element-by-id "xle-graph-id"))
	      (req (new (XMLHttpRequest))))
	 (req.open "get" (+ #L(concatenate 'string "/" *url-base* "/js/fstructure.xml?grammar=")
			    grammar.value
			    "&xle-graph-id="
			    xle-graph-id.value
			    "&previous-fstructure=yes")
		   false)
	 (req.send "")
	 (setf fstructure-td.innerHTML req.responseText)))

     (defun get-next-fstructure ()
       (let* ((fstructure-td (document.get-element-by-id "fstructure"))
	      (grammar (document.get-element-by-id "grammar"))
	      (xle-graph-id (document.get-element-by-id "xle-graph-id"))
	      (req (new (XMLHttpRequest))))
	 (req.open "get" (+ #L(concatenate 'string "/" *url-base* "/js/fstructure.xml?grammar=")
			    grammar.value
			    "&xle-graph-id="
			    xle-graph-id.value
			    "&next-fstructure=yes")
		   false) ;; not asynchronous call
	 (req.send "")
	 (setf fstructure-td.innerHTML req.responseText)))
     
     (defun display-discriminants (all-shown)
       (let* ((doc window.parent.document)
	      (discriminants-table (doc.get-element-by-id "discriminants"))
	      (show-all-fs-discs (doc.get-element-by-id "show-all-fs-discs"))
	      (grammar (doc.get-element-by-id "grammar"))
	      (xle-graph-id (doc.get-element-by-id "xle-graph-id"))
	      (req (new (XMLHttpRequest))))
	 ;;(alert xle-graph-id)
	 (setf show-all-fs-discs.value (not all-shown))
	 (req.open "get" (+ #L(concatenate 'string "/" *url-base* "/js/discriminants.xml?xle-graph-id=")
			    xle-graph-id.value
			    "&grammar=" grammar.value
			    "&show-all-fs-discs=" (not all-shown)
			    )
		   false))
       (req.send "")
       ;;(alert req.responseText)
       (when (not (= req.responseText "")) ;; do nothing when c-structure object has expired
	 (setf discriminants-table.innerHTML req.responseText)))
     ))

(defstylesheet discriminants-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")
     ((xsl:template :match "/")
      ;; top-rated discriminants
      ((xsl:if :test "discriminants/discriminant[@top='yes']|discriminants/segmentation[@top='yes']")
       (tr ((td :class "disc-type" :colspan "5")
	    ((span :style "color: red") "High-frequency discriminants")))
       (xsl:apply-templates/ :select "discriminants/discriminant[@top='yes']|discriminants/segmentation[@top='yes']"))
      ;; non-top-rated discriminants by type
      ((xsl:if :test "discriminants/discriminant[@type='lex-discriminant' and not(@top='yes')]")
       (tr ((td :class "disc-type" :colspan "4") "Lexical discriminants"))
       (xsl:apply-templates/ :select "discriminants/discriminant[@type='lex-discriminant' and not(@top='yes')]"))
      ((xsl:if :test "discriminants/discriminant[@type='morph-discriminant' and not(@top='yes')]")
       (tr ((td :class "disc-type" :colspan "4") "Morphological discriminants"))
       (xsl:apply-templates/ :select "discriminants/discriminant[@type='morph-discriminant' and not(@top='yes')]"))
      ((xsl:if :test "discriminants/segmentation[not(@top='yes')]")
       (tr ((td :class "disc-type" :colspan "4") "C-structure discriminants"))
       (xsl:apply-templates/ :select "discriminants/segmentation[not(@top='yes')]"))
      ((xsl:if :test "discriminants/discriminant[@type='f-structure-discriminant' and not(@top='yes')]")
       (tr ((td :class "disc-type" :colspan "4")
	    "F-structure discriminants"
	    ((span :class "text")
	     " | show all "
	     ((xsl:element :name "input")
	      ((xsl:attribute :name "type") "checkbox")
	      ((xsl:attribute :name "name") "show-all-fs-discs")
	      ((xsl:if :test "discriminants/@show-all-fs-discs")
	       ((xsl:attribute :name "checked") "yes"))
	      ((xsl:attribute :name "onclick")
	       "displayDiscriminants('"
	       (xsl:value-of/ :select "discriminants/@show-all-fs-discs")
	       "')")))))
       (xsl:apply-templates/ :select "discriminants/discriminant[@type='f-structure-discriminant' and not(@top='yes')]")))
     #L(discriminant-templates stream)))

(defmethod display-xle-discriminants-xml ((request http-request) entity)
  (with-xml-response (request entity stream
			      (grammar xle-graph-id show-all-fs-discs)
			      :xsl #'discriminants-xsl
			      :force-xslt :sablotron
			      )
    #+debug(print (list :request-query (request-query request)))
    (let* ((xle-graph-id (parse-integer xle-graph-id :junk-allowed t))
	   (grammar (utf-8-decode grammar))
	   (*grammar* (find-grammar grammar))
	   (graph-table (graph-table *grammar*))
	   (graph.sentence (gethash xle-graph-id graph-table))
	   (graph (car graph.sentence)))
      (discriminants-xml graph stream :show-all-fs-discs-p (equal show-all-fs-discs "true")))))

(publish :path (concatenate 'string "/" *url-base* "/js/discriminants.xml")
	 :class 'xml/html-entity
	 :function #'display-xle-discriminants-xml)

(defmethod fs-fstructure-xml ((request http-request) entity)
  #+debug(print (request-query request))
  (with-xml-response (request entity stream (grammar xle-graph-id previous-fstructure next-fstructure)
			      :xsl #'js-fstructure-xsl
			      :force-xslt :sablotron)
    (let* ((xle-graph-id (parse-integer xle-graph-id :junk-allowed t))
	   (grammar (utf-8-decode grammar))
	   (*grammar* (find-grammar grammar))
	   (graph-table (graph-table *grammar*))
	   (graph.sentence (gethash xle-graph-id graph-table))
	   (graph (car graph.sentence)))
      #m((parse :inspect "yes")
	 #L(f-structure-xml graph stream
			    :graph-addr t 
			    :xle-graph-id xle-graph-id
			    :previous-fstructure-p previous-fstructure
			    :next-fstructure-p next-fstructure)))))

(defstylesheet js-fstructure-xsl ()
  #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0")     
     ((xsl:template :match "/parse")
      (xsl:apply-templates/ :select "projections"))
     #L(f-structure-templates stream)))

(publish :path (concatenate 'string "/" *url-base* "/js/fstructure.xml")
	 :class 'xml/html-entity
	 :function #'fs-fstructure-xml)

(defun parse-input-area (stream &key type)
  #m((div :class "text") ;;(p :style "color: black")
     "Grammar: "     
     ((xsl:element :name "select")
      ((xsl:attribute :name "name") "grammar")
      (xsl:apply-templates/ :select "grammars/grammar"))
     ((xsl:if :test "/parse/@owner")
      " Owner: " (xsl:value-of/ :select "/parse/@owner"))
     ((xsl:if :test "@admin='yes'")
      " | "
      (input/ :style "font-size: 8pt"
	      :type "submit" :name "unload-grammar" :value "Reload")))
  #m((div :class "text") "Write a sentence"
     #-(OR PARGRAM XLE-WEB GISLE) ", ending it with punctuation (. ? or !)"
     #-(OR PARGRAM XLE-WEB GISLE) "."
     #-(OR PARGRAM XLE-WEB GISLE) (br/)
     #-(OR PARGRAM XLE-WEB GISLE) "Please observe orthographic conventions, such as capitalization of proper names"
     ".")
  #m((xsl:element :name "textarea")
     ((xsl:attribute :name "name") "sentence")
     ((xsl:attribute :name "rows") "3")
     ((xsl:attribute :name "cols") "80")
     ((xsl:attribute :name "onkeydown") "submitOnLinefeed(event)")
     ((xsl:if :test "/parse/@lang='geo'")
      ((xsl:attribute :name "style") "font-family: Amirani, Verdana; font-size: 12pt"))
     (xsl:value-of/ :select "@sentence"))
  #m(br/)
  #m(br/)
  #+under-construction
  #m(table
     (tr (td (input/ :type "submit"
		     :name "parse-sentence"
		     :id "parse-sentence"
		     :value "Parse sentence")
	     (input/ :type "hidden"
		     :name "parse-sentence"
		     :id "parse-sentence-hidden"
		     :value "")
	      (br/)
	      (input/ :type "submit" :name "unload-parse-sentence" :value "Reload and parse")
	      (br/)
	      (input/ :type "submit" :name "unload-check-parse-sentence" :value "Reload, check and parse"))
	 (td
	  (nobr "Show "
		((xsl:element :name "input")
		 ((xsl:attribute :name "type") "checkbox")
		 ((xsl:attribute :name "name") "show-discriminants")
		 ((xsl:attribute :name "onchange") "submit()")
		 ((xsl:if :test "@show-discriminants")
		  ((xsl:attribute :name "checked") "yes"))
		 "discriminants ")
		#+disabled
		((xsl:element :name "input")
		 ((xsl:attribute :name "type") "checkbox")
		 ((xsl:attribute :name "name") "show-disjunctions")
		 ((xsl:attribute :name "onchange") "submit()")
		 ((xsl:if :test "@show-disjunctions")
		  ((xsl:attribute :name "checked") "yes"))
		 "disjunctions ")
		((xsl:element :name "input")
		 ((xsl:attribute :name "type") "checkbox")
		 ((xsl:attribute :name "name") "show-c-structure")
		 ((xsl:attribute :name "onchange") "submit()")
		 ((xsl:if :test "@show-c-structure")
		  ((xsl:attribute :name "checked") "yes"))
		 "c-structure ")
		((xsl:element :name "input")
		 ((xsl:attribute :name "type") "checkbox")
		 ((xsl:attribute :name "name") "show-f-structure")
		 ((xsl:attribute :name "onchange") "submit()")
		 ((xsl:if :test "@show-f-structure")
		  ((xsl:attribute :name "checked") "yes"))
		 "f-structure ")
		((xsl:if :test "@mrs-p")
		 ((xsl:element :name "input")
		  ((xsl:attribute :name "type") "checkbox")
		  ((xsl:attribute :name "name") "show-mrs")
		  ((xsl:attribute :name "onchange") "submit()")
		  ((xsl:if :test "@show-mrs")
		   ((xsl:attribute :name "checked") "yes"))
		  "MRS ")
			  
		 ((xsl:element :name "input")
		  ((xsl:attribute :name "type") "checkbox")
		  ((xsl:attribute :name "name") "show-features")
		  ((xsl:attribute :name "onchange") "submit()")
		  ((xsl:if :test "@show-features")
		   ((xsl:attribute :name "checked") "yes"))
		  "Show features of variables ")
		 )
			 
		#+disabled
		((xsl:if :test "not(@inspect)")
		 (br/)
		 ((xsl:element :name "input")
		  ((xsl:attribute :name "type") "checkbox")
		  ((xsl:attribute :name "name") "ranking")
		  ((xsl:if :test "@ranking")
		   ((xsl:attribute :name "checked") "yes"))
		  "Do parse ranking")))
	  (br/)
	  ((xsl:if :test "not(@inspect)")
	   (nobr
	    ((xsl:element :name "input")
	     ((xsl:attribute :name "type") "checkbox")
	     ((xsl:attribute :name "name") "packed")
	     ((xsl:attribute :name "onchange") "submit()")
	     ((xsl:if :test "@packed='true'")
	      ((xsl:attribute :name "checked") "yes"))
	     "Packed representation ")
	    ((xsl:element :name "input")
	     ((xsl:attribute :name "type") "hidden")
	     ((xsl:attribute :name "name") "previous-packed")
	     ((xsl:attribute :name "value") (xsl:value-of/ :select "@previous-packed"))))
	   )
	  
	  (nobr
	   ((xsl:element :name "input")
	    ((xsl:attribute :name "type") "checkbox")
	    ((xsl:attribute :name "name") "disable-OT")
	    ((xsl:if :test "@disable-OT='true'")
	     ((xsl:attribute :name "checked") "yes"))
	    "Disable Optimality marks "))

	  (br/)
	  
	  "C-structure: "
	  (nobr
	   ((xsl:element :name "input")
	    ((xsl:attribute :name "type") "checkbox")
	    ((xsl:attribute :name "name") "suppress-complex-categories")
	    ((xsl:attribute :name "onclick") "submit()")
	    ((xsl:if :test "@suppress-complex-categories='true'")
	     ((xsl:attribute :name "checked") "yes"))
	    "Suppress complex categories "))
	  (br/)

	  "F-structure: "
	  ((xsl:if :test "not(@inspect)")
	   (nobr
	    ((xsl:element :name "input")
	     ((xsl:attribute :name "type") "checkbox")
	     ((xsl:attribute :name "name") "suppress-check")
	     ((xsl:attribute :name "onchange") "submit()")
	     ((xsl:if :test "@suppress-check")
	      ((xsl:attribute :name "checked") "yes"))
	     "Suppress CHECK"))
	   (nobr
	    ((xsl:element :name "input")
	     ((xsl:attribute :name "type") "checkbox")
	     ((xsl:attribute :name "name") "preds-only")
	     ((xsl:attribute :name "onchange") "submit()")
	     ((xsl:if :test "@preds-only")
	      ((xsl:attribute :name "checked") "yes"))
	     "PREDs only"))
	   (nobr
	    ((xsl:element :name "input")
	     ((xsl:attribute :name "type") "checkbox")
	     ((xsl:attribute :name "name") "non-top-f-structures")
	     ((xsl:attribute :name "onchange") "submit()")
	     ((xsl:if :test "@non-top-f-structures")
	      ((xsl:attribute :name "checked") "yes"))
	     "Include non-top F-structures")))
	  (br/)
	  "MRS: "
	  ((xsl:element :name "input")
	   ((xsl:attribute :name "type") "checkbox")
	   ((xsl:attribute :name "name") "show-features")
	   ((xsl:attribute :name "onchange") "submit()")
	   ((xsl:if :test "@show-features")
	    ((xsl:attribute :name "checked") "yes"))
	   "Show features of variables ")
	  )
	 
	 #+disabled ;;#-(OR PARGRAM XLE-WEB)
	 ((xsl:if :test "@morphology-type='plugin-morphology'")
	  (td ((xsl:element :name "input")
	       ((xsl:attribute :name "type") "checkbox")
	       ((xsl:attribute :name "name") "cg-preparse")
	       ((xsl:if :test "@cg-preparse")
		((xsl:attribute :name "checked") "yes"))
	       "CG-preparse ")
	      (br/)
	      (nobr
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "checkbox")
		((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		((xsl:if :test "@cg-preparse-on-fragment-analysis")
		 ((xsl:attribute :name "checked") "yes"))
		"CG-preparse on fragment analysis "))))
	 
	 ;;#+KARTULI
	 #+disabled
	 #L(when (eq type :c-structure)
	     #-sbcl
	     #m(td (nobr
		    ((xsl:element :name "input")
		     ((xsl:attribute :name "type") "checkbox")
		     ((xsl:attribute :name "name") "inspect")
		     ((xsl:if :test "@inspect")
		      ((xsl:attribute :name "checked") "yes"))
		     "Inspect"))
		   ((xsl:if :test "@inspect")
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "partial-nodes")
		      ((xsl:if :test "@partial-nodes")
		       ((xsl:attribute :name "checked") "yes"))
		      "Partial nodes"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "sublexical-nodes")
		      ((xsl:if :test "@sublexical-nodes")
		       ((xsl:attribute :name "checked") "yes"))
		      "Sublexical nodes"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "morph-chart")
		      ((xsl:if :test "@morph-chart")
		       ((xsl:attribute :name "checked") "yes"))
		      "Morphology"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "chart")
		      ((xsl:if :test "@chart")
		       ((xsl:attribute :name "checked") "yes"))
		      "Chart")))))))
  #-orig
  #m(table
     (tr (td (input/ :type "submit"
		     :name "parse-sentence"
		     :id "parse-sentence"
		     :value "Parse sentence")
	     (input/ :type "hidden"
		     :name "parse-sentence"
		     :id "parse-sentence-hidden"
		     :value "")
	      (br/)
	      (input/ :type "submit" :name "unload-parse-sentence" :value "Reload and parse")
	      (br/)
	      (input/ :type "submit" :name "unload-check-parse-sentence" :value "Reload, check and parse"))
	 (td
	  #L(when (eq type :mrs)
	      #m((xsl:element :name "input")
		 ((xsl:attribute :name "type") "checkbox")
		 ((xsl:attribute :name "name") "show-features")
		 ((xsl:attribute :name "onchange") "submit()")
		 ((xsl:if :test "@show-features='true'")
		  ((xsl:attribute :name "checked") "yes"))
		 "Show features of variables ")
	      #m(br/))
	  #L(when (eq type :c-structure)
	      #m((xsl:if :test "not(@inspect)")
		 (nobr
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "checkbox")
		   ((xsl:attribute :name "name") "packed")
		   ((xsl:attribute :name "onchange") "submit()")
		   ((xsl:if :test "@packed='true'")
		    ((xsl:attribute :name "checked") "yes"))
		   "Packed representation ")
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "hidden")
		   ((xsl:attribute :name "name") "previous-packed")
		   ((xsl:attribute :name "value") (xsl:value-of/ :select "@previous-packed"))))
		 (br/)))
	  (nobr
	   ((xsl:element :name "input")
	    ((xsl:attribute :name "type") "checkbox")
	    ((xsl:attribute :name "name") "disable-OT")
	    ((xsl:if :test "@disable-OT='true'")
	     ((xsl:attribute :name "checked") "yes"))
	    "Disable Optimality marks "))
	  (br/))
	 #L(when (eq type :c-structure)
	     #m((xsl:if :test "not(@inspect)")
		(td
		 (nobr
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "checkbox")
		   ((xsl:attribute :name "name") "suppress-check")
		   ((xsl:attribute :name "onchange") "submit()")
		   ((xsl:if :test "@suppress-check")
		    ((xsl:attribute :name "checked") "yes"))
		   "Suppress CHECK"))
		 (br/)
		 (nobr
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "checkbox")
		   ((xsl:attribute :name "name") "suppress-complex-categories")
		   ((xsl:attribute :name "onclick") "submit()")
		   ((xsl:if :test "@suppress-complex-categories='true'")
		    ((xsl:attribute :name "checked") "yes"))
		   "Suppress complex categories "))
		 (br/)
		 (nobr
		  ((xsl:element :name "input")
		   ((xsl:attribute :name "type") "checkbox")
		   ((xsl:attribute :name "name") "preds-only")
		   ((xsl:attribute :name "onchange") "submit()")
		   ((xsl:if :test "@preds-only")
		    ((xsl:attribute :name "checked") "yes"))
		   "PREDs only")))))
	  
	 #+disabled ;;#-(OR PARGRAM XLE-WEB)
	 ((xsl:if :test "@morphology-type='plugin-morphology'")
	  (td ((xsl:element :name "input")
	       ((xsl:attribute :name "type") "checkbox")
	       ((xsl:attribute :name "name") "cg-preparse")
	       ((xsl:if :test "@cg-preparse")
		((xsl:attribute :name "checked") "yes"))
	       "CG-preparse ")
	      (br/)
	      (nobr
	       ((xsl:element :name "input")
		((xsl:attribute :name "type") "checkbox")
		((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis")
		((xsl:if :test "@cg-preparse-on-fragment-analysis")
		 ((xsl:attribute :name "checked") "yes"))
		"CG-preparse on fragment analysis "))))
	 #-(OR PARGRAM XLE-WEB)
	 #L(when (eq type :c-structure)
	     #m(td (nobr
		    ((xsl:element :name "input")
		     ((xsl:attribute :name "type") "checkbox")
		     ((xsl:attribute :name "name") "non-top-f-structures")
		     ((xsl:attribute :name "onchange") "submit()")
		     ((xsl:if :test "@non-top-f-structures")
		      ((xsl:attribute :name "checked") "yes"))
		     "Include non-top F-structures"))
		   (br/)
		   (nobr "Show "
			 ((xsl:element :name "input")
			  ((xsl:attribute :name "type") "checkbox")
			  ((xsl:attribute :name "name") "show-discriminants")
			  ((xsl:attribute :name "onchange") "submit()")
			  ((xsl:if :test "@show-discriminants")
			   ((xsl:attribute :name "checked") "yes"))
			  "discriminants ")
			 #+disabled
			 ((xsl:element :name "input")
			  ((xsl:attribute :name "type") "checkbox")
			  ((xsl:attribute :name "name") "show-disjunctions")
			  ((xsl:attribute :name "onchange") "submit()")
			  ((xsl:if :test "@show-disjunctions")
			   ((xsl:attribute :name "checked") "yes"))
			  "disjunctions ")
			 ((xsl:element :name "input")
			  ((xsl:attribute :name "type") "checkbox")
			  ((xsl:attribute :name "name") "show-c-structure")
			  ((xsl:attribute :name "onchange") "submit()")
			  ((xsl:if :test "@show-c-structure")
			   ((xsl:attribute :name "checked") "yes"))
			  "c-structure ")
			 ((xsl:element :name "input")
			  ((xsl:attribute :name "type") "checkbox")
			  ((xsl:attribute :name "name") "show-f-structure")
			  ((xsl:attribute :name "onchange") "submit()")
			  ((xsl:if :test "@show-f-structure")
			   ((xsl:attribute :name "checked") "yes"))
			  "f-structure ")
			 ((xsl:if :test "@mrs-p")
			  ((xsl:element :name "input")
			   ((xsl:attribute :name "type") "checkbox")
			   ((xsl:attribute :name "name") "show-mrs")
			   ((xsl:attribute :name "onchange") "submit()")
			   ((xsl:if :test "@show-mrs")
			    ((xsl:attribute :name "checked") "yes"))
			   "MRS ")
			  
			  ((xsl:element :name "input")
			   ((xsl:attribute :name "type") "checkbox")
			   ((xsl:attribute :name "name") "show-features")
			   ((xsl:attribute :name "onchange") "submit()")
			   ((xsl:if :test "@show-features")
			    ((xsl:attribute :name "checked") "yes"))
			   "Show features of variables ")
			  )
			 
			 #+disabled
			 ((xsl:if :test "not(@inspect)")
			  (br/)
			  ((xsl:element :name "input")
			   ((xsl:attribute :name "type") "checkbox")
			   ((xsl:attribute :name "name") "ranking")
			   ((xsl:if :test "@ranking")
			    ((xsl:attribute :name "checked") "yes"))
			   "Do parse ranking")))))
	 ;;#+KARTULI
	 #+disabled
	 #L(when (eq type :c-structure)
	     #-sbcl
	     #m(td (nobr
		    ((xsl:element :name "input")
		     ((xsl:attribute :name "type") "checkbox")
		     ((xsl:attribute :name "name") "inspect")
		     ((xsl:if :test "@inspect")
		      ((xsl:attribute :name "checked") "yes"))
		     "Inspect"))
		   ((xsl:if :test "@inspect")
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "partial-nodes")
		      ((xsl:if :test "@partial-nodes")
		       ((xsl:attribute :name "checked") "yes"))
		      "Partial nodes"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "sublexical-nodes")
		      ((xsl:if :test "@sublexical-nodes")
		       ((xsl:attribute :name "checked") "yes"))
		      "Sublexical nodes"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "morph-chart")
		      ((xsl:if :test "@morph-chart")
		       ((xsl:attribute :name "checked") "yes"))
		      "Morphology"))
		    (br/)
		    (nobr
		     ((xsl:element :name "input")
		      ((xsl:attribute :name "type") "checkbox")
		      ((xsl:attribute :name "name") "chart")
		      ((xsl:if :test "@chart")
		       ((xsl:attribute :name "checked") "yes"))
		      "Chart")))))))
  
  #m((xsl:if :test "/parse/messages")
     ((div :class "message-title") "Messages")
     ((div :class "message")
      (xsl:apply-templates/ :select "/parse/messages")))
  #m((xsl:if :test "/parse/errors")
     ((div :class "error-title")
      (xsl:choose
       ((xsl:when :test "/parse/@grammar-loaded-p='no'")
	"Grammar could not be loaded")
       (xsl:otherwise
	"Errors detected")))
     ((div :class "error")
      (xsl:apply-templates/ :select "/parse/errors")))
  #m((xsl:if :test "/parse/@unknown-word")
     ((div :class "error-title")
      "Unknown word: "
      ((span :class "error") (xsl:value-of/ :select "/parse/@unknown-word")))))

(defmethod chart-tree-xml ((graph xle-graph) stream &key chartp)
  (with-slots (morphology-tree current-morphology-tree) graph
    #+test
    (print (list :current-morphology-tree current-morphology-tree
		 :morphology-tree morphology-tree))
    (labels ((sort-branch (branch)
	       (sort branch (lambda (x y)
			      (if (= (car x) (car y))
				  (> (cadr x) (cadr y))
				  (< (car x) (car y))))
		     :key (lambda (b) (nthcdr 4 (car b)))))
	     (walk (branch current-branch stream)
	       (destructuring-bind (edge id label status left right) (car branch)
		 (when (equal status "")
		   #m((node :edge #s edge :id #s id :label #s label
			    :status #s status :current #s(when current-branch "yes")
			    :left #s left :right #s right)
		      #L(mapc (lambda (branch)
				(walk branch
				      (find (car branch) (cdr current-branch) :test #'node-equal :key #'car)
				      stream))
			      (sort-branch (cdr branch)))))))
	     (node-equal (n1 n2)
	       (= (car n1) (car n2))
	       #+old
	       (and (string= (car n1) (car n2))
		    (= (caddr n1) (caddr n2))
		    (= (cadddr n1) (cadddr n2)))))
      #m((chart-tree :type #s(if chartp "chart" "morphology"))
	 #L(mapc (lambda (branch)
		   (walk branch
			 (find (car branch) current-morphology-tree :test #'node-equal :key #'car)
			 stream))
		 (sort-branch morphology-tree))))))

(defun chart-tree-templates (stream)
  #m((xsl:template :match "chart-tree")
     ((xsl:element :name "table")
      (xsl:apply-templates/ )))
  #m((xsl:template :match "node")
      ((xsl:element :name "tr")
       ((xsl:element :name "td")
	((xsl:attribute :name "class") "morph")
	((xsl:attribute :name "onmouseover")
	 "this.className = 'morph-hilite'")
	((xsl:attribute :name "onmouseout")
	 "this.className = 'morph'")
	
	((xsl:attribute :name "onclick")
	 "var edge = document.getElementById('edge');"
	 "edge.value = " (xsl:value-of/ :select "@edge")  "; "
	 "var form = document.getElementById('form'); form.submit()")
	;((xsl:element :name "table")
	; ((xsl:element :name "tr")
	;  ((xsl:element :name "td")
	;   ((xsl:attribute :name "class") "morph")
	   ((xsl:element :name "span")
	    (xsl:choose
	     ((xsl:when :test "@current")
	      ((xsl:attribute :name "style") "color: white; background: blue"))
	     ((xsl:when :test "@status=''")
	      ((xsl:attribute :name "style") "background: #ccffee")))
					;((xsl:attribute :name "onclick")
					; )
	    (nobr (xsl:value-of/ :select "@label") ":"
		  (xsl:value-of/ :select "@id") "["
		  (xsl:value-of/ :select "@left") ","
		  (xsl:value-of/ :select "@right") "]"
		  ((span :style "color: red") (xsl:value-of/ :select "@status")))));)))
       ((td :class "morph-box")
	((xsl:element :name "table")
	 ((xsl:attribute :name "class") "morph")
	 (xsl:apply-templates/ ))))))

#+test
(net.aserve::debug-on :notrap)
#+test
(net.aserve::debug-on :xmit)
#+test
(net.aserve::debug-off :notrap)
#+test
(net.aserve::debug-off :xmit)

:eof