r11148: fix limit / filter, improve udoc support

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 2831defc003504ff2c1f488793d013a80d612535..c91ee8a11b6144b77d769d6af515606d3b282197 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -26,37 +26,56 @@
   (setq *current-srl* srl))
 
 (defmacro query-string (table fields &optional srl where-name where-value
   (setq *current-srl* srl))
 
 (defmacro query-string (table fields &optional srl where-name where-value

-                       &key (lrl "KCUILRL") single distinct order like)
-  (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
-                          (if distinct "distinct " "") fields table))
-        (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}"
+                       &key (lrl "KCUILRL") single distinct order like limit
+                        filter)
+  (let* ((%%fields (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
+                          (if distinct "DISTINCT " "") fields table))
+        (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}"

                                    order)
                      ""))
                                    order)
                      ""))

-        (%%lrl (format nil " and ~:@(~A~)<=" lrl))
+        (%%lrl (format nil " AND ~:@(~A~)<=" lrl))

         (%%where (when where-name
                    (format nil " where ~:@(~A~)~A" where-name
         (%%where (when where-name
                    (format nil " where ~:@(~A~)~A" where-name

-                         (if like " like " "")))))
-    `(concatenate
-      'string
-      ,%%fields
-      ,@(when %%where (list %%where))
-      ,@(when %%where
-         `((typecase ,where-value
-             #+ignore
-             (fixnum
-              (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
-             (number
-              (concatenate 'string "='" (write-to-string ,where-value) "'"))
-             (null
-              " is null")
-             (t
-              (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
-      (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
-      ,@(when %%order (list %%order))
-      ,@(when single (list " limit 1")))))
+                         (if like " like " ""))))
+         (%filter (gensym "FILTER-"))
+         (%single (gensym "SINGLE-"))
+         (%limit (gensym "LIMIT-")))
+    `(let ((,%limit ,limit)
+           (,%single ,single)
+           (,%filter ,filter))
+       (concatenate
+        'string
+        ,%%fields
+        ,@(when %%where (list %%where))
+        ,@(when %%where
+            `((typecase ,where-value
+                #+ignore
+                (fixnum
+                 (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
+                (number
+                 (concatenate 'string "='" (write-to-string ,where-value) "'"))
+                (null
+                 " is null")
+                (t
+                 (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
+        (if ,%filter (concatenate 'string
+                                  ,(if %%where " AND " " WHERE ")
+                                  ,%filter) "")
+        (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
+        ,@(when %%order (list %%order))
+        (cond
+         ((and ,%single ,%limit)
+          (error "Can't set single and limit"))
+         (,%single
+          " LIMIT 1")
+         (,%limit
+          (format nil " LIMIT ~D" ,%limit))
+         (t
+          ""))))))

 
 (defun query-string-eval (table fields &optional srl where-name where-value
 
 (defun query-string-eval (table fields &optional srl where-name where-value

-                         &key (lrl "KCUILRL") single distinct order like)
+                         &key (lrl "KCUILRL") single distinct order like limit filter)
+  (when single (setq limit 1))

   (concatenate
    'string
    (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
   (concatenate
    'string
    (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"


@@ -71,64 +90,72 @@
                  (if like " like '%~A%""='~A'")))
               where-value)
        "")
                  (if like " like '%~A%""='~A'")))
               where-value)
        "")

+   (if filter (concatenate 'string " AND " filter) nil)

    (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
    (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")
    (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
    (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")

-   (if single " limit 1" "")))
+   (if limit (format nil " limit ~D" limit) "")))

 
 
 (defmacro umlisp-query (table fields srl where-name where-value
                     &key (lrl "KCUILRL") single distinct order like
 
 
 (defmacro umlisp-query (table fields srl where-name where-value
                     &key (lrl "KCUILRL") single distinct order like

-                       (query-cmd 'mutex-sql-query))
+                     limit filter (query-cmd 'mutex-sql-query))

   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value
   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value

-     :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+     :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
+     :filter ,filter :limit ,limit)))

 
 (defmacro umlisp-query-eval (table fields srl where-name where-value
 
 (defmacro umlisp-query-eval (table fields srl where-name where-value

-                    &key (lrl "KCUILRL") single distinct order like)
+                    &key (lrl "KCUILRL") single distinct order like 
+                     filter limit)

   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(mutex-sql-query
     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(mutex-sql-query
     (query-string-eval ,table ,fields ,srl ,where-name ,where-value

-     :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+     :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
+     :filter ,filter :limit ,limit)))

 
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value
                                    &key (lrl "KCUILRL") distinct single
 
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value
                                    &key (lrl "KCUILRL") distinct single

-                                   order like (query-cmd 'mutex-sql-query))
+                                   order like (query-cmd 'mutex-sql-query)
+                                    filter limit)

                                &body body)
   (let ((value (gensym))
        (r (gensym)))
     (if single
                                &body body)
   (let ((value (gensym))
        (r (gensym)))
     (if single

-       `(let* ((,value ,where-value)
-               (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
-                                         :lrl ,lrl :single ,single
-                                         :distinct ,distinct :order ,order
-                                         :like ,like
-                                         :query-cmd ,query-cmd))))
-         ,@(unless where-name `((declare (ignore ,value))))
-         (when tuple
-               (destructuring-bind ,fields tuple
-                 ,@body)))
+        (if (and limit (> limit 1))
+            (error "Can't set limit along with single.")
+          `(let* ((,value ,where-value)
+                  (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
+                                            :lrl ,lrl :single ,single
+                                            :distinct ,distinct :order ,order
+                                            :like ,like :filter ,filter
+                                            :query-cmd ,query-cmd))))
+             ,@(unless where-name `((declare (ignore ,value))))
+             (when tuple
+               (destructuring-bind ,fields tuple
+                 ,@body))))

        `(let ((,value ,where-value))
           ,@(unless where-name `((declare (ignore ,value))))
           (let ((,r '()))
             (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
                                          :lrl ,lrl :single ,single :distinct ,distinct
        `(let ((,value ,where-value))
           ,@(unless where-name `((declare (ignore ,value))))
           (let ((,r '()))
             (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
                                          :lrl ,lrl :single ,single :distinct ,distinct

-                                         :order ,order :like ,like))
+                                         :order ,order :filter ,filter :like ,like
+                                          :limit ,limit))

               (push (destructuring-bind ,fields tuple ,@body) ,r))
             (nreverse ,r))
           #+ignore
           (loop for tuple in
                 (umlisp-query ,table ,fields ,srl ,where-name ,value
                               :lrl ,lrl :single ,single :distinct ,distinct
               (push (destructuring-bind ,fields tuple ,@body) ,r))
             (nreverse ,r))
           #+ignore
           (loop for tuple in
                 (umlisp-query ,table ,fields ,srl ,where-name ,value
                               :lrl ,lrl :single ,single :distinct ,distinct

-                              :order ,order :like ,like)
+                              :order ,order :like ,like :filter ,filter :limit ,limit)

               collect (destructuring-bind ,fields tuple ,@body))))))
 
 (defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
                                         &key (lrl "KCUILRL") distinct single
               collect (destructuring-bind ,fields tuple ,@body))))))
 
 (defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
                                         &key (lrl "KCUILRL") distinct single

-                                        order like)
+                                        order like filter limit)

                                  &body body)
   (let ((value (gensym))
        (r (gensym))
                                  &body body)
   (let ((value (gensym))
        (r (gensym))


@@ -138,7 +165,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                               :lrl ,lrl :single ,single
                                               :distinct ,distinct :order ,order
                (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                               :lrl ,lrl :single ,single
                                               :distinct ,distinct :order ,order

-                                              :like ,like))))
+                                              :like ,like :filter ,filter
+                                               :limit ,limit))))

          (when tuple
            (destructuring-bind ,eval-fields tuple
              ,@body)))
          (when tuple
            (destructuring-bind ,eval-fields tuple
              ,@body)))


