X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql-classes.lisp;h=edbd72af2b19a19b8a014591f51cc1de2b54e0a9;hb=62294ad091ddc6b9bb050ca017b62a69c475dedf;hp=59efde5a82ac2927cd25937c63c83ac2404ac4e3;hpb=c7524b9cd7631b94729a20aac13c069ab7988233;p=umlisp.git diff --git a/sql-classes.lisp b/sql-classes.lisp index 59efde5..edbd72a 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-classes.lisp,v 1.18 2003/05/02 21:49:19 kevin Exp $ +;;;; $Id: sql-classes.lisp,v 1.33 2003/05/03 20:09:41 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -29,13 +29,13 @@ (defmacro with-umlisp-query ((table fields srl where-name where-value &key (lrlname "KCUILRL") distinct single - terminal like) + order like) &body body) (let ((query (gensym))) `(unless (and ,where-name (not ,where-value)) (let ((,query (umlisp-query ,table ,fields ,srl ,where-name ,where-value :lrlname ,lrlname :single ,single :distinct ,distinct - :terminal ,terminal :like ,like))) + :order ,order :like ,like))) (if ,single (let ((tuple (car ,query))) (when tuple @@ -46,46 +46,75 @@ (destructuring-bind ,fields tuple ,@body))))))) -(defun umlisp-query (table fields srl where-name where-value - &key (lrlname "KCUILRL") single distinct terminal like) +(defmacro umlisp-query (table fields srl where-name where-value + &key (lrlname "KCUILRL") single distinct order like) "Query the UMLisp database. Return a list of umlisp objects whose name is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" - (when (or (not where-name) where-value) + `(when (or (not ,where-name) ,where-value) (mutex-sql-query - (query-string table fields srl where-name where-value - :lrlname lrlname :single single :distinct distinct :terminal terminal :like like)))) + (query-string-macro ,table ,fields ,srl ,where-name ,where-value + :lrlname ,lrlname :single ,single :distinct ,distinct :order ,order :like ,like)))) +(defmacro query-string-macro (table fields &optional srl where-name where-value + &key (lrlname "KCUILRL") single distinct order like) + (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" + (if distinct "distinct " "") fields table)) + (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) ""))) + `(concatenate + 'string + ,%%fields + (if ,where-name + (format nil + (if (stringp ,where-value) + (if ,like + " where ~A like '%~A%'" + " where ~A='~A'") + " where ~A=~A") + ,where-name ,where-value) + "") + (if ,srl (format nil " and ~:@(~A~) <= ~D" ,lrlname ,srl) "") + ,%%order + (if ,single " limit 1" "")))) + (defun query-string (table fields &optional srl where-name where-value - &key (lrlname "KCUILRL") single distinct terminal like) - (let ((qs (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" - (if distinct "distinct " "") - fields table))) - (when where-name - (setq qs (concatenate 'string qs - (format nil - (if (stringp where-value) - (if like - " where ~A like '%~A%'" - " where ~A='~A'") - " where ~A=~A") - where-name where-value)))) - (when srl - (setq qs (concatenate 'string qs (format nil " and ~:@(~A~) <= ~D" - lrlname srl)))) - (when terminal - (setq qs (concatenate 'string qs " " terminal))) - (when single - (setq qs (concatenate 'string qs " limit 1"))) - qs)) + &key (lrlname "KCUILRL") single distinct order like) + (concatenate + 'string + (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" + (if distinct "distinct " "") fields table) + (if where-name + (format nil + (if (stringp where-value) + (if like + " where ~A like '%~A%'" + " where ~A='~A'") + " where ~A=~A") + where-name where-value) + "") + (if srl (format nil " and ~:@(~A~) <= ~D" lrlname srl) "") + (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "") + (if single " limit 1" ""))) (defun find-ucon-cui (cui &key (srl *current-srl*)) "Find ucon for a cui" - (with-umlisp-query ('mrcon (kpfstr kcuilrl) srl 'cui (parse-cui cui) :single t) + (with-umlisp-query (mrcon (kpfstr kcuilrl) srl 'cui (parse-cui cui) :single t) (make-instance 'ucon :cui (parse-cui cui) - :pfstr kpfstr2 + :pfstr kpfstr :lrl (ensure-integer kcuilrl)))) +(defun find-ucon-cui-old (cui &key (srl *current-srl*)) + "Find ucon for a cui" + (when (stringp cui) (setq cui (parse-cui cui))) + (when cui + (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (string-append ls " limit 1") + (awhen (car (mutex-sql-query ls)) + (destructuring-bind (kpfstr kcuilrl) + (make-instance 'ucon :cui cui :pfstr kpfstr + :lrl (ensure-integer kcuilrl))))))) (defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*)) "Find ucon for a cui" @@ -104,14 +133,14 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl 'lui (parse-lui lui) :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr - :lrl (ensure-integer lrl)))) + :lrl (ensure-integer kcuilrl)))) (defun find-ucon-sui (sui &key (srl *current-srl*)) "Find list of ucon for sui" (with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl 'sui (parse-sui sui) :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr - :lrl (ensure-integer kcuilrl))))) + :lrl (ensure-integer kcuilrl)))) (defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) "Find ucon for cui/sui" @@ -125,8 +154,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucon-str (str &key (srl *current-srl*)) "Find ucon that are exact match for str" (with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl 'str str :distinct t) - (make-instance 'ucon :cui (ensure-integer cui) - :pfstr kpfstr + (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr :lrl (ensure-integer kcuilrl)))) (defun find-ucon-all (&key (srl *current-srl*)) @@ -138,7 +166,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui (ensure-integer cui) :pfstr pfstr :lrl (ensure-integer cuilrl))) - (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :terminal "order by CUI asc" :distinct t) + (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil + :order '(cui asc) :distinct t) :database db))) (defun map-ucon-all (fn &key (srl *current-srl*)) @@ -151,7 +180,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui (ensure-integer cui) :pfstr pfstr :lrl (ensure-integer cuilrl)))) - (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :terminal "order by CUI asc" :distinct t) + (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :order '(cui asc) :distinct t) :database db))) @@ -180,7 +209,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" "Return a list of urel for cui2" (with-umlisp-query ('mrrel (rel cui1 rela sab sl mg kpfstr2) srl 'cui2 (parse-cui cui2) :lrlname "KSRL") (make-instance 'urel :cui2 (parse-cui cui2) :rel rel :cui1 (ensure-integer cui1) :rela rela - :sab sab :sl sl :mg mg :pfstr2 kpfstr2)))) + :sab sab :sl sl :mg mg :pfstr2 kpfstr2))) (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) (mapcar @@ -190,7 +219,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucoc-cui (cui &key (srl *current-srl*)) "Return a list of ucoc for cui" (with-umlisp-query ('mrcoc (cui2 soc cot cof coa kpfstr2) srl 'cui1 (parse-cui cui) - :lrlname "KSRL" :terminal "order by COF asc") + :lrlname "KSRL" :order '(cof asc)) (setq cui2 (ensure-integer cui2)) (when (zerop cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 (parse-cui cui) :cui2 (ensure-integer cui2) :soc soc :cot cot @@ -199,7 +228,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) "Return a list of ucoc for cui2" (with-umlisp-query ('mrcoc (cui1 soc cot cof coa kpfstr2) srl 'cui2 (parse-cui cui2) - :lrlname "KSRL" :terminal "order by COF asc") + :lrlname "KSRL" :order '(cof asc)) (setq cui2 (ensure-integer cui2)) (when (zerop cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 (parse-cui cui2) :soc soc :cot cot @@ -233,7 +262,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (with-umlisp-query ('mrcon (lui lat ts kluilrl) srl 'cui (parse-cui cui) :lrlname 'kluilrl :distinct t) (make-instance 'uterm :lui (ensure-integer lui) :cui (parse-cui cui) - :lat lat :ts ts :lrl (ensure-integer lrl)))) + :lat lat :ts ts :lrl (ensure-integer kluilrl)))) (defun find-uterm-lui (lui &key (srl *current-srl*)) "Return a list of uterm for lui" @@ -242,13 +271,12 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'uterm :cui (ensure-integer cui) :lui (parse-lui lui) :lat lat :ts ts :lrl (ensure-integer kluilrl)))) - (defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) "Return single uterm for cui/lui" (with-umlisp-query ('mrcon (lat ts kluilrl) srl 'kcuilui (make-cuilui (parse-cui cui) (parse-lui lui)) :lrlname 'kluilrl :single t) - (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts :lrl (ensure-integer kluilrl))))) + (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts :lrl (ensure-integer kluilrl)))) (defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) "Return a list of ustr for cui/lui" @@ -273,8 +301,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ustr-sab (sab &key (srl *current-srl*)) "Return the list of ustr for sab" - (with-umlisp-query ('mrso '(kcuisui) srl 'sab sab :lrlname 'srl) - (let ((cuisui (ensure-integer (car tuple)))) + (with-umlisp-query ('mrso (kcuisui) srl 'sab sab :lrlname 'srl) + (let ((cuisui (ensure-integer kcuisui))) (apply #'find-ustr-cuisui (append (multiple-value-list (decompose-cuisui cuisui)) (list :srl srl)))))) @@ -297,20 +325,20 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :lrl lrl :str pfstr)) (query-string 'mrcon '(cui lui sui stt lrl kpfstr) srl nil nil :lrlname 'lrl :distinct t - :terminal "order by SUI asc") + :order '(sui asc)) :database db))) (defun find-string-sui (sui &key (srl *current-srl*)) "Return the string associated with sui" - (with-umlisp-query ('mrcon '(str) srl 'sui sui :lrlname 'lrl :single t) - (car tuple))) + (with-umlisp-query ('mrcon (str) srl 'sui sui :lrlname 'lrl :single t) + str)) (defun find-uso-cuisui (cui sui &key (srl *current-srl*)) (with-umlisp-query ('mrso (sab code srl tty) srl 'kcuisui (make-cuisui cui sui) :lrlname 'srl) (make-instance 'uso :sab sab :code code :srl srl :tty tty))) (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) - (with-umlisp-query ('mrcxt (sab code cxn cxl rnk cxs cui2 hcd rela cx) srl 'kcuisui + (with-umlisp-query ('mrcxt (sab code cxn cxl rnk cxs cui2 hcd rela xc) srl 'kcuisui (make-cuisui cui sui) :lrlname 'ksrl) (make-instance 'ucxt :sab sab :code code :cxn (ensure-integer cxn) @@ -346,7 +374,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-usty-all () "Return list of usty's for all semantic types" - (with-umlisp-query ('mrsty '(tui) nil nil nil :distinct t) + (with-umlisp-query ('mrsty (tui) nil nil nil :distinct t) (find-usty-tui tui))) (defun find-usab-all () @@ -388,39 +416,40 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucon-tui (tui &key (srl *current-srl*)) "Find list of ucon for tui" - (with-umlisp-query ('mrsty (cui) srl 'tui (parse-tui tui) :lrlname 'klrl :terminal "order by cui desc") + (with-umlisp-query ('mrsty (cui) srl 'tui (parse-tui tui) :lrlname 'klrl + :order '(cui asc)) (find-ucon-cui (ensure-integer cui) :srl srl))) (defun find-ucon-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match word. Optionally, use SQL's LIKE syntax" (with-umlisp-query ('mrxw_eng (cui) srl 'wd word :like like :distinct t - :lrlname 'klrl :terminal "order by cui desc") + :lrlname 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match word, optionally use SQL's LIKE syntax" (with-umlisp-query ('mrxnw_eng (cui) srl 'nwd word :like like :distinct t - :lrlname 'klrl :terminal "order by cui desc") + :lrlname 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-ustr-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (with-umlisp-query ('mrxw_eng (cui sui) srl 'wd word :lrlname 'klrl - :terminal "order by cui desc, sui desc") + :order '(cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) (defun find-ustr-normalized-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (with-umlisp-query ('mrxnw_eng (cui sui) srl 'nwd word :lrlname 'klrl - :terminal "order by cui desc, sui desc") + :order '(cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) ;; Special tables (defun find-usrl-all () - (with-umlisp-query ('usrl (sab srl) nil nil nil :terminal "order by sab desc") - (make-instance 'usrl :sab sab :srl (ensure-integer srl)) usrls)) + (with-umlisp-query ('usrl (sab srl) nil nil nil :order '(sab asc)) + (make-instance 'usrl :sab sab :srl (ensure-integer srl)))) ;;; Multiword lookup and score functions @@ -526,7 +555,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-lmod-eui (eui) (with-umlisp-query ('lrmod (bas sca psn_mod fea) nil 'eui eui) - (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psnmod :fea fea))) + (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea))) (defun find-lnom-eui (eui) (with-umlisp-query ('lrnom (bas sca eui2 bas2 sca2) nil 'eui eui) @@ -564,7 +593,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-sdef-ui (ui) (with-umlisp-query ('srdef (rt sty_rl stn_rtn def ex un rh abr rin) nil 'ui ui :single t) - (make-instance 'sdef :rt rt :ui ui :styrl styrl :stnrtn stnrtn + (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn :def def :ex ex :un un :rh rh :abr abr :rin rin))) (defun find-sstre1-ui (ui) @@ -579,7 +608,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-sstr-rl (rl) (with-umlisp-query ('srstre (sty_rl sty_rl2 ls) nil 'rl rl) - (make-instance 'sstr :rl rl :styrl styrl :styrl2 styrl2 :ls ls))) + (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls))) (defun find-sstre2-sty (sty) (with-umlisp-query ('srstre2 (rl sty2) nil 'sty sty) @@ -587,4 +616,4 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-sstr-styrl (styrl) (with-umlisp-query ('srstr (rl sty_rl2 ls) nil 'styrl styrl) - (make-instance 'sstr :styrl styrl :rl rl :styrl2 styrl2 :ls ls))) + (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))