#+:tsdb
(in-package :tsdb)
#+:tsdb
(defparameter *feature-preference-weightings*
'((0 :binary) ))
;;;;;; Patches to disable bold fonts in the LKB since they do not display
;;;;;; hooked letters correctly
;;;
; (in-package :lkb)
; (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))
; ;;
; ;; as of late in 2006, progress on the SMAF front required dan to change all
; ;; `ersatz' entries (as they are currently identified by sub-string match on
; ;; their orthography :-{) to be [ CARG *top* ]. while recorded derivations
; ;; in [incr tsdb()] do not preserve the actual surface form, reconstructing
; ;; derivations and reading off MRSs results in ill-formed EPs, viz. ones with
; ;; an underdetermined CARG. to at least allow re-generation from such MRSs,
; ;; attempt to frob our input MRS as needed. (23-dec-06; oe)
; ;;
; #+:logon
; (loop
; with carg = (mrs:vsym "CARG")
; for ep in (mrs:psoa-liszt input-sem)
; for pred = (mrs:rel-pred ep)
; for constant
; = (cond
; ((string-equal pred "yofc_rel") "DecimalErsatz")
; ((string-equal pred "card_rel") "DecimalErsatz")
; ((string-equal pred "ord_rel") "DecimalErsatz")
; ((string-equal pred "dofw_rel") "DateErsatz")
; ((string-equal pred "dofm_rel") "DateErsatz")
; ((string-equal pred "gen_numval_rel") "DecadeErsatz")
; ((string-equal pred "numbered_hour_rel") "HourErsatz")
; ((string-equal pred "named_rel") "NameErsatz")
; (t "CARG"))
; for parameterizedp = (consp (gethash pred mrs::*relation-index*))
; do
; (loop
; for role in (mrs:rel-flist ep)
; for value = (mrs:fvpair-value role)
; when (eq (mrs:fvpair-feature role) carg) do
; (when (or (eq value *toptype*) (eq value *string-type*))
; (setf (mrs:fvpair-value role) constant))
; (setf parameterizedp nil)
; finally
; (when parameterizedp
; (push
; (mrs::make-fvpair :feature carg :value constant)
; (mrs:rel-flist ep)))))
; (let ((fixup (mt::transfer-mrs input-sem :filter nil :task :generate)))
; (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)))))
; (in-package :lkb)
; (defun draw-chart-window (window stream &key max-width max-height)
; (declare (ignore max-width max-height))
; (let ((*chart-edges* nil))
; (declare (special *chart-edges*))
; ;; Don't bother if there's no chart
; (unless (null (get (chart-window-root window) 'chart-edge-descendents))
; (clim:format-graph-from-root
; (chart-window-root window)
; #'(lambda (node stream)
; (multiple-value-bind (s bold-p)
; (chart-node-text-string node)
; (clim:with-text-face (stream
; ; (if bold-p :bold :roman)
; )
; (let ((cont (get node 'chart-edge-contents)))
; (if cont
; (progn
; (push cont *chart-edges*)
; (clim:with-output-as-presentation
; (stream cont 'edge)
; (write-string s stream)))
; (clim:with-output-as-presentation
; (stream (symbol-name node) 'word)
; (write-string s stream)))))))
; #'(lambda (node)
; (get node 'chart-edge-descendents))
; ;; This trickery is to avoid drawing the connections from the dummy
; ;; root node to the lexical edges
; :arc-drawer #'(lambda (stream from to x1 y1 x2 y2 &rest args)
; (when (or (not (symbolp to))
; (not (get from 'root)))
; (apply #'clim-internals::draw-linear-arc
; (append (list stream from to x1 y1 x2 y2)
; args))))
; :stream stream
; :graph-type :dag
; :merge-duplicates t
; :orientation :horizontal
; :maximize-generations t
; :generation-separation *tree-level-sep*
; :within-generation-separation *tree-node-sep*
; :center-nodes nil)
; (setf (chart-window-edges window) *chart-edges*))))
; (defun display-basic-fs-really (fs title parents paths id)
; (let ((fs-window
; (clim:make-application-frame 'active-fs-window)))
; (setf (active-fs-window-fs fs-window)
; (make-fs-display-record :fs fs :title title :paths paths
; :parents parents
; :type-fs-display *type-fs-display*
; :id id))
; (setf (clim:frame-pretty-name fs-window) title)
; ;; Initialize fonts
; (setf *normal* (clim:parse-text-style (list :sans-serif :roman *fs-type-font-size*)))
; (setf *bold* (clim:parse-text-style (list :sans-serif :roman *fs-type-font-size*)))
; ; (clim:merge-text-styles '(nil :bold nil) *normal*))
; ;; Set up path display
; (let ((path-pane
; (find :path (clim:frame-current-panes fs-window)
; :test #'eq :key #'clim:pane-name)))
; (setf (lkb-window-doc-pane fs-window) path-pane)
; #+:allegro
; (clim:change-space-requirements
; path-pane
; :resize-frame t
; :height (clim:text-style-height *normal* path-pane)
; :max-height (clim:text-style-height *normal* path-pane)))
; ; Run it
; (clim:run-frame-top-level fs-window)))
; (defun draw-parse-tree (ptree-frame stream &key max-width max-height)
; (declare (ignore max-width max-height))
; (let ((node-tree (parse-tree-nodes ptree-frame)))
; (clim:with-text-style (stream (lkb-parse-tree-font))
; (clim:format-graph-from-root
; node-tree
; #'(lambda (node stream)
; (multiple-value-bind (s bold-p)
; (get-string-for-edge node)
; (clim:with-text-face (stream
; ;(if bold-p :bold :roman)
; )
; (if (get node 'edge-record)
; (clim:with-output-as-presentation (stream node 'symbol)
; (write-string s stream))
; (write-string s stream)))))
; #'find-children
; :graph-type :parse-tree
; :stream stream
; :merge-duplicates nil
; :orientation :vertical
; :generation-separation *ptree-level-sep*
; :within-generation-separation *ptree-node-sep*
; :center-nodes nil))))
; (defun draw-res-trees-window (window stream &key max-width max-height)
; (declare (ignore max-width max-height))
; (dolist (tree (parse-tree-frame-trees window))
; (setf (prtree-output-record tree)
; (clim:with-text-style (stream (lkb-summary-tree-font))
; (clim:with-new-output-record (stream)
; (clim:with-output-recording-options (stream :record t)
; (clim:with-output-as-presentation
; (stream tree 'prtree :single-box t)
; (clim:format-graph-from-root
; (prtree-top tree)
; #'(lambda (node stream)
; (multiple-value-bind (s bold-p)
; (get-string-for-edge node)
; (clim:with-text-face (stream
; ;(if bold-p :bold :roman)
; )
; (write-string s stream))))
; #'find-children
; :graph-type :parse-tree
; :stream stream
; :merge-duplicates nil
; :orientation :vertical
; :generation-separation 5
; :move-cursor t
; :within-generation-separation 5
; :center-nodes nil)))
; (terpri stream))))))
; (defun draw-trees-window (frame stream &rest rest)
; (declare (ignore rest))
; ;;
; ;; in case we were displaying the window with an uninitialized frame
; ;;
; (when (null (compare-frame-edges frame))
; (return-from draw-trees-window))
; (setf (compare-frame-tstream frame) stream)
; (unless (and (integerp *tree-display-threshold*)
; (eq (compare-frame-view frame) :classic)
; (> (length (compare-frame-trees frame))
; *tree-display-threshold*))
; (clim:formatting-table (stream :x-spacing "X")
; (loop
; for tree in (compare-frame-trees frame)
; do
; (setf (ctree-ink tree) clim:+foreground-ink+)
; (setf (ctree-record tree)
; (clim:with-new-output-record (stream)
; (clim:with-text-style (stream (comparison-tree-font))
; (clim:with-output-recording-options (stream :record t)
; (clim:formatting-row (stream)
; (clim:formatting-cell
; (stream :align-x :center :align-y :top)
; (clim:with-text-style
; (stream
; (clim:parse-text-style '(:sans-serif :roman 12)))
; (format stream "~%[~a]" (ctree-id tree))))
; (clim:formatting-cell
; (stream :align-x :left :align-y :center)
; (clim:formatting-row (stream)
; (clim:formatting-cell
; (stream :align-x :left :align-y :top)
; (format stream "~@[(~a)~]~%" (ctree-score tree)))
; (clim:formatting-cell
; (stream :align-x :center :align-y :top)
; (clim:with-output-as-presentation
; (stream tree 'ctree :single-box t)
; (if (eq (compare-frame-view frame) :classic)
; (clim:format-graph-from-root
; (or (ctree-symbol tree)
; (setf (ctree-symbol tree)
; (make-new-parse-tree
; (ctree-edge tree) 1)))
; #'(lambda (node stream)
; (multiple-value-bind (s bold-p)
; (get-string-for-edge node)
; (clim:with-text-face
; (stream
; ;(if bold-p :bold :roman)
; )
; (write-string s stream))))
; #'(lambda (node) (get node 'daughters))
; :graph-type :parse-tree
; :stream stream
; :merge-duplicates nil
; :orientation :vertical
; :generation-separation 7
; :move-cursor t
; :within-generation-separation 7
; :center-nodes nil)
; (let ((mrs (edge-mrs (ctree-edge tree))))
; (when mrs
; (mrs::ed-output-psoa
; mrs :stream stream))))))))
; (terpri stream)))))))
; (when (and (compare-frame-trees frame)
; (null (rest (compare-frame-trees frame))))
; (draw-trees-window-completion frame stream)))
; (update-tree-colours frame)))
; (defun draw-trees-window-completion (frame stream)
; (let* ((hook *tree-completion-hook*)
; (hook (typecase hook
; (null nil)
; (function hook)
; (symbol (and (fboundp hook) (symbol-function hook)))
; (string (ignore-errors
; (symbol-function (read-from-string hook))))))
; (tree (first (compare-frame-trees frame)))
; (edge (ctree-edge tree))
; (mrs (or (edge-mrs edge)
; (ignore-errors (mrs::extract-mrs edge))))
; (eds (when mrs (ignore-errors (mrs::ed-convert-psoa mrs)))))
; (multiple-value-bind (result condition)
; (when (functionp hook) (ignore-errors (funcall hook edge mrs)))
; (when condition
; (clim:beep)
; (format
; #+:allegro excl:*initial-terminal-io* #-:allegro *terminal-io*
; "tree-completion-hook(): error `~a'.~%"
; (normalize-string (format nil "~a" condition))))
; (let* ((comment (if (stringp result)
; result
; (rest (assoc :comment result))))
; (result (unless (stringp result) result))
; (font (rest (assoc :font result)))
; (face (rest (assoc :face result)))
; (size (rest (assoc :size result)))
; (style (when (or font face size)
; (clim:merge-text-styles
; (list font face size) '(:sans-serif :bold 12))))
; (color (rest (assoc :color result)))
; (color (ignore-errors (apply #'clim:make-rgb-color color)))
; (bottomp (rest (assoc :bottom result)))
; (align (or (rest (assoc :align result)) :center)))
; (when (and comment (null bottomp))
; (clim:formatting-row (stream)
; (clim:formatting-cell (stream :align-x :center :align-y :top)
; (format stream " ")))
; (let ((record
; (clim:with-new-output-record (stream)
; (clim:formatting-row (stream)
; (clim:formatting-cell
; (stream :align-x :center :align-y :top)
; (format stream "" (ctree-id tree)))
; (clim:formatting-cell (stream :align-x align)
; (clim:with-text-style (stream style)
; (format stream "~%~a" comment)))))))
; (when color (recolor-record record color))
; (clim:replay record stream)))
; (when (and eds (not (eq (compare-frame-view frame) :modern)))
; (clim:formatting-row (stream)
; (clim:formatting-cell (stream :align-x :center :align-y :top)
; (format stream " ")))
; (let ((record
; (clim:with-new-output-record (stream)
; (clim:formatting-row (stream)
; (clim:formatting-cell
; (stream :align-x :center :align-y :top)
; (clim:with-text-style
; (stream
; (clim:parse-text-style '(:sans-serif :roman 12)))
; (format stream "[~a]" (ctree-id tree))))
; (clim:formatting-cell (stream :align-x :left)
; (clim:formatting-column (stream)
; (clim:formatting-cell (stream :align-x :left)
; (format stream "~@[(~a)~]~%" (ctree-score tree)))
; (clim:formatting-cell (stream :align-x :center)
; (clim:with-text-style
; (stream (comparison-dependencies-font))
; (format stream "~a" eds)))))))))
; (recolor-record
; record
; (let ((status (mrs::ed-suspicious-p eds))
; (orange (or (clim:find-named-color
; "orange" (clim:frame-palette frame)
; :errorp nil)
; clim:+yellow+)))
; (cond
; ((member :cyclic status) clim:+red+)
; ((member :fragmented status) orange)
; (t (if (update-match-p frame) clim:+magenta+ clim:+blue+)))))
; (clim:replay record stream)))
; (when (and comment bottomp)
; (clim:formatting-row (stream)
; (clim:formatting-cell (stream :align-x :center :align-y :top)
; (format stream " ")))
; (let ((record
; (clim:with-new-output-record (stream)
; (clim:formatting-row (stream)
; (clim:formatting-cell
; (stream :align-x :center :align-y :top)
; (format stream "" (ctree-id tree)))
; (clim:formatting-cell (stream :align-x align)
; (clim:with-text-style (stream style)
; (format stream "~%~a" comment)))))))
; (when color (recolor-record record color))
; (clim:replay record stream)))))))
; (defun add-mrs-pred-region (stream val)
; (let ((pred-rec
; (make-mrs-type-thing :value val)))
; (clim:with-text-style (stream (clim:parse-text-style
; (make-active-fs-type-font-spec)))
; (clim:with-output-as-presentation
; (stream pred-rec 'mrs-type-thing)
; (if (stringp val)
; (format stream "~s" val)
; (format stream "~(~a~)" val))))))
; (defun show-mrs-window-really (edge &optional mrs title)
; (let ((mframe (clim:make-application-frame 'mrs-simple)))
; (setf *normal* (clim:parse-text-style (make-active-fs-type-font-spec)))
; (setf *bold* (clim:merge-text-styles '(nil :roman nil) *normal*))
; (setf (mrs-simple-mrsstruct mframe)
; (or mrs (and edge (mrs::extract-mrs edge))))
; (setf (clim:frame-pretty-name mframe) (or title "Simple MRS"))
; (clim:run-frame-top-level mframe)))
; (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))
; ;;
; ;; as of late in 2006, progress on the SMAF front required dan to change all
; ;; `ersatz' entries (as they are currently identified by sub-string match on
; ;; their orthography :-{) to be [ CARG *top* ]. while recorded derivations
; ;; in [incr tsdb()] do not preserve the actual surface form, reconstructing
; ;; derivations and reading off MRSs results in ill-formed EPs, viz. ones with
; ;; an underdetermined CARG. to at least allow re-generation from such MRSs,
; ;; attempt to frob our input MRS as needed. (23-dec-06; oe)
; ;;
; #+:logon
; (loop
; with carg = (mrs:vsym "CARG")
; for ep in (mrs:psoa-liszt input-sem)
; for pred = (mrs:rel-pred ep)
; for constant
; = (cond
; ((string-equal pred "yofc_rel") "DecimalErsatz")
; ((string-equal pred "card_rel") "DecimalErsatz")
; ((string-equal pred "ord_rel") "DecimalErsatz")
; ((string-equal pred "dofw_rel") "DateErsatz")
; ((string-equal pred "dofm_rel") "DateErsatz")
; ((string-equal pred "gen_numval_rel") "DecadeErsatz")
; ((string-equal pred "numbered_hour_rel") "HourErsatz")
; ((string-equal pred "named_rel") "NameErsatz")
; (t "CARG"))
; for parameterizedp = (consp (gethash pred mrs::*relation-index*))
; do
; (loop
; for role in (mrs:rel-flist ep)
; for value = (mrs:fvpair-value role)
; when (eq (mrs:fvpair-feature role) carg) do
; (when (or (eq value *toptype*) (eq value *string-type*))
; (setf (mrs:fvpair-value role) constant))
; (setf parameterizedp nil)
; finally
; (when parameterizedp
; (push
; (mrs::make-fvpair :feature carg :value constant)
; (mrs:rel-flist ep)))))
; ; #+:null
; ;;; Enable pre-geration MRS fixup.
; (let ((fixup (mt::transfer-mrs input-sem :filter nil :task :generate)))
; (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)))))
#+: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*)))))))))))