@@ -146,14 +174,16 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
               (,r '()))
           (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                             :lrl ,lrl :single ,single :distinct ,distinct
               (,r '()))
           (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                             :lrl ,lrl :single ,single :distinct ,distinct

-                                            :order ,order :like ,like))
+                                            :order ,order :like ,like
+                                             :filter ,filter :limit ,limit))

             (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
           (nreverse ,r)
           #+ignore
           (loop for tuple in
                 (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                    :lrl ,lrl :single ,single :distinct ,distinct
             (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
           (nreverse ,r)
           #+ignore
           (loop for tuple in
                 (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
                                    :lrl ,lrl :single ,single :distinct ,distinct

-                                   :order ,order :like ,like)
+                                   :order ,order :like ,like :filter ,filter
+                                    :limit ,limit)

               collect (destructuring-bind ,eval-fields tuple ,@body))))))
 
 ;;;
               collect (destructuring-bind ,eval-fields tuple ,@body))))))
 
 ;;;


@@ -214,31 +244,26 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
   (or
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
   (or

-    (caar (mutex-sql-query
-           (format nil "SELECT DISTINCT str FROM MRCONSO WHERE CUI=~D AND KPFENG=1~A LIMIT 1"
-                   cui (if srl (format nil " AND SRL<=~D" srl) ""))))
-    (caar (mutex-sql-query
-           (format nil "SELECT DISTINCT str FROM MRCONSO WHERE CUI=~D~A LIMIT 1"
-                   cui (if srl (format nil " AND SRL<=~D" srl) ""))))))
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t 
+                                  :filter " KPFENG=1" :single t)
+      str)
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t 
+                                  :single t)
+      str)))

 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"
   (ensure-lui-integer lui)
 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"
   (ensure-lui-integer lui)

-  (collect-umlisp-query (mrconso (cui kcuilrl) srl lui lui
-                           :distinct t)
-     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
-                  :lrl (ensure-integer kcuilrl)))

   (unless lui (return-from find-ucon-lui nil))
   (unless lui (return-from find-ucon-lui nil))

