sql-classes.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sql-classes.lisp
   6 ;;;; Purpose:       Routines for reading UMLS objects from SQL database
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: sql-classes.lisp,v 1.17 2003/05/02 21:24:19 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  15 ;;;; UMLisp users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the GNU General Public License.
  17 ;;;; *************************************************************************
  18
  19 (in-package :umlisp)
  20 (declaim (optimize (compilation-speed 0) (debug 3)))
  21
  22
  23 (defvar *current-srl* nil)
  24 (defun current-srl ()
  25   *current-srl*)
  26 (defun current-srl! (srl)
  27   (setq *current-srl* srl))
  28
  29 ;;; Object lookups
  30
  31 ;;; Lookup functions for uterms,ustr in ucons
  32
  33 (defun find-uterm-in-ucon (ucon lui)
  34   (find lui (s#term ucon) :key #'lui :test 'equal))
  35
  36 (defun find-ustr-in-uterm (uterm sui)
  37   (find sui (s#str uterm) :key #'sui :test 'equal))
  38
  39 (defun find-ustr-in-ucon (ucon sui)
  40   (let ((found-ustr nil))
  41     (dolist (uterm (s#term ucon))
  42       (unless found-ustr
  43         (dolist (ustr (s#str uterm))
  44           (unless found-ustr
  45             (when (string-equal sui (sui ustr))
  46               (setq found-ustr ustr))))))
  47     found-ustr))
  48
  49 (defmacro with-umlisp-query ((table fields srl where-name where-value
  50                             &key (lrlname "KCUILRL") distinct single terminal like)
  51                              &body body)
  52   (let ((query (gensym)))
  53     `(unless (and ,where-name (not ,where-value))
  54        (let ((,query (umlisp-query ,table ,fields ,srl ,where-name ,where-value
  55                                    :lrlname ,lrlname :single ,single :distinct ,distinct
  56                                    :terminal ,terminal :like ,like)))
  57          (if ,single
  58              (let ((tuple (car ,query)))
  59                (when tuple
  60                  ,@body))
  61            (loop
  62                for tuple in ,query
  63                collect
  64                  ,@body))))))
  65
  66 (defun umlisp-query (table fields srl where-name where-value
  67                      &key (lrlname "KCUILRL") single distinct terminal like)
  68   "Query the UMLisp database. Return a list of umlisp objects whose name
  69 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
  70   (when (or (not where-name) where-value)
  71     (mutex-sql-query
  72      (query-string table fields srl where-name where-value
  73                    :lrlname lrlname :single single :distinct distinct :terminal terminal :like like))))
  74
  75
  76 (defun query-string (table fields &optional srl where-name where-value
  77                      &key (lrlname "KCUILRL") single distinct terminal like)
  78   (let ((qs (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
  79                     (if distinct "distinct " "")
  80                     fields table)))
  81     (when where-name
  82       (setq qs (concatenate 'string qs
  83                             (format nil
  84                                     (if (stringp where-value)
  85                                         (if like
  86                                             " where ~A like '%~A%'"
  87                                           " where ~A='~A'")
  88                                       " where ~A=~A")
  89                                     where-name  where-value))))
  90     (when srl
  91       (setq qs (concatenate 'string qs (format nil " and ~:@(~A~) <= ~D"
  92                                                lrlname srl))))
  93     (when terminal
  94       (setq qs (concatenate 'string qs " " terminal)))
  95     (when single
  96       (setq qs (concatenate 'string qs " limit 1")))
  97     qs))
  98
  99 (defun find-ucon-cui (cui &key (srl *current-srl*))
 100   "Find ucon for a cui"
 101   (with-umlisp-query ('mrcon '(kpfstr kcuilrl) srl 'cui (parse-cui cui) :single t)
 102     (make-instance 'ucon :cui (parse-cui cui)
 103                    :pfstr (car tuple)
 104                    :lrl (ensure-integer (cadr tuple)))))
 105
 106
 107 (defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*))
 108   "Find ucon for a cui"
 109   (with-umlisp-query ('mrcon '(kcuilrl) srl 'cui (parse-cui cui) :single t)
 110     (make-instance 'ucon :cui (parse-cui cui)
 111                    :lrl (ensure-integer (car tuple))
 112                    :pfstr nil)))
 113
 114 (defun find-pfstr-cui (cui &key (srl *current-srl*))
 115   "Find preferred string for a cui"
 116   (with-umlisp-query ('mrcon '(kpfstr) srl 'cui (parse-cui cui) :single t)
 117     (car tuple)))
 118
 119 (defun find-ucon-lui (lui &key (srl *current-srl*))
 120   "Find list of ucon for lui"
 121   (with-umlisp-query ('mrcon '(cui kpfstr kcuilrl) srl 'lui (parse-lui lui) :distinct t)
 122     (destructuring-bind (cui pfstr lrl) tuple
 123       (make-instance 'ucon :cui (ensure-integer cui)
 124                      :pfstr pfstr
 125                      :lrl (ensure-integer lrl)))))
 126
 127 (defun find-ucon-sui (sui &key (srl *current-srl*))
 128   "Find list of ucon for sui"
 129   (with-umlisp-query ('mrcon '(cui kpfstr kcuilrl) srl 'sui (parse-sui sui) :distinct t)
 130     (destructuring-bind (cui pfstr lrl) tuple
 131       (make-instance 'ucon :cui (ensure-integer cui)
 132                      :pfstr pfstr
 133                      :lrl (ensure-integer lrl)))))
 134
 135 (defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
 136   "Find ucon for cui/sui"
 137   (when (and cui sui)
 138     (with-umlisp-query ('mrcon '(cui kpfstr kcuilrl) srl 'kcuisui
 139                                (make-cuisui (parse-cui cui) (parse-sui sui)))
 140       (destructuring-bind (cui pfstr lrl) tuple
 141         (make-instance 'ucon :cui (ensure-integer cui)
 142                        :pfstr pfstr
 143                        :lrl (ensure-integer lrl))))))
 144
 145 (defun find-ucon-str (str &key (srl *current-srl*))
 146   "Find ucon that are exact match for str"
 147   (with-umlisp-query ('mrcon '(cui kpfstr kcuilrl) srl 'str str :distinct t)
 148     (destructuring-bind (cui pfstr lrl) tuple
 149       (make-instance 'ucon :cui (ensure-integer cui)
 150                      :pfstr pfstr
 151                      :lrl (ensure-integer lrl)))))
 152
 153 (defun find-ucon-all (&key (srl *current-srl*))
 154   "Return list of all ucon's"
 155   (with-sql-connection (db)
 156     (clsql:map-query
 157      'list
 158      #'(lambda (cui pfstr cuilrl)
 159          (make-instance 'ucon :cui (ensure-integer cui)
 160                         :pfstr pfstr
 161                         :lrl (ensure-integer cuilrl)))
 162      (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :terminal "order by CUI asc" :distinct t)
 163      :database db)))
 164
 165 (defun map-ucon-all (fn &key (srl *current-srl*))
 166   "Map a function over all ucon's"
 167   (with-sql-connection (db)
 168     (clsql:map-query
 169      nil
 170      #'(lambda (cui pfstr cuilrl)
 171          (funcall fn
 172                   (make-instance 'ucon :cui (ensure-integer cui)
 173                                  :pfstr pfstr
 174                                  :lrl (ensure-integer cuilrl))))
 175      (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :terminal "order by CUI asc" :distinct t)
 176      :database db)))
 177
 178
 179 (defun find-udef-cui (cui &key (srl *current-srl*))
 180   "Return a list of udefs for cui"
 181   (with-umlisp-query ('mrdef '(sab def) srl 'cui (parse-cui cui) :lrlname "KSRL")
 182     (destructuring-bind (sab def) tuple
 183       (make-instance 'udef :sab sab :def def))))
 184
 185 (defun find-usty-cui (cui &key (srl *current-srl*))
 186   "Return a list of usty for cui"
 187   (with-umlisp-query ('mrsty '(tui sty) srl 'cui (parse-cui cui) :lrlname "KLRL")
 188     (destructuring-bind (tui sty) tuple
 189       (make-instance 'usty :tui (ensure-integer tui) :sty sty))))
 190
 191 (defun find-usty-word (word &key (srl *current-srl*))
 192   "Return a list of usty that match word"
 193   (with-umlisp-query ('mrsty '(tui sty) srl 'sty word :lrlname 'klrl :like t :distinct t)
 194     (destructuring-bind (tui sty) tuple
 195         (make-instance 'usty :tui (ensure-integer tui) :sty sty))))
 196
 197 (defun find-urel-cui (cui &key (srl *current-srl*))
 198   "Return a list of urel for cui"
 199   (with-umlisp-query ('mrrel '(rel cui2 rela sab sl mg kpfstr2) srl 'cui1 (parse-cui cui) :lrlname "KSRL")
 200     (destructuring-bind (rel cui2 rela sab sl mg pfstr2) tuple
 201       (make-instance 'urel :cui1 (parse-cui cui) :rel rel :cui2 (ensure-integer cui2) :rela rela
 202                      :sab sab :sl sl :mg mg :pfstr2 pfstr2))))
 203
 204 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
 205   "Return a list of urel for cui2"
 206   (with-umlisp-query ('mrrel '(rel cui1 rela sab sl mg kpfstr2) srl 'cui2 (parse-cui cui2) :lrlname "KSRL")
 207     (destructuring-bind (rel cui1 rela sab sl mg pfstr2) tuple
 208       (make-instance 'urel :cui2 (parse-cui cui2) :rel rel :cui1 (ensure-integer cui1) :rela rela
 209                              :sab sab :sl sl :mg mg :pfstr2 pfstr2))))
 210
 211 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
 212   (mapcar
 213    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 214    (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
 215
 216 (defun find-ucoc-cui (cui &key (srl *current-srl*))
 217   "Return a list of ucoc for cui"
 218   (with-umlisp-query ('mrcoc '(cui2 soc cot cof coa kpfstr2) srl 'cui1 (parse-cui cui)
 219                              :lrlname "KSRL" :terminal "order by COF asc")
 220     (destructuring-bind (cui2 soc cot cof coa pfstr2) tuple
 221       (setq cui2 (ensure-integer cui2))
 222       (when (zerop cui2) (setq cui2 nil))
 223       (make-instance 'ucoc :cui1 (parse-cui cui) :cui2 (ensure-integer cui2) :soc soc :cot cot
 224                      :cof (ensure-integer cof) :coa coa :pfstr2 pfstr2))))
 225
 226 (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
 227   "Return a list of ucoc for cui2"
 228   (with-umlisp-query ('mrcoc '(cui1 soc cot cof coa kpfstr2) srl 'cui2 (parse-cui cui2)
 229                              :lrlname "KSRL" :terminal "order by COF asc")
 230     (destructuring-bind (cui1 soc cot cof coa pfstr2) tuple
 231       (setq cui2 (ensure-integer cui2))
 232       (when (zerop cui2) (setq cui2 nil))
 233       (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 (parse-cui cui2) :soc soc :cot cot
 234                      :cof (ensure-integer cof) :coa coa :pfstr2 pfstr2))))
 235
 236 (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
 237   "List of ucon with co-occurance cui2"
 238   (mapcar
 239    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 240    (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
 241
 242 (defun find-ulo-cui (cui &key (srl *current-srl*))
 243   "Return a list of ulo for cui"
 244   (with-umlisp-query ('mrlo '(isn fr un sui sna soui) srl 'cui (parse-cui cui) :lrlname "KLRL")
 245       (destructuring-bind (isn fr un sui sna soui) tuple
 246         (make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un :sui (ensure-integer sui) :sna sna
 247                              :soui soui))))
 248
 249 (defgeneric suistr (lo))
 250 (defmethod suistr ((lo ulo))
 251   "Return the string for a ulo object"
 252   (find-string-sui (sui lo)))
 253
 254 (defun find-uatx-cui (cui &key (srl *current-srl*))
 255   "Return a list of uatx for cui"
 256   (with-umlisp-query ('mratx '(sab rel atx) srl 'cui (parse-cui cui) :lrlname 'ksrl)
 257     (destructuring-bind (sab rel atx) tuple
 258       (make-instance 'uatx :sab sab :rel rel :atx atx))))
 259
 260
 261 (defun find-uterm-cui (cui &key (srl *current-srl*))
 262   "Return a list of uterm for cui"
 263   (with-umlisp-query ('mrcon '(lui lat ts kluilrl) srl 'cui (parse-cui cui) :lrlname 'kluilrl
 264                              :distinct t)
 265     (destructuring-bind (lui lat ts lrl) tuple
 266       (make-instance 'uterm :lui (ensure-integer lui) :cui (parse-cui cui)
 267                      :lat lat :ts ts :lrl (ensure-integer lrl)))))
 268
 269 (defun find-uterm-lui (lui &key (srl *current-srl*))
 270   "Return a list of uterm for lui"
 271   (with-umlisp-query ('mrcon '(cui lat ts kluilrl) srl 'lui (parse-lui lui)
 272                              :lrlname 'kluilrl :distinct t)
 273     (destructuring-bind (cui lat ts lrl) tuple
 274       (make-instance 'uterm :cui (ensure-integer cui) :lui (parse-lui lui)
 275                      :lat lat :ts ts :lrl (ensure-integer lrl)))))
 276
 277
 278 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
 279   "Return single uterm for cui/lui"
 280   (with-umlisp-query ('mrcon '(lat ts kluilrl) srl 'kcuilui
 281                              (make-cuilui (parse-cui cui) (parse-lui lui))
 282                              :lrlname 'kluilrl :single t)
 283     (destructuring-bind (lat ts lrl) tuple
 284       (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts :lrl (ensure-integer lrl)))))
 285
 286 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
 287   "Return a list of ustr for cui/lui"
 288   (with-umlisp-query ('mrcon '(sui stt str lrl) srl 'kcuilui (make-cuilui cui lui) :lrlname 'lrl)
 289     (destructuring-bind (sui stt str lrl) tuple
 290       (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
 291                      :cuisui (make-cuisui cui sui) :stt stt :str str
 292                      :lrl (ensure-integer lrl)))))
 293
 294 (defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
 295   "Return the single ustr for cuisui"
 296   (with-umlisp-query ('mrcon '(lui stt str lrl) srl 'kcuisui (make-cuisui cui sui) :lrlname 'lrl :single t)
 297     (destructuring-bind (lui stt str lrl) tuple
 298       (make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui)
 299                      :lui (ensure-integer lui) :stt stt :str str :lrl (ensure-integer lrl)))))
 300
 301 (defun find-ustr-sui (sui &key (srl *current-srl*))
 302   "Return the list of ustr for sui"
 303   (with-umlisp-query ('mrcon '(cui lui stt str lrl) srl 'sui (parse-sui sui) :lrlname 'lrl)
 304     (destructuring-bind (cui lui stt str lrl) tuple
 305       (make-instance 'ustr :sui sui :cui cui :stt stt :str str
 306                      :cuisui (make-cuisui (ensure-integer cui) (parse-sui sui))
 307                      :lui (ensure-integer lui)
 308                      :lrl (ensure-integer lrl)))))
 309
 310 (defun find-ustr-sab (sab &key (srl *current-srl*))
 311   "Return the list of ustr for sab"
 312   (with-umlisp-query ('mrso '(kcuisui) srl 'sab sab :lrlname 'srl)
 313     (let ((cuisui (ensure-integer (car tuple))))
 314       (apply #'find-ustr-cuisui
 315              (append
 316               (multiple-value-list (decompose-cuisui cuisui)) (list :srl srl))))))
 317
 318 (defun find-ustr-all (&key (srl *current-srl*))
 319   "Return list of all ustr's"
 320     (with-sql-connection (db)
 321       (clsql:map-query
 322        'list
 323        #'(lambda (cui lui sui stt lrl pfstr)
 324            (setq cui (ensure-integer cui))
 325            (setq lui (ensure-integer lui))
 326            (setq sui (ensure-integer sui))
 327            (setq lrl (ensure-integer lrl))
 328            (make-instance 'ustr :cui cui
 329                           :lui lui
 330                           :sui sui
 331                           :cuisui (make-cuisui cui sui)
 332                           :stt stt
 333                           :lrl lrl
 334                           :str pfstr))
 335        (query-string 'mrcon '(cui lui sui stt lrl kpfstr) srl nil nil :lrlname 'lrl :distinct t
 336                      :terminal "order by SUI asc")
 337        :database db)))
 338
 339 (defun find-string-sui (sui &key (srl *current-srl*))
 340   "Return the string associated with sui"
 341   (with-umlisp-query ('mrcon '(str) srl 'sui sui :lrlname 'lrl :single t)
 342     (car tuple)))
 343
 344 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
 345   (with-umlisp-query ('mrso '(sab code srl tty) srl 'kcuisui (make-cuisui cui sui) :lrlname 'srl)
 346     (destructuring-bind (sab code srl tty) tuple
 347       (make-instance 'uso :sab sab :code code :srl srl :tty tty))))
 348
 349 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
 350   (with-umlisp-query ('mrcxt '(sab code cxn cxl rnk cxs cui2 hcd rela cx) srl 'kcuisui
 351                              (make-cuisui cui sui) :lrlname 'ksrl)
 352     (destructuring-bind (sab code cxn cxl rnk cxs cui2 hcd rela xc) tuple
 353       (make-instance 'ucxt :sab sab :code code
 354                      :cxn (ensure-integer cxn)
 355                      :cxl cxl :cxs cxs :hcd hcd :rela rela :xc xc
 356                      :rnk (ensure-integer rnk)
 357                      :cui2 (ensure-integer cui2)))))
 358
 359 (defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
 360   (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where ")))
 361     (cond
 362      (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui))))
 363      (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui))))
 364      (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui))))
 365     (when srl
 366         (string-append ls (format nil " and KSRL <= ~d" srl)))
 367     (let ((usats '()))
 368       (dolist (tuple (mutex-sql-query ls))
 369         (destructuring-bind (code atn sab atv) tuple
 370           (push (make-instance 'usat :code code :atn atn :sab sab :atv atv)
 371                 usats)))
 372       (nreverse usats))))
 373
 374
 375 (defun find-usty-tui (tui)
 376   "Find usty for tui"
 377   (with-umlisp-query ('mrsty '(sty) nil 'tui (parse-tui tui) :single t)
 378     (make-instance 'usty :tui (parse-tui tui) :sty (car tuple))))
 379
 380 (defun find-usty-sty (sty)
 381   "Find usty for a sty"
 382   (with-umlisp-query ('mrsty '(tui) nil 'sty sty :single t)
 383     (make-instance 'usty :tui (ensure-integer (car tuple)) :sty sty)))
 384
 385 (defun find-usty-all ()
 386   "Return list of usty's for all semantic types"
 387   (with-umlisp-query ('mrsty '(tui) nil nil nil :distinct t)
 388     (find-usty-tui (car tuple))))
 389
 390 (defun find-usab-all ()
 391   "Find usab for a key"
 392   (with-umlisp-query ('mrsab '(vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) nil nil nil)
 393     (destructuring-bind
 394         (vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) tuple
 395       (make-instance 'usab :vcui (ensure-integer vcui)
 396                      :rcui (ensure-integer rcui)
 397                      :vsab vsab :rsab rsab :son son :sf sf :sver sver :mstart mstart
 398                      :mend mend :imeta imeta :rmeta rmeta :slc slc :scc scc
 399                      :srl (ensure-integer srl)
 400                      :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 401                      :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 402                      :curver curver :sabin sabin))))
 403
 404 (defun find-usab-by-key (key-name key)
 405   "Find usab for a key"
 406   (with-umlisp-query ('mrsab '(vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) nil key-name key :single t)
 407     (destructuring-bind
 408         (vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) tuple
 409       (make-instance 'usab :vcui (ensure-integer vcui)
 410                      :rcui (ensure-integer rcui)
 411                      :vsab vsab :rsab rsab :son son :sf sf :sver sver :mstart mstart
 412                      :mend mend :imeta imeta :rmeta rmeta :slc slc :scc scc
 413                      :srl (ensure-integer srl)
 414                      :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 415                      :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 416                      :curver curver :sabin sabin))))
 417
 418 (defun find-usab-rsab (rsab)
 419   "Find usab for rsab"
 420   (find-usab-by-key "RSAB" rsab))
 421
 422 (defun find-usab-vsab (vsab)
 423   "Find usab for vsab"
 424   (find-usab-by-key "VSAB" vsab))
 425
 426 (defun find-cui-max ()
 427   (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 428
 429 ;;;; Cross table find functions
 430
 431 (defun find-ucon-tui (tui &key (srl *current-srl*))
 432   "Find list of ucon for tui"
 433   (with-umlisp-query ('mrsty '(cui) srl 'tui (parse-tui tui) :lrlname 'klrl :terminal "order by cui desc")
 434     (find-ucon-cui (ensure-integer (car tuple)) :srl srl)))
 435
 436 (defun find-ucon-word (word &key (srl *current-srl*) (like nil))
 437   "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
 438   (let ((ucons '())
 439         (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'"
 440                     (if like " LIKE " "=")
 441                     word)))
 442     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 443     (string-append ls " order by cui desc")
 444     (dolist (tuple (mutex-sql-query ls))
 445       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 446     ucons))
 447
 448 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 449   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 450   (let ((ucons '())
 451         (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'"
 452                     (if like " LIKE " "=")
 453                     word)))
 454     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 455     (string-append ls " order by cui desc")
 456     (dolist (tuple (mutex-sql-query ls))
 457       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 458     ucons))
 459
 460 (defun find-ustr-word (word &key (srl *current-srl*))
 461   "Return list of ustrs that match word"
 462   (with-umlisp-query ('mrxw_eng '(cui sui) srl 'wd word
 463                                 :lrlname 'klrl
 464                                 :terminal "order by cui desc, sui desc")
 465     (destructuring-bind (cui sui) tuple
 466       (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))))
 467
 468 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 469   "Return list of ustrs that match word"
 470   (with-umlisp-query ('mrxnw_eng '(cui sui) srl 'nwd word :lrlname 'klrl
 471                                  :terminal "order by cui desc, sui desc")
 472     (destructuring-bind (cui sui) tuple
 473       (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) ;srl srl))))
 474
 475 ;; Special tables
 476
 477 (defun find-usrl-all ()
 478   (with-umlisp-query ('usrl '(sab srl) nil nil nil :terminal "order by sab desc")
 479     (destructuring-bind (sab srl) tuple
 480       (make-instance 'usrl :sab sab :srl (ensure-integer srl)) usrls)))
 481
 482 ;;; Multiword lookup and score functions
 483
 484 (defun find-ucon-multiword (str &key (srl *current-srl*))
 485   "Return sorted list of ucon's that match a multiword string"
 486   (let* ((words (delimited-string-to-list str #\space))
 487          (ucons '()))
 488     (dolist (word words)
 489       (setq ucons (append ucons (find-ucon-word word :srl srl))))
 490     (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
 491
 492 (defun find-ustr-multiword (str &key (srl *current-srl*))
 493   "Return sorted list of ustr's that match a multiword string"
 494   (let* ((words (delimited-string-to-list str #\space))
 495          (ustrs '()))
 496     (dolist (word words)
 497       (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
 498     (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
 499
 500 (defun sort-score-ucon-str (str ucons)
 501   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 502   (sort-score-umlsclass-str ucons str #'pfstr))
 503
 504 (defun sort-score-ustr-str (str ustrs)
 505   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 506   (sort-score-umlsclass-str ustrs str #'str))
 507
 508 (defun sort-score-umlsclass-str (objs str lookup-func)
 509   "Sort a list of objects based on scoring to a string"
 510   (let ((scored '()))
 511     (dolist (obj objs)
 512       (push
 513        (list obj
 514              (score-multiword-match str (funcall lookup-func obj)))
 515        scored))
 516     (mapcar #'car (sort scored #'> :key #'cadr))))
 517
 518 (defun score-multiword-match (s1 s2)
 519   "Score a match between two strings with s1 being reference string"
 520   (let* ((word-list-1 (delimited-string-to-list s1 #\space))
 521          (word-list-2 (delimited-string-to-list s2 #\space))
 522          (n1 (length word-list-1))
 523          (n2 (length word-list-2))
 524          (unmatched n1)
 525          (score 0)
 526          (nlong 0)
 527          (nshort 0)
 528          short-list long-list)
 529     (declare (fixnum n1 n2 nshort nlong score unmatched))
 530     (if (> n1 n2)
 531         (progn
 532           (setq nlong n1)
 533           (setq nshort n2)
 534           (setq long-list word-list-1)
 535           (setq short-list word-list-2))
 536       (progn
 537         (setq nlong n2)
 538         (setq nshort n1)
 539         (setq long-list word-list-2)
 540         (setq short-list word-list-1)))
 541     (decf score (- nlong nshort)) ;; reduce score for extra words
 542     (dotimes (iword nshort)
 543       (declare (fixnum iword))
 544       (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
 545            (progn
 546              (incf score (- 10 (abs (- kmrcl::it iword))))
 547              (decf unmatched))))
 548     (decf score (* 2 unmatched))
 549     score))
 550
 551
 552 ;;; LEX SQL functions
 553
 554 (defun find-lexterm-eui (eui)
 555   (with-umlisp-query ('lrwd '(wrd) nil 'eui eui :single t)
 556     (make-instance 'lexterm :eui eui :wrd (car tuple))))
 557
 558 (defun find-lexterm-word (wrd)
 559   (with-umlisp-query ('lrwd '(eui) nil 'wrd wrd)
 560     (make-instance 'lexterm :eui (ensure-integer (car tuple))
 561                    :wrd (copy-seq wrd))))
 562
 563 ;; LEX SQL Read functions
 564
 565 (defun find-labr-eui (eui)
 566   (with-umlisp-query ('lrabr '(bas abr eui2 bas2) nil 'eui eui)
 567     (destructuring-bind (bas abr eui2 bas2) tuple
 568       (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
 569                      :eui2 (ensure-integer eui2)))))
 570
 571 (defun find-labr-bas (bas)
 572   (with-umlisp-query ('labr '(eui abr eui2 bas2) nil 'bas bas)
 573     (destructuring-bind (eui abr eui2 bas2) tuple
 574       (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
 575                      :bas (copy-seq bas) :eui2 (ensure-integer eui2)))))
 576
 577 (defun find-lagr-eui (eui)
 578   (with-umlisp-query ('lragr '(str sca agr cit bas) nil 'eui eui)
 579     (destructuring-bind (str sca agr cit bas) tuple
 580       (make-instance 'lagr :eui eui :str str :sca sca :agr agr
 581                      :cit cit :bas bas))))
 582
 583 (defun find-lcmp-eui (eui)
 584   (with-umlisp-query ('lrcmp '(bas sca com) nil 'eui eui)
 585     (destructuring-bind (bas sca com) tuple
 586       (make-instance 'lcmp :eui eui :bas bas :sca sca :com com))))
 587
 588 (defun find-lmod-eui (eui)
 589   (with-umlisp-query ('lrmod '(bas sca psn_mod fea) nil 'eui eui)
 590     (destructuring-bind (bas sca psnmod fea) tuple
 591       (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psnmod :fea fea))))
 592
 593 (defun find-lnom-eui (eui)
 594   (with-umlisp-query ('lrnom '(bas sca eui2 bas2 sca2) nil 'eui eui)
 595       (destructuring-bind (bas sca eui2 bas2 sca2) tuple
 596         (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
 597                        :eui2 (ensure-integer eui2)))))
 598
 599 (defun find-lprn-eui (eui)
 600   (with-umlisp-query ('lrprn '(bas num gnd cas pos qnt fea) nil 'eui eui)
 601     (destructuring-bind (bas num gnd cas pos qnt fea) tuple
 602       (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
 603                      :cas cas :pos pos :qnt qnt :fea fea))))
 604
 605 (defun find-lprp-eui (eui)
 606   (with-umlisp-query ('lrprp '(bas str sca fea) nil 'eui eui)
 607     (destructuring-bind (bas str sca fea) tuple
 608       (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea))))
 609
 610 (defun find-lspl-eui (eui)
 611   (with-umlisp-query ('lrspl '(spv bas) nil 'eui eui)
 612     (destructuring-bind (spv bas) tuple
 613       (make-instance 'lspl :eui eui :spv spv :bas bas))))
 614
 615 (defun find-ltrm-eui (eui)
 616   (with-umlisp-query ('lrtrm '(bas gen) nil 'eui eui)
 617     (make-instance 'ltrm :eui eui :bas bas :gen gen)))
 618
 619 (defun find-ltyp-eui (eui)
 620   (with-umlisp-query ('lrtyp '(bas sca typ) nil 'eui eui)
 621     (destructuring-bind (bas sca typ) tuple
 622       (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ))))
 623
 624 (defun find-lwd-wrd (wrd)
 625   (make-instance 'lwd :wrd
 626                  :euilist (with-umlisp-query ('lrwd '(eui) nil 'wrd wrd)
 627                             (ensure-integer (car tuple)))))
 628
 629 ;;; Semantic Network SQL access functions
 630
 631 (defun find-sdef-ui (ui)
 632   (with-umlisp-query ('srdef '(rt sty_rl stn_rtn def ex un rh abr rin)
 633                              nil 'ui ui :single t)
 634     (destructuring-bind (rt styrl stnrtn def ex un rh abr rin) tuple
 635       (make-instance 'sdef :rt rt :ui ui :styrl styrl :stnrtn stnrtn
 636                      :def def :ex ex :un un :rh rh :abr abr :rin rin))))
 637
 638 (defun find-sstre1-ui (ui)
 639   (with-umlisp-query ('srstre1 '(ui2 ui3) nil 'ui ui)
 640     (destructuring-bind (ui2 ui3) tuple
 641       (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
 642                      :ui3 (ensure-integer ui3)))))
 643
 644 (defun find-sstre1-ui2 (ui2)
 645   (with-umlisp-query ('srstre1 '(ui ui3) nil 'ui2 ui2)
 646     (destructuring-bind (ui ui3) tuple
 647       (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
 648                      :ui3 (ensure-integer ui3)))))
 649
 650 (defun find-sstr-rl (rl)
 651   (with-umlisp-query ('srstre '(sty_rl sty_rl2 ls) nil 'rl rl)
 652     (destructuring-bind (styrl styrl2 ls) tuple
 653       (make-instance 'sstr :rl rl :styrl styrl :styrl2 styrl2 :ls ls))))
 654
 655 (defun find-sstre2-sty (sty)
 656   (with-umlisp-query ('srstre2 '(rl sty2) nil 'sty sty)
 657     (destructuring-bind (rl sty2) tuple
 658       (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2))))
 659
 660 (defun find-sstr-styrl (styrl)
 661   (with-umlisp-query ('srstr '(rl sty_rl2 ls) nil 'styrl styrl)
 662     (destructuring-bind (rl styrl2 ls) tuple
 663       (make-instance 'sstr :styrl styrl :rl rl :styrl2 styrl2 :ls ls))))