sql-classes.lisp

   1 ;;; $Id: sql-classes.lisp,v 1.1 2002/10/08 22:08:56 kevin Exp $
   2
   3 (in-package :umlisp)
   4
   5 (declaim (optimize (speed 3) (safety 1)))
   6
   7 (defvar *current-srl* nil)
   8 (defun current-srl ()
   9   *current-srl*)
  10 (defun current-srl! (srl)
  11   (setq *current-srl* srl))
  12
  13
  14 ;;; Accessors (read on demand)
  15
  16 ;; defines a slot-unbound method for class and slot-name, fills
  17 ;; the slot by calling reader function with the slot values of
  18 ;; the instance's reader-keys
  19 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
  20   (let* ((the-slot-name (gensym))
  21          (the-class (gensym))
  22          (the-instance (gensym))
  23          (keys '()))
  24     (dolist (key reader-keys)
  25       (push (list 'slot-value the-instance (list 'quote key)) keys))
  26     (setq keys (nreverse keys))
  27     `(defmethod slot-unbound (,the-class (,the-instance ,class)
  28                                          (,the-slot-name (eql ',slot-name)))
  29        (declare (ignore ,the-class))
  30        (setf (slot-value ,the-instance ,the-slot-name)
  31            (,reader ,@keys)))))
  32
  33 (def-lazy-reader ucon s#term find-uterm-cui cui)
  34 (def-lazy-reader ucon s#def find-udef-cui cui)
  35 (def-lazy-reader ucon s#sty find-usty-cui cui)
  36 (def-lazy-reader ucon s#rel find-urel-cui cui)
  37 (def-lazy-reader ucon s#coc find-ucoc-cui cui)
  38 (def-lazy-reader ucon s#lo find-ulo-cui cui)
  39 (def-lazy-reader ucon s#atx find-uatx-cui cui)
  40 (def-lazy-reader ucon s#sat find-usat-ui cui)
  41
  42 ;; For uterms
  43 (def-lazy-reader uterm s#str find-ustr-cuilui cui lui)
  44 (def-lazy-reader uterm s#sat find-usat-ui cui lui)
  45
  46 ;; For ustrs
  47 (def-lazy-reader ustr s#sat find-usat-ui cui lui sui)
  48 (def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui)
  49 (def-lazy-reader ustr s#so find-uso-cuisui cui sui)
  50
  51 ;;; Object lookups
  52
  53 ;;; Lookup functions for uterms,ustr in ucons
  54
  55 (defun find-uterm-in-ucon (ucon lui)
  56   (find lui (s#term ucon) :key #'uterm-lui :test 'equal))
  57
  58 (defun find-ustr-in-uterm (uterm sui)
  59   (find sui (s#str uterm) :key #'ustr-sui :test 'equal))
  60
  61 (defun find-ustr-in-ucon (ucon sui)
  62   (let ((found-ustr nil))
  63     (dolist (uterm (s#term ucon))
  64       (unless found-ustr
  65         (dolist (ustr (s#str uterm))
  66           (unless found-ustr
  67             (when (string-equal sui (sui ustr))
  68               (setq found-ustr ustr))))))
  69     found-ustr))
  70
  71
  72 (defun find-ucon-cui (cui &key (srl *current-srl*))
  73   "Find ucon for a cui"
  74   (if (stringp cui)
  75       (setq cui (parse-cui cui)))
  76   (if cui
  77       (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d"
  78                         cui)))
  79         (if srl
  80             (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl))
  81           (string-append ls " limit 1"))
  82         (gu:awhen (car (mutex-sql-query ls))
  83                   (make-instance 'ucon :cui cui :pfstr (car gu::it)
  84                                  :lrl (ensure-integer (cadr gu::it)))))
  85     nil))
  86
  87 (defun find-ucon-lui (lui &key (srl *current-srl*))
  88   "Find list of ucon for lui"
  89   (if (stringp lui)
  90       (setq lui (parse-lui lui)))
  91   (if lui
  92       (let ((ucons '())
  93             (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui)))
  94         (if srl
  95             (string-append ls (format nil " and KCUILRL <= ~d" srl)))
  96         (dolist (tuple (mutex-sql-query ls))
  97           (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
  98                                :pfstr (nth 1 tuple)
  99                                :lrl (ensure-integer (nth 2 tuple)))
 100                 ucons))
 101         (nreverse ucons))
 102     nil))
 103
 104 (defun find-ucon-sui (sui &key (srl *current-srl*))
 105   "Find list of ucon for sui"
 106   (if (stringp sui)
 107       (setq sui (parse-sui sui)))
 108   (if sui
 109       (let ((ucons '())
 110             (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui)))
 111         (when srl
 112             (string-append ls (format nil " and KCUILRL <= ~d" srl)))
 113         (let ((tuples (mutex-sql-query ls)))
 114           (dolist (tuple tuples)
 115             (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
 116                                  :pfstr (nth 1 tuple)
 117                                  :lrl (ensure-integer (nth 2 tuple)))
 118                   ucons)))
 119     (nreverse ucons))
 120   nil))
 121
 122 (defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
 123   "Find ucon for cui/sui"
 124   (if (stringp cui)
 125       (setq cui (parse-cui cui)))
 126   (if (stringp sui)
 127       (setq sui (parse-sui sui)))
 128   (if (and cui sui)
 129       (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d"
 130                         (make-cuisui cui sui))))
 131         (when srl
 132             (string-append ls (format nil " and KCUILRL <= ~d" srl)))
 133         (gu:aif (car (mutex-sql-query ls))
 134              (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it))
 135                             :pfstr (nth 1 gu::it)
 136                             :lrl (ensure-integer (nth 2 gu::it)))
 137              nil))
 138     nil))
 139
 140 (defun find-ucon-str (str &key (srl *current-srl*))
 141   "Find ucon that are exact match for str"
 142   (if str
 143       (let ((ucons '())
 144             (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str)))
 145         (when srl
 146             (string-append ls " and KCUILRL <= ~d" srl))
 147         (dolist (tuple (mutex-sql-query ls))
 148           (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
 149                                :pfstr (nth 1 tuple)
 150                                :lrl (ensure-integer (nth 2 tuple))) ucons))
 151         (nreverse ucons))
 152     nil))
 153
 154 (defun find-ucon-all (&key (srl *current-srl*))
 155   "Return list of all ucon's"
 156   (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON"))
 157     (when srl
 158       (string-append ls (format nil " where KCUILRL <= ~d" srl)))
 159     (string-append ls " order by CUI asc")
 160     (with-sql-connection (db)
 161       (clsql:map-query
 162        'list
 163        #'(lambda (cui pfstr cuilrl)
 164            (make-instance 'ucon :cui (ensure-integer cui)
 165                           :pfstr pfstr
 166                           :lrl (ensure-integer cuilrl)))
 167        ls
 168        :database db))))
 169
 170
 171
 172 (defun find-udef-cui (cui &key (srl *current-srl*))
 173   "Return a list of udefs for cui"
 174   (let ((udefs '())
 175         (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui)))
 176     (when srl
 177         (string-append ls (format nil " and KSRL <= ~d" srl)))
 178     (dolist (tuple (mutex-sql-query ls))
 179       (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs))
 180     (nreverse udefs)))
 181
 182 (defun find-usty-cui (cui &key (srl *current-srl*))
 183   "Return a list of usty for cui"
 184   (let ((ustys '())
 185         (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui)))
 186     (when srl
 187         (string-append ls (format nil " and KLRL <= ~d" srl)))
 188     (dolist (tuple (mutex-sql-query ls))
 189       (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
 190     ustys))
 191
 192 (defun find-usty-word (word &key (srl *current-srl*))
 193   "Return a list of usty that match word"
 194   (let ((ustys '())
 195         (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word)))
 196     (when srl
 197         (string-append ls (format nil " and KLRL <= ~d" srl)))
 198     (dolist (tuple (mutex-sql-query ls))
 199       (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
 200     ustys))
 201
 202 (defun find-urel-cui (cui &key (srl *current-srl*))
 203   "Return a list of urel for cui"
 204   (let ((urels '())
 205         (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui)))
 206     (when srl
 207         (string-append ls (format nil " and KSRL <= ~d" srl)))
 208     (dolist (tuple (mutex-sql-query ls))
 209       (push (make-instance 'urel
 210               :cui1 cui
 211               :rel (nth 0 tuple)
 212               :cui2 (ensure-integer (nth 1 tuple))
 213               :rela (nth 2 tuple)
 214               :sab (nth 3 tuple)
 215               :sl (nth 4 tuple)
 216               :mg (nth 5 tuple)
 217               :pfstr2 (nth 6 tuple))
 218             urels))
 219     (nreverse urels)))
 220
 221 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
 222   "Return a list of urel for cui2"
 223   (let ((urels '())
 224         (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2)))
 225     (when srl
 226         (string-append ls (format nil " and SRL <= ~d" srl)))
 227     (dolist (tuple (mutex-sql-query ls))
 228       (push (make-instance 'urel
 229               :cui2 cui2
 230               :rel (nth 0 tuple)
 231               :cui1 (ensure-integer (nth 1 tuple))
 232               :rela (nth 2 tuple)
 233               :sab (nth 3 tuple)
 234               :sl (nth 4 tuple)
 235               :mg (nth 5 tuple)
 236               :pfstr2 (nth 6 tuple))
 237             urels))
 238     (nreverse urels)))
 239
 240 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
 241   (mapcar
 242    #'(lambda (cui) (find-ucon-cui cui :key srl))
 243    (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
 244
 245 (defun find-ucoc-cui (cui &key (srl *current-srl*))
 246   "Return a list of ucoc for cui"
 247   (let ((ucocs '())
 248         (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui)))
 249     (when srl
 250         (string-append ls (format nil " and KLRL <= ~d" srl)))
 251     (string-append ls " order by COF asc")
 252     (dolist (tuple (mutex-sql-query ls))
 253       (let ((cui2 (ensure-integer (nth 0 tuple))))
 254         (when (zerop cui2)
 255           (setq cui2 nil))
 256         (push (make-instance 'ucoc :cui1 cui
 257                              :cui2 cui2
 258                              :soc (nth 1 tuple)
 259                              :cot (nth 2 tuple)
 260                              :cof (ensure-integer (nth 3 tuple))
 261                              :coa (nth 4 tuple)
 262                              :pfstr2 (nth 5 tuple))
 263               ucocs)))
 264     ucocs)) ;; akready ordered by SQL select
 265
 266 (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
 267   "Return a list of ucoc for cui2"
 268   (let ((ucocs '())
 269         (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2)))
 270     (when srl
 271         (string-append ls (format nil " and KSRL <= ~d" srl)))
 272     (string-append ls " order by COF asc")
 273     (dolist (tuple (mutex-sql-query ls))
 274       (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple))
 275                            :cui2 cui2
 276                            :soc (nth 1 tuple)
 277                            :cot (nth 2 tuple)
 278                            :cof (ensure-integer (nth 3 tuple))
 279                            :coa (nth 4 tuple)
 280                            :pfstr2 (nth 5 tuple))
 281             ucocs))
 282     ucocs)) ;; already ordered by SQL select
 283
 284 (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
 285   "List of ucon with co-occurance cui2"
 286   (mapcar
 287    #'(lambda (cui) (find-ucon-cui cui :key srl))
 288    (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
 289
 290 (defun find-ulo-cui (cui &key (srl *current-srl*))
 291   "Return a list of ulo for cui"
 292   (let ((ulos '())
 293         (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui)))
 294     (when srl
 295         (string-append ls (format nil " and KLRL <= ~d" srl)))
 296     (dolist (tuple (mutex-sql-query ls))
 297       (push (make-instance 'ulo :isn (nth 0 tuple)
 298                            :fr (ensure-integer (nth 1 tuple))
 299                            :un (nth 2 tuple)
 300                            :sui (ensure-integer (nth 3 tuple))
 301                            :sna (nth 4 tuple)
 302                            :soui (nth 5 tuple))
 303             ulos))
 304     (nreverse ulos)))
 305
 306 (defmethod suistr ((lo ulo))
 307   "Return the string for a ulo object"
 308   (find-string-sui (sui lo)))
 309
 310 (defun find-uatx-cui (cui &key (srl *current-srl*))
 311   "Return a list of uatx for cui"
 312   (let ((uatxs '())
 313         (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui)))
 314     (when srl
 315         (string-append ls (format nil " and KSRL <= ~d" srl)))
 316     (dolist (tuple (mutex-sql-query ls))
 317       (push (make-instance 'uatx :sab (nth 0 tuple)
 318                            :rel (nth 1 tuple)
 319                            :atx (nth 2 tuple))
 320             uatxs))
 321     (nreverse uatxs)))
 322
 323
 324 (defun find-uterm-cui (cui &key (srl *current-srl*))
 325   "Return a list of uterm for cui"
 326   (let ((uterms '())
 327         (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui)))
 328     (when srl
 329         (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 330     (dolist (tuple (mutex-sql-query ls))
 331       (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple))
 332                            :cui cui
 333                            :lat (nth 1 tuple)
 334                            :ts (nth 2 tuple)
 335                            :lrl (ensure-integer (nth 3 tuple)))
 336         uterms))
 337     (nreverse uterms)))
 338
 339 (defun find-uterm-lui (lui &key (srl *current-srl*))
 340   "Return a list of uterm for lui"
 341   (if (stringp lui)
 342       (setq lui (parse-lui lui)))
 343   (let ((uterms '())
 344         (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui)))
 345     (when srl
 346         (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 347     (dolist (tuple (mutex-sql-query ls))
 348       (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple))
 349                            :lui lui
 350                            :lat (nth 1 tuple)
 351                            :ts (nth 2 tuple)
 352                            :lrl (ensure-integer (nth 3 tuple)))
 353             uterms))
 354     (nreverse uterms)))
 355
 356 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
 357   "Return single uterm for cui/lui"
 358   (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui))))
 359     (when srl
 360         (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 361     (gu:aif (car (mutex-sql-query ls))
 362          (make-instance 'uterm :cui cui
 363                         :lui lui
 364                         :lat (nth 0 gu::it)
 365                        :ts (nth 1 gu::it)
 366                        :lrl (ensure-integer (nth 2 gu::it)))
 367          nil)))
 368
 369 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
 370   "Return a list of ustr for cui/lui"
 371   (declare (fixnum cui lui))
 372   (let ((ustrs '())
 373         (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui))))
 374     (when srl
 375         (string-append ls (format nil " and LRL <= ~d" srl)))
 376     (dolist (tuple (mutex-sql-query ls))
 377       (let* ((sui (ensure-integer (car tuple)))
 378              (ustr (make-instance 'ustr :sui sui
 379                                   :cui cui
 380                                   :cuisui (make-cuisui cui sui)
 381                                   :lui lui
 382                                   :stt (nth 1 tuple)
 383                                   :str (nth 2 tuple)
 384                                   :lrl (ensure-integer (nth 3 tuple)))))
 385         (push ustr ustrs)))
 386     (nreverse ustrs)))
 387
 388 (defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
 389   "Return the single ustr for cuisui"
 390   (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d"
 391                     (make-cuisui cui sui))))
 392     (when srl
 393         (string-append ls (format nil " and LRL <= ~d" srl)))
 394     (gu:aif (car (mutex-sql-query ls))
 395          (make-instance 'ustr :sui sui
 396                         :cui cui
 397                         :cuisui (make-cuisui cui sui)
 398                         :lui (ensure-integer (nth 0 gu::it))
 399                         :stt (nth 1 gu::it)
 400                         :str (nth 2 gu::it)
 401                         :lrl (ensure-integer (nth 3 gu::it)))
 402          nil)))
 403
 404 (defun find-ustr-sui (sui &key (srl *current-srl*))
 405   "Return the list of ustr for sui"
 406   (if (stringp sui)
 407       (setq sui (parse-sui sui)))
 408   (let ((ustrs '())
 409         (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui)))
 410     (when srl
 411         (string-append ls (format nil " and LRL <= ~d" srl)))
 412     (dolist (tuple (mutex-sql-query ls))
 413       (let ((cui (ensure-integer (car tuple))))
 414         (push (make-instance 'ustr :sui sui
 415                              :cui cui
 416                              :cuisui (make-cuisui cui sui)
 417                              :lui (ensure-integer (nth 1 tuple))
 418                              :stt (nth 2 tuple)
 419                              :str (nth 3 tuple)
 420                              :lrl (ensure-integer (nth 4 tuple)))
 421         ustrs)))
 422     (nreverse ustrs)))
 423
 424 (defun find-ustr-sab (sab &key (srl *current-srl*))
 425   "Return the list of ustr for sab"
 426   (let ((ustrs '())
 427         (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab)))
 428     (when srl
 429         (string-append ls (format nil " and SRL <= ~d" srl)))
 430     (dolist (tuple (mutex-sql-query ls))
 431       (let ((cuisui (ensure-integer (car tuple))))
 432         (push (apply #'find-ustr-cuisui
 433                      (append
 434                       (multiple-value-list (decompose-cuisui cuisui))
 435                       (list :srl srl)))
 436               ustrs)))
 437     (nreverse ustrs)))
 438
 439 (defun find-ustr-all (&key (srl *current-srl*))
 440   "Return list of all ustr's"
 441   (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON"))
 442     (when srl
 443       (string-append ls (format nil " where LRL <= ~d" srl)))
 444     (string-append ls " order by SUI asc")
 445     (with-sql-connection (db)
 446       (clsql:map-query
 447        'list
 448        #'(lambda (cui lui sui stt lrl pfstr)
 449            (setq cui (ensure-integer cui))
 450            (setq lui (ensure-integer lui))
 451            (setq sui (ensure-integer sui))
 452            (setq lrl (ensure-integer lrl))
 453            (make-instance 'ustr :cui cui
 454                           :lui lui
 455                           :sui sui
 456                           :cuisui (make-cuisui cui sui)
 457                           :stt stt
 458                           :lrl lrl
 459                           :str pfstr))
 460        ls
 461        :database db))))
 462
 463 (defun find-string-sui (sui &key (srl *current-srl*))
 464   "Return the string associated with sui"
 465   (let ((ls (format nil "select STR from MRCON where SUI=~d" sui)))
 466     (when srl
 467       (string-append ls (format nil " and LRL <= ~d" srl)))
 468     (string-append ls " limit 1")
 469     (caar (mutex-sql-query ls))))
 470
 471 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
 472   (declare (fixnum cui sui))
 473   (let ((usos '())
 474         (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d"
 475                     (make-cuisui cui sui))))
 476     (when srl
 477         (string-append ls (format nil " and SRL <= ~d" srl)))
 478     (dolist (tuple (mutex-sql-query ls))
 479       (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple)
 480                            :srl (nth 2 tuple) :tty (nth 3 tuple))
 481             usos))
 482     (nreverse usos)))
 483
 484 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
 485   (declare (fixnum cui sui))
 486   (let ((ucxts '())
 487         (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d"
 488                     (make-cuisui cui sui))))
 489     (when srl
 490         (string-append ls (format nil " and KSRL <= ~d" srl)))
 491     (dolist (tuple (mutex-sql-query ls))
 492       (push (make-instance 'ucxt :sab (nth 0 tuple)
 493                            :code (nth 1 tuple)
 494                            :cxn (ensure-integer (nth 2 tuple))
 495                            :cxl (nth 3 tuple)
 496                            :rnk (ensure-integer (nth 4 tuple))
 497                            :cxs (nth 5 tuple)
 498                            :cui2 (ensure-integer (nth 6 tuple))
 499                            :hcd (nth 7 tuple)
 500                            :rela (nth 8 tuple)
 501                            :xc (nth 9 tuple))
 502             ucxts))
 503     (nreverse ucxts)))
 504
 505 (defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
 506   (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where ")))
 507     (cond
 508      (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui))))
 509      (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui))))
 510      (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui))))
 511     (when srl
 512         (string-append ls (format nil " and KSRL <= ~d" srl)))
 513     (let ((usats '()))
 514       (dolist (tuple (mutex-sql-query ls))
 515         (push (make-instance 'usat :code (nth 0 tuple)
 516                              :atn (nth 1 tuple)
 517                              :sab (nth 2 tuple)
 518                              :atv (nth 3 tuple))
 519               usats))
 520       (nreverse usats))))
 521
 522
 523 (defun find-pfstr-cui (cui)
 524   (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui))))
 525
 526 (defun find-usty-tui (tui)
 527   "Find usty for tui"
 528   (setq tui (parse-tui tui))
 529     (gu:aif (car (mutex-sql-query
 530                (format nil "select STY from MRSTY where TUI=~d limit 1" tui)))
 531          (make-instance 'usty :tui tui :sty (nth 0 gu::it))
 532          nil))
 533
 534 (defun find-usty-sty (sty)
 535   "Find usty for a sty"
 536   (gu:aif (car (mutex-sql-query
 537                 (format nil "select TUI from MRSTY where STY='~a' limit 1" sty)))
 538           (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty)
 539           nil))
 540
 541 (defun find-usty-all ()
 542   "Return list of usty's for all semantic types"
 543   (let ((ustys '()))
 544     (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
 545       (push (find-usty-tui (nth 0 tuple)) ustys))
 546     (nreverse ustys)))
 547
 548 (defun find-usty_freq-all ()
 549   (let ((usty_freqs '()))
 550     (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
 551       (let* ((tui (car tuple))
 552              (freq (ensure-integer
 553                      (caar (mutex-sql-query
 554                             (format nil "select count(*) from MRSTY where TUI=~a" tui))))))
 555         (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs)))
 556     (sort usty_freqs #'> :key #'usty_freq-freq)))
 557
 558
 559
 560
 561 (defun find-cui-max ()
 562   (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 563     (ensure-integer cui)))
 564
 565 ;;;; Cross table find functions
 566
 567 (defun find-ucon-tui (tui &key (srl *current-srl*))
 568   "Find list of ucon for tui"
 569   (when (stringp tui)
 570       (setq tui (parse-tui tui)))
 571   (let ((ucons '())
 572         (ls (format nil "select CUI from MRSTY where TUI=~d" tui)))
 573     (when srl
 574         (string-append ls (format nil " and KLRL <= ~d" srl)))
 575     (string-append ls " order by cui desc")
 576     (dolist (tuple (mutex-sql-query ls))
 577       (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons))
 578     ucons))
 579
 580 (defun find-ucon-word (word &key (srl *current-srl*) (like nil))
 581   "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
 582   (let ((ucons '())
 583         (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'"
 584                     (if like " LIKE " "=")
 585                     word)))
 586     (when srl
 587       (string-append ls (format nil " and KLRL <= ~d" srl)))
 588     (string-append ls " order by cui desc")
 589     (dolist (tuple (mutex-sql-query ls))
 590       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 591     ucons))
 592
 593 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 594   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 595   (let ((ucons '())
 596         (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'"
 597                     (if like " LIKE " "=")
 598                     word)))
 599     (when srl
 600       (string-append ls (format nil " and KLRL <= ~d" srl)))
 601     (string-append ls " order by cui desc")
 602     (dolist (tuple (mutex-sql-query ls))
 603       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 604     ucons))
 605
 606 (defun find-ustr-word (word &key (srl *current-srl*))
 607   "Return list of ustrs that match word"
 608   (let ((ustrs '())
 609         (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word)))
 610     (when srl
 611         (string-append ls (format nil " and KLRL <= ~d" srl)))
 612     (string-append ls " order by cui desc,sui desc")
 613     (dolist (tuple (mutex-sql-query ls))
 614       (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
 615             ustrs))
 616     ustrs))
 617
 618 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 619   "Return list of ustrs that match word"
 620   (let ((ustrs '())
 621         (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word)))
 622     (when srl
 623         (string-append ls (format nil " and KLRL <= ~d" srl)))
 624     (string-append ls " order by cui desc,sui desc")
 625     (dolist (tuple (mutex-sql-query ls))
 626       (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
 627             ustrs))
 628     ustrs))
 629
 630
 631 ;;; Multiword lookup and score functions
 632
 633 (defun find-ucon-multiword (str &key (srl *current-srl*))
 634   "Return sorted list of ucon's that match a multiword string"
 635   (let* ((words (delimited-string-to-list str #\space))
 636          (ucons '()))
 637     (dolist (word words)
 638       (setq ucons (append ucons (find-ucon-word word :srl srl))))
 639     (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
 640
 641 (defun find-ucon-normalized-multiword (str &key (srl *current-srl*))
 642   "Return sorted list of ucon's that match a multiword string"
 643   (let* ((words (delimited-string-to-list str #\space))
 644          (ucons '())
 645          (nwords '()))
 646     (dolist (word words)
 647       (let ((nws (lvg:process-terms word)))
 648         (dolist (nword nws)
 649           (push nword nwords))))
 650     (dolist (word nwords)
 651       (setq ucons (append ucons (find-ucon-word word :srl srl))))
 652     (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
 653
 654 (defun find-ustr-multiword (str &key (srl *current-srl*))
 655   "Return sorted list of ustr's that match a multiword string"
 656   (let* ((words (delimited-string-to-list str #\space))
 657          (ustrs '()))
 658     (dolist (word words)
 659       (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
 660     (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
 661
 662 (defun find-ustr-normalized-multiword (str &key (srl *current-srl*))
 663   "Return sorted list of ustr's that match a multiword string"
 664   (let* ((words (delimited-string-to-list str #\space))
 665          (ustrs '())
 666          (nwords '()))
 667     (dolist (word words)
 668       (let ((nws (lvg:process-terms word)))
 669         (dolist (nword nws)
 670           (push nword nwords))))
 671     (dolist (word nwords)
 672       (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
 673     (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui))))
 674
 675 (defun a (str)
 676   (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui))
 677
 678 (defun find-normalized-matches-for-str (str lookup-func key-func)
 679   "Return list of objects that normalize match for words in string,
 680 eliminate duplicates."
 681   (let ((objs '())
 682         (nwords '()))
 683     (dolist (word (delimited-string-to-list str #\space))
 684       (dolist (nword (lvg:process-terms word))
 685         (unless (member nword nwords :test #'string-equal)
 686           (push nword nwords))))
 687     (dolist (nw nwords)
 688       (setq objs (append objs (funcall lookup-func nw))))
 689     (delete-duplicates objs :key key-func :test #'eql)))
 690
 691 (defun sort-score-ucon-str (str ucons)
 692   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 693   (sort-score-umlsclass-str ucons str #'pfstr))
 694
 695 (defun sort-score-ustr-str (str ustrs)
 696   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 697   (sort-score-umlsclass-str ustrs str #'str))
 698
 699 (defun sort-score-umlsclass-str (objs str lookup-func)
 700   "Sort a list of objects based on scoring to a string"
 701   (let ((scored '()))
 702     (dolist (obj objs)
 703       (push
 704        (list obj
 705              (score-multiword-match str (funcall lookup-func obj)))
 706        scored))
 707     (mapcar #'car (sort scored #'> :key #'cadr))))
 708
 709 (defun score-multiword-match (s1 s2)
 710   "Score a match between two strings with s1 being reference string"
 711   (let* ((word-list-1 (delimited-string-to-list s1 #\space))
 712          (word-list-2 (delimited-string-to-list s2 #\space))
 713          (n1 (length word-list-1))
 714          (n2 (length word-list-2))
 715          (unmatched n1)
 716          (score 0)
 717          (nlong 0)
 718          (nshort 0)
 719          short-list long-list)
 720     (declare (fixnum n1 n2 nshort nlong score unmatched))
 721     (if (> n1 n2)
 722         (progn
 723           (setq nlong n1)
 724           (setq nshort n2)
 725           (setq long-list word-list-1)
 726           (setq short-list word-list-2))
 727       (progn
 728         (setq nlong n2)
 729         (setq nshort n1)
 730         (setq long-list word-list-2)
 731         (setq short-list word-list-1)))
 732     (decf score (- nlong nshort)) ;; reduce score for extra words
 733     (dotimes (iword nshort)
 734       (declare (fixnum iword))
 735       (gu:aif (position (nth iword short-list) long-list :test #'string-equal)
 736            (progn
 737              (incf score (- 10 (abs (- gu::it iword))))
 738              (decf unmatched))))
 739     (decf score (* 2 unmatched))
 740     score))
 741
 742
 743 ;;; LEX SQL functions
 744
 745 (defun find-lexterm-eui (eui)
 746   (gu:awhen (car (mutex-sql-query
 747                   (format nil "select WRD from LRWD where EUI=~d" eui)))
 748             (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it))))
 749
 750 (defun find-lexterm-word (wrd)
 751   (gu:awhen (mutex-sql-query
 752              (format nil "select EUI from LRWD where WRD='~a'" wrd))
 753             (let ((terms '()))
 754               (dolist (tuple gu:it)
 755                 (let ((eui (ensure-integer (nth 0 tuple))))
 756                   (push
 757                    (make-instance 'lexterm :eui eui :wrd (copy-seq wrd))
 758                    terms)))
 759               (nreverse terms))))
 760
 761 ;; LEXTERM accessors, read on demand
 762
 763 (def-lazy-reader lexterm s#abr find-labr-eui eui)
 764 (def-lazy-reader lexterm s#agr find-lagr-eui eui)
 765 (def-lazy-reader lexterm s#cmp find-lcmp-eui eui)
 766 (def-lazy-reader lexterm s#mod find-lmod-eui eui)
 767 (def-lazy-reader lexterm s#nom find-lnom-eui eui)
 768 (def-lazy-reader lexterm s#prn find-lprn-eui eui)
 769 (def-lazy-reader lexterm s#prp find-lprp-eui eui)
 770 (def-lazy-reader lexterm s#spl find-lspl-eui eui)
 771 (def-lazy-reader lexterm s#trm find-ltrm-eui eui)
 772 (def-lazy-reader lexterm s#typ find-ltyp-eui eui)
 773
 774 ;; LEX SQL Read functions
 775
 776 (defun find-labr-eui (eui)
 777     (gu:awhen (mutex-sql-query
 778                (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui))
 779               (let ((results '()))
 780                 (dolist (tuple gu::it)
 781                   (push
 782                    (make-instance 'labr :eui eui
 783                                   :bas (nth 0 tuple)
 784                                   :abr (nth 1 tuple)
 785                                   :eui2 (ensure-integer (nth 2 tuple))
 786                                   :bas2 (nth 3 tuple))
 787                    results))
 788                 (nreverse results))))
 789
 790 (defun find-labr-bas (bas)
 791   (gu:awhen (mutex-sql-query
 792                (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas))
 793               (let ((results '()))
 794                 (dolist (tuple gu::it)
 795                   (push
 796                    (make-instance 'labr :eui (ensure-integer (nth 0 tuple))
 797                                   :bas (copy-seq bas)
 798                                   :abr (nth 1 tuple)
 799                                   :eui2 (ensure-integer (nth 2 tuple))
 800                                   :bas2 (nth 3 tuple))
 801                    results))
 802                 (nreverse results))))
 803
 804 (defun find-lagr-eui (eui)
 805   (gu:awhen (mutex-sql-query
 806                (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui))
 807               (let ((results '()))
 808                 (dolist (tuple gu::it)
 809                   (push
 810                    (make-instance 'lagr
 811                                   :eui eui
 812                                   :str (nth 0 tuple)
 813                                   :sca (nth 1 tuple)
 814                                   :agr (nth 2 tuple)
 815                                   :cit (nth 3 tuple)
 816                                   :bas (nth 4 tuple))
 817                    results))
 818                 (nreverse results))))
 819
 820 (defun find-lcmp-eui (eui)
 821   (gu:awhen (mutex-sql-query
 822                (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui))
 823               (let ((results '()))
 824                 (dolist (tuple gu::it)
 825                   (push
 826                    (make-instance 'lcmp
 827                                   :eui eui
 828                                   :bas (nth 0 tuple)
 829                                   :sca (nth 1 tuple)
 830                                   :com (nth 2 tuple))
 831                    results))
 832                 (nreverse results))))
 833
 834 (defun find-lmod-eui (eui)
 835   (gu:awhen (mutex-sql-query
 836                (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui))
 837               (let ((results '()))
 838                 (dolist (tuple gu::it)
 839                   (push
 840                    (make-instance 'lmod
 841                                   :eui eui
 842                                   :bas (nth 0 tuple)
 843                                   :sca (nth 1 tuple)
 844                                   :psnmod (nth 2 tuple)
 845                                   :fea (nth 3 tuple))
 846                    results))
 847                 (nreverse results))))
 848
 849 (defun find-lnom-eui (eui)
 850   (gu:awhen (mutex-sql-query
 851                (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui))
 852               (let ((results '()))
 853                 (dolist (tuple gu::it)
 854                   (push
 855                    (make-instance 'lnom
 856                                   :eui eui
 857                                   :bas (nth 0 tuple)
 858                                   :sca (nth 1 tuple)
 859                                   :eui2 (ensure-integer (nth 2 tuple))
 860                                   :bas2 (nth 3 tuple)
 861                                   :sca2 (nth 4 tuple))
 862                    results))
 863                 (nreverse results))))
 864
 865 (defun find-lprn-eui (eui)
 866   (gu:awhen (mutex-sql-query
 867                (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui))
 868               (let ((results '()))
 869                 (dolist (tuple gu::it)
 870                   (push
 871                    (make-instance 'lprn
 872                                   :eui eui
 873                                   :bas (nth 0 tuple)
 874                                   :num (nth 1 tuple)
 875                                   :gnd (nth 2 tuple)
 876                                   :cas (nth 3 tuple)
 877                                   :pos (nth 4 tuple)
 878                                   :qnt (nth 5 tuple)
 879                                   :fea (nth 6 tuple))
 880                    results))
 881                 (nreverse results))))
 882
 883 (defun find-lprp-eui (eui)
 884   (gu:awhen (mutex-sql-query
 885                (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui))
 886               (let ((results '()))
 887                 (dolist (tuple gu::it)
 888                   (push
 889                    (make-instance 'lprp
 890                                   :eui eui
 891                                   :bas (nth 0 tuple)
 892                                   :str (nth 1 tuple)
 893                                   :sca (nth 2 tuple)
 894                                   :fea (nth 3 tuple))
 895                    results))
 896                 (nreverse results))))
 897
 898 (defun find-lspl-eui (eui)
 899   (gu:awhen (mutex-sql-query
 900                (format nil "select SPV,BAS from LRSPL where EUI=~d" eui))
 901               (let ((results '()))
 902                 (dolist (tuple gu::it)
 903                   (push
 904                    (make-instance 'lspl
 905                                   :eui eui
 906                                   :spv (nth 0 tuple)
 907                                   :bas (nth 1 tuple))
 908                    results))
 909                 (nreverse results))))
 910
 911
 912 (defun find-ltrm-eui (eui)
 913   (gu:awhen (mutex-sql-query
 914                (format nil "select BAS,GEN from LRTRM where EUI=~d" eui))
 915               (let ((results '()))
 916                 (dolist (tuple gu::it)
 917                   (push
 918                    (make-instance 'ltrm
 919                                   :eui eui
 920                                   :bas (nth 0 tuple)
 921                                   :gen (nth 1 tuple))
 922                    results))
 923                 (nreverse results))))
 924
 925 (defun find-ltyp-eui (eui)
 926   (gu:awhen (mutex-sql-query
 927                (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui))
 928               (let ((results '()))
 929                 (dolist (tuple gu::it)
 930                   (push
 931                    (make-instance 'ltyp
 932                                   :eui eui
 933                                   :bas (nth 0 tuple)
 934                                   :sca (nth 1 tuple)
 935                                   :typ (nth 2 tuple))
 936                    results))
 937                 (nreverse results))))
 938
 939 (defun find-lwd-wrd (wrd)
 940   (gu:awhen (mutex-sql-query
 941              (format nil "select EUI from LRWD where WRD='~a'" wrd))
 942               (let ((results '()))
 943                 (dolist (tuple gu::it)
 944                   (push (ensure-integer (nth 0 tuple)) results))
 945                 (make-instance 'lwd :wrd wrd
 946                                :euilist (nreverse results)))))
 947
 948 ;;; Semantic Network SQL access functions
 949
 950 (defun find-sdef-ui (ui)
 951   (gu:awhen (car (mutex-sql-query
 952                   (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui)))
 953             (make-instance 'sdef :rt (nth 0 gu::it)
 954                            :ui ui
 955                            :styrl (nth 1 gu::it)
 956                            :stnrtn (nth 2 gu::it)
 957                            :def (nth 3 gu::it)
 958                            :ex (nth 4 gu::it)
 959                            :un (nth 5 gu::it)
 960                            :rh (nth 6 gu::it)
 961                            :abr (nth 7 gu::it)
 962                            :rin (nth 8 gu::it))))
 963
 964 (defun find-sstre1-ui (ui)
 965   (gu:awhen (mutex-sql-query
 966                (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui))
 967               (let ((results '()))
 968                 (dolist (tuple gu::it)
 969                   (push
 970                    (make-instance 'sstre1 :ui ui
 971                                   :ui2 (ensure-integer (nth 0 tuple))
 972                                   :ui3 (ensure-integer (nth 1 tuple)))
 973                    results))
 974                 (nreverse results))))
 975
 976 (defun find-sstre1-ui2 (ui2)
 977   (gu:awhen (mutex-sql-query
 978                (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2))
 979               (let ((results '()))
 980                 (dolist (tuple gu::it)
 981                   (push
 982                    (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple))
 983                                   :ui2 ui2
 984                                   :ui3 (ensure-integer (nth 1 tuple)))
 985                    results))
 986                 (nreverse results))))
 987
 988 (defun find-sstr-rl (rl)
 989   (gu:awhen (mutex-sql-query
 990                (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl))
 991               (let ((results '()))
 992                 (dolist (tuple gu::it)
 993                   (push
 994                    (make-instance 'sstr
 995                                   :rl rl
 996                                   :styrl (nth 0 tuple)
 997                                   :styrl2 (nth 1 tuple)
 998                                   :ls (nth 2 tuple))
 999                    results))
1000                 (nreverse results))))
1001
1002
1003 (defun find-sstre2-sty (sty)
1004   (gu:awhen (mutex-sql-query
1005              (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty))
1006             (let ((results '()))
1007               (dolist (tuple gu::it)
1008                 (push
1009                  (make-instance 'sstre2
1010                                 :sty (copy-seq sty)
1011                                 :rl (nth 0 tuple)
1012                                 :sty2 (nth 1 tuple))
1013                                 results))
1014                 (nreverse results))))
1015
1016 (defun find-sstr-styrl (styrl)
1017   (gu:awhen (mutex-sql-query
1018                (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl))
1019               (let ((results '()))
1020                 (dolist (tuple gu::it)
1021                   (push
1022                    (make-instance 'sstr :styrl styrl
1023                                   :rl (nth 0 tuple)
1024                                   :styrl2 (nth 1 tuple)
1025                                   :ls (nth 2 tuple))
1026                    results))
1027                 (nreverse results))))
1028
1029