;;; -*- Mode: Common-Lisp; Package: itsdb; Encoding: utf-8; -*-

(in-package :itsdb)

(defparameter *www-port* 8010)

(defparameter *www-log* nil)

(defparameter *www-interrupt* nil)

(defparameter *www-logon-css* "logon")

(defparameter *www-logon-js* "logon")

(defparameter *www-custom-js* "noen")

(defparameter *www-alttxt-js* "alttxt")

(defparameter *www-scriptaculous-js*
  '("builder" "controls" "dragdrop" "effects" "prototype"
    "scriptaculous" "slider"))

(defparameter *www-title* :noen)

(defparameter *www-disclaimer* nil)

(defparameter *www-introduction* "noen")

(defparameter *www-sample* "Bergensområdet er tett befolket fremdeles.")

(defparameter *www-roots* nil)

(defparameter *www-generics* nil)

(defparameter *www-urls* 
  '((:parse "http://www.ling.uib.no/~victoria/NorGram/")
    (:generate "http://www.delph-in.net/erg")))

(defparameter *www-icon* nil)

(defparameter *www-1x20* nil)

(defparameter *www-comparisons*
  '((:smt "http://www.isi.edu/publications/licensed-sw/pharaoh/")
    (:google "http://www.google.com/translate_t?sl=no&tl=en")
    (:visl "http://www.gramtrans.com/?pair=nor2eng")
    (:it "http://www.tranexp.com:2000/Translate/result.shtml")))

(defparameter *www-maximal-number-of-edges* 20000)

(defparameter *www-maximal-number-of-results* 5)

(defparameter *www-capabilities* nil)

(defvar %www-clients% 0)

(defvar %www-item-id% 0)

(defvar %www-object-counter% 0)

(defvar %www-attic% (make-array 512))

(defvar %www-request% nil)

(defvar %www-entity% nil)

(defvar %www-item% nil)

