;;;; 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.
(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
;;;; 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.
(,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)
;;;; 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.
" 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" "")))
&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
(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)
(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
;;;; 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.
(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)))))
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)))
(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)
(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)
(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"
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))))
(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))))
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
;;;; 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.
(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")
projects / umlisp.git / commitdiff