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 ;;;; Author:   Kevin M. Rosenberg
   8 ;;;; Created:  Apr 2000
   9 ;;;;
  10 ;;;; This file, part of UMLisp, is
  11 ;;;;    Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D.
  12 ;;;;
  13 ;;;; UMLisp users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the GNU General Public License.
  15 ;;;; *************************************************************************
  16
  17 (in-package #:umlisp)
  18
  19
  20 (defvar *current-srl* nil)
  21 (defun current-srl ()
  22   *current-srl*)
  23 (defun set-current-srl (srl)
  24   (setq *current-srl* srl))
  25
  26 ;; SQLNAME is required for collision of SQL reserved words (MYSQL 8: RANK)
  27 ;; and column names in UMLS (RANK in MRRANK)
  28 (defvar *sql-reserved-names* '("RANK"))
  29 (defmethod sqlname ((c ucol))
  30   (sqlname (col c)))
  31 (defmethod sqlname ((name string))
  32   (if (find name *sql-reserved-names* :test #'string-equal)
  33       (concatenate 'string "_" name)
  34     name))
  35 (defmethod sqlname ((l list))
  36   (mapcar #'sqlname l))
  37 (defmethod sqlname ((s symbol))
  38   (sqlname (symbol-name s)))
  39
  40 (defmacro query-string (table fields srl where-name where-value
  41                         &key (lrl "KCUILRL") single distinct order like limit
  42                         filter)
  43   (let* ((%%fields (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
  44                            (if distinct "DISTINCT " "") (sqlname fields) table))
  45          (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}"
  46                                     order)
  47                       ""))
  48          (%%lrl (format nil " AND ~:@(~A~)<=" lrl))
  49          (%%where (when where-name
  50                     (format nil " WHERE ~:@(~A~)~A" (sqlname where-name)
  51                           (if like " like " ""))))
  52          (%filter (gensym "FILTER-"))
  53          (%single (gensym "SINGLE-"))
  54          (%limit (gensym "LIMIT-")))
  55     `(let ((,%limit ,limit)
  56            (,%single ,single)
  57            (,%filter ,filter))
  58        (concatenate
  59         'string
  60         ,%%fields
  61         ,@(when %%where (list %%where))
  62         ,@(when %%where
  63             `((typecase ,where-value
  64                 #+ignore
  65                 (fixnum
  66                  (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
  67                 (number
  68                  (concatenate 'string "='" (write-to-string ,where-value) "'"))
  69                 (null
  70                  " IS NULL")
  71                 (t
  72                  (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
  73         (if ,%filter (concatenate 'string
  74                                   ,(if %%where " AND " " WHERE ")
  75                                   ,%filter) "")
  76         (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
  77         ,@(when %%order (list %%order))
  78         (cond
  79          ((and ,%single ,%limit)
  80           (error  "Can't set single (~S) and limit (~S)" ,%single ,%limit))
  81          (,%single
  82           " LIMIT 1")
  83          (,%limit
  84           (format nil " LIMIT ~D" ,%limit))
  85          (t
  86           ""))))))
  87
  88 (defun query-string-eval (table fields srl where-name where-value
  89                           &key (lrl "KCUILRL") single distinct order like limit filter)
  90   (when single (setq limit 1))
  91   (concatenate
  92    'string
  93    (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
  94            (if distinct "DISTINCT " "") (sqlname fields) table)
  95    (if where-name (format nil " WHERE ~:@(~A~)" (sqlname where-name)) "")
  96    (if where-name
  97        (format nil
  98                (typecase where-value
  99                  (number "='~D'")
 100                  (null " IS NULL")
 101                  (t
 102                   (if like " LIKE '%~A%'" "='~A'")))
 103                where-value)
 104        "")
 105    (if filter (concatenate 'string " AND " filter) nil)
 106    (if srl (format nil " AND ~:@(~A~)<=~D" lrl srl) "")
 107    (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}" order) "")
 108    (if limit (format nil " LIMIT ~D" limit) "")))
 109
 110
 111 (defmacro umlisp-query (table fields srl where-name where-value
 112                      &key (lrl "KCUILRL") single distinct order like
 113                      limit filter (query-cmd 'mutex-sql-query))
 114   "Query the UMLisp database. Return a list of umlisp objects whose name
 115 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 116   `(,query-cmd
 117     (query-string ,table ,fields ,srl ,where-name ,where-value
 118      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
 119      :filter ,filter :limit ,limit)))
 120
 121 (defmacro umlisp-query-eval (table fields srl where-name where-value
 122                      &key (lrl "KCUILRL") single distinct order like
 123                      filter limit)
 124   "Query the UMLisp database. Return a list of umlisp objects whose name
 125 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 126   `(mutex-sql-query
 127     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
 128      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
 129      :filter ,filter :limit ,limit)))
 130
 131 ;; only WHERE-VALUE and SRL are evaluated
 132 (defmacro collect-umlisp-query ((table fields srl where-name where-value
 133                                     &key (lrl "KCUILRL") distinct single
 134                                     order like (query-cmd 'mutex-sql-query)
 135                                     filter limit)
 136                                 &body body)
 137   (let ((value (gensym))
 138         (r (gensym)))
 139     (if single
 140         (if (and limit (> limit 1))
 141             (error "Can't set limit along with single.")
 142           `(let* ((,value ,where-value)
 143                   (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
 144                                             :lrl ,lrl :single ,single
 145                                             :distinct ,distinct :order ,order
 146                                             :like ,like :filter ,filter
 147                                             :query-cmd ,query-cmd))))
 148              ,@(unless where-name `((declare (ignore ,value))))
 149              (when tuple
 150                (destructuring-bind ,fields tuple
 151                  ,@body))))
 152         `(let ((,value ,where-value))
 153            ,@(unless where-name `((declare (ignore ,value))))
 154            (let ((,r '()))
 155              (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
 156                                           :lrl ,lrl :single ,single :distinct ,distinct
 157                                           :order ,order :filter ,filter :like ,like
 158                                           :limit ,limit))
 159                (push (destructuring-bind ,fields tuple ,@body) ,r))
 160              (nreverse ,r))
 161            #+ignore
 162            (loop for tuple in
 163                  (umlisp-query ,table ,fields ,srl ,where-name ,value
 164                                :lrl ,lrl :single ,single :distinct ,distinct
 165                                :order ,order :like ,like :filter ,filter :limit ,limit)
 166                collect (destructuring-bind ,fields tuple ,@body))))))
 167
 168 (defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
 169                                          &key (lrl "KCUILRL") distinct single
 170                                          order like filter limit)
 171                                   &body body)
 172   (let ((value (gensym))
 173         (r (gensym))
 174         (eval-fields (cadr fields)))
 175     (if single
 176         `(let* ((,value ,where-value)
 177                 (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 178                                                :lrl ,lrl :single ,single
 179                                                :distinct ,distinct :order ,order
 180                                                :like ,like :filter ,filter
 181                                                :limit ,limit))))
 182           (when tuple
 183             (destructuring-bind ,eval-fields tuple
 184               ,@body)))
 185         `(let ((,value ,where-value)
 186                (,r '()))
 187            (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 188                                              :lrl ,lrl :single ,single :distinct ,distinct
 189                                              :order ,order :like ,like
 190                                              :filter ,filter :limit ,limit))
 191              (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
 192            (nreverse ,r)
 193            #+ignore
 194            (loop for tuple in
 195                  (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 196                                     :lrl ,lrl :single ,single :distinct ,distinct
 197                                     :order ,order :like ,like :filter ,filter
 198                                     :limit ,limit)
 199                collect (destructuring-bind ,eval-fields tuple ,@body))))))
 200
 201 ;;;
 202 ;;; Read from SQL database
 203
 204 (defmacro ensure-cui-integer (cui)
 205   `(if (stringp ,cui)
 206     (setq ,cui (parse-cui ,cui))
 207     ,cui))
 208
 209 (defmacro ensure-lui-integer (lui)
 210   `(if (stringp ,lui)
 211     (setq ,lui (parse-lui ,lui))
 212     ,lui))
 213
 214 (defmacro ensure-sui-integer (sui)
 215   `(if (stringp ,sui)
 216     (setq ,sui (parse-sui ,sui))
 217     ,sui))
 218
 219 (defmacro ensure-aui-integer (aui)
 220   `(if (stringp ,aui)
 221     (setq ,aui (parse-aui ,aui))
 222     ,aui))
 223
 224 (defmacro ensure-rui-integer (rui)
 225   `(if (stringp ,rui)
 226     (setq ,rui (parse-rui ,rui))
 227     ,rui))
 228
 229 (defmacro ensure-tui-integer (tui)
 230   `(if (stringp ,tui)
 231     (setq ,tui (parse-tui ,tui))
 232     ,tui))
 233
 234 (defmacro ensure-eui-integer (eui)
 235   `(if (stringp ,eui)
 236     (setq ,eui (parse-eui ,eui))
 237     ,eui))
 238
 239 (defun make-ucon-cui (cui)
 240   (ensure-cui-integer cui)
 241   (when cui
 242     (make-instance 'ucon :cui cui)))
 243
 244 (defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr)
 245   "Find ucon for a cui. If set SAB, the without-pfstr is on by default"
 246   (ensure-cui-integer cui)
 247   (unless cui (return-from find-ucon-cui nil))
 248
 249   (if without-pfstr
 250       (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :single t)
 251                             (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
 252                                            :pfstr nil)))
 253    (or
 254      (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t :filter "KPFENG=1")
 255         (make-instance 'ucon :cui cui :pfstr str
 256                        :lrl kcuilrl))
 257      (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t)
 258         (make-instance 'ucon :cui cui :pfstr str
 259                        :lrl kcuilrl))))
 260
 261 (defun find-uconso-cui (cui &key sab (srl *current-srl*))
 262   "Find uconso for a cui."
 263   (ensure-cui-integer cui)
 264   (unless cui (return-from find-uconso-cui nil))
 265
 266   (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str
 267                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
 268                                       kluilrl ksuilrl) srl cui cui
 269                                       :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 270     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
 271                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
 272                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
 273                    :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
 274                    :ksuilrl ksuilrl)))
 275
 276 (defun find-uconso-cuisui (cuisui &key sab (srl *current-srl*))
 277   "Find uconso for a cuisui."
 278   (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str
 279                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
 280                                       kluilrl ksuilrl) srl kcuisui cuisui
 281                                       :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 282     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
 283                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
 284                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
 285                    :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
 286                    :ksuilrl ksuilrl)))
 287
 288
 289 (defun find-uconso-code (code &key first sab (srl *current-srl*) (like nil))
 290   "Return list of uconso objects that match code. Optional, filter for SAB. Optionally, use SQL's LIKE syntax"
 291   (collect-umlisp-query (mrconso (cui sab) srl code code :like like :distinct t
 292                                  :lrl klrl
 293                                  :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 294     (let ((uconsos (find-uconso-cui cui :sab sab :srl srl)))
 295       (if first
 296           (first uconsos)
 297           uconsos))))
 298
 299 (defun find-uconso-sui (sui &key sab (srl *current-srl*))
 300   "Find uconso for a sui. If set SAB, the without-pfstr is on by default"
 301   (ensure-sui-integer sui)
 302 ;;  (unless (and sui (stringp sab))
 303   (unless sui
 304     (return-from find-uconso-sui nil))
 305
 306   (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str
 307                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
 308                                       kluilrl ksuilrl) srl sui sui
 309                                       :distinct t
 310                                       :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 311     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
 312                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
 313                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
 314                    :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
 315                    :ksuilrl ksuilrl)))
 316
 317 (defun find-pfstr-cui (cui &key (srl *current-srl*))
 318   "Find preferred string for a cui"
 319   (ensure-cui-integer cui)
 320   (or
 321    (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
 322                                   :filter " KPFENG=1" :single t)
 323       str)
 324    (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
 325                                   :single t)
 326                          str)))
 327
 328 (defun find-lrl-cui (cui &key (srl *current-srl*))
 329   "Find LRL for a cui"
 330   (ensure-cui-integer cui)
 331   (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :distinct t :single t)
 332                         (ensure-integer kcuilrl)))
 333
 334 (defun find-ucon-lui (lui &key (srl *current-srl*))
 335   "Find list of ucon for lui"
 336   (ensure-lui-integer lui)
 337   (unless lui (return-from find-ucon-lui nil))
 338   (or
 339    (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
 340                                   :filter " KPFENG=1" :single t)
 341       (make-instance 'ucon :cui (ensure-integer cui)
 342                      :pfstr str :lrl (ensure-integer kcuilrl)))
 343    (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
 344                                   :single t)
 345       (make-instance 'ucon :cui (ensure-integer cui)
 346                      :pfstr str :lrl (ensure-integer kcuilrl)))))
 347
 348 (defun find-ucon-sui (sui &key (srl *current-srl*))
 349   "Find list of ucon for sui"
 350   (ensure-sui-integer sui)
 351   (collect-umlisp-query (mrconso (cui kcuilrl) srl sui sui :distinct t)
 352     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 353                    :lrl (ensure-integer kcuilrl))))
 354
 355 (defun find-ucon-aui (aui &key (srl *current-srl*))
 356   "Find list of ucon for aui"
 357   (ensure-aui-integer aui)
 358   (collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t)
 359     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 360                    :lrl (ensure-integer kcuilrl))))
 361
 362 (defun find-ucon-cuisui (cuisui &key (srl *current-srl*))
 363   "Find ucon for cui/sui"
 364   (collect-umlisp-query (mrconso (cui kcuilrl) srl kcuisui cuisui)
 365     (make-instance 'ucon :cui cui
 366                    :pfstr (find-pfstr-cui cui)
 367                    :lrl (ensure-integer kcuilrl))))
 368
 369 (defun find-ucon-cui-sui (cui sui &key (srl *current-srl*))
 370   "Find ucon for cui/sui"
 371   (ensure-cui-integer cui)
 372   (ensure-sui-integer sui)
 373   (when (and cui sui)
 374     (find-ucon-cui-sui cui sui :srl srl)))
 375
 376 (defun find-ucon-str (str &key (srl *current-srl*))
 377   "Find ucon that are exact match for str"
 378   (collect-umlisp-query (mrconso (cui kcuilrl) srl str str :distinct t)
 379     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 380                    :lrl (ensure-integer kcuilrl))))
 381
 382 (defun find-ucon-all (&key (srl *current-srl*))
 383   "Return list of all ucon's"
 384   (with-sql-connection (db)
 385     (clsql:map-query
 386      'list
 387      #'(lambda (tuple)
 388          (destructuring-bind (cui cuilrl) tuple
 389              (make-instance 'ucon :cui (ensure-integer cui)
 390                             :pfstr (find-pfstr-cui cui)
 391                             :lrl (ensure-integer cuilrl))))
 392      (query-string mrconso (cui kcuilrl) srl nil nil
 393                    :order (cui asc) :distinct t)
 394      :database db)))
 395
 396 (defun find-ucon-all2 (&key (srl *current-srl*))
 397   "Return list of all ucon's"
 398   (collect-umlisp-query (mrconso (cui kcuilrl) srl nil nil :order (cui asc)
 399                             :distinct t)
 400     (make-instance 'ucon :cui (ensure-integer cui)
 401                    :pfstr (find-pfstr-cui cui)
 402                    :lrl (ensure-integer kcuilrl))))
 403
 404 (defun find-cui-ucon-all (&key (srl *current-srl*))
 405   "Return list of CUIs for all ucons"
 406   (collect-umlisp-query (mrconso (cui) srl nil nil :order (cui asc)
 407                                :distinct t)
 408                         cui))
 409
 410 (defun map-ucon-all (fn &key (srl *current-srl*))
 411   "Map a function over all ucon's"
 412   (with-sql-connection (db)
 413     (clsql:map-query
 414      nil
 415      #'(lambda (tuple)
 416          (destructuring-bind (cui cuilrl) tuple
 417            (funcall fn (make-instance 'ucon :cui (ensure-integer cui)
 418                                       :pfstr (find-pfstr-cui cui)
 419                                       :lrl (ensure-integer cuilrl)))))
 420      (query-string mrconso (cui kcuilrl) srl nil nil :order (cui asc)
 421                    :distinct t)
 422      :database db)))
 423
 424
 425 (defun find-udef-cui (cui &key (srl *current-srl*))
 426   "Return a list of udefs for cui"
 427   (ensure-cui-integer cui)
 428   (collect-umlisp-query (mrdef (sab def suppress) srl cui cui :lrl "KSRL"
 429                                :distinct t)
 430     (make-instance 'udef :sab sab :def def :suppress suppress)))
 431
 432 (defun find-udoc-key (key)
 433   "Return list of abbreviation documentation for a key"
 434   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)
 435     (make-instance 'udoc :dockey key :dvalue value :dtype type :expl expl)))
 436
 437 (defun find-udoc-value (value)
 438   "Return abbreviation documentation"
 439   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)
 440     (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 441
 442 (defun find-udoc-key-value (dockey value)
 443   (collect-umlisp-query (mrdoc (type expl) nil dockey dockey :filter (format nil "VALUE='~A'" value))
 444       (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 445
 446 (defun find-udoc-all ()
 447   "Return all abbreviation documentation"
 448   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
 449     (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 450
 451 (defun find-usty-cui (cui &key (srl *current-srl*))
 452   "Return a list of usty for cui"
 453   (ensure-cui-integer cui)
 454   (collect-umlisp-query (mrsty (tui sty) srl cui cui :lrl "KLRL")
 455     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 456
 457 (defun find-usty-word (word &key (srl *current-srl*))
 458   "Return a list of usty that match word"
 459   (collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t
 460                             :distinct t)
 461     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 462
 463 (defun find-urel-cui (cui &key (srl *current-srl*) filter without-pfstr2)
 464   "Return a list of urel for cui"
 465   (ensure-cui-integer cui)
 466   (collect-umlisp-query (mrrel (aui1 rel stype1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 467                                srl cui1 cui :lrl "KSRL" :filter filter)
 468     (let ((rel
 469       (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
 470                      :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
 471                      :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
 472                      :suppress suppress :cvf cvf)))
 473       (unless without-pfstr2
 474         (setf (slot-value rel 'pfstr2) (find-pfstr-cui cui2)))
 475       rel)))
 476
 477 (defun find-urel-rui (rui &key (srl *current-srl*))
 478   "Return the urel for a rui"
 479   (ensure-rui-integer rui)
 480   (collect-umlisp-query (mrrel (aui1 rel stype1 cui1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 481                                srl rui rui :lrl "KSRL" :single t)
 482     (make-instance 'urel :cui1 cui1 :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
 483                    :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
 484                    :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
 485                    :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
 486
 487 (defun find-cui2-urel-cui (cui &key (srl *current-srl*))
 488   "Return a list of urel for cui"
 489   (ensure-cui-integer cui)
 490   (collect-umlisp-query (mrrel (cui2) srl cui1
 491                                cui :lrl "KSRL")
 492                         cui2))
 493
 494 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
 495   "Return a list of urel for cui2"
 496   (ensure-cui-integer cui2)
 497   (collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 498                                srl cui2 cui2 :lrl "KSRL")
 499     (make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2)
 500                    :stype2 stype2 :rui (ensure-integer rui) :srui srui
 501                    :stype1 stype1 :cui1 (ensure-integer cui1)
 502                    :aui1 (ensure-integer aui1)
 503                    :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
 504                    :pfstr2 (find-pfstr-cui cui2))))
 505
 506 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
 507   (ensure-cui-integer cui2)
 508   (loop for cui in (remove-duplicates
 509                     (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
 510         collect (find-ucon-cui cui :srl srl)))
 511
 512 #+mrcoc (defun find-ucoc-cui (cui &key (srl *current-srl*))
 513   "Return a list of ucoc for cui"
 514   (ensure-cui-integer cui)
 515   (collect-umlisp-query (mrcoc (aui1 cui2 aui2 sab cot cof coa) srl cui1
 516                             cui :lrl klrl :order (cof asc))
 517     (setq cui2 (ensure-integer cui2))
 518     (when (eql 0 cui2) (setq cui2 nil))
 519     (make-instance 'ucoc :cui1 cui :aui1 (ensure-integer aui1)
 520                    :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2)
 521                    :cot cot :cof (ensure-integer cof) :coa coa :sab sab
 522                    :pfstr2 (find-pfstr-cui cui2))))
 523
 524 #+mrcoc (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
 525   "Return a list of ucoc for cui2"
 526   (ensure-cui-integer cui2)
 527   (collect-umlisp-query (mrcoc (cui1 aui1 aui2 sab cot cof coa) srl cui2
 528                             cui2 :lrl klrl :order (cof asc))
 529     (when (zerop cui2) (setq cui2 nil))
 530     (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2
 531                    :aui1 (ensure-integer aui1) :aui2 (ensure-integer aui2)
 532                    :sab sab :cot cot :cof (ensure-integer cof) :coa coa
 533                    :pfstr2 (find-pfstr-cui cui2))))
 534
 535 #+mrcoc (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
 536   "List of ucon with co-occurance cui2"
 537   (ensure-cui-integer cui2)
 538   (mapcar
 539    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 540    (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
 541
 542
 543 (defun find-uterm-cui (cui &key (srl *current-srl*))
 544   "Return a list of uterm for cui"
 545   (ensure-cui-integer cui)
 546   (collect-umlisp-query (mrconso (lui lat ts kluilrl) srl cui cui
 547                             :lrl kluilrl :distinct t)
 548     (make-instance 'uterm :lui (ensure-integer lui) :cui cui
 549                    :lat lat :ts ts :lrl (ensure-integer kluilrl))))
 550
 551 (defun find-uterm-lui (lui &key (srl *current-srl*))
 552   "Return a list of uterm for lui"
 553   (ensure-lui-integer lui)
 554   (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
 555                              :lrl kluilrl :distinct t)
 556     (make-instance 'uterm :cui (ensure-integer cui) :lui lui
 557                    :lat lat :ts ts :lrl (ensure-integer kluilrl))))
 558
 559 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
 560   "Return single uterm for cui/lui"
 561   (ensure-cui-integer cui)
 562   (ensure-lui-integer lui)
 563   (collect-umlisp-query (mrconso (lat ts kluilrl) srl kcuilui
 564                              (make-cuilui cui lui)
 565                              :lrl kluilrl :single t)
 566     (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
 567                    :lrl (ensure-integer kluilrl))))
 568
 569 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
 570   "Return a list of ustr for cui/lui"
 571   (ensure-cui-integer cui)
 572   (ensure-lui-integer lui)
 573   (collect-umlisp-query (mrconso (sui stt str suppress ksuilrl) srl kcuilui
 574                                  (make-cuilui cui lui) :lrl ksuilrl :distinct t)
 575                 (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
 576                    :cuisui (make-cuisui cui sui) :stt stt :str str :suppress suppress
 577                    :lrl (ensure-integer ksuilrl))))
 578
 579 (defun find-ustr-cuisui (cuisui &key (srl *current-srl*))
 580   "Return the single ustr for cuisui"
 581   (collect-umlisp-query (mrconso (cui lui sui stt str suppress ksuilrl) srl kcuisui
 582                                  cuisui :lrl ksuilrl :single t)
 583     (make-instance 'ustr :sui sui :cui cui :cuisui cuisui
 584                    :lui (ensure-integer lui) :stt stt :str str :suppress suppress
 585                    :lrl (ensure-integer ksuilrl))))
 586
 587 (defun find-ustr-cui-sui (cui sui &key (srl *current-srl*))
 588   "Return the single ustr for cuisui"
 589   (ensure-cui-integer cui)
 590   (ensure-sui-integer sui)
 591   (find-ustr-cuisui (make-cuisui cui sui) :srl srl))
 592
 593 (defun find-ustr-sui (sui &key (srl *current-srl*))
 594   "Return the list of ustr for sui"
 595   (ensure-sui-integer sui)
 596   (collect-umlisp-query (mrconso (cui lui stt str suppress ksuilrl) srl sui sui
 597                             :lrl ksuilrl :distinct t)
 598     (make-instance 'ustr :sui sui :cui cui :stt stt :str str
 599                    :cuisui (make-cuisui (ensure-integer cui) sui)
 600                    :suppress suppress
 601                    :lui (ensure-integer lui) :lrl (ensure-integer ksuilrl))))
 602
 603 (defun find-ustr-sab (sab &key (srl *current-srl*))
 604   "Return the list of ustr for sab"
 605   (collect-umlisp-query (mrconso (kcuisui) srl sab sab :lrl srl)
 606     (let ((cuisui (ensure-integer kcuisui)))
 607       (find-ustr-cuisui cuisui :srl srl))))
 608
 609 (defun find-ustr-all (&key (srl *current-srl*))
 610   "Return list of all ustr's"
 611     (with-sql-connection (db)
 612       (clsql:map-query
 613        'list
 614        #'(lambda (tuple)
 615            (destructuring-bind (cui lui sui stt ksuilrl suppress) tuple
 616              (make-instance 'ustr :cui (ensure-integer cui)
 617                             :lui (ensure-integer lui) :sui (ensure-integer sui)
 618                             :stt stt :str (find-pfstr-cui cui)
 619                             :cuisui (make-cuisui (ensure-integer cui)
 620                                                  (ensure-integer sui))
 621                             :suppress suppress
 622                             :lrl (ensure-integer ksuilrl))))
 623        (query-string mrconso (cui lui sui stt ksuilrl) srl nil nil :lrl ksuilrl
 624                      :distinct t
 625                      :order (sui asc))
 626        :database db)))
 627
 628 (defun find-string-sui (sui &key (srl *current-srl*))
 629   "Return the string associated with sui"
 630   (ensure-sui-integer sui)
 631   (collect-umlisp-query (mrconso (str) srl sui sui :lrl ksuilrl :single t)
 632     str))
 633
 634 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
 635   (ensure-sui-integer sui)
 636   (ensure-cui-integer cui)
 637   (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str ts)
 638                                  srl kcuisui (make-cuisui cui sui) :lrl srl)
 639     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
 640                    :cui cui :sui sui :saui saui :sdui sdui :scui scui
 641                    :lat lat :str str :ts ts)))
 642
 643 (defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
 644   (ensure-cui-integer cui)
 645   (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str sui ts)
 646                                  srl cui cui :lrl srl :limit limit
 647                                  :filter (when english-only "LAT='ENG'"))
 648      (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
 649                     :cui cui :sui sui :saui saui :sdui sdui :scui scui
 650                     :lat lat :str str :ts ts)))
 651
 652 (defun find-uso-aui (aui &key (srl *current-srl*))
 653   (ensure-sui-integer aui)
 654   (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui lat
 655                                       str ts) srl aui aui :lrl srl :single t)
 656     (make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty
 657                    :sui sui :saui saui :sdui sdui :scui scui :lat lat
 658                    :str str :ts ts)))
 659
 660 (defun find-uhier-cui (cui &key (srl *current-srl*))
 661   (ensure-cui-integer cui)
 662   (collect-umlisp-query (mrhier (aui cxn paui sab rela ptr hcd cvf)
 663                             srl cui cui :lrl ksrl)
 664     (make-instance 'uhier :cui cui :aui (ensure-integer aui)
 665                    :cxn (ensure-integer cxn)
 666                    :paui (ensure-integer paui)
 667                    :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
 668
 669 (defun find-uhier-all (&key (srl *current-srl*))
 670   (collect-umlisp-query (mrhier (cui aui cxn paui sab rela ptr hcd cvf)
 671                             srl nil nil :lrl ksrl)
 672     (make-instance 'uhier :cui cui :aui (ensure-integer aui)
 673                    :cxn (ensure-integer cxn)
 674                    :paui (ensure-integer paui)
 675                    :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
 676
 677 (defun find-usat-ui (cui &optional lui sui &key (srl *current-srl*))
 678   (ensure-cui-integer cui)
 679   (ensure-lui-integer lui)
 680   (ensure-sui-integer sui)
 681   (let ((ls "SELECT CODE,ATN,SAB,ATV FROM MRSAT WHERE "))
 682     (cond
 683       (sui (string-append ls "KCUISUI='"
 684                           (integer-string (make-cuisui cui sui) 14)
 685                           "'"))
 686       (lui (string-append ls "KCUILUI='"
 687                           (integer-string (make-cuilui cui lui) 14)
 688                           "' and sui='0'"))
 689       (t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
 690                         "' and lui='0' and sui='0'")))
 691     (when srl
 692       (string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
 693     (loop for tuple in (mutex-sql-query ls) collect
 694           (destructuring-bind (code atn sab atv) tuple
 695             (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
 696
 697 (defun find-usty-tui (tui)
 698   "Find usty for tui"
 699   (ensure-tui-integer tui)
 700   (collect-umlisp-query (mrsty (sty) nil tui tui :single t)
 701     (make-instance 'usty :tui tui :sty sty)))
 702
 703 (defun find-usty-sty (sty)
 704   "Find usty for a sty"
 705   (collect-umlisp-query (mrsty (tui) nil sty sty :single t)
 706     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 707
 708 (defun find-usty-all ()
 709   "Return list of usty's for all semantic types"
 710   (collect-umlisp-query (mrsty (tui) nil nil nil :distinct t)
 711     (find-usty-tui tui)))
 712
 713 (defun find-usab-all ()
 714   "Return all usab objects"
 715   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
 716                                   rmeta slc scc srl tfr cfr cxty ttyl atnl lat
 717                                   cenc curver sabin ssn scit) nil nil nil)
 718     (make-instance 'usab :vcui (ensure-integer vcui)
 719                    :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
 720                    :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
 721                    :rmeta rmeta :slc slc :scc scc  :srl (ensure-integer srl)
 722                    :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 723                    :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 724                    :curver curver :sabin sabin :ssn ssn :scit scit)))
 725
 726 (defun find-usab-by-key (key-name key &key current)
 727   "Find usab for a key"
 728   (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart
 729                                        vend imeta rmeta slc scc srl tfr cfr cxty
 730                                        ttyl atnl lat cenc curver sabin
 731                                        ssn scit)
 732                                      nil key-name key :single t
 733                                      :filter (when current "RMETA=''"))
 734      (make-instance 'usab :vcui (ensure-integer vcui)
 735                     :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
 736                     :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
 737                     :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
 738                     :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 739                     :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 740                     :curver curver :sabin sabin
 741                     :ssn ssn :scit scit)))
 742
 743 (defun find-usab-rsab (rsab &key (current t))
 744   "Find usab for rsab"
 745   (find-usab-by-key 'rsab rsab))
 746
 747 (defun find-usab-vsab (vsab &key (current t))
 748   "Find usab for vsab"
 749   (find-usab-by-key 'vsab vsab))
 750
 751 (defun find-cui-max ()
 752   (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 753
 754 (defun find-umap-cui (cui)
 755   (ensure-cui-integer cui)
 756   (collect-umlisp-query (mrmap (mapsetsab mapsubsetid maprank fromid fromsid fromexpr
 757                                           fromtype fromrule fromres rel rela toid tosid
 758                                           toexpr totype torule tores maprule maptype
 759                                           mapatn mapatv cvf)
 760                                nil mapsetcui cui)
 761     (make-instance 'umap :mapsetcui cui :mapsetsab mapsetsab :mapsubsetid mapsubsetid
 762                    :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid
 763                    :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres
 764                    :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype
 765                    :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn
 766                    :mapatv mapatv :cvf cvf)))
 767
 768 (defun find-usmap-cui (cui)
 769   (ensure-cui-integer cui)
 770   (collect-umlisp-query (mrsmap (mapsetsab fromexpr fromtype rel rela toexpr totype cvf)
 771                                nil mapsetcui cui)
 772     (make-instance 'usmap :mapsetcui cui :mapsetsab mapsetsab
 773                    :fromexpr fromexpr :fromtype fromtype
 774                    :rel rel :rela rela :toexpr toexpr :totype totype
 775                    :cvf cvf)))
 776
 777 ;;;; Cross table find functions
 778
 779 (defun find-ucon-tui (tui &key (srl *current-srl*))
 780   "Find list of ucon for tui"
 781   (ensure-tui-integer tui)
 782   (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
 783     (find-ucon-cui (ensure-integer cui) :srl srl)))
 784
 785 (defun mrconso-query-word-cui (word sab srl like)
 786   (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A"
 787           (if like " LIKE " "=")
 788           (clsql-sys::sql-escape-quotes word)
 789           (etypecase sab
 790             (string
 791              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 792             (cons
 793              (format nil " AND c.sab IN (~{'~A'~^,~})"
 794                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 795             (null
 796              ""))
 797           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 798
 799 (defun mrconso-query-word-sui (word sab srl like)
 800   (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A"
 801           (if like " LIKE " "=")
 802           (clsql-sys::sql-escape-quotes word)
 803           (etypecase sab
 804             (string
 805              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 806             (cons
 807              (format nil " AND c.sab IN (~{'~A'~^,~})"
 808                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 809             (null
 810              ""))
 811           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 812
 813 (defun find-uconso-word (word &key sab (srl *current-srl*) (like nil))
 814   "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax"
 815   (cond
 816     (sab
 817      (let ((sui-query (mrconso-query-word-sui word sab srl like))
 818            (uconsos nil))
 819        (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
 820          (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab))))
 821        (remove-duplicates uconsos :key 'cui)))
 822     (t
 823      (collect-umlisp-query-eval ('mrxw_eng '(kcuisui) srl 'wd word :like like
 824                                            :lrl 'klrl :order '(kcuisui asc))
 825        (find-uconso-cuisui kcuisui :srl srl)))))
 826
 827 (defun find-ucon-word (word &key sab (srl *current-srl*) (like nil))
 828   "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 829   (cond
 830     (sab
 831      (let ((query (mrconso-query-word-cui word sab srl like)))
 832        (loop for tuple in (mutex-sql-query query)
 833              collect (make-instance 'ucon :cui (first tuple)))))
 834     (t
 835      (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
 836                                            :lrl 'klrl :order '(cui asc))
 837        (find-ucon-cui cui :srl srl)))))
 838
 839 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 840   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 841   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 842                                       :lrl 'klrl :order '(cui asc))
 843     (find-ucon-cui cui :srl srl)))
 844
 845 (defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
 846   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 847   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 848                                          :lrl 'klrl :order '(cui asc))
 849                              cui))
 850
 851 (defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
 852   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 853   (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
 854                                          :lrl 'klrl :order '(cui asc))
 855                              lui))
 856
 857 (defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
 858   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 859   (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
 860                                          :lrl 'klrl :order '(cui asc))
 861     sui))
 862
 863 (defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
 864   "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 865   (cond
 866     (sab
 867      (let ((query (format nil "SELECT c.sui,c.cui,c.lui,c.str,c.lrl,c.stt,c.suppress,c.cuisui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND x.lui=c.lui AND x.sui=c.sui~A~A"
 868                           (if like "LIKE" "=")
 869                           (clsql-sys::sql-escape-quotes word)
 870                           (typecase sab
 871                             (string
 872                              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 873                             (cons
 874                              (format nil " AND c.sab IN (~('~A'~^,~))"
 875                                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 876                             (null
 877                              ""))
 878                           (if srl (format nil " AND KCUILRL <= ~D" srl) ""))))
 879        (loop for tuple in (mutex-sql-query query)
 880           collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple
 881                     (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl
 882                                    :stt stt :suppress suppress :cuisui cuisui)))))
 883     (t
 884      (collect-umlisp-query (mrxw_eng (kcuisui) srl wd word :lrl klrl
 885                                      :order (cui asc sui asc))
 886        (find-ustr-cuisui kcuisui :srl srl)))))
 887
 888 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 889   "Return list of ustrs that match word"
 890   (collect-umlisp-query (mrxnw_eng (kcuisui) srl nwd word :lrl klrl
 891                                  :order (cui asc sui asc))
 892     (find-ustr-cuisui kcuisui :srl srl)))
 893
 894 (defun find-uterm-word (word &key (srl *current-srl*))
 895   "Return list of uterms that match word"
 896   (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
 897                                :order (cui asc lui asc))
 898     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 899
 900 (defun find-uterm-normalized-word (word &key (srl *current-srl*))
 901   "Return list of uterms that match word"
 902   (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
 903                                  :order (cui asc lui asc))
 904     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 905
 906 (defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
 907   "Return list of ucons that match non-english word"
 908   (collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
 909                                         :distinct t :lrl 'klrl :order '(cui asc))
 910     (find-ucon-cui cui :srl srl)))
 911
 912 (defun find-ustr-noneng-word (word &key (srl *current-srl*))
 913   "Return list of ustrs that match non-english word"
 914   (collect-umlisp-query (mrxw_noneng (kcuisui) srl wd word :lrl klrl
 915                                   :order (cui asc sui asc))
 916     (find-ustr-cuisui kcuisui :srl srl)))
 917
 918 ;; Special tables
 919
 920 (defun find-usrl-all ()
 921   (collect-umlisp-query (usrl (sab srl) nil nil nil :order (sab asc))
 922     (make-instance 'usrl :sab sab :srl (ensure-integer srl))))
 923
 924 ;;; Multiword lookup and score functions
 925
 926 (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
 927                                 only-exact-if-match limit &key extra-lookup-args)
 928   (let ((uobjs '()))
 929     (dolist (word (delimited-string-to-list str #\space))
 930       (setq uobjs (nconc uobjs
 931                          (kmrcl:flatten (apply obj-lookup-fun word :srl srl extra-lookup-args)))))
 932     (let ((sorted
 933            (funcall sort-fun str
 934                     (delete-duplicates uobjs :test #'= :key key))))
 935       (let ((len (length sorted)))
 936         (cond
 937          ((zerop len)
 938           (return-from find-uobj-multiword nil))
 939          ((and only-exact-if-match (multiword-match str (pfstr (first sorted))))
 940           (first sorted))
 941          (limit
 942           (if (and (plusp limit) (> len limit))
 943               (subseq sorted 0 limit)
 944             limit))
 945          (t
 946           sorted))))))
 947
 948 (defun find-ucon-multiword (str &key (srl *current-srl*)
 949                                      (only-exact-if-match t)
 950                                      limit
 951                                      sab)
 952   (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
 953                        #'cui srl only-exact-if-match limit
 954                        :extra-lookup-args (list :sab sab)))
 955
 956 (defun find-uconso-multiword (str &key (srl *current-srl*)
 957                                      (only-exact-if-match t)
 958                                      limit
 959                                      sab)
 960   (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
 961                        #'cui srl only-exact-if-match limit
 962                        :extra-lookup-args (list :sab sab)))
 963
 964 (defun find-uterm-multiword (str &key (srl *current-srl*)
 965                                       (only-exact-if-match t)
 966                                       limit)
 967   (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
 968                        #'lui srl only-exact-if-match limit))
 969
 970 (defun find-ustr-multiword (str &key (srl *current-srl*)
 971                                      (only-exact-if-match t)
 972                                      limit
 973                                      sab)
 974   (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
 975                        #'sui srl only-exact-if-match limit
 976                        :extra-lookup-args (list :sab sab)))
 977
 978 (defun sort-score-pfstr-str (str uobjs)
 979   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 980   (sort-score-umlsclass-str uobjs str #'pfstr))
 981
 982 (defun sort-score-ustr-str (str ustrs)
 983   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 984   (sort-score-umlsclass-str ustrs str #'str))
 985
 986 (defun sort-score-umlsclass-str (objs str lookup-func)
 987   "Sort a list of objects based on scoring to a string"
 988   (let ((scored '()))
 989     (dolist (obj objs)
 990       (push (list obj (score-multiword-match str (funcall lookup-func obj)))
 991        scored))
 992     (mapcar #'car (sort scored #'> :key #'cadr))))
 993
 994
 995 ;;; LEX SQL functions
 996
 997 (defun find-lexterm-eui (eui)
 998   (ensure-eui-integer eui)
 999   (collect-umlisp-query (lrwd (wrd) nil eui eui :single t)
1000     (make-instance 'lexterm :eui eui :wrd wrd)))
1001
1002 (defun find-lexterm-word (wrd)
1003   (collect-umlisp-query (lrwd (eui) nil wrd wrd)
1004     (make-instance 'lexterm :eui (ensure-integer eui)
1005                    :wrd (copy-seq wrd))))
1006
1007 ;; LEX SQL Read functions
1008
1009 (defun find-labr-eui (eui)
1010   (ensure-eui-integer eui)
1011   (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
1012     (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
1013                    :eui2 (ensure-integer eui2))))
1014
1015 (defun find-labr-bas (bas)
1016   (collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
1017     (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
1018                    :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
1019
1020 (defun find-lagr-eui (eui)
1021   (ensure-eui-integer eui)
1022   (collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
1023     (make-instance 'lagr :eui eui :str str :sca sca :agr agr
1024                    :cit cit :bas bas)))
1025
1026 (defun find-lcmp-eui (eui)
1027   (ensure-eui-integer eui)
1028   (collect-umlisp-query (lrcmp (bas sca com) nil eui eui)
1029     (make-instance 'lcmp :eui eui :bas bas :sca sca :com com)))
1030
1031 (defun find-lmod-eui (eui)
1032   (ensure-eui-integer eui)
1033   (collect-umlisp-query (lrmod (bas sca psn_mod fea) nil eui eui)
1034     (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea)))
1035
1036 (defun find-lnom-eui (eui)
1037   (ensure-eui-integer eui)
1038   (collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
1039     (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
1040                    :eui2 (ensure-integer eui2))))
1041
1042 (defun find-lprn-eui (eui)
1043   (ensure-eui-integer eui)
1044   (collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
1045     (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
1046                    :cas cas :pos pos :qnt qnt :fea fea)))
1047
1048 (defun find-lprp-eui (eui)
1049   (ensure-eui-integer eui)
1050   (collect-umlisp-query (lrprp (bas str sca fea) nil eui eui)
1051     (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea)))
1052
1053 (defun find-lspl-eui (eui)
1054   (ensure-eui-integer eui)
1055   (collect-umlisp-query (lrspl (spv bas) nil eui eui)
1056     (make-instance 'lspl :eui eui :spv spv :bas bas)))
1057
1058 (defun find-ltrm-eui (eui)
1059   (ensure-eui-integer eui)
1060   (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
1061     (make-instance 'ltrm :eui eui :bas bas :gen gen)))
1062
1063 (defun find-ltyp-eui (eui)
1064   (ensure-eui-integer eui)
1065   (collect-umlisp-query (lrtyp (bas sca typ) nil eui eui)
1066     (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)))
1067
1068 (defun find-lwd-wrd (wrd)
1069   (make-instance 'lwd :wrd wrd
1070                  :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
1071                                                 (ensure-integer eui))))
1072
1073 ;;; Semantic Network SQL access functions
1074
1075 (defun find-sdef-ui (ui)
1076   (collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
1077                             nil ui ui :single t)
1078     (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
1079                    :def def :ex ex :un un :rh rh :abr abr :rin rin)))
1080
1081 (defun find-sstre1-ui (ui)
1082   (collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
1083     (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
1084                    :ui3 (ensure-integer ui3))))
1085
1086 (defun find-sstre1-ui2 (ui2)
1087   (collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
1088     (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
1089                    :ui3 (ensure-integer ui3))))
1090
1091 (defun find-sstr-rl (rl)
1092   (collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
1093     (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls)))
1094
1095 (defun find-sstre2-sty (sty)
1096   (collect-umlisp-query (srstre2 (rl sty2) nil sty sty)
1097     (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2)))
1098
1099 (defun find-sstr-styrl (styrl)
1100   (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
1101     (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
1102
1103
1104 ;;; **************************
1105 ;;; Local Classes
1106 ;;; **************************
1107
1108
1109 (defun find-count-table (conn table srl count-variable srl-control)
1110   (with-sql-connection (conn)
1111   (cond
1112    ((stringp srl-control)
1113     (ensure-integer
1114      (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
1115                               count-variable table srl-control srl)
1116                       conn))))
1117    ((null srl-control)
1118     (ensure-integer
1119      (caar (sql-query (format nil "select count(~a) from ~a"
1120                               count-variable table )
1121                       conn))))
1122    (t
1123     (error "Unknown srl-control")
1124     0))))
1125
1126 (defun insert-ustats (conn name count srl)
1127   (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
1128                        name count (if srl srl 3))
1129                conn))
1130
1131 (defun find-ustats-all (&key (srl *current-srl*))
1132   (if srl
1133       (collect-umlisp-query (ustats (name count srl) nil srl srl
1134                                     :order (name asc))
1135                             (make-instance 'ustats :name name
1136                                            :hits (ensure-integer count)
1137                                            :srl (ensure-integer srl)))
1138     (collect-umlisp-query (ustats (name count srl) nil nil nil
1139                                   :order (name asc))
1140                           (make-instance 'ustats :name name
1141                                          :hits (ensure-integer count)
1142                                          :srl (ensure-integer srl)))))
1143
1144 (defun find-ustats-srl (srl)
1145   (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
1146                            (make-instance 'ustats :name name :hits (ensure-integer count))))
1147
1148 (defun find-urank-sab (sab &key (srl *current-srl*))
1149   (collect-umlisp-query (mrrank (rank sab suppress tty) nil sab sab)
1150                         (make-instance 'urank :rank rank :sab sab :tty tty :suppress suppress)))
1151
1152 (defun find-urank-all (&key (srl *current-srl*))
1153   (if srl
1154       (collect-umlisp-query (mrrank (rank sab suppress tty) nil ksrl srl)
1155                             (make-instance 'urank :rank rank :sab sab :tty tty :suppress suppress))
1156       (collect-umlisp-query (mrrank (rank sab suppress tty ksrl) nil nil nil)
1157                             (make-instance 'urank :rank rank :sab sab :tty tty :suppress suppress))))