;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: cgp; Base: 10; Readtable: augmented-readtable -*- ;; ;; Copyright (C) Paul Meurer 2002-2005. All rights reserved. ;; paul.meurer@aksis.uib.no ;; Aksis, University of Bergen ;; ;; Web-interface to the computational lexicon (Norsk ordbank) ;; ;;------------------------------------------------------------------------------------- ;; TO DO: ;;------------------------------------------------------------------------------------- ;; PROBLEMS: ;; ;;------------------------------------------------------------------------------------- (in-package :cgp) (eval-when (:compile-toplevel :load-toplevel :execute) (setf lxml::*encoding* :utf-8) (setf lxml::*newline-after-endtag-p* nil)) (dolist (tagger (list *nbo-tagger* #+nny-parser *nny-tagger*)) (let ((path (concat "projects:cgp;nets;" (string-downcase (symbol-name (language tagger))) "-"))) (setf (names tagger) (load-wordforms tagger (concat path "new-names.txt"))))) #+test (net.aserve::debug-on :notrap) #+test (net.aserve::debug-on :xmit) #+test (net.aserve::debug-off :notrap) #+test (net.aserve::debug-off :xmit) #+test (let ((*tagger* *nbo-tagger*)) (print (lemma-and-features "gå" :net (lemmata-forms *tagger*)))) #+test (let ((*tagger* *nbo-tagger*)) (format t "~(~{~a~^ ~}~)" (code-features #*0000010010010100010110000001000101001000100000000000000000000000000000000000100000000000000000010000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))) #+test (let ((*tagger* *nbo-tagger*)) (print (most-probable-compound-last-chunk "klatrestevner" t))) #+test (let ((*tagger* *nbo-tagger*)) (print (compound-lemma "klatrestevne"))) #+test (let ((*tagger* *nbo-tagger*)) (print (tag-compound "klatrestevner"))) #+test (defparameter *nbo-new-wordforms-net* (load-wordforms "projects:cgp;nets;nbo-new-wordforms.txt")) ;;(defparameter *nny-new-wordforms-net* (load-wordforms "projects:cgp;nets;nny-new-wordforms.txt")) #+test (store-new-wordforms *nbo-new-wordforms-net* "projects:cgp;nets;nbo-new-wordforms.txt") #+test (store-new-wordforms *nny-new-wordforms-net* "projects:cgp;nets;nny-new-wordforms.txt") #+test (string-net::print-strings *nbo-new-wordforms-net*) #+test (let ((*tagger* *nbo-tagger*)) (print (lemma-and-features "Kristin" :net (cdr *nbo-new-wordforms-net*);(lemmata-forms *tagger*) :decompress-base "Kristin"))) (defmethod lexicon-search-request-xml ((request http-request) entity) (with-xml-response (request entity stream (language word lemma document wordlist delete delete-wordform toggle-suppression toggle-wordform-suppression new-lemma new-wordform new-features new-name-wordform new-name-features sample-lemma add-by-sample add-name-by-sample edit-lemma remove-lemma remove-name-lemma add-paradigm add-name-paradigm write-backup) :force-xslt :sablotron :xsl (lambda (request entity) (if (string= language "nrn") (menota-lexicon-search-xsl request entity) (lexicon-search-xsl request entity)))) #-debug(print (list :lexicon-search-request-xml (request-query request))) (let ((tagger (cond ((or (null language) (string= language "nbo")) *nbo-tagger*) ((string= language "nrn") *menota-multi-tagger*) ((string= language "nny") *nny-tagger*)))) (lexicon-search-xml tagger language :word word :lemma lemma :stream stream :request request :wordlist wordlist :document document :delete delete :delete-wordform delete-wordform :toggle-suppression toggle-suppression :toggle-wordform-suppression toggle-wordform-suppression :new-lemma new-lemma :new-wordform new-wordform :new-features new-features :new-name-wordform new-name-wordform :new-name-features new-name-features :sample-lemma sample-lemma :add-by-sample add-by-sample :add-name-by-sample add-name-by-sample :edit-lemma edit-lemma :remove-lemma remove-lemma :remove-name-lemma remove-name-lemma :add-paradigm add-paradigm :add-name-paradigm add-name-paradigm :write-backup write-backup)))) (defmethod lexicon-search-xml ((tagger multi-tagger) language &key word lemma stream request wordlist new-wordform new-features sample-lemma add-by-sample edit-lemma remove-lemma add-paradigm write-backup &allow-other-keys) (let* ((*tagger* tagger) (*special-word-list* (when wordlist (get-user-wordlist *tagger* wordlist))) (new-net (cdr *special-word-list*)) (word (utf-8-decode (or word lemma))) (sample-lemma (utf-8-decode sample-lemma)) (wordforms+features #+test(when word (lemma-and-features word :net (lemmata-forms *tagger*)))) (lemma+features #+test(when word (lemma-and-features word :net (lexicon *tagger*)))) (wordforms+features-by-sample ())) #-debug(print (cons :*special-word-list* *special-word-list*)) (when (and write-backup new-net) (store-wordforms tagger (print (car new-net)) (print (concat *wordlist-directory* (car *special-word-list*) ".txt")))) (cond (remove-lemma (remove-lemma new-net word)) ((and new-wordform new-features) (unless (listp new-wordform) (add-new-wordform *tagger* word (utf-8-decode new-wordform) (utf-8-decode new-features) :net new-net))) ((and add-by-sample sample-lemma) (setf wordforms+features-by-sample (or (lemma-and-features sample-lemma :net (car new-net) :decompress-base word) #+orig (lemma-and-features sample-lemma :net (lemmata-forms *tagger*) :decompress-base word)))) (add-paradigm (remove-lemma new-net #+ignore(new-wordforms *tagger*) word) (dolist (pair (request-query request)) (when (search "new-wordform" (car pair)) (let* ((fstring (concat "new-features" (subseq (car pair) 12))) (features (cdr (find fstring (request-query request) :test #'string= :key #'car)))) (unless (or (string= (cdr pair) "") (string= features "")) (add-new-wordform *tagger* word (utf-8-decode (cdr pair)) (utf-8-decode features) :net (when add-paradigm new-net) :net-accessor #'new-wordforms))))))) (let ((new-wordforms+features (when (and word *special-word-list*) (print (lemma-and-features word :net (car new-net))))) (new-lemma+features (when (and word *special-word-list*) (print (lemma-and-features word :net (cdr new-net)))))) #m(?xml-stylesheet :type "text/xsl" :href "/cl/cgp/lexicon-search.xsl") #m((lexicon-entries :language #L (or language "nbo") :wordlist #L wordlist :word #L word) #L(when wordforms+features #m((entry :lexicon #L(cond (wordforms+features "Fullformleksikon")) :type "lemma") (lemma #S word) #L(dolist (word+features wordforms+features) #m(word/ :form #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features) (feature-vector tagger))) '("&" "&" "<" "<" ">" ">")))))) #L(when word (when new-net #m((entry :lexicon #L(car *special-word-list*) ;; "Nye ord (NOB)" :type #L(if edit-lemma "unconfirmed-lemma" "new-lemma")) (lemma #S word) #L(when new-wordforms+features (loop for word+features in new-wordforms+features for id from 0 do #m(word/ :form #L (car word+features) :editable #L(if edit-lemma "true" "false") :id #L (when edit-lemma id) :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features) (feature-vector tagger))) '("&" "&" "<" "<" ">" ">")))))))) #L(when wordforms+features-by-sample #m((entry :lexicon #L(concat (car *special-word-list*) ", ubekreftet") :type "unconfirmed-lemma") (lemma #S word) #L(loop for word+features in wordforms+features-by-sample for id from 0 do #m(word/ :form #L (car word+features) :editable "true" :id #L id :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features) (feature-vector tagger))) '("&" "&" "<" "<" ">" ">")))))) #L(when lemma+features #m((entry :lexicon #L(cond (lemma+features "Fullformleksikon")) :type "wordform") #L(dolist (word+features lemma+features) #m(word/ :form #L word :lemma #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features) (feature-vector tagger))) '("&" "&" "<" "<" ">" ">")))))) #L(when new-lemma+features #m((entry :lexicon "Nye ord, ubekreftet" :type "wordform") #L(dolist (word+features new-lemma+features) #m(word/ :form #L word :lemma #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features) (feature-vector tagger))) '("&" "&" "<" "<" ">" ">")))))))))) (defmethod lexicon-search-xml ((tagger cg-multi-tagger) language &key word stream request wordlist new-wordform new-features new-name-wordform new-name-features lemma sample-lemma add-by-sample add-name-by-sample edit-lemma remove-lemma remove-name-lemma add-paradigm add-name-paradigm write-backup) (let* ((*tagger* tagger) (*special-word-list* (when wordlist (get-user-wordlist *tagger* wordlist))) (new-net (cdr *special-word-list*)) ;;(new-wordforms *nbo-tagger*)) (new-names-net (names *tagger*)) (*analyser-lexicon* (cgp::compound-analyser *tagger*)) (word (utf-8-decode (or word lemma))) ;; to be fixed (sample-lemma (utf-8-decode sample-lemma)) (wordforms+features (when word (lemma-and-features word :net (lemmata-forms *tagger*)))) (lemma+features (when word (lemma-and-features word :net (lexicon *tagger*)))) (compound-forms+features (when word (unless wordforms+features (tag-compound word)))) (wordforms+features-by-sample ()) (name-wordforms+features-by-sample ())) #+debug(print (cons :*special-word-list* *special-word-list*)) (when (and write-backup new-net) (store-wordforms *tagger* (car new-net) (concat *wordlist-directory* (car *special-word-list*) ".txt") #+ignore(concat "projects:cgp;nets;" language "-new-wordforms.txt"))) (when (and write-backup new-names-net) (store-wordforms *tagger* (car new-names-net) (concat "projects:cgp;nets;" language "-new-names.txt"))) (cond (remove-lemma (remove-lemma new-net word)) (remove-name-lemma (remove-lemma new-names-net word)) ((and new-wordform new-features) (unless (listp new-wordform) (add-new-wordform *tagger* word (utf-8-decode new-wordform) (utf-8-decode new-features) :net new-net))) ((and new-name-wordform new-name-features) (unless (listp new-name-wordform) (add-new-wordform *tagger* word (utf-8-decode new-name-wordform) (utf-8-decode new-name-features) :net-accessor #'names))) ((and add-by-sample sample-lemma) (setf wordforms+features-by-sample (or (lemma-and-features sample-lemma :net (car new-net) :decompress-base word) (lemma-and-features sample-lemma :net (lemmata-forms *tagger*) :decompress-base word)))) ((and add-name-by-sample sample-lemma) (setf name-wordforms+features-by-sample (or (lemma-and-features sample-lemma :net (car new-names-net) :decompress-base word) (when new-net (lemma-and-features sample-lemma :net (car new-net) :decompress-base word)) (lemma-and-features sample-lemma :net (lemmata-forms *tagger*) :decompress-base word)))) ;; ?? names? ((or add-paradigm add-name-paradigm) (remove-lemma new-net #+ignore(new-wordforms *tagger*) word) (dolist (pair (request-query request)) (when (search "new-wordform" (car pair)) (let* ((fstring (concat "new-features" (subseq (car pair) 12))) (features (cdr (find fstring (request-query request) :test #'string= :key #'car)))) (unless (or (string= (cdr pair) "") (string= features "")) (add-new-wordform *tagger* word (utf-8-decode (cdr pair)) (utf-8-decode features) :net (when add-paradigm new-net) :net-accessor (if add-paradigm #'new-wordforms #'names)))))))) (let ((new-wordforms+features (when (and word *special-word-list*) (print (lemma-and-features word :net (car new-net))))) (new-lemma+features (when (and word *special-word-list*) (print (lemma-and-features word :net (cdr new-net))))) (new-name-wordforms+features (when word (lemma-and-features word :net (car new-names-net)))) #+unused (new-name-lemma+features (when word (lemma-and-features word :net (cdr new-names-net))))) #m(?xml-stylesheet :type "text/xsl" :href "/cl/cgp/lexicon-search.xsl") #m((lexicon-entries :language #L (or language "nbo") :wordlist #L wordlist :word #L word) #L(when wordforms+features #m((entry :lexicon #L(cond (wordforms+features "NBO-fullformleksikon")) :type "lemma") (lemma #S word) #L(dolist (word+features wordforms+features) #m(word/ :form #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">")))))) #L(when word (when new-net #m((entry :lexicon #L(car *special-word-list*) ;; "Nye ord (NOB)" :type #L(if edit-lemma "unconfirmed-lemma" "new-lemma")) (lemma #S word) #L(when new-wordforms+features (loop for word+features in new-wordforms+features for id from 0 do #m(word/ :form #L (car word+features) :editable #L(if edit-lemma "true" "false") :id #L (when edit-lemma id) :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">"))))))) #+disabled #m((entry :lexicon "Nye navn (NOB)" :type #L(if edit-lemma "unconfirmed-name-lemma" "new-name-lemma")) (lemma #S word) #L(when new-name-wordforms+features (loop for word+features in new-name-wordforms+features for id from 0 do #m(word/ :form #L (car word+features) :editable #L(if edit-lemma "true" "false") :id #L (when edit-lemma id) :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">"))))))) #L(when wordforms+features-by-sample #m((entry :lexicon #L(concat (car *special-word-list*) ", ubekreftet") :type "unconfirmed-lemma") (lemma #S word) #L(loop for word+features in wordforms+features-by-sample for id from 0 do #m(word/ :form #L (car word+features) :editable "true" :id #L id :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">")))))) #L(when name-wordforms+features-by-sample #m((entry :lexicon "Nye navn (NOB), ubekreftet" :type "unconfirmed-name-lemma") (lemma #S word) #L(loop for word+features in name-wordforms+features-by-sample for id from 0 do #m(word/ :form #L (car word+features) :editable "true" :id #L id :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">")))))) #L(when (or lemma+features compound-forms+features) #m((entry :lexicon #L(cond (lemma+features "NBO-fullformleksikon") (compound-forms+features "NBO-sammensetningsanalysator")) :type "wordform") #L(dolist (word+features (or lemma+features compound-forms+features)) #m(word/ :form #L word :lemma #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">")))))) #L(when new-lemma+features #m((entry :lexicon "Nye ord (NOB), ubekreftet" :type "wordform") #L(dolist (word+features new-lemma+features) #m(word/ :form #L word :lemma #L (car word+features) :editable "false" :features #L(subst-substrings (format nil "~(~{~a~^ ~}~)" (code-features (cdr word+features))) '("&" "&" "<" "<" ">" ">")))))) #+ignore (feature-list #L(dotimes (i (length (code-vector-sort-array *tagger*))) #m(feature #S(subst-substrings (format nil "~(~a~)" (code-feature i)) '("&" "&" "<" "<" ">" ">"))))))))) (defstylesheet lexicon-search-xsl () "Writes xsl stylesheet for corpus document display." #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0") ((xsl:template :match "/lexicon-entries") (html (head (title "Søk i Norsk ordbank")) ((body :style "font-family: Verdana, Tahoma, MS Sans Serif, Arial, Geneva, Helvetica") ((xsl:element :name "FORM") ((xsl:attribute :name "method") "post") ((xsl:attribute :name "id") "searchForm") ((xsl:attribute :name "action") "/cl/cgp/lexicon-search.xml?language=" (xsl:value-of/ :select "@language")) "Søk etter lemma eller ordform: " ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "word") ((xsl:attribute :name "style") "width: 200") ((xsl:attribute :name "value") (xsl:value-of/ :select "@word"))) ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "wordlist") ((xsl:attribute :name "value") (xsl:value-of/ :select "@wordlist"))) (xsl:text " ") (input/ :type "submit" :style "color: black; font-weight: bold" :name "search" :value "Søk") (br/) (br/) (i "Treff:") ((table :style "width: 100%") (xsl:apply-templates/ :select "entry") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") "Lag sikkerhetskopi av listen med nye ord " (input/ :type "submit" :name "write-backup" :value "Lag")))))))) ((xsl:template :match "entry[@type='lemma']") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "leksikon:") (xsl:text " ") (xsl:value-of/ :select "@lexicon"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "lemma:") ((span :style "font-weight: bold") (xsl:text " ") (xsl:value-of/ :select "lemma")))) (tr ((td :style "background: #ccddee; font-style: italic") "ordform") ((td :style "background: #ccddee; font-style: italic" :colspan "2") "trekk")) (xsl:apply-templates/ :select "word")) ((xsl:template :match "entry[@type='new-lemma' or @type='new-name-lemma' or @type='editable-lemma']") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "leksikon:") (xsl:text " ") (xsl:value-of/ :select "@lexicon"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "lemma:") ((span :style "font-weight: bold") (xsl:text " ") (xsl:value-of/ :select "lemma")))) ((xsl:if :test "@type='lemma' or word") (tr ((td :style "background: #ccddee; font-style: italic") "ordform") ((td :style "background: #ccddee; font-style: italic" :colspan "2") "trekk"))) (xsl:apply-templates/ :select "word") ((xsl:if :test ;;"not(../entry[@type='unconfirmed-lemma' or @type='unconfirmed-name-lemma'])" "not(@type='unconfirmed-lemma' or @type='unconfirmed-name-lemma')") ;; edit lemma ((xsl:if :test "@type='lemma' or word") (tr ((td :style "color: red" :colspan "3") "Rediger lemmaet: " (input/ :type "submit" :style "color: black; font-weight: bold" :name "edit-lemma" :value "Rediger")))) ;; input for adding new wordforms to lemma (tr ((td :style "color: red" :colspan "3") (xsl:choose ((xsl:when :test "@type='lemma' or word") "... eller legg ") (xsl:otherwise "Legg ")) "til en ny ordform til lemmaet '" (b (xsl:value-of/ :select "lemma")) "' (sammen med tilhørende trekk):")) (tr ((td :style "color: black; font-weight: bold") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") (xsl:choose ((xsl:when :test "@type='new-lemma'") ((xsl:attribute :name "name") "new-wordform")) ((xsl:when :test "@type='new-name-lemma'") ((xsl:attribute :name "name") "new-name-wordform"))) ((xsl:attribute :name "style") "width: 100") ((xsl:attribute :name "value") "")) (xsl:text " ") (input/ :type "submit" :name "add-wordform" :value "Legg til")) ((td :style "color: #1133aa" :colspan "2") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") (xsl:choose ((xsl:when :test "@type='new-lemma'") ((xsl:attribute :name "name") "new-features")) ((xsl:when :test "@type='new-name-lemma'") ((xsl:attribute :name "name") "new-name-features"))) ((xsl:attribute :name "style") "width: 300") ((xsl:attribute :name "value") "")))) ((xsl:if :test "@type='lemma' or word") (tr ((td :style "color: red" :colspan "3") "... eller slett lemmaet '" (b (xsl:value-of/ :select "lemma")) "': " #+ignore(input/ :type "submit" :style "color: black; font-weight: bold" :name "remove-lemma" :value "Slett") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "submit") (xsl:choose ((xsl:when :test "@type='new-lemma'") ((xsl:attribute :name "name") "remove-lemma")) ((xsl:when :test "@type='new-name-lemma'") ((xsl:attribute :name "name") "remove-name-lemma"))) ((xsl:attribute :name "value") "Slett") ((xsl:attribute :name "style") "color: black; font-weight: bold"))))) ((xsl:if :test ;; "not(../entry[@type='lemma'] or word)" "not(@type='lemma' or word)") (tr ((td :style "color: red" :colspan "3") "... eller lag et nytt paradigme. Ordet '" (b (xsl:value-of/ :select "lemma")) "' skal bøyes på samme måte som:")) (tr ((td :style "color: black; font-weight: bold") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "sample-lemma") ((xsl:attribute :name "style") "width: 100") ((xsl:attribute :name "value") "")) (xsl:text " ") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "submit") (xsl:choose ((xsl:when :test "@type='new-lemma'") ((xsl:attribute :name "name") "add-by-sample")) ((xsl:when :test "@type='new-name-lemma'") ((xsl:attribute :name "name") "add-name-by-sample"))) ((xsl:attribute :name "value") "Lag")) #+ignore (input/ :type "submit" :name "add-by-sample" :value "Lag")))))) ((xsl:template :match "entry[@type='unconfirmed-lemma']") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "leksikon:") (xsl:text " ") (xsl:value-of/ :select "@lexicon"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "lemma:") ((span :style "font-weight: bold") (xsl:text " ") (xsl:value-of/ :select "lemma")))) (tr ((td :style "background: #ccddee; font-style: italic") "ordform") ((td :style "background: #ccddee; font-style: italic" :colspan "2") "trekk")) (xsl:apply-templates/ :select "word") (tr ((td :style "color: red" :colspan "3") "Gjerne rediger trekkene og/eller ordformene før du bekrefter.")) ;; confirm new lemma (tr ((td :style "color: black; font-weight: bold") (input/ :type "submit" :name "add-paradigm" :value "Bekreft"))) ) ((xsl:template :match "entry[@type='unconfirmed-name-lemma']") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "leksikon:") (xsl:text " ") (xsl:value-of/ :select "@lexicon"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "lemma:") ((span :style "font-weight: bold") (xsl:text " ") (xsl:value-of/ :select "lemma")))) (tr ((td :style "background: #ccddee; font-style: italic") "ordform") ((td :style "background: #ccddee; font-style: italic" :colspan "2") "trekk")) (xsl:apply-templates/ :select "word") (tr ((td :style "color: red" :colspan "3") "Gjerne rediger trekkene og/eller ordformene før du bekrefter.")) ;; confirm new lemma (tr ((td :style "color: black; font-weight: bold") (input/ :type "submit" :name "add-name-paradigm" :value "Bekreft"))) ) ((xsl:template :match "entry[@type='wordform']") (tr ((td :colspan "3" :style "background: red; hight: 1; width: 100%"))) (tr ((td :colspan "3") ((span :style "background: #ccddee; font-style: italic") "leksikon:") (xsl:text " ") (xsl:value-of/ :select "@lexicon"))) (tr ((td :style "background: #ccddee; font-style: italic") "ordform") ((td :style "background: #ccddee; font-style: italic") "lemma") ((td :style "background: #ccddee; font-style: italic") "trekk")) (xsl:apply-templates/ :select "word")) ((xsl:template :match "word[@editable='false']") (tr ((td :style "color: black; font-weight: bold") (xsl:value-of/ :select "@form")) (xsl:choose ((xsl:when :test "@lemma") ((td :style "color: black; font-weight: bold") (xsl:value-of/ :select "@lemma")) ((td :style "color: #1133aa") (xsl:value-of/ :select "@features"))) (xsl:otherwise ((td :style "color: #1133aa" :colspan "2") (xsl:value-of/ :select "@features")))))) ((xsl:template :match "word[@editable='true']") (tr ((td :style "color: black; font-weight: bold") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "new-wordform" (xsl:value-of/ :select "@id")) ((xsl:attribute :name "style") "width: 100") ((xsl:attribute :name "value") (xsl:value-of/ :select "@form"))) (xsl:choose ((xsl:when :test "@lemma") ((td :style "color: black; font-weight: bold") (xsl:value-of/ :select "@lemma")) ((td :style "color: #1133aa") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "new-features" (xsl:value-of/ :select "@id")) ((xsl:attribute :name "style") "width: 300") ((xsl:attribute :name "value") (xsl:value-of/ :select "@features"))))) (xsl:otherwise ((td :style "color: #1133aa" :colspan "2") ((xsl:element :name "INPUT") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "new-features" (xsl:value-of/ :select "@id")) ((xsl:attribute :name "style") "width: 300") ((xsl:attribute :name "value") (xsl:value-of/ :select "@features")))) ))))))) (defmethod lexicon-lemmata-xml ((request http-request) entity) (with-xml-response (request entity stream (language match wordlist) :force-xslt :sablotron :xsl #'lexicon-lemmata-xsl) #-debug(print (request-query request)) (let* ((tagger (cond ((or (null language) (string= language "nbo")) *nbo-tagger*) ((string= language "nrn") *menota-multi-tagger*) ((string= language "nny") *nny-tagger*))) (*tagger* tagger) (*special-word-list* (when wordlist (get-user-wordlist *tagger* wordlist))) (new-net (cdr *special-word-list*)) (match (utf-8-decode match))) #m(?xml-stylesheet :type "text/xsl" :href "/cl/cgp/lexicon-lemmata.xsl") #m((lexicon-lemmata :language #L (or language "nbo") :wordlist #L wordlist :match #L match) #L(when *special-word-list* (nmap-strings (car new-net) (lambda (string) (when (eq (string<= match string) (length match)) #m(lemma #s string))) nil nil t #\:)))))) (defstylesheet lexicon-lemmata-xsl () #m((xsl:stylesheet xmlns:xsl "http://www.w3.org/1999/XSL/Transform" :version "1.0") ((xsl:template :match "/lexicon-lemmata") (html (head (title "Lemmata")) ((body :style "font-family: Tahoma, MS Sans Serif, Arial, Geneva, Helvetica") ((xsl:element :name "form") ((xsl:attribute :name "method") "post") ((xsl:attribute :name "id") "searchForm") ((xsl:attribute :name "action") "/cl/cgp/lexicon-lemmata.xml") "Søk etter lemma: " ((xsl:element :name "input") ((xsl:attribute :name "type") "text") ((xsl:attribute :name "name") "match") ((xsl:attribute :name "style") "width: 200") ((xsl:attribute :name "value") (xsl:value-of/ :select "@match"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "wordlist") ((xsl:attribute :name "value") (xsl:value-of/ :select "@wordlist"))) ((xsl:element :name "input") ((xsl:attribute :name "type") "hidden") ((xsl:attribute :name "name") "language") ((xsl:attribute :name "value") (xsl:value-of/ :select "@language"))) (xsl:text " ") (input/ :type "submit" :style "color: black; font-weight: bold" :name "search" :value "Søk") (br/) (br/) ((table :style "width: 100%") (xsl:apply-templates/ :select "lemma")))))) ((xsl:template :match "lemma") (tr ((td :style "font-family: Notator Uni") (xsl:apply-templates/)))))) #+test (lexicon-lemmata-xml *menota-multi-tagger* :nrn "" :stream *standard-output* :wordlist "menota-test") (publish :path "/cl/cgp/lexicon-lemmata.xml" :class 'xml/html-entity :function #'lexicon-lemmata-xml :authorizer *authorizer*) (publish :path "/cl/cgp/lexicon-search.xml" :class 'xml/html-entity :function #'lexicon-search-request-xml :authorizer *authorizer* :documentation "Redigeringsside for Norsk ordbank, slik den er brukt av Oslo-Bergen-taggeren.") (publish :path "/cl/cgp/lexicon-search.xsl" :content-type "text/xml" :function #'lexicon-search-xsl) #+ignore (publish :path "/cl/cgp/menota-lexicon-search.xsl" :content-type "text/xml" :function #'menota-lexicon-search-xsl) :eof