-
-  (let ((tuple (car (mutex-sql-query "SELECT cui,kcuilrl,str FROM MRCONSO WHERE LUI=~D AND KPFENG=1~A ORDER BY kcuilrl ASC LIMIT 1"
-                                     lui (if srl (format nil " AND SRL<=~D" srl) "")))))
-    (unless tuple
-      (setq tuple (car (mutex-sql-query "SELECT cui,kcuilrl,str FROM MRCONSO WHERE LUI=~D~A ORDER BY kcuilrl ASC LIMIT 1"
-                                        lui (if srl (format nil " AND SRL<=~D" srl) "")))))
-    (unless tuple
-      (return-from find-ucon-lui nil))
-    (make-instance 'ucon :cui (first tuple) :pfstr (third tuple)
-                   :lrl (ensure-integer (third tuple)))))
+  (or
+   (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
+                                  :filter " KPFENG=1" :single t)
+      (make-instance 'ucon :cui (ensure-integer cui)
+                     :pfstr str :lrl (ensure-integer kcuilrl)))
+   (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
+                                  :single t)
+      (make-instance 'ucon :cui (ensure-integer cui)
+                     :pfstr str :lrl (ensure-integer kcuilrl)))))

 
 (defun find-ucon-sui (sui &key (srl *current-srl*))
   "Find list of ucon for sui"
 
 (defun find-ucon-sui (sui &key (srl *current-srl*))
   "Find list of ucon for sui"


@@ -323,24 +348,21 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-udoc-key (key)
   "Return list of abbreviation documentation for a key"
   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)
 (defun find-udoc-key (key)
   "Return list of abbreviation documentation for a key"
   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)

-    (make-instance 'udoc :key key :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey key :dvalue value :dtype type :expl expl)))

 
 (defun find-udoc-value (value)
   "Return abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)
 
 (defun find-udoc-value (value)
   "Return abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)

-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 

-(defun find-udoc-key-value (key value)
-  (let ((tuple (car (mutex-sql-query
-                    (format nil "SELECT TYPE,EXPL FROM MRDOC WHERE DOCKEY='~A' AND VALUE='~A'"
-                            key value)))))
-    (when tuple
-      (make-instance 'udoc :key key :value value :type (first tuple) :expl (second tuple)))))
+(defun find-udoc-key-value (dockey value)
+  (collect-umlisp-query (mrdoc (type expl) nil dockey dockey :filter (format nil "VALUE='~A'" value))
+      (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 (defun find-udoc-all ()
   "Return all abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
 
 (defun find-udoc-all ()
   "Return all abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)

-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 (defun find-usty-cui (cui &key (srl *current-srl*))
   "Return a list of usty for cui"
 
 (defun find-usty-cui (cui &key (srl *current-srl*))
   "Return a list of usty for cui"


@@ -511,17 +533,28 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
   (ensure-sui-integer sui)
   (ensure-cui-integer cui)
 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
   (ensure-sui-integer sui)
   (ensure-cui-integer cui)

-  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui) srl kcuisui
+  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str) srl kcuisui

                           (make-cuisui cui sui) :lrl srl)
     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
                           (make-cuisui cui sui) :lrl srl)
     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty

-                  :cui cui :sui sui :saui saui :sdui sdui :scui scui)))
+                  :cui cui :sui sui :saui saui :sdui sdui :scui scui
+                   :lat lat :str str)))
+
+(defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
+  (ensure-cui-integer cui)
+  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str sui) 
+                                 srl cui cui :lrl srl :limit limit
+                                 :filter (when english-only "LAT='ENG'"))
+     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
+                    :cui cui :sui sui :saui saui :sdui sdui :scui scui
+                    :lat lat :str str)))

 
 (defun find-uso-aui (aui &key (srl *current-srl*))
   (ensure-sui-integer aui)
 
 (defun find-uso-aui (aui &key (srl *current-srl*))
   (ensure-sui-integer aui)

-  (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui) srl aui
+  (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui lat str) srl aui

                                 aui :lrl srl :single t)
     (make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty
                                 aui :lrl srl :single t)
     (make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty

-                  :sui sui :saui saui :sdui sdui :scui scui)))
+                  :sui sui :saui saui :sdui sdui :scui scui
+                   :lat lat :str str)))

 
 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
   (ensure-cui-integer cui)
 
 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
   (ensure-cui-integer cui)


@@ -588,7 +621,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (find-usty-tui tui)))
 
 (defun find-usab-all ()
     (find-usty-tui tui)))
 
 (defun find-usab-all ()

-  "Find usab for a key"
+  "Return all usab objects"

   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
                                  rmeta slc scc srl tfr cfr cxty ttyl atnl lat
                                  cenc curver sabin ssn scit) nil nil nil)
   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
                                  rmeta slc scc srl tfr cfr cxty ttyl atnl lat
                                  cenc curver sabin ssn scit) nil nil nil)