;;; LKB code patches
#-(or :lkb-v5.3 :lkb-v5.4)
(in-package :cl-user)
#+(:lkb-v5.3 :lkb-v5.4)
(in-package :lkb)
;;; Temporary hacks
(in-package :mrs)
(defun prune-semi (&key (lex lkb::*lexdb*))
(loop
for x in (lkb::get-raw-records lex "select name from lex_cache right join semi_mod using (name) limit 0")
do
(lkb::run-command lex (format nil "DELETE FROM semi_mod WHERE name=~a"
(lkb::psql-quote-literal (car x))))
(lkb::run-command lex (format nil "DELETE FROM semi_pred WHERE lex_id=~a"
(lkb::psql-quote-literal (car x))))
))
;;;(defun generate-from-mrs-internal (input-sem &key nanalyses)
;;;
;;; ;; (ERB 2003-10-08) For aligned generation -- if we're in first only
;;; ;; mode, break up the tree in *parse-record* for reference by
;;; ;; ag-gen-lex-priority and ag-gen-rule-priority. Store in *found-configs*.
;;; #+:arboretum
;;; (populate-found-configs)
;;;
;;; ;;
;;; ;; inside the generator, apply the VPM in reverse mode to map to grammar-
;;; ;; internal variable types, properties, and values. the internal MRS, beyond
;;; ;; doubt, is what we should use for lexical instantiations and Skolemization.
;;; ;; regarding trigger rules and the post-generation MRS compatibility test, on
;;; ;; the other hand, we have a choice. in principle, these should operate in
;;; ;; the external (SEM-I) MRS namespace (the real MRS layer); however, trigger
;;; ;; rules are created from FSs (using grammar-internal nomenclature) and, more
;;; ;; importantly, the post-generation test uses the grammar-internal hierarchy
;;; ;; to test for predicate, variable type, and property subsumption. hence, it
;;; ;; is currently convenient to apply these MRS-level operations with grammar-
;;; ;; internal names, i.e. at an ill-defined intermediate layer.
;;; ;;
;;; ;; _fix_me_
;;; ;; the proper solution to all this mysery will be to create separate SEM-I
;;; ;; hierarchies, i.e. enrich the SEM-I files with whatever underspecifications
;;; ;; the grammar wants to provide at the MRS level, and then import that file
;;; ;; into its own, grammar-specific namespace. one day soon, i hope, i might
;;; ;; actually get to implementing this design ... (22-jan-09; oe)
;;; ;;
;;; (setf input-sem (mt:map-mrs input-sem :semi :backward))
;;;
;;; ;;
;;; ;; per request by dan, manufacture a top handle, if missing and enable the
;;; ;; generator `input compliance' mechanism. (8-mar-10; oe)
;;; ;;
;;; (when (and mrs::*rel-handel-path* (null (mrs:psoa-top-h input-sem)))
;;; (setf (mrs:psoa-top-h input-sem)
;;; (mrs::make-var :id (funcall mrs::*variable-generator*) :type "h")))
;;; (let ((fixup (mt::transfer-mrs input-sem :filter nil :task :fixup :recurse t)))
;;; (when (rest fixup)
;;; (error 'generation/fixup-ambiguity :mrss fixup))
;;; (when fixup
;;; (setf input-sem (mt::edge-mrs (first fixup)))))
;;;
;;; (setf *generator-internal-mrs* input-sem)
;;; (with-package (:lkb)
;;; (clear-gen-chart)
;;; (setf *cached-category-abbs* nil)
;;;
;;; ;;
;;; ;; no need to even try generating when there is no relation index
;;; ;;
;;; (unless (and (hash-table-p mrs::*relation-index*)
;;; (> (hash-table-count mrs::*relation-index*) 0))
;;; (error 'generator-uninitialized))
;;;
;;; (let ((*gen-packing-p* (if *gen-first-only-p* nil *gen-packing-p*))
;;; lex-results lex-items grules lex-orderings
;;; tgc tcpu conses symbols others)
;;; (time-a-funcall
;;; #'(lambda ()
;;; (multiple-value-setq (lex-results grules lex-orderings)
;;; (mrs::collect-lex-entries-from-mrs input-sem))
;;; (multiple-value-setq (lex-items grules lex-orderings)
;;; (filter-generator-lexical-items
;;; (apply #'append lex-results) grules lex-orderings)))
;;; #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest ignore)
;;; (declare (ignore tr ignore))
;;; (setf tgc (+ tgcu tgcs) tcpu (+ tu ts)
;;; conses (* scons 8) symbols (* ssym 24) others sother)))
;;; (setq %generator-statistics%
;;; (pairlis '(:ltgc :ltcpu :lconses :lsymbols :lothers)
;;; (list tgc tcpu conses symbols others)))
;;;
;;; (when *debugging* (print-generator-lookup-summary lex-items grules))
;;;
;;; (let ((rel-indexes nil) (rel-indexes-n -1) (input-rels 0))
;;; (dolist (lex lex-items)
;;; (loop
;;; with eps = (mrs::found-lex-main-rels lex)
;;; initially (setf (mrs::found-lex-main-rels lex) 0)
;;; for ep in eps
;;; for index = (ash 1 (or (getf rel-indexes ep)
;;; (setf (getf rel-indexes ep)
;;; (incf rel-indexes-n))))
;;; do
;;; (setf (mrs::found-lex-main-rels lex)
;;; (logior (mrs::found-lex-main-rels lex) index))))
;;; (dolist (grule grules)
;;; (when (mrs::found-rule-p grule)
;;; (loop
;;; with eps = (mrs::found-rule-main-rels grule)
;;; initially (setf (mrs::found-rule-main-rels grule) 0)
;;; for ep in eps
;;; for index = (ash 1 (or (getf rel-indexes ep)
;;; (setf (getf rel-indexes ep)
;;; (incf rel-indexes-n))))
;;; do
;;; (setf (mrs::found-rule-main-rels grule)
;;; (logior (mrs::found-rule-main-rels grule) index)))))
;;; (setf %generator-unknown-eps% nil)
;;; (loop
;;; for ep in (mrs::psoa-liszt input-sem)
;;; do
;;; (if (getf rel-indexes ep)
;;; (setq input-rels
;;; (logior input-rels (ash 1 (getf rel-indexes ep))))
;;; (push ep %generator-unknown-eps%)))
;;; (when %generator-unknown-eps%
;;; (error 'unknown-predicates :eps %generator-unknown-eps%))
;;;
;;; #+:debug
;;; (setf %rel-indexes rel-indexes %input-rels input-rels)
;;;
;;; (chart-generate
;;; input-sem input-rels lex-items grules lex-orderings rel-indexes
;;; *gen-first-only-p* :nanalyses nanalyses)))))
;;; end temporary hacks
#+:tsdb
(in-package :tsdb)
;;; process.lisp
(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))))
;;; pvm.lisp
(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
(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)
)
(: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))
;;; www.lisp
(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") 0)
(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::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* "~%")
(mrs::output-mrs1
(or mrs (mrs::extract-mrs edge))
'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*)))))))))))