From: Kevin M. Rosenberg Date: Mon, 5 May 2003 23:13:28 +0000 (+0000) Subject: r4820: *** empty log message *** X-Git-Tag: v2006ac.2~200 X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=commitdiff_plain;h=58e6e7e38d835e51beb5f21440b4b7bd27d106f2 r4820: *** empty log message *** --- diff --git a/parse-common.lisp b/parse-common.lisp index 8ba30e6..c47acb4 100644 --- a/parse-common.lisp +++ b/parse-common.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: parse-common.lisp,v 1.4 2002/10/21 02:23:46 kevin Exp $ +;;;; $Id: parse-common.lisp,v 1.5 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -37,19 +37,19 @@ (pathname filename))) -(defun read-umls-line (strm) +(defun read-umls-line-new (strm) "Read a line from a UMLS stream, split into fields" (let ((line (read-line strm nil 'eof))) (if (stringp line) ;; ensure not 'eof - (let* ((len (length line)) - (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line - (if (char= #\| (char line (1- len))) - (subseq line 0 (1- len)) - line))) - (declare (fixnum len)) - (delimited-string-to-list maybe-remove-terminal #\|)) + (delimited-string-to-list line #\| t) line))) +(defun read-umls-line (strm) + "Read a line from a UMLS stream, split into fields" + (let ((line (read-line strm nil 'eof))) + (if (stringp line) ;; ensure not 'eof + (delimited-string-to-list line #\| t) + line))) ;;; Find field lengths for LEX and NET files diff --git a/parse-macros.lisp b/parse-macros.lisp index edccfe8..d356282 100644 --- a/parse-macros.lisp +++ b/parse-macros.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: parse-macros.lisp,v 1.2 2002/10/09 23:03:41 kevin Exp $ +;;;; $Id: parse-macros.lisp,v 1.3 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -39,7 +39,7 @@ (,ustream (umls-pathname ,filename) :direction :input :if-exists :overwrite) (do ((,line (read-buffered-fields ,buffer ,ustream) (read-buffered-fields ,buffer ,ustream))) - ((eq ,line 'eof) t) + ((eq ,line 'kl::eof) t) ,@body))))) (defmacro with-buffered2-umls-file ((line filename) &body body) diff --git a/sql-classes.lisp b/sql-classes.lisp index 8a400e1..728c756 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-classes.lisp,v 1.69 2003/05/04 04:41:07 kevin Exp $ +;;;; $Id: sql-classes.lisp,v 1.70 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -68,7 +68,7 @@ " where ~A='~A'"))) where-name where-value) "") - (if srl (format nil " and ~:@(~A~) <= ~D" lrl srl) "") + (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "") (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "") (if single " limit 1" ""))) @@ -94,7 +94,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" &key (lrl "KCUILRL") distinct single order like) &body body) - (let ((value (gensym))) + (let ((value (gensym)) + (r (gensym))) (if single `(let* ((,value ,where-value) (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value @@ -106,19 +107,26 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (destructuring-bind ,fields tuple ,@body))) `(let ((,value ,where-value)) - ,@(unless where-name `((declare (ignore ,value)))) - (loop for tuple in - (umlisp-query ,table ,fields ,srl ,where-name ,value - :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like) - collect (destructuring-bind ,fields tuple - ,@body)))))) + ,@(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)) + (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) + collect (destructuring-bind ,fields tuple ,@body)))))) (defmacro with-umlisp-query-eval ((table fields srl where-name where-value &key (lrl "KCUILRL") distinct single order like) &body body) (let ((value (gensym)) + (r (gensym)) (eval-fields (cadr fields))) (if single `(let* ((,value ,where-value) @@ -129,13 +137,19 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (when tuple (destructuring-bind ,eval-fields tuple ,@body))) - `(let ((,value ,where-value)) - (loop for tuple in - (umlisp-query-eval ,table ,fields ,srl ,where-name ,value - :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like) - collect (destructuring-bind ,eval-fields tuple - ,@body)))))) + `(let ((,value ,where-value) + (,r '())) + (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value + :lrl ,lrl :single ,single :distinct ,distinct + :order ,order :like ,like)) + (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) + collect (destructuring-bind ,eval-fields tuple ,@body)))))) ;;; ;;; Read from SQL database diff --git a/sql-create.lisp b/sql-create.lisp index 101a02a..236b137 100644 --- a/sql-create.lisp +++ b/sql-create.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-create.lisp,v 1.6 2003/05/04 08:55:52 kevin Exp $ +;;;; $Id: sql-create.lisp,v 1.7 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -94,10 +94,11 @@ (let ((q (umls-col-quotechar col))) (concatenate 'string q (insert-col-value col value) q))))) (format - nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~{~a~^,~})" + nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)" (umls-file-table file) (umls-file-fields file) - (append + (concat-separated-strings + "," (mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values) (custom-col-values (custom-colstructs-for-file file) values t))))) @@ -114,7 +115,7 @@ delim))) result)) -(defun col-value (col doquote values) +(defun custom-col-value (col doquote values) (let ((custom-value (funcall (umls-col-custom-value-func col) values))) (if doquote (let ((q (umls-col-quotechar col))) @@ -123,7 +124,7 @@ (defun custom-col-values (colstructs values doquote) "Returns a list of string column values for SQL inserts for custom columns" - (loop for col in colstructs collect (col-value col doquote values))) + (loop for col in colstructs collect (custom-col-value col doquote values))) (defun remove-custom-cols (cols) @@ -236,7 +237,7 @@ This is much faster that using create-umls-db-insert." (with-sql-connection (conn) (sql-drop-tables conn) (sql-create-tables conn) - (mapcar + (map 'nil #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn)) *umls-files*) (sql-create-indexes conn) @@ -247,7 +248,7 @@ This is much faster that using create-umls-db-insert." (defun translate-all-files (&optional (extension ".trans")) "Copy translated files and return postgresql copy commands to import" (make-noneng-index-file extension) - (mapcar (lambda (f) (translate-file f extension)) *umls-files*)) + (map 'nil (lambda (f) (translate-file f extension)) *umls-files*)) (defun translate-file (file extension) "Translate a umls file into a format suitable for sql copy cmd" @@ -258,7 +259,7 @@ This is much faster that using create-umls-db-insert." nil) (with-open-file (ostream path :direction :output) (with-umls-file (line (umls-file-fil file)) - (princ (umls-translate file line) ostream) + (umls-translate file line ostream) (princ #\newline ostream)) t)))) @@ -275,7 +276,7 @@ This is much faster that using create-umls-db-insert." (with-open-file (ostream path :direction :output) (dolist (inputfile (noneng-lang-index-files)) (with-umls-file (line (umls-file-fil inputfile)) - (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols + (umls-translate outfile line ostream) ;; use outfile for custom cols (princ #\newline ostream)))) t)))) @@ -305,20 +306,34 @@ This is much faster that using create-umls-db-insert." line) (custom-col-values-old (custom-colstructs-for-file file) line "|" nil)))) -(defun umls-translate (file line) +(defun concat-separated-strings (separator &rest lists) + (format nil (format nil "~~{~~A~~^~A~~}" separator) (mapappend #'identity lists))) + +(defun print-separated-strings (strm separator &rest lists) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0))) + (do* ((rest-lists lists (cdr rest-lists)) + (list (car rest-lists) (car rest-lists)) + (last-list (null (cdr rest-lists)) (null (cdr rest-lists)))) + ((null list) strm) + (do* ((lst list (cdr lst)) + (elem (car lst) (car lst)) + (last-elem (null (cdr lst)) (null (cdr lst)))) + ((null lst)) + (write-string elem strm) + (unless (and last-elem last-list) + (write-string separator strm))))) + +(defun col-value (col value) + (if (eq (umls-col-datatype col) 'sql-u) + (write-to-string (parse-ui value "")) + (escape-backslashes value))) + +(defun umls-translate (file line strm) "Translate a single line for sql output" - (format nil "~{~A~^|~}" - (append - (mapcar - (lambda (col value) - (concatenate - 'string - (if (eq (umls-col-datatype col) 'sql-u) - (format nil "~d" (parse-ui value "")) - (escape-backslashes value)))) - (remove-custom-cols (umls-file-colstructs file)) - line) - (custom-col-values (custom-colstructs-for-file file) line nil)))) + (print-separated-strings + strm "|" + (mapcar #'col-value (remove-custom-cols (umls-file-colstructs file)) line) + (custom-col-values (custom-colstructs-for-file file) line nil))) ;;; Routines for analyzing cost of fixed size storage diff --git a/tests.lisp b/tests.lisp index 79fd4e3..0caf623 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: May 2003 ;;;; -;;;; $Id: tests.lisp,v 1.3 2003/05/03 17:10:08 kevin Exp $ +;;;; $Id: tests.lisp,v 1.4 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -24,30 +24,55 @@ (rem-all-tests) -(deftest qs.1 (umlisp::query-string 'mrcon '(cui lui)) +(deftest qs.1 (umlisp::query-string mrcon (cui lui)) "select CUI,LUI from MRCON") -(deftest qs.2 (umlisp::query-string 'mrcon '(cui lui) 0) - "select CUI,LUI from MRCON and KCUILRL <= 0") +(deftest qs.1e (umlisp::query-string-eval 'mrcon '(cui lui)) + "select CUI,LUI from MRCON") + +(deftest qs.2 (umlisp::query-string mrcon (cui lui) 0) + "select CUI,LUI from MRCON and KCUILRL<=0") + +(deftest qs.2e (umlisp::query-string-eval 'mrcon '(cui lui) 0) + "select CUI,LUI from MRCON and KCUILRL<=0") -(deftest qs.3 (umlisp::query-string 'mrcon '(cui lui) nil 'cui 5) +(deftest qs.3 (umlisp::query-string mrcon (cui lui) nil cui 5) "select CUI,LUI from MRCON where CUI=5") -(deftest qs.4 (umlisp::query-string 'mrcon '(cui lui) nil 'kpfstr "Abc") +(deftest qs.3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5) + "select CUI,LUI from MRCON where CUI=5") + +(deftest qs.4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc") "select CUI,LUI from MRCON where KPFSTR='Abc'") -(deftest qs.5 (umlisp::query-string 'mrcon '(cui lui) 2 'cui 5 :single t) - "select CUI,LUI from MRCON where CUI=5 and KCUILRL <= 2 limit 1") +(deftest qs.4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc") + "select CUI,LUI from MRCON where KPFSTR='Abc'") + +(deftest qs.5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t) + "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1") + +(deftest qs.5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t) + "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1") + +(deftest qs.6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1") + +(deftest qs.6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1") + +(deftest qs.7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc)) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc") -(deftest qs.6 (umlisp::query-string 'mrdef '(sab def) 2 'cui 39 :lrlname 'ksrl :single t) - "select SAB,DEF from MRDEF where CUI=39 and KSRL <= 2 limit 1") +(deftest qs.7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc)) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc") -(deftest qs.7 (umlisp::query-string 'mrdef '(sab def) 2 'cui 39 :lrlname 'ksrl :order '((cui . asc))) - "select SAB,DEF from MRDEF where CUI=39 and KSRL <= 2 order by CUI asc") +(deftest qs.8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl + :order (cui asc def desc)) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc") -(deftest qs.8 (umlisp::query-string 'mrdef '(sab def) 2 'cui 39 :lrlname 'ksrl - :order '((cui . asc) (def . desc))) - "select SAB,DEF from MRDEF where CUI=39 and KSRL <= 2 order by CUI asc,DEF desc") +(deftest qs.8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl + :order '(cui asc def desc)) + "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc")