r11140: do not export internal functions

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 2c8c93eb760cda10257ac11e68dac2788ca6af77..2831defc003504ff2c1f488793d013a80d612535 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -189,11 +189,15 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (ensure-cui-integer cui)
   (unless cui (return-from find-ucon-cui nil))
 
-  (let ((tuple (car (mutex-sql-query "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D AND KPFENG=1 AND SRL<=~D"
-                                     cui srl))))
+  (let ((tuple (car (mutex-sql-query 
+                     (format nil
+                             "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D AND KPFENG=1~A"
+                             cui (if srl (format nil " AND SRL<=~D" srl) ""))))))
     (unless tuple
-      (setq tuple (car (mutex-sql-query "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D AND SRL<=~D"
-                                        cui srl))))
+      (setq tuple (car (mutex-sql-query
+                        (format nil
+                                "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D"
+                                cui (if srl (format nil " AND SRL<=~D" srl) nil))))))
     (unless tuple
       (return-from find-ucon-cui nil))
     (make-instance 'ucon :cui cui :pfstr (second tuple)
@@ -211,11 +215,11 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (ensure-cui-integer cui)
   (or
     (caar (mutex-sql-query
-           (format nil "SELECT str FROM MRCONSO WHERE CUI=~D AND KPFENG=1 AND SLR<=~D"
-                   cui srl)))
+           (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 str FROM MRCONSO WHERE CUI=~D AND SLR<=~D"
-                   cui srl)))))
+           (format nil "SELECT DISTINCT str FROM MRCONSO WHERE CUI=~D~A LIMIT 1"
+                   cui (if srl (format nil " AND SRL<=~D" srl) ""))))))
 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"
@@ -226,11 +230,11 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                   :lrl (ensure-integer kcuilrl)))
   (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 AND SRL<=~D"
-                                     lui srl))))
+  (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 AND SRL<=~D"
-                                        lui srl))))
+      (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)
@@ -720,33 +724,43 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 ;;; Multiword lookup and score functions
 
 (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
-                           only-exact-if-match)
+                           only-exact-if-match limit)
   (let ((uobjs '()))
     (dolist (word (delimited-string-to-list str #\space))
       (setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
     (let ((sorted
           (funcall sort-fun str
                    (delete-duplicates uobjs :test #'= :key key))))
-      (if (and (plusp (length sorted))
-              only-exact-if-match
-              (multiword-match str (pfstr (first sorted))))
-         (first sorted)
-       sorted))))
+      (let ((len (length sorted)))
+        (cond
+         ((zerop len)
+          (return-from find-uobj-multiword nil))
+         ((and only-exact-if-match (multiword-match str (pfstr (first sorted))))
+          (first sorted))
+         (limit
+          (if (and (plusp limit) (> len limit))
+              (subseq sorted 0 limit)
+            limit))
+         (t
+          sorted))))))
 
 (defun find-ucon-multiword (str &key (srl *current-srl*)
-                                    (only-exact-if-match t))
+                                    (only-exact-if-match t)
+                                     limit)
   (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
-                      #'cui srl only-exact-if-match))
+                      #'cui srl only-exact-if-match limit))
 
 (defun find-uterm-multiword (str &key (srl *current-srl*)
-                                     (only-exact-if-match t))
+                                     (only-exact-if-match t)
+                                      limit)
   (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
-                      #'lui srl only-exact-if-match))
+                      #'lui srl only-exact-if-match limit))
 
 (defun find-ustr-multiword (str &key (srl *current-srl*)
-                                    (only-exact-if-match t))
+                                    (only-exact-if-match t)
+                                     limit)
   (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
-                      #'sui srl only-exact-if-match))
+                      #'sui srl only-exact-if-match limit))
 
 (defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"