;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10; Readtable: augmented-readtable -*- ;;;; XLE-Web users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; Author: Paul Meurer (paul.meurer@aksis.uib.no) and Helge Dyvik (helge.dyvik@lili.uib.no) ;;;; Aksis, Unifob, University of Bergen, Norway ;;;; http://www.aksis.uib.no ;; Using graph-id in hidden field makes sure that no two sessions accidentally access the same graph. (in-package :XLE) #+test (net.aserve::shutdown) #+test (net.aserve::start :port 8060) #+test (net.aserve::debug-on :notrap) #+test (net.aserve::debug-on :xmit) #+test (net.aserve::debug-off :notrap) #+test (net.aserve::debug-off :xmit) (defmethod mrs-xml ((request http-request) entity) (with-xml-response (request entity stream (grammar sentence xle-graph-id show-features next-solution same-solution previous-solution m-projection disable-OT ranking cg-preparse-on-fragment-analysis cg-preparse disjunction-choice packed admin unload-grammar) :force-xslt :sablotron :xsl #'mrs-xsl) #+debug(print (cons :mrs-xml (request-query request))) (let* ((grammar (utf-8-decode grammar)) (user-id (get-basic-authorization request)) (*grammar* (find-grammar grammar :owner user-id))) #+debug(print (list :grammar grammar *grammar*)) (when (and *grammar* unload-grammar) (unload-grammar *grammar*)) (if *grammar* (let* ((sentence (print (if sentence (string-trim '(#\Space #\Tab #\Linefeed #\Newline) (utf-8-decode sentence)) (default-sentence *grammar*)))) ;;(graph-table (graph-table *grammar*)) (xle-graph-id (or (parse-integer xle-graph-id :junk-allowed t) (incf *graph-id*))) ;;(graph.sentence (gethash xle-graph-id graph-table)) ;;(previous-graph (car graph.sentence)) (graph #+old(get-graph sentence xle-graph-id next-solution same-solution previous-solution disable-OT cg-preparse-on-fragment-analysis cg-preparse disjunction-choice) (get-graph *grammar* :sentence sentence :xle-graph-id xle-graph-id :next-solution next-solution :same-solution same-solution :previous-solution previous-solution :disable-OT disable-OT :cg-preparse-on-fragment-analysis cg-preparse-on-fragment-analysis :cg-preparse cg-preparse :disjunction-choice disjunction-choice :error-on-fatal-grammar-error-p nil :ranking-p t)) (*print-extras-p* (if show-features t nil)) (*seen-nodes* ())) #+debug(print (list :graph graph :dc disjunction-choice :packed packed :same same-solution)) (unwind-protect (cond (graph #+debug(describe graph) (let ((disjunction-choice (when disjunction-choice (parse-integer disjunction-choice) #+ignore(intern (string-upcase disjunction-choice) :xle)))) #+debug(print (list :same-solution same-solution :previous-p previous-solution)) (multiple-value-bind (var-array c-structure mrs count pos) (if t;packed (cond ((and same-solution (solution-nr graph)) (get-current-packed-solution graph)) (t #+ignore (when (and (not packed) (null (solution-nr graph))) (setf (solution-nr graph) -1)) (get-packed-solution graph :valid-only-p nil :build-c-structure-p t :build-f-structure-p t :disjunction-choice disjunction-choice :get-mrs-p t :previous-p previous-solution :next-p next-solution :ranking-p ranking))) (cond (same-solution (get-current-solution graph)) (t (get-solution graph :valid-only-p nil :max-solutions nil :prefetch-p t :build-c-structure-p t :build-f-structure-p t :previous-p previous-solution :next-p next-solution)))) (declare (ignore var-array c-structure)) #+debug(print (list :var-array var-array :c-structure c-structure)) #+debug(setf *mrs* mrs) #m(?xml-stylesheet :type "text/xsl" :href #s(concat "/" *url-base* "/xle-mrs.xsl")) #m((parse :grammar #s (name *grammar*) :sentence #S sentence :admin #s admin :owner #s (owner *grammar*) :lang #s (language *grammar*) :user #s user-id :xle-graph-id #L xle-graph-id :count #S count :unoptimal-count #S (unless nil ;;disable-OT (- (unoptimal-solutions-count graph) (restricted-solutions-count graph))) :pos #L pos :m-projection #L m-projection :show-features #s(if *print-extras-p* "true") :disable-OT #s(when disable-OT "true") :packed #s(when packed "true") :ranking #s ranking :cg-preparse-on-fragment-analysis #s cg-preparse-on-fragment-analysis :cg-preparse #s cg-preparse) (grammars #L(dolist (grammar.obj (grammar-list)) (destructuring-bind (grammar . obj) grammar.obj #m((grammar :short-name #s grammar :name #s (name obj) :owner #s (owner obj)))))) #+old (grammars #L(maphash (lambda (grammar obj) #m((grammar :name #s grammar :owner #s(owner obj)))) *grammars*)) #+cg-morphology #L(multiple-value-bind (regexp sentence-list) (norgram-tokenize-sentence sentence :preparse-p cg-preparse) (declare (ignore regexp)) (sentence-morphology-xml sentence-list (dat::make-string-tree) stream)) #s mrs)))) (t (print :no-graph))) (when (and graph (parser graph)) (setf (parser-active-p (parser graph)) nil)))) (error "No grammar defined."))))) (defun print-compstate-fields (compstate) (mapc (lambda (accessor-list) (print (cons (car accessor-list) (ff:fslot-value-typed 'DUCompState nil compstate (car accessor-list))))) '((max-heap :int) ;; HEAPptr *heaps ; /* array of fsm heap pointers */ (heaps :unsigned-long) ;; int graph_ct ; /* number of graphs allocated */ (graph-ct :int) ;; DUProp *props ; /* user defined properties ; (see graph.h for definition of DUProp) */ (props :unsigned-long) ;; Grammar *grammar ; /* the grammar being used */ (grammar :unsigned-long) ;; struct Chart *chart ; /* the chart being used */ (chart :unsigned-long) ;; unsigned int completing ; /* we have started to look for incomplete ; nogoods, and may generate some not ;clauses. */ (completing :unsigned-int) ;; unsigned int gen_goal_predicting ; /* this bit is set when the generator ; predicts new goal values, to prevent ; an optimization in the FU code */ (gen-goal-predicting :unsigned-int) ;; AVPair *goal_filter ; /* used by filter_constraint */ (goal-filter :unsigned-long) ;; AVPair *path_avpair ; /* used for instantiating off-path constraints. */ (path-avpair :unsigned-long) ;; void *path_arc ; /* used for determining which off-path attributes should ; be nonconstructive. */ (path-arc :unsigned-long) ;; unsigned int solving ; /* we have started to solve the nogood database. */ (solving :unsigned-int) ;; unsigned int prune ; /* whether or not clauses should be pruned. */ (prune :unsigned-int) ;; unsigned int debugging ; /* We are debugging. */ (debugging :unsigned-int) ;; unsigned int total_events ; /* Total events processed. */ (total-events :unsigned-int) ;; unsigned shared_gensyms ; /* whether typed values that are equivalent */ ; /* should get the same gensym in overlapping */ ; /* contexts. This is used by check_disjuncts. */ (shared-gensyms :unsigned-int) ;; ?? ;; AVPair **attr_index ; /* This is an index of constraints by the attributes ; that they are stored on. It is used by the global ; completeness code. */ (attr-index :unsigned-long) ;; int attr_index_size ; /* The attr_index size. */ (attr-index-size :int) ;; AttrID *local_attr ; /* An array of local attributes. */ (local-attr :unsigned-long) ;; char **inverse_cat ; /* This is an array of categories that need to be ; added as REL_CAT_INVERSE. */ (inverse-cat :unsigned-long) ;; int next_inverse_cat ; /* The inverse_cat size. */ (next-inverse-cat :int) ;; ArgList *arglists ; /* Array of arglists encountered so far. */ (arglists :unsigned-long) ;; int arglists_size ; /* Size of the arglist array. */ (arglists-size :int) ;; int next_arglist ; /* The index of the next arglist available. */ (next-arglist :int) ;; int filler_counts_invalid ; /* We can't filter analyses based on filler ; counts because there was an unlicenced ; distribution encountered. */ (filler-counts-invalid :int) ;; /* ----------------------------------------------------------------- */ ;; /* Optimality Theory information is cached on the DUCompState rather */ ;; /* than the grammar so that it can vary between the parser and */ ;; /* the generator. */ ;; /* ----------------------------------------------------------------- */ ;; int num_OT_ranks ; /* The number of OT ranks stored in OT_rank */ (num-OT-ranks :int) ;; SExp **OT_rank ; ;; /* Array of lists of OT marks sorted by rank */ (OT-rank :unsigned-long) ;; HASH_TABLEptr OT_hash ; /* Hash from name to OTMark */ (OT-hash :unsigned-long) ;; HASH_TABLEptr edge_span_hash ; /* Used for local optimality marks */ (edge-span-hash :unsigned-long) ;; int neutral_OT_mark ; /* The position of the NEUTRAL OT mark. */ (neutral-OT-mark :int) ;; int nogood_OT_mark ; /* The position of the NOGOOD OT mark. */ (nogood-OT-mark :int) ;; int cstructure_OT_mark ; /* The position of the CSTRUCTURE OT mark. */ (cstructure-OT-mark :int) ;; int ungrammatical_OT_mark ; /* The position of the UNGRAMMATICAL OT mark. */ (ungrammatical-OT-mark :int) ;; int inconsistent_OT_mark ; /* The position of the INCONSISTENT OT mark. */ (inconsistent-OT-mark :int) ;; int incomplete_OT_mark ; /* The position of the INCOMPLETE OT mark. */ (incomplete-OT-mark :int) ;; int incoherent_OT_mark ; /* The position of the INCOHERENT OT mark. */ (incoherent-OT-mark :int) ;; int local_OT_mark ; /* whether there are any local OT marks. */ (local-OT-mark :int) ;; int fragment_OT_mark_override ; /* temporary position of Fragment mark */ ; /* (used by the fragment guide) */ (fragment-OT-mark-override :int) ;; int disable_OT ; /* Disable Optimality Theory. */ (disable-OT :int) ;; int OT_stop_point[MAX_STOP_POINT_SIZE] ; /* intermediate stopping points. */ (OT-stop-point (:array :int #.+MAX_STOP_POINT_SIZE+)) ;; int OT_stop_point_size ; /* the number of elements in the array above. */ (OT-stop-point-size :int) ;; int current_stop_point ; /* The mark that we are processing down to. */ (current-stop-point :int) ;; OTMark *OT_overrides ; /* User overrides for optimality marks. */ (OT-overrides :unsigned-long) ;; ?? ;; char *fieldlockfile[LAST_FIELD_NAME] ; /* file where field name locked. */ (fieldlockfile :unsigned-long) ;; ?? ;; int fieldlockline[LAST_FIELD_NAME] ; /* line where field name locked. */ (fieldlockline :int) ;; int queues ; /* number of graphs with non-empty queues. */ (queues :int) ;; int discharged_queue ; /* whether a queue got discharged. */ (discharged-queue :int) ;; HASH_TABLEptr constraint_hash ; /* Hash from SExp to data. */ (constraint-hash :unsigned-long) ;; HASH_TABLEptr attribute_hash ; /* Hash from strings to AttrID. */ (attribute-hash :unsigned-long) ;; int has_complex_sisters ; /* The chart has complex sisters (e.g */ ; /* (* RIGHT_SISTER RIGHT_SISTER). */ (has-complex-sisters :int) ;; int abbrev_contains_pred ; /* abbreviation attributes that contain preds. */ (abbrev-contains-pred :int) ))) (defmethod print-object-xml ((obj mrs::psoa) stream &key (rel-partition-size 6) &allow-other-keys) (let ((*package* (find-package mrs::*mrs-package*))) #m(psoa ((fvpair :feature "TOP") #s(mrs::psoa-top-h obj)) ((fvpair :feature "INDEX") #s(mrs::psoa-index obj)) ((fvpair :feature "RELS") (liszt #L(if rel-partition-size (let* ((liszt (mrs::psoa-liszt obj)) (length (length liszt)) (spread-p nil) (balance-p nil) (row -1)) (multiple-value-bind (rows rem) (floor length rel-partition-size) (cond ((and (< rem (- rel-partition-size 2)) (< rem rows)) (setf spread-p t)) ((< rem (/ rel-partition-size 2)) (setf balance-p t))) #+ignore (print (list :spread-p spread-p :balance-p balance-p :rem rem)) (loop while liszt do #m(rel-partition #L(progn (incf row) (dotimes (i (+ rel-partition-size (cond (spread-p (if (< (decf rem) 0) 0 1)) (balance-p (if (= row (- rows 1)) (- (ceiling rem 2)) 0)) (t 0)))) (let ((rel (pop liszt))) (when rel #m#s rel)))))))) (dolist (rel (mrs::psoa-liszt obj)) #m#s rel)))) ((fvpair :feature "HCONS") (h-cons #L(let (#+ignore(*package* (find-package :mrs))) (dolist (h-cons (mrs::psoa-h-cons obj)) #m#s h-cons))))))) (defmethod print-object-xml ((obj mrs::hcons) stream &key &allow-other-keys) (let ((*package* (find-package mrs::*mrs-package*))) #m((handle-var :relation #L(mrs::hcons-relation obj)) (scarg #s(mrs::hcons-scarg obj)) (outscpd #s(mrs::hcons-outscpd obj))))) (defmethod print-object-xml ((obj mrs::rel) stream &key &allow-other-keys) (let* ((*package* (find-package mrs::*mrs-package*)) (pred (mrs::rel-pred obj))) (when (not (stringp pred)) (warn "invalid pred: ~s" pred) (setf pred (format nil "~s" pred))) #+debug(print (list :pred (mrs::rel-pred obj) :flist (mrs::rel-flist obj) :extra (mrs::rel-extra obj))) #m((rel :pred #s pred :lnk #s(mrs::output-lnk (mrs::rel-lnk obj) :stream nil)) #s(mrs::rel-handel obj) #L(when (mrs::rel-flist obj) #m(extra #L(dolist (fvpair (mrs::rel-flist obj)) #m#s fvpair))) #L(when (mrs::rel-extra obj) #m(extra #L(dolist (extrapair (mrs::rel-extra obj)) #m#s extrapair)))))) (defmethod print-object-xml ((obj mrs::var) stream &key (print-extras-p *print-extras-p*) &allow-other-keys) (let ((*package* (find-package mrs::*mrs-package*))) #m((handle-var :id #L(mrs::var-id obj) :name #L(mrs::var-string obj) :type #L(mrs::var-type obj)) #L(when (and print-extras-p (not (find obj *seen-nodes*)) (mrs::var-extra obj)) (push obj *seen-nodes*) #m(extra #L(dolist (extrapair (mrs::var-extra obj)) #m#s extrapair)))))) (defmethod print-object-xml ((obj mrs::extrapair) stream &key &allow-other-keys) (let ((*package* (find-package mrs::*mrs-package*))) #m((extrapair :feature #L(mrs::extrapair-feature obj)) #s(mrs::extrapair-value obj)))) (defmethod print-object-xml ((obj mrs::fvpair) stream &key &allow-other-keys) (let ((*package* (find-package mrs::*mrs-package*))) #m((fvpair :feature #L(mrs::fvpair-feature obj)) #L(let ((value (mrs::fvpair-value obj))) (cond ((not (consp value)) #m#s value) ((eq (car value) 'semform) #m#s(cadr value)) (t ;; normalized PP attachment #m(normalized-set #s(car value) #s(cadr value)))))))) (defstylesheet mrs-xsl () #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0") ((xsl:template :match "/parse") (html ((head) (title "MRS") ((style :type "text/css") (CSS-STYLE (div :margin "16" :color #-BW "#004499" #+BW "black" :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica") (div.title :font-size "18" :font-weight "bold" :text-align "center") (div.morph :margin-top "0" :margin-bottom "0") (p :color #-BW "#004499" #+BW "black" :font-size "12" :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica") (table :padding "2pt" :font-size "8pt" :border-collapse "collapse") (tr :font-family "Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica") #-BW (td.avp :border-left "1px gray solid" :border-right "1px gray solid") #+BW (td.avp :border-left "1px black solid" :border-right "1px black solid") (td.avp-focus :border "2px red solid") (td.fs :border-left "2px gray solid" :border-right "2px gray solid") (tr.dis-border :border "1px gray solid") (td.dis :color #-BW "green" #+BW "black" :cursor "pointer");; :vertical-align "top") (td.dis-chosen :color #-BW "red" #+BW "black" :font-weight "bold" :cursor "pointer");; :vertical-align "top") (td.attribute :color #-BW "#004499" #+BW "black" :font-weight "bold") (td.attribute-label :color "white" :background "blue" :font-weight "bold") (td.var :color #-BW "red" #+BW "black" :vertical-align "bottom" :font-size "8pt") (td.pred :color "black") (td.left-brace :font-size "18pt" :border-right "2px #dddddd solid") (td.right-brace :font-size "18pt" :border-left "2px #dddddd solid") (span.qeq :color #-BW "#004499" #+BW "black") (span.qeq-focus :color "white" :background "gray") (span.attribute :color #-BW "#004499" #+BW "black" :font-weight "bold") (span.handle :color "black") (span.handle-label :color "white" :background "blue") (span.harg :color "white" :background "red") (span.larg :color "white" :background "blue") (span.handle-arg :color "white" :background "red") (span.pointer :color #-BW "red" #+BW "black") (span.pointer-focus :background "red" :color "white") (a :text-decoration "none" :color "black") (span.morph :color "black") )) ((SCRIPT :type "text/javascript" :language "javascript") (!CDATA #L(js/xle stream)))) ((body :onload "document.form.sentence.focus()") (table (tr (td ((div :class "title") "XLE-MRS") ((form :method "post" :id "form") ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "xle-graph-id") ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "packed") ((xsl:attribute :name "value") (xsl:value-of/ :select "@packed"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "disjunction-choice") ((xsl:attribute :name "id") "disjunction-choice") ((xsl:attribute :name "value") (xsl:value-of/ :select "@disjunction-choice"))) ;;(p "Write a Norwegian sentence (bokmål), ending it with punctuation (. ? or !):") #L(parse-input-area stream :type :mrs) #-test ((xsl:if :test "packed-disjunction") ;;((div :class "title") "Disjunctions") (table (xsl:apply-templates/ :select "packed-disjunction"))) (br/) (xsl:choose ((xsl:when :test "@count = 0") (p "No solution was found.")) (xsl:otherwise (table (tr (td (xsl:choose ((xsl:when :test "@count = 1") "One solution " ((xsl:if :test "@unoptimal-count and @unoptimal-count>0") " (+ " (xsl:value-of/ :select "@unoptimal-count") " unoptimal solution(s)) ") " was found. ") (xsl:otherwise (xsl:value-of/ :select "@count") ((xsl:if :test "@unoptimal-count and @unoptimal-count>0") " (+ " (xsl:value-of/ :select "@unoptimal-count") " unoptimal)") " solutions were found. ")) ((xsl:if :test "@unoptimal-count and @unoptimal-count>0") (br/) "Only optimal solutions are shown.")) ((xsl:if :test "@count > 1") (td (input/ :style "font-size: 8pt" :type "submit" :name "previous-solution" :value "Previous") (input/ :style "font-size: 8pt" :type "submit" :name "next-solution" :value "Next"))))))) ) ((xsl:if :test "@count > 0") (table (tr ((xsl:if :test "@count > 1") (td "Solution " (xsl:value-of/ :select "1 + @pos") ": ")) (td ((form :method "post" :action #s(concat "/" *url-base* "/xle.xml")) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "xle-graph-id") ((xsl:attribute :name "value") (xsl:value-of/ :select "@xle-graph-id"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "grammar") ((xsl:attribute :name "value") (xsl:value-of/ :select "@grammar"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "disable-OT") ((xsl:attribute :name "value") (xsl:value-of/ :select "@disable-OT"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "packed") ((xsl:attribute :name "value") (xsl:value-of/ :select "@packed"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "cg-preparse") ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "cg-preparse-on-fragment-analysis") ((xsl:attribute :name "value") (xsl:value-of/ :select "@cg-preparse-on-fragment-analysis"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "m-projection") ;; used?? ((xsl:attribute :name "value") (xsl:value-of/ :select "@m-projection"))) (input/ :style "font-size: 8pt" :type "submit" :name "from-mrs" :value "Show C- and F-structure"))))) ((div :class "title") "MRS") (xsl:apply-templates/ :select "psoa") #+test ((xsl:if :test "packed-disjunction") ((div :class "title") "Disjunctions") (table (xsl:apply-templates/ :select "packed-disjunction"))) #+cg-morphology ((div :class "title") "Morphology") #+cg-morphology (xsl:apply-templates/ :select "sentence-morphology")))))))) ((xsl:template :match "grammar") ((xsl:if :test "not(@owner) or @owner = /parse/@user") ((xsl:element :name "option") ((xsl:attribute :name "value") (xsl:value-of/ :select "@name")) ((xsl:if :test "@name=/parse/@grammar") ((xsl:attribute :name "selected") "true")) (xsl:value-of/ :select "@short-name")))) ((xsl:template :match "packed-disjunction") ((xsl:element :name "tr") ((xsl:attribute :name "class") (xsl:choose ((xsl:when :test "../../packed-disjunction|../../packed-conjunction") "dis-border") (xsl:otherwise "dis"))) ((xsl:element :name "td") ((xsl:attribute :name "class") (xsl:choose ((xsl:when :test "@chosen='yes'") "dis-chosen") (xsl:otherwise "dis"))) ((xsl:attribute :name "onclick") "chooseDisjunction('" (xsl:value-of/ :select "@node-id") "')") ;;(xsl:value-of/ :select "@summand") ":" (xsl:value-of/ :select "@name") ;;":" (xsl:value-of/ :select "@node-id") ) ((xsl:element :name "td") (table (xsl:apply-templates/))))) ((xsl:template :match "packed-conjunction") ((xsl:element :name "tr") ((xsl:attribute :name "class") (xsl:choose ((xsl:when :test "../../packed-disjunction|../../packed-conjunction") "dis-border") (xsl:otherwise "dis"))) (td "&") #+ignore ((xsl:element :name "td") ((xsl:attribute :name "class") (xsl:choose ((xsl:when :test "@chosen='yes'") "dis-chosen") (xsl:otherwise "dis"))) ((xsl:attribute :name "onclick") "chooseDisjunction('" (xsl:value-of/ :select "@id") "')") (xsl:value-of/ :select "@id")) ((xsl:element :name "td") (table (xsl:apply-templates/))))) ((xsl:template :match "sentence-morphology") ((div :class "morph") (xsl:apply-templates/ :select "token"))) ((xsl:template :match "token") ((div :class "morph") (hr/) (xsl:apply-templates/ :select "disjunction"))) ((xsl:template :match "disjunction") ((div :class "morph") (xsl:apply-templates/ :select "segment") (br/) (xsl:apply-templates/ :select "fst-segment"))) ((xsl:template :match "segment") (span (xsl:value-of/ :select "@string") (xsl:text " ") (xsl:apply-templates/ :select "morph")) ((xsl:if :test "following-sibling::*") ", ")) ((xsl:template :match "fst-segment") ((span :style "color: red") (xsl:value-of/ :select "@string") (xsl:text " ") (xsl:apply-templates/ :select "morph")) ((xsl:if :test "following-sibling::*") ", ")) ((xsl:template :match "morph") ((span :class "morph") (xsl:value-of/ :select "text()") ((xsl:if :test "following-sibling::*") " | "))) #L(mrs-templates stream))) (defun mrs-templates (stream) #m((xsl:template :match "psoa") ((table :class "mrs") (tr ((td :class "fs") ((table :class "mrs") (xsl:apply-templates/)))))) #m((xsl:template :match "fvpair|extrapair") (tr ((td :class "attribute") (xsl:value-of/ :select "@feature")) (xsl:choose ((xsl:when :test "handle-var/extra") ((td :class "mrs") ((table :class "mrs") (tr ((td :class "fs") (xsl:apply-templates/)))))) (xsl:otherwise ((td) (xsl:apply-templates/)))))) #m((xsl:template :match "normalized-set") (nobr "{" (xsl:apply-templates/ :select "handle-var") "}")) #m((xsl:template :match "handle-var") (xsl:choose ((xsl:when :test "extra") ((table :class "mrs") (tr ((td :class "mrs" :colspan "1") ((xsl:element :name "span") ((xsl:attribute :name "class") "handle") ((xsl:attribute :name "name") (xsl:value-of/ :select "@name")) ((xsl:attribute :name "id") (xsl:value-of/ :select "@name")) ((xsl:attribute :name "onmouseover") "hiliteHandleLabel(this);") ((xsl:attribute :name "onmouseout") "unhiliteHandleLabel(this);") (xsl:value-of/ :select "@name")))) (xsl:apply-templates/))) (xsl:otherwise ((xsl:element :name "span") ((xsl:attribute :name "class") "handle") ((xsl:attribute :name "name") (xsl:value-of/ :select "@name")) ((xsl:attribute :name "id") (xsl:value-of/ :select "@name")) ((xsl:attribute :name "onmouseover") "hiliteHandleLabel(this);") ((xsl:attribute :name "onmouseout") "unhiliteHandleLabel(this);") (xsl:value-of/ :select "@name")))) ((xsl:if :test "following-sibling::handle-var") ", ")) #m((xsl:template :match "extra") (xsl:apply-templates/)) #m((xsl:template :match "h-cons") ((table :class "h-cons") ((tr :colspan "3") ((td :class "mrs" :style "font-size: 14pt") "{") ((td :class "mrs") (xsl:apply-templates/ :select "handle-var")) ((td :class "mrs" :style "font-size: 14pt") "}")))) #m((xsl:template :match "handle-var[@relation='QEQ']") (xsl:apply-templates/ :select "scarg") (xsl:text " ") ((xsl:element :name "span") ((xsl:attribute :name "class") "qeq") ((xsl:attribute :name "harg-id") (xsl:value-of/ :select "scarg/handle-var/@name")) ((xsl:attribute :name "larg-id") (xsl:value-of/ :select "outscpd/handle-var/@name")) ((xsl:attribute :name "onmouseover") "hiliteQeq(this);") ((xsl:attribute :name "onmouseout") "unhiliteQeq(this);") "QEQ") (xsl:text " ") (xsl:apply-templates/ :select "outscpd") ((xsl:if :test "following-sibling::*") ", ")) #m((xsl:template :match "scarg") ((xsl:element :name "span") ((xsl:attribute :name "class") "handle") ((xsl:attribute :name "name") (xsl:value-of/ :select "handle-var/@name")) ((xsl:attribute :name "id") (xsl:value-of/ :select "handle-var/@name")) ;;((xsl:attribute :name "outscpd-id") (xsl:value-of/ :select "../outscpd/handle-var/@name")) ((xsl:attribute :name "onmouseover") "hiliteHandleLabel(this);") ((xsl:attribute :name "onmouseout") "unhiliteHandleLabel(this);") (xsl:value-of/ :select "handle-var/@name"))) #m((xsl:template :match "outscpd") ((xsl:element :name "span") ((xsl:attribute :name "class") "handle") ((xsl:attribute :name "name") (xsl:value-of/ :select "handle-var/@name")) ((xsl:attribute :name "id") (xsl:value-of/ :select "handle-var/@name")) ((xsl:attribute :name "onmouseover") "hiliteHandleLabel(this);") ((xsl:attribute :name "onmouseout") "unhiliteHandleLabel(this);") (xsl:value-of/ :select "handle-var/@name"))) #m((xsl:template :match "rel") ((td :class "mrs") ((table :class "mrs") (tr ((td :class "fs") ((table :class "mrs") (tr ((td :class "pred" :colspan "2") (nobr (xsl:value-of/ :select "@pred") ((span :style "color: gray") (xsl:value-of/ :select "@lnk"))))) (tr ((xsl:element :name "td") ((xsl:attribute :name "class") "attribute") ((xsl:attribute :name "lbl") (xsl:value-of/ :select "handle-var/@name")) "LBL") ((td :class "mrs") (xsl:apply-templates/ :select "handle-var"))) (xsl:apply-templates/ :select "extra")))))) ((xsl:if :test "following-sibling::* or ../following-sibling::rel-partition") ((td :class "mrs") ", "))) #m((xsl:template :match "rel-partition") (tr (td ((table :class "mrs") (tr (xsl:apply-templates/ :select "rel")))))) #m((xsl:template :match "liszt") ((table :class "mrs") ((tr :colspan "3") ((td :class "left-brace") "{") (xsl:apply-templates/ :select "rel") (td ((table :class "mrs") (xsl:apply-templates/ :select "rel-partition"))) ((td :class "right-brace") "}"))))) #+obsolete (publish :path (concat "/" *url-base* "/xle-mrs.xml") :class 'xml/html-entity :function #'mrs-xml) #+obsolete (publish :path (concat "/" *url-base* "/xle-mrs.xsl") :content-type "text/xml" :function #'mrs-xsl) (publish :path (concat "/" *url-base* "/xle-mrs.xml") :class 'xml/html-entity :function #'xle-xml) #-pargram (publish :path "/cl/sm/wn-entry.xml" :content-type "text/html" :function #'(lambda (req ent) (with-http-response (req ent :response *response-moved-permanently*) (setf (reply-header-slot-value req :location) "http://decentius.hit.uib.no/cl/sm/wn-entry.xml") (with-http-body (req ent) ;; this is optional and most likely unnecessary since most ;; browsers understand the redirect response #+ignore #m(html (head (title "Object Moved")) (body (h1 "Object Moved") "The picture you're looking for is now at " ((a href "pic") "http://decentius.hit.uib.no/cl/sm/wn-entry.xml"))))))) #+from-morph-server (defun sentence-morphology-xml (sentence-list segments stream) #m(sentence-morphology #L(dolist (disjunction-list sentence-list) #+debug(print (list :disjunction-list disjunction-list)) #m(token #L(dolist (dis disjunction-list) #m(disjunction #L(dolist (segment (car dis)) (destructuring-bind (str id dcp) segment (let* ((morphology (nth-value 1 (norgram-morphology-regexp str segments (cond ((null (cdar dis)) nil) ((eq segment (caar dis)) :first) (t :second))))) (fst-morphology (get-norgram-fst-morphology str)) (length (when id (length morphology)))) #m((segment :string #s(if (and id (> length 1)) (format nil "~a\\~d" str id) (format nil "~a" str))) #L(dolist (reading morphology) #m(morph #s(format nil "~{~a~}" reading))) ) #m((fst-segment :string #s(if (and id (> length 1)) (format nil "~a\\~d" str id) (format nil "~a" str))) #L(dolist (reading fst-morphology) #m(morph #s reading)) ))) (terpri stream)) #L(dolist (str (cdr dis)) ;; fixme: what about ids and compound segments here?? (let ((morphology (nth-value 1 (norgram-morphology-regexp str segments)))) #m((segment :string #s str) #L(dolist (reading morphology) #m(morph #s(format nil "~{~a~}" reading))))) (terpri stream))) (terpri stream) #+test(cdr dis)) ) (terpri stream)))) #+test (net.aserve::debug-on :notrap) #+test (net.aserve::debug-on :xmit) #+test (net.aserve::debug-off :notrap) #+test (net.aserve::debug-off :xmit) :eof