X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql-classes.lisp;h=48e7d54a538e66bea2290c61e8d4ae76037bbd92;hb=5be6bdf06e0c99612a4c1a1d6f110e424400d96e;hp=3af923d2b1e7c1def2e54282f4cf0c06411275de;hpb=16330812b9a0fef2394d2a45889ab04bec5d3859;p=umlisp.git diff --git a/sql-classes.lisp b/sql-classes.lisp index 3af923d..48e7d54 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.88 2003/07/21 00:53:27 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D. @@ -76,10 +76,11 @@ (defmacro umlisp-query (table fields srl where-name where-value - &key (lrl "KCUILRL") single distinct order like) + &key (lrl "KCUILRL") single distinct order like + (query-cmd 'mutex-sql-query)) "Query the UMLisp database. Return a list of umlisp objects whose name is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" - `(mutex-sql-query + `(,query-cmd (query-string ,table ,fields ,srl ,where-name ,where-value :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like))) @@ -94,8 +95,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" ;; only WHERE-VALUE and SRL are evaluated (defmacro collect-umlisp-query ((table fields srl where-name where-value &key (lrl "KCUILRL") distinct single - order like) - &body body) + order like (query-cmd 'mutex-sql-query)) + &body body) (let ((value (gensym)) (r (gensym))) (if single @@ -103,7 +104,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct :order ,order - :like ,like)))) + :like ,like + :query-cmd ,query-cmd)))) ,@(unless where-name `((declare (ignore ,value)))) (when tuple (destructuring-bind ,fields tuple @@ -254,6 +256,12 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :pfstr kpfstr :lrl (ensure-integer kcuilrl)))) +(defun find-cui-ucon-all (&key (srl *current-srl*)) + "Return list of CUIs for all ucons" + (collect-umlisp-query (mrcon (cui) srl nil nil :order (cui asc) + :distinct t) + cui)) + (defun map-ucon-all (fn &key (srl *current-srl*)) "Map a function over all ucon's" (with-sql-connection (db) @@ -296,6 +304,13 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :cui2 (ensure-integer cui2) :rela rela :sab sab :sl sl :mg mg :pfstr2 kpfstr2))) +(defun find-cui2-urel-cui (cui &key (srl *current-srl*)) + "Return a list of urel for cui" + (ensure-cui-integer cui) + (collect-umlisp-query (mrrel (cui2) srl cui1 + cui :lrl "KSRL") + cui2)) + (defun find-urel-cui2 (cui2 &key (srl *current-srl*)) "Return a list of urel for cui2" (ensure-cui-integer cui2) @@ -495,12 +510,12 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-usab-all () "Find usab for a key" - (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver mstart mend imeta + (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) nil nil nil) (make-instance 'usab :vcui (ensure-integer vcui) :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son - :sf sf :sver sver :mstart mstart :mend mend :imeta imeta + :sf sf :sver sver :vstart vstart :vend vend :imeta imeta :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl) :tfr (ensure-integer tfr) :cfr (ensure-integer cfr) :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc @@ -508,13 +523,13 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-usab-by-key (key-name key) "Find usab for a key" - (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver mstart - mend imeta rmeta slc scc srl tfr cfr cxty + (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart + vend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) nil key-name key :single t) (make-instance 'usab :vcui (ensure-integer vcui) :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son - :sf sf :sver sver :mstart mstart :mend mend :imeta imeta + :sf sf :sver sver :vstart vstart :vend vend :imeta imeta :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl) :tfr (ensure-integer tfr) :cfr (ensure-integer cfr) :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc @@ -551,6 +566,24 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :lrl 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) +(defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil)) + "Return list of cui that match word, optionally use SQL's LIKE syntax" + (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t + :lrl 'klrl :order '(cui asc)) + cui)) + +(defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil)) + "Return list of cui that match word, optionally use SQL's LIKE syntax" + (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t + :lrl 'klrl :order '(cui asc)) + lui)) + +(defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil)) + "Return list of cui that match word, optionally use SQL's LIKE syntax" + (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t + :lrl 'klrl :order '(cui asc)) + sui)) + (defun find-ustr-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl @@ -715,9 +748,9 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ))) (defun find-lwd-wrd (wrd) - (make-instance 'lwd :wrd + (make-instance 'lwd :wrd wrd :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd) - (ensure-integer eui)))) + (ensure-integer eui)))) ;;; Semantic Network SQL access functions @@ -748,3 +781,104 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-sstr-styrl (styrl) (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl) (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls))) + + +;;; ************************** +;;; Local Classes +;;; ************************** + + +(defun make-ustats () + (with-sql-connection (conn) + (ignore-errors (sql-execute "drop table USTATS" conn)) + (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn) + + (dotimes (srl 4) + (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl) + (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl) + (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl) + (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl) + (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl) + (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl) + (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl) + (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl) + (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl) + (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl) + (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl) + (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl) + (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl) + (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl) + (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl) + (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl) + (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl) + (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl) + (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl)) + (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn)) + (find-ustats-all)) + +(defun insert-ustats-count (conn name table count-variable srl-control srl) + (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl)) + +(defun find-count-table (conn table srl count-variable srl-control) + (cond + ((stringp srl-control) + (ensure-integer + (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d" + count-variable table srl-control srl) + conn)))) + ((null srl-control) + (ensure-integer + (caar (sql-query (format nil "select count(~a) from ~a" + count-variable table ) + conn)))) + (t + (error "Unknown srl-control") + 0))) + +(defun insert-ustats (conn name count srl) + (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)" + name count (if srl srl 3)) + conn)) + +(defun find-ustats-all (&key (srl *current-srl*)) + (if srl + (collect-umlisp-query (ustats (name count srl) nil srl srl + :order (name asc)) + (make-instance 'ustats :name name + :hits (ensure-integer count) + :srl (ensure-integer srl))) + (collect-umlisp-query (ustats (name count srl) nil nil nil + :order (name asc)) + (make-instance 'ustats :name name + :hits (ensure-integer count) + :srl (ensure-integer srl))))) + +(defun find-ustats-srl (srl) + (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc)) + (make-instance 'ustats :name name :hits (ensure-integer count)))) + + + +(defun find-bsab-sab (sab) + (collect-umlisp-query (bonus_sab (name count) nil sab sab :single t) + (make-instance 'bsab :sab sab :name name :hits (ensure-integer count)))) + +(defun find-bsab-all () + (collect-umlisp-query (bonus_sab (sab name count) nil nil nil :order (sab asc)) + (make-instance 'bsab :sab sab :name name :hits (ensure-integer count)))) + +(defun find-btty-tty (tty) + (collect-umlisp-query (bonus_tty (name count) nil tty tty :single t) + (make-instance 'btty :tty tty :name name :hits (ensure-integer count)))) + +(defun find-btty-all () + (collect-umlisp-query (bonus_tty (tty name count) nil nil nil :order (tty asc)) + (make-instance 'btty :tty tty :name name :hits (ensure-integer count)))) + +(defun find-brel-rel (rel) + (collect-umlisp-query (bonus_rel (sab sl rel rela count) nil rel rel) + (make-instance 'brel :sab sab :sl sl :rel rel :rela rela + :hits (ensure-integer count))))