(pushnew :logon *features*)
(defun gen-chart-check-compatible (edge)
;; construct the MRS for edge
;; We test for 'compatibility' rather than equality - in
;; particular, semantics of generated string might be more specific than
;; input MRS wrt things like scope.
(or (and *bypass-equality-check* (not (eq *bypass-equality-check* :filter)))
;;
;; at this point, we will try do confirm that the candidate realization
;; has a semantics compatible to our input. in order for the comparison
;; to take advantage of the grammar-internal type hierarchy, we actually
;; compare internal MRSs. still, to get default values (and `purity' and
;; such), go through the SEM-I VPM twice: extract-mrs() does the forward
;; mapping by default, so to return to internal values, run backwards one
;; more time. (4-jul-06; oe)
;;
(let* ((input *generator-internal-mrs*)
(mrs (let ((mrs:*lnkp* :id)) (mrs::extract-mrs edge))))
(setf (edge-mrs edge) mrs)
;;
;; see the comment on extract-string-from-g-edge() for our rationale in
;; determining the surface string for this .edge. just here. the side
;; effect on the `lnk' value in EPs is destructive. unfortunately, EPs
;; get copied in equate-all-qeqs(), and those copies will end up in the
;; solution returned by compare-mrss(). hence, we need to make sure to
;; destructively set LNK values early enough. (16-jul-08; oe)
;;
(extract-string-from-g-edge edge)
(let* ((imrs (mt:map-mrs mrs :semi :backward))
(imrs (if *gen-equate-qeqs-p* (mrs::equate-all-qeqs imrs) imrs))
#+:logon
(roles (list (mrs::vsym "TPC") (mrs::vsym "PSV")))
;;
;; in a few cases, the input is over-specified, e.g. using an
;; `i' variable for an unbound subject in infinitivals.
;;
#+:logon
(types '(("i" "u")))
(solution (mt::compare-mrss imrs input :type :subsumption))
(solution (if solution
(if *mrs-icons-strict-check-p*
(if
(mrs::mrs-equalp imrs input nil nil t t)
solution)
solution)))
(distance
;;
;; _fix_me_
;; the following is, say, incredibly naive: rather than trying
;; ten or so times, the comparison should be able to carry on
;; when detecting a problem (that can be remedied according to
;; one of the known ways of relaxation) and return a suitable
;; code indicating which exception(s) had to be made.
;; (30-may-06; oe)
(or (when solution 0)
#+:logon
(when (eq *bypass-equality-check* :filter)
(or
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles))
1)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:types types))
2)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:properties t))
3)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles :types types))
4)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles :properties t))
5)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles :properties t :types types))
6)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:hcons t))
7)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles :hcons t))
8)
(when (setf solution
(mt::compare-mrss
imrs input :type :subsumption
:roles roles :properties t :hcons t))
9)
42)))))
(when solution
(let* ((eps (mt::solution-eps solution))
(distortion
(ignore-errors (mrs::compute-lnk-distortion eps))))
(push (cons :distortion distortion) (edge-flags edge))))
(values (and (numberp distance) (= distance 0)) distance)))))
;; ;;; Web demo
;; #+: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*)))))))))))