;;; -*- 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" "sound"))
(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-analyses 100)
(defparameter *www-maximal-number-of-results* 5)
(defparameter *www-capabilities* nil)
(defparameter *www-brat-base* 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"))))
(brat
(namestring
(dir-append (get-sources-dir "tsdb") '(:relative "tsdb" "brat")))))
(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"))
(when *www-brat-base*
(publish-directory :prefix "/brat/" :destination brat)))
;;
;; _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)))
(publish :path "/rest/0.9/parse"
:content-type "application/json"
:function #'(lambda (request entity)
(www-logon request entity :format :json))))
(defun www-logon (request entity &key (format :html))
(setf %www-request% request %www-entity% entity)
(let* ((method (request-method request))
(body (when (eq method :post) (get-request-body request)))
(query
(if body (form-urlencoded-to-query body) (request-query request)))
(task (or (lookup-form-value "task" query) "analyze"))
(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))
(tokensp (when (null body)
(let ((foo (lookup-form-value "tokens" query)))
(cond
((string-equal foo "json") :json)
((string-equal foo "yy") :yy)))))
(derivationp (if (null body)
(let ((foo (lookup-form-value "derivation" query)))
(cond
((string-equal foo "json") :json)
((string-equal foo "udf") :udf)))
(if (stringp output)
(equal output "derivation")
(member "derivation" output :test #'equal))))
(treep (if (null body)
(let ((foo (lookup-form-value "tree" query)))
(and (eq format :html) (null foo) :html))
(if (stringp output)
(equal output "tree")
(member "tree" output :test #'equal))))
(mrsp (if (null body)
(let ((foo (lookup-form-value "mrs" query)))
(cond
((string-equal foo "json") :json)
((string-equal foo "simple") :simple)
((string-equal foo "latex") :latex)))
(if (stringp output)
(equal output "mrs")
(member "mrs" output :test #'equal))))
(edsp (if (null body)
(let ((foo (lookup-form-value "eds" query)))
(cond
((and (null foo) (eq format :html)) :html)
((string-equal foo "json") :json)
((string-equal foo "native") :native)
((or (string-equal foo "amr")
(string-equal foo "penman")
(string-equal foo "arborial"))
:amr)
((string-equal foo "dot") :dot)
((string-equal foo "latex") :latex)))
(if (stringp output)
(equal output "eds")
(member "eds" output :test #'equal))))
(dmp (if (null body)
(let ((foo (lookup-form-value "dm" query)))
(cond
((and (null foo) (eq format :html) *www-brat-base*)
:sdp)
((string-equal foo "sdp") :sdp)
((string-equal foo "latex") :latex)))
(when (if (stringp output)
(equal output "dm")
(member "dm" output :test #'equal))
:sdp)))
(nresults (or (lookup-form-value "results" query)
(lookup-form-value "nresults" query)
(if (eq format :json)
1
*www-maximal-number-of-results*)))
(nanalyses (or (lookup-form-value "analyses" query)
(lookup-form-value "nanalyses" query)))
(nanalyses (or (ignore-errors (parse-integer nanalyses))
*www-maximal-number-of-analyses))
(filter (let ((foo (lookup-form-value "filter" query)))
(unless (string-equal foo "") foo)))
(propertiesp (let ((foo (lookup-form-value "properties" query)))
(or (null foo) (not (string-equal foo "null")))))
(roots (let ((foo (lookup-form-value "roots" query)))
(if (stringp foo) (list foo) foo)))
(genericsp (let ((foo (or (lookup-form-value "genericsp" query)
(lookup-form-value "generics" query))))
(or (null query)
(string-equal foo "yes")
(and (eq format :json)
(not (string-equal foo "null"))))))
(*www-maximal-number-of-results*
(let ((n (if (integerp nresults)
nresults
(ignore-errors (parse-integer nresults)))))
(cond
((integerp n) n)
((equal nresults "all") nil)
(t *www-maximal-number-of-results*)))))
(if (eq format :json)
(with-http-response (request entity)
(with-http-body (request entity
:external-format (excl:crlf-base-ef :utf-8)
:headers '(("Access-Control-Allow-Origin" . "*")))
(when (and (null tokensp) (null derivationp)
(null mrsp) (null edsp) (null dmp))
(setf edsp :json))
(www-parse
input
:exhaustivep exhaustivep :nanalyses nanalyses :tokensp tokensp
:derivationp derivationp :treep treep :mrsp mrsp :edsp edsp :dmp dmp
:roots roots :genericsp genericsp
:filter filter :propertiesp propertiesp
:request request :format format :stream *html-stream*)))
(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 "65"))
" "
((: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*
"~%~%")
(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*
"~
~@[~* | ~]unknown words:~
"
*www-roots*)
(html
((:td :class "buttons")
((:input
:type "checkbox" :name "genericsp" :value "yes"
:if* genericsp :checked '||)))))
(format *html-stream* "
~%"))
((: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")
" | 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 "dm"
:if* dmp :checked '||)))
((:td :class "buttons")
"dm ")
((:td :class "buttons")
((:input
:type "checkbox" :name "output" :value "eds"
:if* edsp :checked '||)))
((:td :class "buttons")
"eds ")
((:td :class "buttons")
((:input
:type "checkbox" :name "output" :value "mrs"
:if* mrsp :checked '||)))
((:td :class "buttons")
"mrs ")
((:td :class "buttons")
" | show: ")
((:td :class "buttons")
((:select :size 1 :name "nresults")
((:option :value "1"
:if* (equal nresults "1") :selected '||) "1")
((:option :value "5"
:if* (or (equal nresults "5")
(not (member
nresults '("1" "10" "50")
:test #'equal)))
: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") " results")))
:newline))
(cond
((and (string-equal task "analyze") input)
(www-parse
input
:exhaustivep exhaustivep :nanalyses nanalyses
:tokensp tokensp :derivationp derivationp :treep treep
:mrsp mrsp :edsp edsp :dmp dmp
:roots roots :genericsp genericsp
:filter filter :propertiesp propertiesp
:request request :format format :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 nanalyses
tokensp derivationp treep mrsp edsp dmp
roots genericsp propertiesp filter
request format 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 (or nanalyses 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 format))
(case format
(:html (format stream "~%")))
(cond
((null error)
(case format
(:html
(format
stream
"~
[~d of ~d~@[ (of ~a)~] ~:[analyses~;analysis~]~
~@[; processing time: ~,2f seconds~]~
~@[; ~a edges~]]
~%~
~
~%~a
~
~%~% ~
~%"
i i))
(:json
(format
stream "~:[,~% ~;~]{\"result-id\": ~d, \"score\": ~,4f"
(zerop i) i (get-field :score result))
(when dm
(format stream ",~% \"dm\":~%")
(let ((string (string-trim '(#\Space #\Newline) dm)))
(format stream " \"~a\"" (json-escape-string string))))))
when (and derivation (smember derivationp '(:json :udf))) do
(case format
(:json
(format stream ",~% \"derivation\":~%")
(case derivationp
(:json
(format stream " ")
(pprint-derivation
derivation :format :json :stream stream
:labels t :rulep t :lexicalp t))
(:udf
(let* ((string (pprint-derivation derivation :stream nil))
(string (string-trim '(#\Space #\Newline) string)))
(format stream " \"~a\"" (json-escape-string string)))))))
when (and treep edge) do
(case format
(:html
(format stream "~%")
(lkb::html-tree edge :stream stream :indentation 4)
(format stream " ~%")))
when (and edsp (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))))
(case format
(:html
(format stream "~%")
(mrs:eds-output-psoa
mrs :format :html :stream stream :n i
:propertiesp t :filter filter
:normalizep t)
(format stream " ~%"))
(:json
(format stream ",~% \"eds\":~%")
(if (smember edsp '(:native :amr :latex :dot))
(let* ((string
(mrs:eds-output-psoa
mrs :format edsp :stream nil :n i
:propertiesp propertiesp :filter filter
:normalizep t))
(string (string-trim '(#\Space #\Newline) string)))
(format stream " \"~a\"" (json-escape-string string)))
(mrs:eds-output-psoa
mrs :format :json :stream stream
:n i :propertiesp propertiesp
:filter filter :prefix " " :normalizep t))))
when (and mrsp (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))))
(case format
(:html
(format stream "~%")
(mrs::output-mrs1 mrs 'mrs::html stream i)
(format stream " ~%"))
(:json
(format stream ",~% \"mrs\":~%")
(if (or (eq mrsp :simple) (eq mrsp :latex))
(let* ((string
(with-output-to-string (stream)
(mrs::output-mrs1
mrs
(case mrsp
(:simple 'mrs::simple)
(:latex 'mrs::latex))
stream)))
(string (string-trim '(#\Space #\Newline) string)))
(format stream " \"~a\"" (json-escape-string string)))
(mrs::mrs-output-json
mrs :propertiesp propertiesp
:stream stream :prefix " "))))
do
(case format
(:html (format stream " "))
(:json (format stream "}")))))
((or (null error) (equal error ""))
(case format
(:html
(format
stream
"~
No result(s) were found for this input. ~
Is it well-formed?
~%~
~
The parser exhausted its search space limit ~
(of ~d passive edge~p);
~%
~
The following input tokens were not found in the lexicon:
~%"
error))
(:json
(format stream "{\"readings\": -1}"))))
((and rawp (stringp error))
(case format
(:html
(format
stream
"~a.~%
~%"
(string-right-trim '(#\. #\? #\!) error)))))
(t
(case format
(:html
(format
stream
"~
The server encountered an (unexpected) error:
~%"
(string-right-trim '(#\. #\? #\!) error)))
(:json
(format stream "{\"readings\": -1}")))))
(case format
(:html
(format stream " ~%")
(www-version stream)))))
(defun www-translate (input &key exhaustivep request stream)
(format stream "~%")
(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 "~%")
(format
stream
"Other Translations (Scraped off the Internet) ~
~%"
(get-field :id comparison) (get-field :id comparison)
(get-field :url comparison) (or output " ")))
(format
stream
"
~%"))
(format stream " ~%")
(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*
"~
[~d of ~d ~:[analyses~;analysis~]~
~@[; processing time: ~,2f seconds~]~
~@[; ~a edges~]]
~%~
~% ~
~% ~
all analyses ~% ~
selection ~% ~
~% ~
| ~% ~
~
5 ~
10 ~
50 ~
100 ~
all ~
~% results~% ~
~%"
(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*
"~
~%")
(loop
for i from 0
for result in results
for surface
= (or (get-field :surface result)
(get-field :tree result))
for class = (determine-string-class surface)
for score = (get-field :score result)
when (stringp surface) do
(format
*html-stream*
"~
~
(~a) ~
~
~a ~
~
~@[ [~,1f]~] ~
~%"
i class class i surface score))
(format *html-stream* "
~%")
finally (format *html-stream* "
~%")
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*
"~%~% ~
~%"
i i i)
when (and edge (not (eq type :transfer))) do
(format *html-stream* "~%")
(lkb::html-tree
edge :stream *html-stream* :indentation 4)
(format *html-stream* " ~%")
when (and tree (eq type :transfer)) do
(format
*html-stream*
"~%")
(format
*html-stream*
"~%")
#+: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*
"~
~(~a~) [~a] ~%"
(mt::edge-rule derivation)
(mt::edge-id derivation)))
(format *html-stream* "
~%")
when (or mrs edge) do
(format *html-stream* "~%")
(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:eds-output-psoa
mrs :format :html :stream *html-stream*
:n i :propertiesp t :normalizep t)
(format *html-stream* " ~%")
when (or mrs edge) do
(format *html-stream* "~%")
(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* " ~%")
do (format *html-stream* " ")))
((or (null error) (equal error ""))
(format
*html-stream*
"~
No result(s) were found for this input. ~
Is it grammatical?
~%~
~
The processor exhausted its search space limit ~
(of ~d passive edge~p);
~%
~
The following input tokens were ~
not recognized by the processor:
~%"
error))
((and rawp (stringp error))
(format
*html-stream*
"~a.~%
~%"
(string-right-trim '(#\. #\? #\!) error)))
(t
(format
*html-stream*
"~
The server encountered an (unexpected) error:
~%"
(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*
"~
[~d of ~d ~:[analyses~;analysis~]~
~@[; processing time: ~,2f seconds~]~
~@[; ~a edges~]]
~%~
~% ~
~% ~
all analyses ~% ~
selection ~% ~
~% ~
| ~% ~
~
5 ~
10 ~
50 ~
100 ~
all ~
~% results~% ~
~%"
(www-store-object nil item)
(www-store-object nil results)
(not (eq type :transfer)))
(when (and (eq type :generate) (> readings 0))
(format
*html-stream*
"~
~%")
(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*
"~
~
(~a) ~
~
~a ~
~
~@[ [~,1f]~] ~
~%"
i class class i tree score))
(format *html-stream* "
~%")
finally (format *html-stream* "
~%")
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*
"~%~% ~
~%"
i i i)
when (and edge (not (eq type :transfer))) do
(format *html-stream* "~%")
(lkb::html-tree
edge :stream *html-stream* :indentation 4)
(format *html-stream* " ~%")
when (and tree (eq type :transfer)) do
(format
*html-stream*
"~%")
(format
*html-stream*
"~%")
#+: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*
"~
~(~a~) [~a] ~%"
(mt::edge-rule derivation)
(mt::edge-id derivation)))
(format *html-stream* "
~%")
when (or mrs edge) do
(format *html-stream* "~%")
(when (null mrs)
(setf mrs (mrs::extract-mrs edge)))
(mrs:eds-output-psoa
mrs :format :html :stream *html-stream*
:n i :propertiesp t :normalizep t)
(format *html-stream* " ~%")
when (or mrs edge) do
(format *html-stream* "~%")
(when (null mrs)
(setf mrs (mrs::extract-mrs edge)))
(mrs::output-mrs1
mrs 'mrs::html *html-stream* i)
(format *html-stream* " ~%")
do (format *html-stream* " ")))
((or (null error) (equal error ""))
(format
*html-stream*
"~
No result(s) were found for this input. ~
Is it grammatical?
~%~
~
The processor exhausted its search space limit ~
(of ~d passive edge~p);
~%
~
The following input tokens were ~
not recognized by the processor:
~%"
error))
((and rawp (stringp error))
(format
*html-stream*
"~a.~%
~%"
(string-right-trim '(#\. #\? #\!) error)))
(t
(format
*html-stream*
"~
The server encountered an (unexpected) error:
~%"
(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 " ")
(:td
((:input
:type "button" :name "save" :value "save"
:disabled '||)))
(when data
(html
(:td " ")
(:td
((:input
:type "submit" :name "action" :value "previous")))
(:td " ")
(:td
((:input
:type "submit" :name "action" :value "next")))))
(:td " ")
(:td
((:input :type "submit" :name "action" :value "clear")))
(:td " | 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 " | 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 url = "http://svn.emmtee.net/trunk/lingo/lkb/tex/mrs.sty"
with dependency
= "http://svn.emmtee.net/trunk/lingo/lkb/tex/tikz-dependency.sty"
with *reconstruct-cache*
= (make-hash-table :test #'eql)
with mrs::*lnkp* = :characters
initially
(format
*html-stream*
"%~%% LaTeX result(s) for ‘~a’~%~
% [~a; ~a]~%%~%~
% use ‘~a’ and~%% ‘~a’~%%~%~%~%"
(get-field :i-input item)
*www-title* (current-time :long :pretty) url dependency)
for result in results
for i from 0
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))
for dm = (dm-construct item (list i) :format :latex)
when (or mrs edge) do
(format
*html-stream*
"%~%% result # ~a~%%~%~%"
(get-field :result-id result))
when edge do
(format *html-stream* "%~%% HPSG Derivation Tree~%%~%")
(ignore-errors
(lkb::latex-tree
edge :stream *html-stream* :format :derivation))
(format *html-stream* "%~%% Labeled Constituent Tree~%%~%")
(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))))
(format
*html-stream* "%~%% Minimal Recursion Semantics (MRS)~%%~%")
(mrs::output-mrs1 mrs 'mrs::latex *html-stream*)
(terpri *html-stream*)
(format
*html-stream*
"%~%% LaTeX Elementary Dependency Structure (EDS)~%%~%")
(mrs:eds-output-psoa mrs :format :latex :stream *html-stream* :normalizep t)
(terpri *html-stream*)
(format
*html-stream*
"%~%% DOT Elementary Dependency Structure (EDS)~%%~%")
(mrs:eds-output-psoa
mrs :format :dot :cargp :inline :stream *html-stream* :normalizep t)
(terpri *html-stream*)
(format
*html-stream*
"%~%% DELPH-IN MRS Bi-Lexical Dependencies (DM)~%%~%")
(write-string dm *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 "))
((:td :class "buttons")
((:input
:type "text" :name "where"
:value "" :size "40")))
((:td :class "buttons") " ")
((:td :class "buttons")
((:input
:type "submit" :name "action" :value "summarize")))
((:td :class "buttons") " ")
((:td :class "buttons")
((:input
:type "submit" :name "action" :value "browse")))
((:td :class "buttons") " ")
((: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
"~%"))
(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
((:script
:src "/logon.js" :language "javascript"
:type "text/javascript"))
((:script
:src "/custom.js" :language "javascript"
:type "text/javascript"))
#+:null
((:script
:src "/prototype.js" :language "javascript"
:type "text/javascript"))
#+:null
((:script
:src "/scriptaculous.js" :language "javascript"
:type "text/javascript"))
:newline
((:script
:src "/alttxt.js" :language "javascript"
:type "text/javascript"))
:newline
(format
stream
"~%"
(smember :transfer *www-capabilities*)
(smember :generate *www-capabilities*)
(smember :translate *www-capabilities*))
(when name
(format
stream
"~%"
name))
(when *www-brat-base*
(format
stream
"~%[~
LOGON (~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
" — ~@[
~]~a~@[~* ~]"
url grammar url))
(format stream "]
~%")
(when (stringp *www-disclaimer*) (write-string *www-disclaimer* stream))
(when (functionp *www-disclaimer*) (funcall *www-disclaimer* stream))
(format
stream
"~%
")
(when *www-brat-base*
(format
stream
"~%"
*www-brat-base*)))
(let ((lock (mp:make-process-lock)))
(defun www-log (request input readings time edges error &key (format :html))
(declare (ignore format))
(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)))))