(defun www-initialize (&key (port *www-port*) pattern)
  (setf *www-port* port)
  (let ((interrupt (format 
                    nil 
                    "/tmp/.aserve.~a.~a" 
                    (current-user) port)))
    (when (keywordp *www-title*)
      (when (null *www-log*)
        (setf *www-log*
          (format
           nil
           "www.~(~a~).~a.~a.log"
           *www-title* *www-port* (current-user))))
      (setf *www-title*
        (case *www-title*
          (:noen "Norwegian-English LOGON On-Line Demonstrator")
          (:deen "German-English LOGON On-Line Demonstrator")
          (:ende "English-German LOGON On-Line Demonstrator")
          (:jaen "Japanese-English LOGON On-Line Demonstrator")
          (:enja "English-Japanese LOGON On-Line Demonstrator")
          (:erg "English Resource Grammar (ERG) LOGON On-Line Demonstrator")
          (:gg "German Grammar (GG) LOGON On-Line Demonstrator")
          (:jacy "JACY LOGON On-Line Demonstrator")
          (:srg "Spanish Resource Grammar (SRG) LOGON On-Line Demonstrator")
          (:cst "CST Danish Grammar (CST) LOGON On-Line Demonstrator")
          (:hag "Hausa Grammar (HAG) LOGON On-Line Demonstrator")
          (:krg "Korean Resource Grammar (KRG) LOGON On-Line Demonstrator")
          (t (format nil "~a LOGON On-Line Demonstrator" *www-title*)))))
    (when (null *www-log*)
      (setf *www-log*
        (format nil "www.~a.~a.log"  *www-port* (current-user))))

    (unless *www-icon*
      (setf *www-icon*
        (make-pathname
         :directory
         (pathname-directory 
          (dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "html")))
         :name "logon.gif")))
    (unless *www-1x20*
      (setf *www-1x20*
        (make-pathname
         :directory
         (pathname-directory 
          (dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "html")))
         :name "1x20.jpg")))
    
    (sleep 2)
    (setf %www-clients% 0)
    (setf %www-item-id% 0)
    (setf %www-object-counter% 0)
    (setf %www-attic% (make-array 512))
    ;;
    ;; a first attempt at `session management': if we fail to grab the port we
    ;; need, attempt to shut down the competing process (assuming it is a web
    ;; server that unterstands our interrupt protocol), wait long enough for
    ;; the interrupt handler to take effect, and try again.
    ;;
    (unless (ignore-errors
             (start :port port :external-format (excl:crlf-base-ef :utf-8)))
      (format
       t
       "initialize(): unable to bind port to ~d; attempting interrupt.~%"
       port)
      (force-output t)
      (with-open-file (foo interrupt :direction :output :if-exists :supersede))
      (sleep 10)
      (start :port port :external-format (excl:crlf-base-ef :utf-8)))
    (unless (mp:process-p *www-interrupt*)
      (flet ((check-interrupt () 
               (loop
                 (when (probe-file interrupt)
                   (format
                    t
                    "check-interrupt(): exiting for `~a'~%"
                    interrupt)
                   (force-output t)
                   (delete-file interrupt)
                   (excl:exit))
                 (sleep 5))))
        (setf *www-interrupt*
          (mp:process-run-function 
              '(:name "aserve interrupt handler") #'check-interrupt)))))

  (unless *www-capabilities*
    (when (loop
              for client in *pvm-clients*
              for cpu = (pvm:client-cpu client)
              thereis (smember :parse (pvm:cpu-task cpu)))
      (pushnew :parse *www-capabilities*))
    (when (loop
              for client in *pvm-clients*
              for cpu = (pvm:client-cpu client)
              thereis (smember :transfer (pvm:cpu-task cpu)))
      (pushnew :transfer *www-capabilities*))
    (when (loop
              for client in *pvm-clients*
              for cpu = (pvm:client-cpu client)
              thereis (smember :generate (pvm:cpu-task cpu)))
      (pushnew :generate *www-capabilities*))
    (when (and (smember :parse *www-capabilities*)
               (smember :transfer *www-capabilities*)
               (smember :generate *www-capabilities*))
      (pushnew :translate *www-capabilities*)))
    
  (let ((css
         (pathname-directory 
          (dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "css"))))
        (js
         (pathname-directory 
          (dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "js")))))
        
    (publish-file
     :path "/logon.css"
     :file (make-pathname :directory css :name *www-logon-css* :type "css"))
    (publish-file
     :path "/logon.js"
     :file (make-pathname :directory js :name *www-logon-js* :type "js"))
    (let ((file (if (pathnamep *www-custom-js*)
                  *www-custom-js*
                  (make-pathname
                   :directory js :name *www-custom-js* :type "js"))))
      (publish-file :path "/custom.js" :file file))
    (publish-file
     :path "/alttxt.js"
     :file (make-pathname :directory js :name *www-alttxt-js* :type "js")))
  ;;
  ;; _fix_me_
  ;; for the run-time binaries, we need to recompute these paths (and maybe a
  ;; few others too).                                           (1-dec-08; oe)
  ;;
  (publish-file :path "/icon.gif" :file *www-icon*)
  (publish-file :path "/1x20.jpg" :file *www-1x20*)

  (publish :path "/compare"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-compare request entity)))

  (publish :path "/fetch"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-fetch request entity)))

  (loop
      with directory
      = (pathname-directory 
         (dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "js")))
      for name in *www-scriptaculous-js*
      for file = (make-pathname :directory directory :name name :type "js")
      when (probe-file file)
      do (publish-file :path (format nil "/~a.js" name) :file file))
        
  (publish :path "/logon"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-logon request entity)))
  (publish :path "/browse"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-browse request entity)))
  (publish :path "/view"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-view request entity)))
  (publish :path "/podium"
   :content-type "text/html"
   :function #'(lambda (request entity) 
                 (www-podium request entity :pattern pattern)))
  (publish :path "/itsdb"
   :content-type "text/html"
   :function #'(lambda (request entity) (www-itsdb request entity))))

(defun www-logon (request entity)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (task (lookup-form-value "task" query))
         (input (or (lookup-form-value "input" query) *www-sample*))
         (exhaustivep (let ((foo (lookup-form-value "exhaustivep" query)))
                        (string-equal foo "all")))
         (output (lookup-form-value "output" query))
         (treep (or (null body) 
                    (if (stringp output)
                      (equal output "tree")
                      (member "tree" output :test #'equal))))
         (mrsp (or (null body) 
                   (if (stringp output)
                     (equal output "mrs")
                     (member "mrs" output :test #'equal))))
         (nresults (or (lookup-form-value "nresults" query) "5"))
         (roots (let ((foo (lookup-form-value "roots" query)))
                  (if (stringp foo) (list foo) foo)))
         (genericsp (let ((foo (lookup-form-value "genericsp" query)))
                      (or (null query) (string-equal foo "yes"))))
         (*www-maximal-number-of-results*
          (cond
           ((equal nresults "1") 1)
           ((equal nresults "5") 5)
           ((equal nresults "10") 10)
           ((equal nresults "50") 50)
           ((equal nresults "100") 100)
           ((equal nresults "500") 500)
           ((equal nresults "all") nil)
           (t *www-maximal-number-of-results*))))
    (with-http-response (request entity)
      (with-http-body (request entity
                               :external-format (excl:crlf-base-ef :utf-8))
        
        (www-doctype *html-stream*)
        (html (:html
               (www-header 
                *html-stream* 
                (format
                 nil
                 "~a~@[ (~a)~]"
                 *www-title*
                 (cond
                  ((string-equal task "analyze") "Analysis")
                  ((string-equal task "translate") "Translation"))))
               ((:body :onload "messenger()")
                :newline
                (:center
                 (unless (eq method :post)
                   (www-output
                    *www-introduction* :stream *html-stream*
                    :absolutep (pathnamep *www-introduction*)))
                 ((:form 
                   :action "/logon" :method "post" :id "main"
                   :onsubmit "submitter('main')"
                   :accept-charset "utf-8" :target "_self")
                  :newline
                  ((:input :type "button"  :class "bright" :value "Sample"
                    :onclick "showSample('main', 'input');"))
                  " "
                  ((:input :type "button"  :class "bright" :value "Reset"
                    :onclick "clearElement('main', 'input');"))
                  " "
                  ((:input
                    :type "text" :name "input" :class "bright"
                    :value (or input "") :size "70"))
                  " "
                  ((:input 
                    :type "submit" :name "task" :class "bright" :id "analyze"
                    :value "Analyze" :disabled '||'
                    :onclick "setTarget('main', '_self');"))
                  " "
                  ((:input 
                    :type "submit" :name "task" :class "bright" :id "translate"
                    :value "Translate" :disabled '||'
                    :onclick "setTarget('main', '_self');"))
                  :br :newline
                  (when (or *www-roots* *www-generics*)
                    (format
                     *html-stream*
                     "<table border=\"0\" cellspacing=\"0\">~%<tr>~%")
                    (when *www-roots*
                      (html
                       ((:td :class "buttons") "allow:")
                       (loop
                           for root in *www-roots*
                           for name = (first root)
                           for active = (if roots
                                          (member name roots :test #'equal)
                                          (fourth root))
                           do
                             (html
                              ((:td :class "buttons")
                               ((:input
                                 :type "checkbox" :name "roots" :value name
                                 :if* active :checked '||)))
                              ((:td :class "buttons")
                               (format *html-stream* "~a" name))))
                       :newline))
                    (when *www-generics*
                      (format
                       *html-stream*
                       "<td class=\"buttons\">~
                          ~@[~*&nbsp;&nbsp;|&nbsp;&nbsp;~]unknown words:~
                        </td>"
                       *www-roots*)
                      (html
                       ((:td :class "buttons")
                        ((:input
                          :type "checkbox" :name "genericsp" :value "yes"
                          :if* genericsp :checked '||)))))
                    (format *html-stream* "</tr></table>~%"))
                  ((:table :border 0 :cellspacing 0)
                   (:tr
                    ((:td :class "buttons") "search:")
                    ((:td :class "buttons")
                     ((:input
                       :type :radio :name "exhaustivep"
                       :value "all" :if* exhaustivep :checked '||)))
                    ((:td :class "buttons") "all")
                    ((:td :class "buttons")
                     ((:input
                       :type :radio :name "exhaustivep"
                       :value "best"
                       :if* (not exhaustivep) :checked '||)))
                    ((:td :class "buttons") "best" )
                    ((:td :class "buttons")
                     "&nbsp;&nbsp;|&nbsp;&nbsp;output:")
                    ((:td :class "buttons")
                     ((:input
                       :type "checkbox" :name "output" :value "tree"
                       :if* treep :checked '||)))
                    ((:td :class "buttons") "tree")
                    ((:td :class "buttons")
                     ((:input
                       :type "checkbox" :name "output" :value "mrs"
                       :if* mrsp :checked '||)))
                    ((:td :class "buttons") "mrs")
                    ((:td :class "buttons")
                     "&nbsp;&nbsp;|&nbsp;&nbsp;show:&nbsp;")
                    ((:td :class "buttons")
                     ((:select :size 1 :name "nresults")
                      ((:option :value "1"
                        :if* (equal nresults "1") :selected '||) "1")
                      ((:option :value "5"
                        :if* (equal nresults "5") :selected '||) "5")
                      ((:option :value "10"
                        :if* (equal nresults "10") :selected '||) "10")
                      ((:option :value "50"
                        :if* (equal nresults "50") :selected '||) "50")
                      ((:option :value "100") "100")
                      ((:option :value "500") "500")
                      ((:option :value "all") "all")))
                    ((:td :class "buttons") "&nbsp;results")))
                  :newline))
                (cond
                 ((and (string-equal task "analyze") input)
                  (www-parse
                   input
                   :exhaustivep exhaustivep :treep treep :mrsp mrsp
                   :roots roots :genericsp genericsp
                   :request request :stream *html-stream*))
                 ((and (string-equal task "translate") input)
                  (www-translate
                   input :exhaustivep exhaustivep 
                   :request request :stream *html-stream*))
                 (t
                  (www-version *html-stream*))))))))))

(defun www-parse (input &key exhaustivep treep mrsp
                             roots genericsp request stream)

  (let* ((item (pairlis '(:i-id :parse-id :i-input 
                          :edges)
                        (list (incf %www-item-id%) 0 input
                              *www-maximal-number-of-edges*)))
         (nresults (or *www-maximal-number-of-results* 0))
         (nanalyses (if exhaustivep 0 nresults))
         (roots (loop
                    for root in roots
                    for match
                    = (find root *www-roots* :key #'first :test #'equal)
                    when match collect (list (second match) (third match))))
         (flags (when *www-generics* (list :generics (and genericsp t))))
         (item 
          (setf %www-item%
            (pvm-process 
             item :parse 
             :exhaustive exhaustivep
             :roots roots :flags flags
             :nanalyses nanalyses :nresults nresults)))
         (readings (get-field :readings item))
         (nresults (or *www-maximal-number-of-results* readings))
         (time (get-field :tcpu item))
         (time (and (numberp time) (/ time 1000)))
         (pedges (get-field :pedges item))
         (results (get-field :results item))
         (unique (length results))
         (rawp nil)
         (error (get-field :error item))
         (error (unless (and (numberp readings) (> readings 0) results)
                  (or
                   (loop
                       with end = 0 
                       with start with starts with ends
                       with result
                       while end do
                         (setf start end)
                         (multiple-value-setq (start end starts ends)
                           (ppcre::scan
                            "Word `([^']*)' is not in lexicon."
                            error :start start))
                         (when (and starts ends)
                           (pushnew 
                            (subseq error (aref starts 0) (aref ends 0)) 
                            result
                            :test #'equal))
                       finally (return (nreverse result)))
                   (when (search "invalid SEM-I predicates" error)
                     (setf rawp t)
                     error)
                   (when (search "no lexicon entries for" error)
                     (loop
                         with end = 0 with start = end 
                         with starts with ends
                         with result
                         while end do
                           (setf start end)
                           (multiple-value-setq (start end starts ends)
                             (ppcre::scan
                              "\"([^\"]*)\""
                              error :start start))
                           (when (and starts ends)
                             (pushnew 
                              (subseq error (aref starts 0) (aref ends 0)) 
                              result
                              :test #'equal))
                         finally (return (nreverse result))))
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit \\(([0-9]+)\\)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit exhausted \\(([0-9]+)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   error))))
    (when request (www-log request input readings time pedges error))
    (format stream "<center>~%")
    (cond
     ((null error)
      (format
       stream 
       "<div id=summary>~
        [~d of ~d~@[ (of ~a)~] ~:[analyses~;analysis~]~
        ~@[; processing time: ~,2f seconds~]~
        ~@[; ~a edges~]]</div>~%~
        <br>~%"
       (if (numberp *www-maximal-number-of-results*)
         (min unique readings *www-maximal-number-of-results*)
         (min unique readings))
       (min unique readings)
       (and (not (= readings unique)) readings)
       (= readings 1)
       time pedges pedges)
      (loop
          with *reconstruct-cache* = (make-hash-table :test #'eql)
          with mrs::*mrs-relations-per-row* = 5
          with mrs::*lnkp* = :characters
          initially
            (format 
             stream 
             "<form action=\"/browse\" method=post id=\"browse\" ~
                    onsubmit=\"synchronize('main', 'browse')\" ~
                    accept-charset=\"utf-8\" target=\"_blank\">~%~
              <input type=hidden name=item value=~a>~%  ~
              <input type=hidden name=results value=~a>~%  ~
              <input type=hidden name=exhaustivep value=\"best\">~%  ~
              <input type=hidden name=nresults value=\"~a\">~%  ~
              <div id=action>~%  ~
              <input type=submit name=action ~
                class=\"bright\" value=latex>~%  ~
              <input type=submit name=action ~
                class=\"bright\" value=compare>~%  ~
              <select name=set size=1>~%    ~
              <option value=all>all analyses</option>~%    ~
              <option value=active selected>selection</option>~%    ~
              </select>~%  ~
              &nbsp;&nbsp;|&nbsp;&nbsp;~%  ~
              <input type=submit name=action class=\"bright\" ~
                     value=\"transfer\"~@[~* disabled~] ~
                     onclick=\"setTarget('main', 'transfer')\">~%  ~
              <input type=submit name=action class=\"bright\" ~
                     value=\"generate\"~@[~* disabled~] ~
                     onclick=\"setTarget('main', 'generate')\">~%  ~
              <input type=submit name=action value=avm disabled>&nbsp;~%  ~
              <input type=submit name=action value=scope disabled>&nbsp;~%  ~
              </div>~%<table class=results>~%"
             (www-store-object nil item) (www-store-object nil results)
             *www-maximal-number-of-results*
             (not (smember :transfer *www-capabilities*))
             (not (smember :generate *www-capabilities*)))
          finally (format stream "</table></form>~%")
          for i from 0
          for result in results
          for derivation = (get-field :derivation result)
          for mrs = (mrs::read-mrs-from-string (get-field :mrs result))
          for edge = (when (or treep (and mrsp (null mrs)))
                       (or (get-field :edge result)
                           (when derivation 
                             (let ((edge (reconstruct derivation)))
                               (setf (lkb::edge-mrs edge) mrs)
                               edge))))
          while (< i nresults) 
          do
            (when edge (nconc result (acons :edge edge nil)))
            (format 
             stream 
             "<tr>~%<td class=resultsNavigation>~%  ~
              <table class=resultsNavigation>~%    ~
              <tr><td class=center>~%~
              <div class=resultsNavigation>#&thinsp;~a</div></td></tr>~%    ~
              <tr><td class=center>~
              <input type=checkbox name=selection value=\"~a\">~
              </td></tr>~%  ~
              </table></td>~%"
             i i)
          when (and treep edge) do
            (format stream "<td class=resultsTree>~%")
            (lkb::html-tree edge :stream stream :indentation 4)
            (format stream "</td>~%")
          when (and mrsp (or mrs edge)) do
            (format stream "<td class=resultsMrs>~%")
            (when (null mrs)
              (setf mrs (mrs::extract-mrs edge))
              (let ((mrs (with-output-to-string (stream)
                           (mrs::output-mrs1
                            mrs 'mrs::simple stream))))
                (nconc result (acons :mrs mrs nil))))
            (mrs::output-mrs1 mrs 'mrs::html stream i)
            (format stream "</td>~%")
          do (format stream "</tr>")))
     ((or (null error) (equal error ""))
      (format
       stream 
       "<div id=error>~
        <p>No result(s) were found for this input.&nbsp;&nbsp;~
        Is it well-formed?</p>~%~
        </div>~%"))
     ((integerp error)
      (format
       stream 
       "<div id=error>~
        <p>The parser exhausted its search space limit ~
        (of ~d passive edge~p);<br>~%  ~
        try non-exhaustive parsing or a shorter (or less ambiguous) ~
        sentence.</p>~%</div>~%"
       error error))
     ((consp error)
      (format
       stream 
       "<div id=error>~
        The following input tokens were not found in the lexicon:<br>~%  ~
        ~{&lsquo;~a&rsquo;~^ ~}.~%</div>~%"
       error))
     ((and rawp (stringp error))
      (format
       stream
       "<div id=error>~a.~%</div>~%"
       (string-right-trim '(#\. #\? #\!) error)))
     (t
      (format
       stream 
       "<div id=error>~
        The server encountered an (unexpected) error:<br>~%  ~
        &lsquo;~a&rsquo;.~%</div>~%"
       (string-right-trim '(#\. #\? #\!) error))))
    (format stream "</center>~%")
    (www-version stream)))

(defun www-translate (input &key exhaustivep request stream)

  (format stream "<center>~%")
  (let* ((n (if exhaustivep *www-maximal-number-of-results* 1))
         (comparisons
          (loop
              for comparison in *www-comparisons*
              for id = (first comparison)
              for task = (background #'www-translate-item input :engine id)
              collect (pairlis '(:task :id :url)
                               (list task id (second comparison)))))
         result)
    ;;
    ;; to give the background threads the opportunity to send out all requests
    ;;
    (sleep 0.1)

    ;;
    ;; _fix_me_
    ;; we should possibly use translate-item() instead, if only to have correct
    ;; statistics available for logging below.  however, then (by default) the
    ;; individual results would no longer be available, i.e. we might have to
    ;; require that translate-string() does the object storage already (which
    ;; would eliminate the potential for id mismatches).        (10-mar-07; oe)
    ;;                                                      
    (setf result
      (setf %www-item%
        (translate-string 
         input :stream stream :format :html
         :nanalyses (format nil "~ax~ax~ax50" n n n)
         :index %www-object-counter%)))
    ;;
    ;; at this point, we rely on translate-string() to have arranged for items
    ;; to be rendered with anchors using object ids in the order corresponding
    ;; to those assigned by the www-store-object() calls below.  this mainly
    ;; serves to increase modularity, i.e. spare translate-string() from having
    ;; to do the actual object storage.
    ;;
    (let* ((www (get-field :www result))
           (id (and (numberp www) (www-store-object nil result)))
           (time (get-field :total result)))
      (unless (= www id)
        (www-warn 
         request
         (format 
          nil
          "www-translate(): object id mismatch (~a != ~a)"
          www id)))
      (loop
          for transfer in (get-field :transfers result)
          for www = (get-field :www transfer)
          for id = (and (numberp www)(www-store-object nil transfer))
          for realizations = (get-field :realizations transfer)
          unless (= www id) do
            (www-warn 
             request
             (format 
              nil
              "www-translate(): object id mismatch (~a != ~a)"
              www id))
          do
            (loop
                for realization in realizations
                for www = (get-field :www realization)
                for id = (and (numberp www) (www-store-object nil realization))
                unless (= www id) do
                  (www-warn 
                   request
                   (format 
                    nil
                    "www-translate(): object id mismatch (~a != ~a)"
                    www id))
                do
                  (incf time (get-field :total realization)))
            (incf time (or (get-field :total transfer) 0)))
    
      (when request
        (let ((readings (length (get-field :translations result)))
              (error (get-field :error result)))
          (www-log request input readings time -1 error))))

    (when comparisons
      (format stream "<table class=\"comparison\">~%")
      (format 
       stream 
       "<tr><th>Other Translations (Scraped off the Internet)</th></tr>~%")
      (sleep 0.1)
      (loop
          for comparison in comparisons
          for task = (get-field :task comparison)
          for results = (get-field :results (background-status task))
          for output = (get-field :surface (first results))
          do
            (nconc comparison (acons :output output nil))
            (format
             stream
             "<tr class=\"comparison\">~
              <td><div id=\"~(~a~)\" ~
                    onMouseOver=\"post('~(~a~)');\" onMouseOut=\"unpost();\">~
                  <a href=\"~a\" target=\"_blank\">~a</a></div></td></tr>~%"
             (get-field :id comparison) (get-field :id comparison)
             (get-field :url comparison) (or output "&nbsp;")))
      (format stream "</table><script>~%  var pending = Array();~%")
      (loop
          for comparison in comparisons
          for id = (get-field :id comparison)
          unless (get-field :output comparison)
          do
            (format
             stream
             "  pending['~(~a~)'] = ~d;~%  ComparisonUpdate('~(~a~)');~%"
             id (www-store-object nil (get-field :task comparison)) id))
      (format stream "</script>~%"))
       
    (format stream "</center>~%")
    (www-version stream)))

(defun www-browse (request entity &key results)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (action (lookup-form-value "action" query))
         (results (or results
                      (if query 
                        (lookup-form-value "results" query)
                        (request-query-value "results" request :post nil))))
         (results (typecase results
                    (string (ignore-errors (parse-integer results)))
                    (number results)))
         (set (lookup-form-value "set" query))
         (selection (lookup-form-value "selection" query)))
    (cond
     ((string-equal action "latex")
      (when (and selection (string-equal set "active"))
        (loop
            with all = (www-retrieve-object nil results)
            with active = nil
            for foo in (if (listp selection) selection (list selection))
            for i = (ignore-errors (parse-integer foo))
            for edge = (and i (nth i all))
            when results do (push edge active)
            finally (setf results (www-store-object nil active))))
      (www-latex request entity :results results))
     ((string-equal action "compare")
      (when (and selection (string-equal set "active"))
        (loop
            with all = (www-retrieve-object nil results)
            with active = nil
            for foo in (if (listp selection) selection (list selection))
            for i = (ignore-errors (parse-integer foo))
            for edge = (and i (nth i all))
            when results do (push edge active)
            finally (setf results (www-store-object nil active))))
      (www-compare request entity :results results))
     ((or (string-equal action "transfer")
          (string-equal action "generate"))
      (when (and selection (string-equal set "active"))
        ;;
        ;; for transfer or generation, we can only take in one result at a time
        ;;
        (loop
            with all = (www-retrieve-object nil results)
            with active = nil
            for foo in (if (listp selection) selection (list selection))
            for i = (ignore-errors (parse-integer foo))
            for edge = (and i (nth i all))
            when results do (push edge active)
            finally (setf results (www-store-object nil active))))
      (www-process
       request entity :results results
       :type (if (string-equal action "transfer") :transfer :generate))))))

(defun www-process (request entity &key type results (wait 5))
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (item (if query 
                 (lookup-form-value "item" query)
                 (request-query-value "item" request :post nil)))
         (item (typecase item
                 (string (ignore-errors (parse-integer item)))
                 (number item)))
         (item (www-retrieve-object nil item))
         (results (or results
                      (if query 
                        (lookup-form-value "results" query)
                        (request-query-value "results" request :post nil))))
         (results (typecase results
                    (string (ignore-errors (parse-integer results)))
                    (number results)))
         (results (www-retrieve-object nil results))
         (results (stable-sort 
                   results #'< 
                   :key #'(lambda (foo) (get-field :result-id foo))))
         (item (acons 
                :ranks
                (loop
                    for i from 1
                    for result in results
                    unless (get-field :mrs result) do
                      ;;
                      ;; if need be, say if earlier we only visualized the tree
                      ;; structure, or on results returned from the generator,
                      ;; attempt to fill in the MRS for this .result.
                      ;;
                      (let* ((derivation (get-field :derivation result))
                             (edge
                              (or (get-field :edge result)
                                  (and derivation (reconstruct derivation))))
                             (mrs (and edge (mrs::extract-mrs edge))))
                        (when mrs
                          (let ((mrs (with-output-to-string (stream)
                                       (mrs::output-mrs1
                                        mrs 'mrs::simple stream))))
                            (nconc result (acons :mrs mrs nil)))))
                    collect (acons :rank i result))
                item))
         (exhaustivep (let ((foo (lookup-form-value "exhaustivep" query)))
                        (string-equal foo "all")))
         (nresults (lookup-form-value "nresults" query))
         (nresults
          (cond
           ((equal nresults "1") 1)
           ((equal nresults "5") 5)
           ((equal nresults "10") 10)
           ((equal nresults "50") 50)
           ((equal nresults "100") 100)
           ((equal nresults "500") 500)
           ((equal nresults "all") nil)
           (t *www-maximal-number-of-results*)))
         (nanalyses (if exhaustivep 0 nresults))
         (hook (and (eq type :generate) "mrs::get-mrs-string"))
         (item 
          (setf %www-item% 
            (pvm-process
             item type :wait wait :exhaustive exhaustivep
             :nanalyses nanalyses :nresults nresults :semantix-hook hook)))
         (readings (get-field :readings item))
         (time (get-field :tcpu item))
         (time (and (numberp time) (/ time 1000)))
         (pedges (get-field :pedges item))
         (results (get-field :results item))
         (rawp nil)
         (error (get-field :error item))
         (error (unless (and (numberp readings) (> readings 0) results)
                  (or
                   (loop
                       with end = 0 
                       with start with starts with ends
                       with result
                       while end do
                         (setf start end)
                         (multiple-value-setq (start end starts ends)
                           (ppcre::scan
                            "Word `([^']*)' is not in lexicon."
                            error :start start))
                         (when (and starts ends)
                           (pushnew 
                            (subseq error (aref starts 0) (aref ends 0)) 
                            result
                            :test #'equal))
                       finally (return (nreverse result)))
                   (when (search "no lexicon entries for" error)
                     (loop
                         with end = 0 with start = end 
                         with starts with ends
                         with result
                         while end do
                           (setf start end)
                           (multiple-value-setq (start end starts ends)
                             (ppcre::scan
                              "\"([^\"]*)\""
                              error :start start))
                           (when (and starts ends)
                             (pushnew 
                              (subseq error (aref starts 0) (aref ends 0)) 
                              result
                              :test #'equal))
                         finally (return (nreverse result))))
                   (when (or (search "invalid SEM-I predicates" error)
                             (search "invalid transfer predicates" error)
                             (search "invalid predicates" error)
                             (search "unknown input relation" error))
                     (setf rawp t)
                     error)
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit \\(([0-9]+)\\)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit exhausted \\(([0-9]+)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   error))))
    (when request 
      (www-log 
       request (get-field :i-input item) readings time pedges error))

    (with-http-response (request entity)
      (with-http-body (request entity
                       :external-format (excl:crlf-base-ef :utf-8))
        
        (www-doctype *html-stream*)
        (html (:html
               (www-header 
                *html-stream* 
                (format
                 nil
                 "~a~@[ (~a)~]"
                 *www-title*
                 (case type
                   (:transfer "Transfer")
                   (:generate "Generation")))
                (case type
                  (:transfer "transfer")
                  (:generate "generate")))
               ((:body :onload "messenger()")
                (:center
                 (unless (eq method :post)
                   (www-output
                    *www-introduction* :stream *html-stream*
                    :absolutep (pathnamep *www-introduction*)))
                 ((:form 
                   :action "/browse" :method "post" 
                   :id "browse" :target "_blank"
                   :accept-charset "utf-8")
                  :newline
                  (:center
                   (cond
                    ((null error)
                     (format
                      *html-stream* 
                      "<div id=summary>~
                       [~d of ~d ~:[analyses~;analysis~]~
                       ~@[; processing time: ~,2f seconds~]~
                      ~@[; ~a edges~]]</div>~%~
                      <br>~%"
                     (if (numberp *www-maximal-number-of-results*)
                       (min readings *www-maximal-number-of-results*)
                       readings)
                     readings (= readings 1)
                     time pedges pedges)
                    (loop
                        with *reconstruct-cache* 
                        = (make-hash-table :test #'eql)
                        with mrs::*mrs-relations-per-row* = 5
                        with mrs::*lnkp* = :characters
                        initially
                          (format 
                           *html-stream* 
                           "<input type=hidden name=item value=~a>~%  ~
                            <input type=hidden name=results value=~a>~%  ~
                            <div id=action>~%  ~
                            <input type=button name=\"close\" ~
                                   class=\"bright\" value=\"close\"
                                   onClick='window.close()'>&nbsp;&nbsp;~
                            <input type=submit name=action ~
                                   class=\"bright\" value=latex>~%  ~
                            <input type=submit name=action value=compare ~
                                   disabled>~%  ~
                            <select name=set size=1>~%    ~
                              <option value=all>all analyses</option>~%    ~
                              <option value=active ~
                                      selected>selection</option>~%    ~
                            </select>~%  ~
                            &nbsp;&nbsp;|&nbsp;&nbsp;~%  ~
                            <input type=submit name=\"action\" ~
                                   onclick=\"setTarget('main', 'transfer')\" ~
                                   value=\"transfer\"~@[~* disabled~]>~%   ~
                            <input type=submit name=\"action\" ~
                                   onclick=\"setTarget('main', 'generate')\" ~
                                   value=\"generate\"~@[~* disabled~]>~%  ~
                            ~@[~*<input type=submit name=\"action\" ~
                                        value=\"avm\" disabled>&nbsp;~%  ~]~
                            <input type=submit name=\"action\" ~
                                   value=\"scope\" disabled>&nbsp;~%  ~
                            &nbsp;&nbsp;|&nbsp;&nbsp;show:&nbsp;~%~
                            <select size=1 name=nresults>~
                              <option value=\"5\" selected>5</option>~
                              <option value=\"10\">10</option>~
                              <option value=\"50\">50</option>~
                              <option value=\"100\">100</option>~
                              <option value=\"all\">all</option>~
                            </select>~%  &nbsp;results~%  ~
                            </div>~%"
                           (www-store-object nil item) 
                           (www-store-object nil results)
                           (not (smember :transfer *www-capabilities*))
                           (not (smember :generate *www-capabilities*))
                           (not (eq type :transfer)))
                          (when (and (eq type :generate) (> readings 0))
                            (format 
                             *html-stream*
                             "<div class=generatorOutputs>~
                              <table class=generatorOutputs>~%")
                            (loop
                                for i from 0
                                for result in results
                                for tree = (get-field :tree result)
                                for class = (determine-string-class tree)
                                for score = (get-field :score result)
                                when (stringp tree) do
                                  (format
                                   
                                   
                                   *html-stream*
                                   "<tr>~
                                      <td class=generatorOutputIndex>~
                                        (~a)&nbsp;&nbsp;</td>~
                                      <td class=~
                                            generator~:[~*~;~:(~a~)~]Output>~
                                        <a href=\"#result~a\">~a</a></td>~
                                      <td class=generatorOutputScore>~
                                        ~@[&nbsp;&nbsp;[~,1f]~]</td>~
                                    </tr>~%"
                                   i class class i tree score))
                            (format *html-stream* "</table></div>~%"))
                          (format *html-stream* "<table class=results>~%")
                        finally (format *html-stream* "</table></form>~%")
                        for i from 0
                        for result in results
                        for derivation = (get-field :derivation result)
                        for mrs = (mrs::read-mrs-from-string 
                                   (get-field :mrs result))
                        for edge = (or (get-field :edge result)
                                       (and derivation 
                                            (reconstruct derivation)))
                        for tree = (get-field :tree result)
                        while (< i nresults) 
                        do (when edge (nconc result (acons :edge edge nil)))
                        when (or mrs edge (and tree (eq type :transfer))) do
                          (format 
                           *html-stream* 
                           "<tr>~%<td class=resultsNavigation>~%  ~
                            <table class=resultsNavigation>~%    ~
                            <a name=\"result~a\"><tr><td class=center>~%~
                            <div class=resultsNavigation>#&thinsp;~a</div>~
                            </td></tr>~%    ~
                            <tr><td class=center>~
                            <input type=checkbox name=selection value=\"~a\">~
                            </td></tr>~%  ~
                            </table></td>~%"
                           i i i)
                        when (and edge (not (eq type :transfer))) do
                          (format *html-stream* "<td class=resultsTree>~%")
                          (lkb::html-tree 
                           edge :stream *html-stream* :indentation 4)
                          (format *html-stream* "</td>~%")
                        when (and tree (eq type :transfer)) do
                          (format 
                           *html-stream*
                           "<td class=resultsDerivations>~%")
                          (format 
                           *html-stream* 
                           "<table class=resultsDerivations>~%")
                          #+:mt
                          (loop
                              for derivation
                              = (mt::read-derivation-from-string tree)
                              then (mt::edge-daughter derivation)
                              while (and (mt::edge-p derivation) 
                                         (mt::edge-daughter derivation))
                              do
                                (format
                                 *html-stream*
                                 "<td class=resultsDerivation>~
                                    ~(~a~)&nbsp;&nbsp;[~a]</td></tr>~%"
                                 (mt::edge-rule derivation)
                                 (mt::edge-id derivation)))
                          (format *html-stream* "</table></td>~%")
                        when (or mrs edge) do
                          (format *html-stream* "<td class=resultsMrs>~%")
                          (when (null mrs)
                            (setf mrs (mrs::extract-mrs edge))
                            (let ((mrs (with-output-to-string (stream)
                                         (mrs::output-mrs1
                                          mrs 'mrs::simple stream))))
                              (nconc result (acons :mrs mrs nil))))
                          (mrs::output-mrs1 mrs 'mrs::html *html-stream* i)
                          (format *html-stream* "</td>~%")
                        do (format *html-stream* "</tr>")))
                   ((or (null error) (equal error ""))
                    (format
                     *html-stream* 
                     "<div id=error>~
                      <p>No result(s) were found for this input.&nbsp;&nbsp;~
                      Is it grammatical?</p>~%~
                      </div>~%"))
                   ((integerp error)
                    (format
                     *html-stream* 
                     "<div id=error>~
                      <p>The processor exhausted its search space limit ~
                      (of ~d passive edge~p);<br>~
                      try non-exhaustive processing or a shorter ~
                      (or less ambiguous) ~
                      input.</p>~%</div>~%"
                     error error))
                   ((consp error)
                    (format
                     *html-stream* 
                     "<div id=error>~
                      The following input tokens were ~
                      not recognized by the processor:<br>~%  ~
                      ~{&lsquo;~(~a~)&rsquo;~^ ~}.~%</div>~%"
                     error))
                   ((and rawp (stringp error))
                    (format
                     *html-stream* 
                     "<div id=error>~a.~%</div>~%"
                     (string-right-trim '(#\. #\? #\!) error)))
                   (t
                    (format
                     *html-stream* 
                     "<div id=error>~
                      The server encountered an (unexpected) error:<br>~%  ~
                      &lsquo;~a&rsquo;.~%</div>~%"
                     (string-right-trim '(#\. #\? #\!) error))))
                  (www-version *html-stream*)))))))))))

(defun www-view (request entity &key type item nresults)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (item 
          (or item
              (let* ((item (if query 
                             (lookup-form-value "item" query)
                             (request-query-value "item" request :post nil)))
                     (item (typecase item
                             (string (ignore-errors (parse-integer item)))
                             (number item))))
                (www-retrieve-object nil item))))
         (nresults (or nresults (lookup-form-value "nresults" query)))
         (nresults
          (cond
           ((equal nresults "1") 1)
           ((equal nresults "5") 5)
           ((equal nresults "10") 10)
           ((equal nresults "50") 50)
           ((equal nresults "100") 100)
           ((equal nresults "500") 500)
           ((equal nresults "all") nil)
           (t *www-maximal-number-of-results*)))
         (type (or type
                   (cond
                    ((null item) :unknown)
                    ((get-field :transfers item) :parse)
                    ((get-field :realizations item) :transfer)
                    (t :generate))))
         (readings (get-field :readings item))
         (time (get-field :tcpu item))
         (time (and (numberp time) (/ time 1000)))
         (pedges (get-field :pedges item))
         (results (get-field :results item))
         (rawp nil)
         (error (get-field :error item))
         (error (unless (and (numberp readings) (> readings 0))
                  (or
                   (loop
                       with end = 0 
                       with start with starts with ends
                       with result
                       while end do
                         (setf start end)
                         (multiple-value-setq (start end starts ends)
                           (ppcre::scan
                            "Word `([^']*)' is not in lexicon."
                            error :start start))
                         (when (and starts ends)
                           (pushnew 
                            (subseq error (aref starts 0) (aref ends 0)) 
                            result
                            :test #'equal))
                       finally (return (nreverse result)))
                   (when (search "no lexicon entries for" error)
                     (loop
                         with end = 0 with start = end 
                         with starts with ends
                         with result
                         while end do
                           (setf start end)
                           (multiple-value-setq (start end starts ends)
                             (ppcre::scan
                              "\"([^\"]*)\""
                              error :start start))
                           (when (and starts ends)
                             (pushnew 
                              (subseq error (aref starts 0) (aref ends 0)) 
                              result
                              :test #'equal))
                         finally (return (nreverse result))))
                   (when (or (search "invalid SEM-I predicates" error)
                             (search "invalid transfer predicates" error)
                             (search "invalid predicates" error)
                             (search "unknown input relation" error))
                     (setf rawp t)
                     error)
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit \\(([0-9]+)\\)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   (multiple-value-bind (foo bar)
                       (ppcre::scan-to-strings 
                        "edge limit exhausted \\(([0-9]+)" error)
                     (declare (ignore foo))
                     (when bar 
                       (ignore-errors 
                        (read-from-string (aref bar 0) nil nil))))
                   error))))
    (when request 
      (www-log 
       request (get-field :i-input item) readings time pedges error))

    (with-http-response (request entity)
      (with-http-body (request entity
                       :external-format (excl:crlf-base-ef :utf-8))
        
        (www-doctype *html-stream*)
        (html (:html
               (www-header 
                *html-stream*
                (format
                 nil
                 "~a~@[ (~a)~]"
                 *www-title*
                 (case type
                  (:parse "Analysis")
                  (:transfer "Transfer")
                  (:generate "Generation")))
                ;;
                ;; in case we were called as a call-back from the fan-out HTML,
                ;; then all viewing targets a new window.
                ;;
                (if (null query)
                  (gensym "")
                  (case type
                    (:parse "parse")
                    (:transfer "transfer")
                    (:generate "generate")
                    (t (gensym "")))))
               ((:body :onload "messenger()")
                (:center
                 ((:form 
                   :action "/browse" :method "post" 
                   :id "browse" :target "_blank"
                   :onsubmit "submitter('main')"
                   :accept-charset "utf-8")
                  :newline
                  (:center
                   (cond
                    ((null error)
                     (format
                      *html-stream* 
                      "<div id=summary>~
                       [~d of ~d ~:[analyses~;analysis~]~
                       ~@[; processing time: ~,2f seconds~]~
                      ~@[; ~a edges~]]</div>~%~
                      <br>~%"
                     (if (numberp *www-maximal-number-of-results*)
                       (min readings *www-maximal-number-of-results*)
                       readings)
                     readings (= readings 1)
                     time pedges pedges)
                    (loop
                        with *reconstruct-cache* 
                        = (make-hash-table :test #'eql)
                        with mrs::*mrs-relations-per-row* = 5
                        initially
                          (format 
                           *html-stream* 
                           "<input type=hidden name=item value=~a>~%  ~
                            <input type=hidden name=results value=~a>~%  ~
                            <div id=action>~%  ~
                            <input type=button name=close value=close ~
                                   onClick='window.close()'>&nbsp;&nbsp;~
                            <input type=submit name=action ~
                                   class=\"bright\" value=latex>~%  ~
                            <input type=submit name=action value=compare ~
                                   disabled>~%  ~
                            <select name=set size=1>~%    ~
                              <option value=all>all analyses</option>~%    ~
                              <option value=active ~
                                      selected>selection</option>~%    ~
                            </select>~%  ~
                            &nbsp;&nbsp;|&nbsp;&nbsp;~%  ~
                            <input type=submit name=action ~
                                   onclick=\"setTarget('main', 'transfer')\" ~
                                   value=transfer>~%   ~
                            <input type=submit name=action ~
                                   onclick=\"setTarget('main', 'generate')\" ~
                                   value=generate>~%  ~
                            ~@[~*<input type=submit name=action value=avm ~
                                        disabled>&nbsp;~%  ~]~
                            <input type=submit name=action value=scope ~
                                   disabled>&nbsp;~%  ~
                            &nbsp;&nbsp;|&nbsp;&nbsp;show:&nbsp;~%~
                            <select size=1 name=nresults>~
                              <option value=\"5\" selected>5</option>~
                              <option value=\"10\">10</option>~
                              <option value=\"50\">50</option>~
                              <option value=\"100\">100</option>~
                              <option value=\"all\">all</option>~
                            </select>~%  &nbsp;results~%  ~
                            </div>~%"
                           (www-store-object nil item) 
                           (www-store-object nil results)
                           (not (eq type :transfer)))
                          (when (and (eq type :generate) (> readings 0))
                            (format 
                             *html-stream*
                             "<div class=generatorOutputs>~
                              <table class=generatorOutputs>~%")
                            (loop
                                for i from 0
                                for result in results
                                for tree = (get-field :tree result)
                                for class = (determine-string-class tree)
                                for score = (get-field :score result)
                                when (stringp tree) do
                                  (format
                                   *html-stream*
                                   "<tr>~
                                      <td class=generatorOutputIndex>~
                                        (~a)&nbsp;&nbsp;</td>~
                                      <td class=~
                                            generator~:[~*~;~:(~a~)~]Output>~
                                        <a href=\"#result~a\">~a</a></td>~
                                      <td class=generatorOutputScore>~
                                        ~@[&nbsp;&nbsp;[~,1f]~]</td>~
                                    </tr>~%"
                                   i class class i tree score))
                            (format *html-stream* "</table></div>~%"))
                          (format *html-stream* "<table class=results>~%")
                        finally (format *html-stream* "</table></form>~%")
                        for i from 0
                        for result in results
                        for derivation = (get-field :derivation result)
                        for mrs = (mrs::read-mrs-from-string 
                                   (get-field :mrs result))
                        for edge = (or (get-field :edge result)
                                       (and derivation 
                                            (reconstruct derivation)))
                        for tree = (get-field :tree result)
                        while (< i nresults) 
                        do (when edge (nconc result (acons :edge edge nil)))
                        when (or mrs edge (and tree (eq type :transfer))) do
                          (format 
                           *html-stream* 
                           "<tr>~%<td class=resultsNavigation>~%  ~
                            <table class=resultsNavigation>~%    ~
                            <a name=\"result~a\"><tr><td class=center>~%~
                            <div class=resultsNavigation>#&thinsp;~a</div>~
                            </td></tr>~%    ~
                            <tr><td class=center>~
                            <input type=checkbox name=selection value=\"~a\">~
                            </td></tr>~%  ~
                            </table></td>~%"
                           i i i)
                        when (and edge (not (eq type :transfer))) do
                          (format *html-stream* "<td class=resultsTree>~%")
                          (lkb::html-tree 
                           edge :stream *html-stream* :indentation 4)
                          (format *html-stream* "</td>~%")
                        when (and tree (eq type :transfer)) do
                          (format 
                           *html-stream*
                           "<td class=resultsDerivations>~%")
                          (format 
                           *html-stream* 
                           "<table class=resultsDerivations>~%")
                          #+:mt
                          (loop
                              for derivation
                              = (mt::read-derivation-from-string tree)
                              then (mt::edge-daughter derivation)
                              while (and (mt::edge-p derivation) 
                                         (mt::edge-daughter derivation))
                              do
                                (format
                                 *html-stream*
                                 "<td class=resultsDerivation>~
                                    ~(~a~)&nbsp;&nbsp;[~a]</td></tr>~%"
                                 (mt::edge-rule derivation)
                                 (mt::edge-id derivation)))
                          (format *html-stream* "</table></td>~%")
                        when (or mrs edge) do
                          (format *html-stream* "<td class=resultsMrs>~%")
                          (mrs::output-mrs1 
                           (or mrs (mrs::extract-mrs edge))
                           'mrs::html *html-stream* i)
                          (format *html-stream* "</td>~%")
                        do (format *html-stream* "</tr>")))
                   ((or (null error) (equal error ""))
                    (format
                     *html-stream* 
                     "<div id=error>~
                      <p>No result(s) were found for this input.&nbsp;&nbsp;~
                      Is it grammatical?</p>~%~
                      </div>~%"))
                   ((integerp error)
                    (format
                     *html-stream* 
                     "<div id=error>~
                      <p>The processor exhausted its search space limit ~
                      (of ~d passive edge~p);<br>~
                      try non-exhaustive processing or a shorter ~
                      (or less ambiguous) ~
                      input.</p>~%</div>~%"
                     error error))
                   ((consp error)
                    (format
                     *html-stream* 
                     "<div id=error>~
                      The following input tokens were ~
                      not recognized by the processor:<br>~%  ~
                      ~{&lsquo;~(~a~)&rsquo;~^ ~}.~%</div>~%"
                     error))
                   ((and rawp (stringp error))
                    (format
                     *html-stream* 
                     "<div id=error>~a.~%</div>~%"
                     (string-right-trim '(#\. #\? #\!) error)))
                   (t
                    (format
                     *html-stream* 
                     "<div id=error>~
                      The server encountered an (unexpected) error:<br>~%  ~
                      &lsquo;~a&rsquo;.~%</div>~%"
                     (string-right-trim '(#\. #\? #\!) error))))
                   (www-version *html-stream*)))))))))))

(defun determine-string-class (string)
  (cond
   ((search " || /" string) :token)
   ((search "|| " string) :fragment)))

(defun www-compare (request entity &key data results)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (index (if query 
                  (lookup-form-value "frame" query)
                  (request-query-value "frame" request :post nil)))
         (frame (when (stringp index) (ignore-errors (parse-integer index))))
         (frame (when (integerp frame) (www-retrieve-object nil frame)))
         (results (or results
                      (if query 
                        (lookup-form-value "results" query)
                        (request-query-value "results" request :post nil))))
         (results (typecase results
                    (string (ignore-errors (parse-integer results)))
                    (number results)))
         (data (or data
                   (if query 
                     (lookup-form-value "data" query)
                     (request-query-value "data" request :post nil))))
         (action (lookup-form-value "action" query))
         (mode (lookup-form-value "mode" query))
         (mode (and mode (intern (string-upcase mode) :keyword)))
         (display (lookup-form-value "display" query))
         (display (and display (intern (string-upcase display) :keyword)))
         classicp concisep orderedp fullp)

    ;;
    ;; there are quite a few different ways for this function to be called ...
    ;;
    (cond
     ;;
     ;; first-time entry for browsing a (Redwoods-type) profile: construct a
     ;; comparison frame, store it in the attic, and initialize everything.
     ;;
     ((and (null frame) data)
      (setf frame (browse-trees data :runp nil))
      (setf index (www-store-object nil frame))
      (browse-tree 
       data (first (lkb::compare-frame-ids frame)) frame :runp nil))
     ;;
     ;; interactive parse comparison from set of results: again, construct a 
     ;; new comparison frame, store it in the attic, and initialize everything.
     ;; go into `modern' discriminant mode, mostly for advertising purposes ...
     ;;
     ((and (null frame) (integerp results))
      (let* ((results (www-retrieve-object nil results))
             (*reconstruct-cache* (make-hash-table :test #'eql))
             (edges (loop
                        for result in results
                        for derivation = (get-field :derivation result)
                        for mrs = (let ((mrs (get-field :mrs result)))
                                    (mrs::read-mrs-from-string mrs))
                        for edge = (or (get-field :edge result)
                                       (let ((edge
                                              (if derivation
                                                (reconstruct derivation)
                                                (lkb::make-edge
                                                 :from 0 :to 0))))
                                         (nconc result (acons :edge edge nil))
                                         (setf (lkb::edge-mrs edge) mrs)
                                         edge))
                        collect edge))
             (lkb::*tree-discriminants-mode* :modern)
             (lkb::*tree-display-threshold* 10))
        (when edges
          (setf frame (lkb::compare edges :runp nil))
          (setf index (www-store-object nil frame)))))
     ;;
     ;; call-back from comparison form: perform whatever action was requested
     ;; and update the comparison frame and our local variables accordingly.
     ;; 
     (frame
      (cond
       ;;
       ;; while browsing a profile, move to previous or following item: from 
       ;; the list of identifiers in the frame, find the appropriate position
       ;; and re-initialize the compare frame
       ;;
       ((member action '("previous" "next") :test #'string-equal)
        (let ((nextp (string-equal action "next"))
              (current (lkb::compare-frame-item frame)))
          (loop
              with status = nil
              for ids on (if nextp
                           (lkb::compare-frame-ids frame)
                           (reverse (lkb::compare-frame-ids frame)))
              for next = (or (when (eql current (first ids)) (second ids))
                             (when (eq :null (get-field :status status))
                               (second ids)))
              when next 
              do (setf status (browse-tree data next frame :runp nil))
              unless (or (null next) (eq :null (get-field :status status)))
              return next)))
                  
       ((and mode (not (eq mode (lkb::compare-frame-mode frame))))
        (setf (lkb::compare-frame-mode frame) mode)
        (lkb::set-up-compare-frame frame (lkb::compare-frame-edges frame)))

      ((and display (not (eq display (lkb::compare-frame-display frame))))
       (setf (lkb::compare-frame-display frame) display)
       (lkb::update-trees frame))
      

      ((string-equal action "clear")
       (lkb::reset-discriminants frame))
      (t
       (loop
           with discriminants = (lkb::compare-frame-discriminants frame)
           with decisions = nil
           for i from 0 to (length (lkb::compare-frame-discriminants frame))
           for key = (format nil "~a" i)
           for value = (lookup-form-value key query)
           when (and value (not (equal value "?"))) do
             (let ((value (when (equal value "+") t)))
               (push (cons i value) decisions))
           finally
             (loop
                 for (i . value) in decisions
                 for discriminant = (nth i discriminants)
                 do
                   (setf (lkb::discriminant-toggle discriminant) value)
                   (setf (lkb::discriminant-state discriminant) value))
             (lkb::recompute-in-and-out frame)
             (lkb::update-trees frame t))))))

    (setf classicp (eq (lkb::compare-frame-mode frame) :classic))
    (setf concisep (eq (lkb::compare-frame-display frame) :concise))
    (setf orderedp (eq (lkb::compare-frame-display frame) :ordered))
    (setf fullp (eq (lkb::compare-frame-display frame) :full))

    #+:debug
    (setf lkb::%frame% frame)
    
    (with-http-response (request entity)
      (with-http-body (request entity
                               :external-format (excl:crlf-base-ef :utf-8))
        (www-doctype *html-stream*)
        (html (:html
               (www-header *html-stream* "Redwoods Tree Comparison")
               ((:body :onload "messenger()")
                (:center
                 ((:form 
                   :action "/compare" :method "post"
                   :accept-charset "utf-8")
                  ((:table :class "compareNavigation")
                   (:span
                    (:td
                     ((:input 
                       :type "button" :name "close" :value "close"
                       :onClick "window.close()")))
                    (:td "&nbsp;")
                    (:td
                     ((:input 
                       :type "button" :name "save" :value "save"
                       :disabled '||)))
                    (when data
                      (html
                       (:td "&nbsp;")
                       (:td
                        ((:input 
                          :type "submit" :name "action" :value "previous")))
                       (:td "&nbsp;")
                       (:td
                        ((:input 
                          :type "submit" :name "action" :value "next")))))
                    (:td "&nbsp;")
                    (:td
                     ((:input :type "submit" :name "action" :value "clear")))
                    (:td "&nbsp;&nbsp;|&nbsp;&nbsp;mode:")
                    (:td
                     (;;
                      ;; _fix_me_
                      ;; originally, i had :disabled '|| on the mode selection;
                      ;; if we were to enable comparison on transfer outputs, i
                      ;; imagine only :modern should be allowed (as there would
                      ;; be no sensible derivations to discriminate), but just
                      ;; now i fail to think of other situations where :classic
                      ;; could go wrong.                        (26-apr-08; oe)
                      ;;
                      (:select 
                       :size 1 :name "mode"
                       :onChange "this.form.submit()")
                      ((:option 
                        :value "classic" 
                        :if* classicp :selected :if* classicp '||)
                       "classic")
                      ((:option 
                        :value "modern" 
                        :if* (not classicp) :selected :if* (not classicp) '||)
                       "modern")))
                    (:td "&nbsp;&nbsp;|&nbsp;&nbsp;display:")
                    (:td
                     ((:select 
                       :size 1 :name "display"
                       :onChange "this.form.submit()")
                      ((:option 
                        :value "concise" 
                        :if* concisep :selected :if* concisep '||)
                       "concise")
                      ((:option 
                        :value "ordered" 
                        :if* orderedp :selected :if* orderedp '||)
                       "ordered")
                      ((:option 
                        :value "full" 
                        :if* fullp :selected :if* fullp '||)
                       "full")))))
                  :newline
                  (when data
                    (html 
                     ((:input :type "hidden" :name "data" :value data))))
                  ((:input :type "hidden" :name "frame" :value index))
                  :newline
                  (when frame
                    (lkb::html-compare frame :stream *html-stream*))
                  (www-version *html-stream*))))))))))

(defun www-latex (request entity &key results)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (item (if query 
                 (lookup-form-value "item" query)
                 (request-query-value "item" request :post nil)))
         (item (typecase item
                 (string (ignore-errors (parse-integer item)))
                 (number item)))
         (item (www-retrieve-object nil item))
         (results (or results
                      (if query 
                        (lookup-form-value "results" query)
                        (request-query-value "results" request :post nil))))
         (results (typecase results
                    (string (ignore-errors (parse-integer results)))
                    (number results)))
         (results (www-retrieve-object nil results))
         (results (stable-sort 
                   results #'< 
                   :key #'(lambda (foo) (get-field :result-id foo)))))

    (with-http-response (request entity
                         :format :text
                         :content-type "text/plain; charset=UTF-8;")
      (with-http-body (request entity
                       :external-format (excl:crlf-base-ef :utf-8))
        
        (loop
            with *reconstruct-cache* 
            = (make-hash-table :test #'eql)
            with mrs::*lnkp* = :characters
            initially
              (format 
               *html-stream*
               "%~%% LaTeX result(s) for `~a'~%~
                % [~a; ~a]~%%~%~%~%"
               (get-field :i-input item)
               *www-title* (current-time :long :pretty))
            for result in results
            for derivation = (get-field :derivation result)
            for mrs = (mrs::read-mrs-from-string 
                       (get-field :mrs result))
            for edge = (or (get-field :edge result)
                           (let ((edge
                                  (and derivation (reconstruct derivation))))
                             (when edge (nconc result (acons :edge edge nil)))
                             edge))
            when (or mrs edge) do
              (format
               *html-stream*
               "%~%% result # ~a~%%~%"
               (get-field :result-id result))
            when edge do
              (ignore-errors
               (lkb::latex-tree
                edge :stream *html-stream* :format :derivation))
              (ignore-errors
               (lkb::latex-tree
                edge :stream *html-stream* :format :syntax))
            when (or mrs edge) do
              (when (null mrs)
                (setf mrs (mrs::extract-mrs edge))
                (let ((mrs (with-output-to-string (stream)
                             (mrs::output-mrs1
                              mrs 'mrs::simple stream))))
                  (nconc result (acons :mrs mrs nil))))
              (mrs::output-mrs1 mrs 'mrs::latex *html-stream*)
              (terpri *html-stream*))))))

(defun www-fetch (request entity)
  #+:debug
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (id (if query 
               (lookup-form-value "id" query)
               (request-query-value "id" request :post nil)))
         (id (when (stringp id) (ignore-errors (parse-integer id))))
         (object (when id (www-retrieve-object nil id)))
         (value (background-status object))
         (value
          (get-field :surface (first (get-field :results value)))))

    (with-http-response (request entity :content-type "text/plain")
      (with-http-body (request entity
                       :external-format (excl:crlf-base-ef :utf-8))
        (html (when value (format *html-stream* value)))))))

(defun www-podium (request entity &key pattern)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body))))
    (declare (ignore query))

    (with-http-response (request entity)
      (with-http-body (request entity
                               :external-format (excl:crlf-base-ef :utf-8))
        (www-doctype *html-stream*)
        (html (:html
               (www-header *html-stream* "[incr tsdb()] Redwoods Treebanks")
               ((:body :onload "messenger()")
                (:center
                 ((:form
                   :action "/itsdb" :method "post" :target "_blank"
                   :accept-charset "utf-8")
                  :newline
                  ((:table :border 0 :cellspacing 0)
                   (:tr
                    ((:td :class "buttons") (:i "where&nbsp;"))
                    ((:td :class "buttons")
                     ((:input
                       :type "text" :name "where"
                       :value "" :size "40")))
                    ((:td :class "buttons") "&nbsp;")
                    ((:td :class "buttons")
                     ((:input 
                       :type "submit" :name "action"  :value "summarize")))
                    ((:td :class "buttons") "&nbsp;")
                    ((:td :class "buttons")
                     ((:input 
                       :type "submit" :name "action" :value "browse")))
                    ((:td :class "buttons") "&nbsp;")
                    ((:td :class "buttons")
                     ((:input 
                       :type "submit" :name "action" :value "Errors" 
                       :disabled '||)))))
                  :br :newline
                  ((:div :class "profiles")
                   (tsdb-do-list 
                    *tsdb-home* :pattern pattern
                    :stream *html-stream* :format :html)))
                 (www-version *html-stream*)))))))))

(defun www-itsdb (request entity)
  (setf %www-request% request %www-entity% entity)
  (let* ((method (request-method request))
         (body (when (eq method :post) (get-request-body request)))
         (query (and body (form-urlencoded-to-query body)))
         (action (lookup-form-value "action" query))
         (data (lookup-form-value "data" query))
         (condition (lookup-form-value "condition" query)))

    (cond
     ((equal action "browse")
      (www-compare request entity :data data))
     ((equal action "summarize")
      (with-http-response (request entity)
        (with-http-body (request entity
                                 :external-format (excl:crlf-base-ef :utf-8))
          (www-doctype *html-stream*)
        (html 
         (:html
          (www-header *html-stream* "Redwoods Annotation Summary")
          ((:body :onload "messenger()")
           (:center
            (analyze-trees 
             data :file *html-stream* :condition condition :format :html)
            (www-version *html-stream*)))))))))))

(defun www-doctype (stream)
  (format
   stream
   "<!DOCTYPE HTML PUBLIC ~
      \"-//W3C//DTD HTML 4.01 Transitional//EN\">~%"))

(defun www-header (stream title &optional (name "default"))
  (let ((*html-stream* stream))
    (html (:head
           ((:meta
             :http-equiv "Content-Type" 
             :content "text/html; charset=utf-8"))
           (:title (format stream "~a" title))
           :newline
           ((:link
             :type "text/css" :rel "stylesheet"
             :href "/logon.css"))
           :newline
           ((:link
             :type "image/gif" :rel "icon"
             :href "/icon.gif"))
           :newline
           #+:null
           (format
            *html-stream*
            "<!-- W3C standards ompliance patch for MicroSoft browsers -->~%  ~
               <!--[if lt IE 7]>~
               <script src=\"ms.js\" type=\"text/javascript\">~
               <script>~
             <![endif]-->~%")
           ((:script
             :src "/logon.js" :language "javascript" 
             :type "text/javascript"))
           ((:script
             :src "/custom.js" :language "javascript" 
             :type "text/javascript"))
           ((:script
             :src "/prototype.js" :language "javascript" 
             :type "text/javascript"))
           ((:script
             :src "/scriptaculous.js" :language "javascript" 
             :type "text/javascript"))
           :newline
           ((:script
             :src "/alttxt.js" :language "javascript" 
             :type "text/javascript"))
           :newline
           (format
            stream
            "<script>__transferP__ = ~:[false~;true~];~%  ~
               __generateP__ = ~:[false~;true~];~%  ~
               __translateP__ = ~:[false~;true~];~%</script>~%"
            (smember :transfer *www-capabilities*)
            (smember :generate *www-capabilities*)
            (smember :translate *www-capabilities*))
           (when name
             (format stream "<script>window.name = '~a'</script>~%" name)))
          :newline)))

(defun www-version (stream)
  (format
   stream
   "<center>~%<div id=version>[~
    <a href=\"http://www.emmtee.net/\">LOGON</a> (~a)"
   (subseq mt::*version* 7 32))
  (loop
      for task in '(:parse :transfer :generate)
      for grammar
      = (loop
            for client in *pvm-clients*
            for cpu = (pvm:client-cpu client)
            when (smember task (pvm:cpu-task cpu))
            return (pvm:cpu-grammar cpu)
            finally (return "unknown"))
      for url = (second (assoc task *www-urls*))
      when (smember task *www-capabilities*) do
        (format
         stream
         " &mdash; ~@[<a href=\"~a\">~]~a~@[~*</a>~]"
         url grammar url))
  (format stream "]</div></center>~%")
  (when (stringp *www-disclaimer*) (write-string *www-disclaimer* stream))
  (when (functionp *www-disclaimer*) (funcall *www-disclaimer* stream))
  (format
   stream
   "~%<div id=\"navtxt\" class=\"navtext\" ~
         style=\"position: absolute; top: -100px; left: 0px; ~
                 visibility: hidden\"></div>"))

(let ((lock (mp:make-process-lock)))
  (defun www-log (request input readings time edges error)
    (mp:with-process-lock (lock)
      (with-open-file (stream *www-log* :direction :output
                       :if-does-not-exist :create :if-exists :append)
        (let* ((headers (net.aserve::request-headers request))
               (forwarded (rest (assoc :x-forwarded-for headers)))
               (socket (request-socket request))
               (address (or forwarded (socket:remote-host socket)))
               (host (socket:ipaddr-to-hostname address)))
          (format
           stream
           "[~a] www-log(): [~a] `~a' --- ~a~@[ (~,2f)~]~@[ <~a>~]~
            ~@[ error: `~a'~].~%"
           (current-time :long :pretty) 
           (or host address) input readings time edges
           (unless (equal error "") error))))))
  (defun www-warn (request string)
    (mp:with-process-lock (lock)
      (with-open-file (stream *www-log* :direction :output
                       :if-does-not-exist :create :if-exists :append)
        (let* ((socket (request-socket request))
               (address (socket:remote-host socket))
               (host (socket:ipaddr-to-hostname address)))
          (format
           stream
           "[~a] www-warn(): [~a] ~a.~%"
           (current-time :long :pretty) 
           (or host address) string))))))

(let ((lock (mp:make-process-lock)))
  (defun www-store-object (id object &key globalp)
    (mp:with-process-lock (lock)
      (let ((n %www-object-counter%))
        (setf (aref %www-attic% n) (cons (if globalp -1 id) object))
        (incf %www-object-counter%)
        (when (>= %www-object-counter% (array-total-size %www-attic%))
          (setf %www-attic% 
            (adjust-array %www-attic% (* %www-object-counter% 2))))
        n)))

  (defun www-retrieve-object (id n)
    (when (and (numberp n) (>= n 0) (< n (array-total-size %www-attic%)))
      (mp:with-process-lock (lock)
        (let ((bucket (aref %www-attic% n)))
          (when (or (equal (first bucket) -1) (equal (first bucket) id))
            (rest bucket)))))))

(defun lookup-form-value (name query)
  (loop
      with result = nil
      for (key . value) in query
      when (string-equal key name) do (push value result)
      finally (return (if (rest result) result (first result)))))

(defun www-output (file &key (stream t) (absolutep t) values)
  (let ((file (if absolutep
                file
                (merge-pathnames
                 (make-pathname
                  :directory (pathname-directory 
                              (dir-append
                               (get-sources-dir "tsdb")
                               '(:relative "tsdb" "html"))))
                 (make-pathname :name file :type "html")))))
    (when (probe-file file)
      (loop
          with buffer = (make-array 4096
                                    :element-type 'character
                                    :adjustable t :fill-pointer 0)
          with in = (open file :direction :input)
          for c = (read-char in nil nil)
          while c do (vector-push-extend c buffer)
          finally
            (close in)
            (apply #'format stream buffer values)))))