;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: TSDB -*-
(in-package :tsdb)
(defun pvm-process (item &optional (type :parse)
&key class flags
(trees-hook :local)
(semantix-hook :local)
(exhaustive *tsdb-exhaustive-p*)
(nanalyses *tsdb-maximal-number-of-analyses*)
(nresults
(if *tsdb-write-passive-edges-p*
-1
*tsdb-maximal-number-of-results*))
roots
(filter *process-suppress-duplicates*)
(i-id 0) (parse-id 0)
result-id
(wait 5))
;;
;; zero out :edge or :tree fields, if any, since they are not remote readable
;;
(when (listp item)
(loop
for result in (get-field :results item)
for edge = (assoc :edge result)
for tree = (assoc :tree result)
when edge do (setf (rest edge) nil)
when (and nil tree) do (setf (rest tree) nil)))
(let* ((item (if (stringp item)
(pairlis '(:i-id :parse-id :i-input)
(list i-id parse-id item))
item))
(client (allocate-client
item :task type :class class :flags flags :wait wait))
(cpu (and client (client-cpu client)))
(tid (and client (client-tid client)))
(protocol (and client (client-protocol client)))
(tagger (when (cpu-p cpu) (cpu-tagger cpu)))
(p-input (when (eq type :parse)
(let ((input (get-field :i-input item)))
(cond
((and (cpu-p cpu) (cpu-preprocessor cpu))
(call-hook
(cpu-preprocessor cpu) input
(when (consp tagger) tagger)))
(*tsdb-preprocessing-hook*
(call-hook
*tsdb-preprocessing-hook* input
(when (consp tagger) tagger)))))))
(item (acons :p-input p-input item))
(custom (if (and (eq protocol :raw) roots)
(let ((roots (loop for root in roots collect (second root))))
(format nil "start-symbols := ~{~a~^ ~}." roots))
(rest (assoc type *process-custom*))))
(status (if tid
(case protocol
(:raw
(cond
((eq type :generate)
(process-item item :type type :result-id result-id
:exhaustive exhaustive
:nanalyses nanalyses
:nresults nresults :filter filter
:trees-hook trees-hook
:semantix-hook semantix-hook
:verbose nil
:interactive nil :burst t
:client client))
(t (process_item tid item nanalyses
nresults nil custom))
)
)
(:lisp
(revaluate
tid
`(process-item
(quote ,item)
:type ,type
:result-id ,result-id
:exhaustive ,exhaustive
:nanalyses ,nanalyses
:nresults ,nresults :filter (quote ,filter)
:trees-hook ,trees-hook :semantix-hook ,semantix-hook
:verbose nil :interactive nil :burst t)
nil
:key :process-item
:verbose nil)))
:null))
(item
(case status
(:ok
(let ((status (process-queue nil :client client)))
(if (rest (assoc :pending status))
(pairlis '(:readings :error)
(list -1
(format nil "PVM client exit <~x>" tid)))
;;
;; _fix_me_
;; this is how things used to be in the web demo; is it really
;; necessary to put the original item back on? (3-jul-04; oe)
;;
(append (rest (assoc :result status))
(when (eq type :parse) item)))))
(:error
(setf (client-status client) :error)
(pairlis '(:readings :error)
(list
-1 (format nil "PVM internal error <~x>" tid))))
(:null
(pairlis '(:readings :error)
(list
-1
(format
nil
"maximum number of active sessions exhausted"))))))
(results (get-field :results item)))
;;
;; _fix_me_
;; so, why not invoke the full enrich-result() here? (10-oct-08; oe)
;;
(when results
(nconc item (acons :unique (length results) nil))
(setf (get-field :results item) results))
item))
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: TSDB -*-
(in-package :tsdb)
(defun process-item (item &key trees-hook semantix-hook
(type :parse)
(stream *tsdb-io*)
(verbose t)
client
(exhaustive *tsdb-exhaustive-p*)
(nanalyses *tsdb-maximal-number-of-analyses*)
(nresults
(if *tsdb-write-passive-edges-p*
-1
*tsdb-maximal-number-of-results*))
(filter *process-suppress-duplicates*)
result-id
interactive burst)
(let ((strikes (get-field :strikes item)))
(when (and (numberp strikes) (numberp *process-client-retries*)
(> strikes *process-client-retries*))
(when (and verbose
client (client-p client)
(smember type '(:parse :generate :translate)))
(print-item item :stream stream :interactive interactive))
(return-from process-item
(pairlis '(:readings :error)
(list -1
(format
nil
"maximum number of strikes exhausted (~a)"
strikes))))))
(cond
((and client
(smember type '(:parse :transfer :generate :translate))
(client-p client))
;;
;; adjust resource limits recorded in .item. according to cpu definition
;;
(let* ((cpu (client-cpu client))
(edges (cpu-edges cpu)))
(when (numberp edges)
(if (get-field :edges item)
(setf (get-field :edges item) edges)
(nconc item (acons :edges edges nil)))))
(let* ((nanalyses (if exhaustive
0
(if (or (and (integerp nanalyses) (>= nanalyses 1))
(and (eq type :translate) (stringp nanalyses)))
nanalyses
1)))
(trees-hook (and *tsdb-write-tree-p* trees-hook))
(semantix-hook (and *tsdb-write-mrs-p* semantix-hook))
(tid (client-tid client))
(reader (find-attribute-reader :mrs))
(mrs (when (smember type '(:transfer :generate))
(let* ((id
(if (numberp result-id)
result-id
(unless *process-exhaustive-inputs-p*
(loop
for rank in (get-field :ranks item)
when (eql (get-field :rank rank) 1)
return (get-field :result-id rank)))))
(result
(when id
(loop
for result in (get-field :results item)
when (eql (get-field :result-id result) id)
return result)))
(mrs (get-field :mrs result)))
(if (and reader (stringp mrs))
(funcall reader mrs)
mrs))))
(mrs (when mrs
(typecase mrs
(string mrs)
#+:lkb
(mrs::psoa
(with-output-to-string (stream)
(mrs::output-mrs1 mrs 'mrs::simple stream))))))
(custom (rest (assoc type *process-custom*)))
(status (if (eq (client-protocol client) :lisp)
(revaluate
tid
`(process-item
(quote ,item)
:type ,type
:trees-hook ,trees-hook
:semantix-hook ,semantix-hook
:exhaustive ,exhaustive :nanalyses ,nanalyses
:nresults ,nresults :filter (quote ,filter)
:verbose nil :interactive nil :burst t)
nil
:key :process-item
:verbose nil)
(process_item
tid (progn (set-field :mrs mrs item) item )
nanalyses nresults interactive custom))))
(case status
(:ok
(setf (client-status client) (cons (get-universal-time) item))
:ok)
(:error (setf (client-status client) :error) :error))))
((null client)
(let* ((trees-hook (if (eq trees-hook :local)
*tsdb-trees-hook*
trees-hook))
(semantix-hook (if (eq semantix-hook :local)
*tsdb-semantix-hook*
semantix-hook))
(run-id (get-field :run-id item))
(parse-id (get-field :parse-id item))
(i-id (get-field :i-id item))
(i-wf (get-field :i-wf item))
(i-length (get-field :i-length item))
(i-input (or (and interactive (get-field :o-input item))
(get-field :p-input item)
(get-field :i-input item)))
(reader (find-attribute-reader :mrs))
(mrs (when (smember type '(:transfer :generate))
(let* ((id
(if (numberp result-id)
result-id
(unless *process-exhaustive-inputs-p*
(loop
for rank in (get-field :ranks item)
when (eql (get-field :rank rank) 1)
return (get-field :result-id rank)))))
(result
(when id
(loop
for result in (get-field :results item)
when (eql (get-field :result-id result) id)
return result)))
(mrs (get-field :mrs result))
(derivation (get-field :derivation result))
(edge (and derivation
(ignore-errors (reconstruct derivation)))))
(when edge (setf %graft-aligned-generation-hack% edge))
(if (and reader (stringp mrs))
(funcall reader mrs)
mrs))))
(targets (when (smember type '(:translate))
(loop
for output in (get-field :outputs item)
for surface = (get-field :o-surface output)
when (and (stringp surface)
(not (string= surface "")))
collect surface)))
(gc (get-field :gc item))
(edges (get-field :edges item))
result i-load)
(case gc
(:local #+:allegro (excl:gc))
(:global #+:allegro (excl:gc t)))
(gc-statistics-reset)
(setf i-load (unless interactive #+:pvm (load_average) #-:pvm nil))
(setf result
(if (and (smember type '(:transfer :generate))
(null mrs))
;;
;; _fix_me_
;; there appears to be some duplication of the MRS determination code
;; a little up, and of some of the processing calls further down; try
;; to clean this up one day. (18-sep-05; oe)
;;
(loop
for inputs in (get-field :results item)
for i from 1 to (if (numberp *process-exhaustive-inputs-p*)
*process-exhaustive-inputs-p*
(length inputs))
for mrs = (let ((mrs (get-field :mrs inputs)))
(if (and reader (stringp mrs))
(funcall reader mrs)
mrs))
for result =
(case type
(:transfer
(transfer-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:generate
(generate-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst)))
when (let ((readings (get-field :readings result)))
(and (numberp readings) (> readings 0)))
return result
else collect result into results
finally (return (first results)))
(case type
(:parse
(parse-item i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:transfer
(transfer-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:generate
(generate-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:translate
(translate-item i-input
:id i-id :wf i-wf :length i-length
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst
:targets targets)))))
;;
;; this is a bit archaic: when between one or three global gc()s occured
;; during processing, redo it (unless we were told not to). this goes
;; back to the days, where post-gc() cpu time (rehashing) would show as
;; a significant skewing fact and inhibit reliable timing measures.
;;
(when (and (not *tsdb-minimize-gcs-p*) (not (eq gc :global))
(not interactive)
(>= (gc-statistics :global) 1) (<= (gc-statistics :global) 3))
(when verbose
(format
stream
" (~d gc~:p);~%" (gc-statistics :global))
(force-output stream))
(setf (get-field :gc item) :global)
#+:allegro (excl:gc t)
(when verbose
(print-item item :stream stream :interactive interactive))
(gc-statistics-reset)
(setf i-load #+:pvm (load_average) #-:pvm nil)
(setf result
(case type
(:parse
(parse-item i-input :edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:transfer
(transfer-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:generate
(generate-item mrs
:string i-input
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst))
(:translate
(translate-item i-input
:id i-id :wf i-wf
:edges edges
:trace interactive
:exhaustive exhaustive
:nanalyses nanalyses
:trees-hook trees-hook
:semantix-hook semantix-hook
:nresults nresults :filter filter
:burst burst
:targets targets)))))
#+:allegro
(when (and (= (get-field+ :readings result -1) -1)
(equal (class-of
(get-field :condition result))
(find-class 'excl:interrupt-signal)))
(when verbose
(format
stream
"~&do-process(): abort on keyboard interrupt signal.~%")
(force-output stream))
(throw :break nil))
(let* ((readings (get-field :readings result))
(others (get-field :others result))
(timeup (get-field :timeup result))
(comment (get-field+ :comment result ""))
(global (gc-statistics :global))
(scavenge (gc-statistics :scavenge))
(new (gc-statistics :new))
(old (gc-statistics :old))
(total (length (gc-statistics :efficiency)))
(efficiency (round (average (gc-statistics :efficiency))))
;;
;; no point doing the gc() statistics in :translation mode, as it
;; will always dispatch all of the work to further PVM clients
;;
(comment (if (eq type :translate)
comment
(format
nil
"~a (:global . ~d) (:scavenge . ~d) ~
(:new . ~d) (:old . ~d) ~
(:efficiency . ~d) (:total . ~d)"
comment global scavenge new old efficiency total)))
(a-load #+:pvm (load_average) #-:pvm nil))
(when (and (integerp others) (< others -1))
(push (cons :others (+ (expt 2 32) others)) result))
(push (cons :i-load i-load) result)
(push (cons :a-load a-load) result)
(push (cons :parse-id parse-id) result)
(push (cons :run-id run-id) result)
(push (cons :i-id i-id) result)
(push (cons :gc gc) result)
(push (cons :gcs (+ global scavenge)) result)
(push (cons :comment comment) result)
(when (and timeup (not (= readings -1)))
(push (cons :error (if (stringp timeup) timeup "timeup")) result)))
result))))
;;; -*- Mode: Common-Lisp; Package: itsdb; Encoding: utf-8; -*-
(in-package :itsdb)
(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 tree = (get-field :surface 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))
(let ((mrs (with-output-to-string (stream)
(mrs::output-mrs1
mrs 'mrs::simple stream))))
(nconc result (acons :mrs mrs nil))))
(mrs::ed-output-psoa
mrs :format :html :stream *html-stream*
:n i :propertyp 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 :surface 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::ed-output-psoa
mrs :format :html :stream *html-stream*
:n i :propertyp 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*)))))))))))
;;; Now load some modified CSS
;;;(setf *www-logon-css* "hag")
;;;
;;;
;;;(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 "/hag.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-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 "/hag.css"))
;;; :newline
;;; ((:link
;;; :type "image/gif" :rel "icon"
;;; :href "/icon.gif"))
;;; :newline
;;; #+:null
;;; (format
;;; *html-stream*
;;; "~% ~
;;; ~%")
;;; ((: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
;;; "~%"
;;; (smember :transfer *www-capabilities*)
;;; (smember :generate *www-capabilities*)
;;; (smember :translate *www-capabilities*))
;;; (when name
;;; (format stream "~%" name)))
;;; :newline)))