X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql-create.lisp;h=49f550e9b99bf7f36c26bffdd1ebd770d50825fb;hb=7e088e3bca94e4cba5a00f3c3734db4ea57f4e2f;hp=101a02a06a0debfac257b5450cb1c287b55749e8;hpb=48a89995e768d67fcda55849a70b0ea759ad190a;p=umlisp.git

diff --git a/sql-create.lisp b/sql-create.lisp
index 101a02a..49f550e 100644
--- a/sql-create.lisp
+++ b/sql-create.lisp
@@ -4,10 +4,10 @@
 ;;;;
 ;;;; Name:          sql-create
 ;;;; Purpose:       Create SQL database for UMLisp
-;;;; Programmer:    Kevin M. Rosenberg
+;;;; Author:        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.21 2003/05/06 08:15:47 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -17,118 +17,66 @@
 ;;;; *************************************************************************
 
 (in-package :umlisp)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
-
-
-(defun create-table-cmd-old (file)
-  "Return sql command to create a table"
-  (let ((col-func 
-	 (lambda (c) 
-	   (let ((sqltype (umls-col-sqltype c)))
-	     (concatenate 'string (umls-col-col c)
-			  " "
-			  (if (or (string-equal sqltype "VARCHAR")
-				  (string-equal sqltype "CHAR"))
-			      (format nil "~a (~a)" sqltype (umls-col-max c))
-			      sqltype)
-			  ",")))))
-    (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
-	    (string-trim-last-character
-	     (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
 
+(eval-when (:compile-toplevel)
+  (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
 
 (defun create-table-cmd (file)
   "Return sql command to create a table"
   (let ((col-func 
 	 (lambda (c) 
-	   (let ((sqltype (umls-col-sqltype c)))
+	   (let ((sqltype (sqltype c)))
 	     (concatenate 'string
-			  (umls-col-col c)
+			  (col c)
 			  " "
 			  (if (or (string-equal sqltype "VARCHAR")
 				  (string-equal sqltype "CHAR"))
-			      (format nil "~a (~a)" sqltype (umls-col-max c))
+			      (format nil "~a (~a)" sqltype (cmax c))
 			      sqltype))))))
-    (format nil "CREATE TABLE ~a (~{~a~^,~})" (umls-file-table file)
-	    (mapcar col-func (umls-cols-for-umls-file file)))))
+    (format nil "CREATE TABLE ~a (~{~a~^,~})" (table file)
+	    (mapcar col-func (ucols-for-ufile file)))))
 
 (defun create-custom-table-cmd (tablename sql-cmd)
   "Return SQL command to create a custom table"
   (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
 
-(defun insert-values-cmd-old (file values)
-  "Return sql insert command for a row of values"  
-  (let ((insert-func
-	 (lambda (col value)
-	   (concatenate
-	    'string
-	    (umls-col-quotechar col)
-	    (if (null (umls-col-parsefunc col)) 
-		value
-		(format nil "~A" (funcall (umls-col-parsefunc col) value)))
-	    (umls-col-quotechar col)
-	    ","))))
-    (format
-     nil "INSERT INTO ~a (~a) VALUES (~a)"
-     (umls-file-table file)
-     (string-trim-last-character
-      (mapcar-append-string (lambda (c) (concatenate 'string c ","))
-			    (umls-file-fields file)))
-     (string-trim-last-character
-      (concatenate 'string
-		   (mapcar2-append-string insert-func
-					  (remove-custom-cols (umls-file-colstructs file)) 
-					  values)
-		   (custom-col-values-old (custom-colstructs-for-file file) values "," t)))
-     )))
-
 (defun insert-col-value (col value)
-  (if (null (umls-col-parsefunc col)) 
+  (if (null (parse-fun col)) 
       value
-      (format nil "~A" (funcall (umls-col-parsefunc col) value))))
+      (format nil "~A" (funcall (parse-fun col) value))))
 
 (defun insert-values-cmd (file values)
   "Return sql insert command for a row of values"  
   (let ((insert-func
 	 (lambda (col value)
-	   (let ((q (umls-col-quotechar col)))
+	   (let ((q (quotechar col)))
 	     (concatenate 'string q (insert-col-value col value) q)))))
     (format
-     nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~{~a~^,~})"
-     (umls-file-table file)
-     (umls-file-fields file)
-     (append
-      (mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values)
-      (custom-col-values (custom-colstructs-for-file file) values t)))))
-
-(defun custom-col-values-old (colstructs values delim doquote)
-  "Returns a string of column values for SQL inserts for custom columns"
-  (let ((result ""))
-    (dolist (col colstructs)
-      (let* ((func (umls-col-custom-value-func col))
-	     (custom-value (funcall func values)))
-	(string-append result 
-		       (if doquote (umls-col-quotechar col))
-		       (escape-backslashes custom-value)
-		       (if doquote (umls-col-quotechar col))
-		       delim)))
-    result))
-
-(defun col-value (col doquote values)
-  (let ((custom-value (funcall (umls-col-custom-value-func col) values)))
-    (if doquote
-	(let ((q (umls-col-quotechar col)))
-	  (concatenate 'string q (escape-backslashes custom-value) q))
-	(escape-backslashes custom-value))))
-
-(defun custom-col-values (colstructs values doquote)
+     nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
+     (table file)
+     (fields file)
+     (concat-separated-strings
+      "," 
+      (mapcar insert-func (remove-custom-cols (ucols file)) values)
+      (custom-col-values (custom-ucols-for-file file) values t)))))
+
+
+(defun custom-col-value (col values doquote)
+  (let ((custom-value (funcall (custom-value-fun col) values)))
+    (if custom-value
+	(if doquote
+	    (let ((q (quotechar col)))
+	      (concatenate 'string q (escape-backslashes custom-value) q))
+	    (escape-backslashes custom-value))
+	"")))
+
+(defun custom-col-values (ucols 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 ucols collect (custom-col-value col values doquote)))
 
 (defun remove-custom-cols (cols)
   "Remove custom cols from a list col umls-cols"
-  (remove-if #'umls-col-custom-value-func cols))
+  (remove-if #'custom-value-fun cols))
 
 (defun find-custom-cols-for-filename (filename)
   (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
@@ -137,75 +85,71 @@
   (find-if (lambda (x) (and (string-equal filename (car x))
 			    (string-equal col (cadr x)))) +custom-cols+))
 
-
 (defun custom-colnames-for-filename (filename)
   (mapcar #'cadr (find-custom-cols-for-filename filename)))
 
-(defun custom-colstructs-for-file (file)
-  (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
+(defun custom-ucols-for-file (file)
+  (remove-if-not #'custom-value-fun (ucols file)))
 
 (defun noneng-lang-index-files ()
-  (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
-				  (string-equal (umls-file-fil f) "MRXW." :end1 5) 
-				  (not (string-equal (umls-file-fil f) "MRXW.ENG"))
-				  (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
-		 *umls-files*))
+  (remove-if-not
+   (lambda (f) (and (> (length (fil f)) 4)
+		    (string-equal (fil f) "MRXW." :end1 5) 
+		    (not (string-equal (fil f) "MRXW.ENG"))
+		    (not (string-equal (fil f) "MRXW.NONENG"))))
+   *umls-files*))
 
 ;;; SQL Command Functions
 
 (defun create-index-cmd (colname tablename length)
   "Return sql create index command"
   (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
-	  (concatenate 'string tablename "_" colname "_X") tablename colname
-	  (if (integerp length)
-	      (format nil "(~d)" length)
-	      "")))
+	  (concatenate 'string tablename "_" colname "_X")
+	  tablename colname
+	  (if (integerp length) (format nil "(~d)" length) "")))
 
 (defun create-all-tables-cmdfile ()
   "Return sql commands to create all tables. Not need for automated SQL import"
   (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
 
-
 ;; SQL Execution functions
 
 (defun sql-drop-tables (conn)
   "SQL Databases: drop all tables"
-  (mapcar
-   (lambda (file)
-     (ignore-errors 
-       (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
-   *umls-files*))
+  (dolist (file *umls-files*)
+    (ignore-errors 
+      (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
 
 (defun sql-create-tables (conn)
   "SQL Databases: create all tables" 
-  (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
+  (dolist (file *umls-files*)
+    (sql-execute (create-table-cmd file) conn)))
 
 (defun sql-create-custom-tables (conn)
   "SQL Databases: create all custom tables"
-  (mapcar (lambda (ct)
-	    (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
-	  +custom-tables+))
+  (dolist (ct +custom-tables+)
+    (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
   
 (defun sql-insert-values (conn file)
   "SQL Databases: inserts all values for a file"  
-  (with-umls-file (line (umls-file-fil file))
+  (with-umls-file (line (fil file))
     (sql-execute (insert-values-cmd file line) conn)))
 
 (defun sql-insert-all-values (conn)
   "SQL Databases: inserts all values for all files"  
-  (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
+  (dolist (file *umls-files*)
+    (sql-insert-values conn file)))
 
 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
   "SQL Databases: create all indexes"
-  (mapcar 
-   (lambda (idx) 
-     (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)) 
-   indexes))
+  (dolist (idx indexes)
+    (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))) 
 
 (defun make-usrl (conn)
   (sql-execute "drop table if exists USRL" conn)
   (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
-  (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
+  (dolist (tuple (mutex-sql-query
+		  "select distinct SAB,SRL from MRSO order by SAB asc"))
     (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" 
 			 (car tuple) (ensure-integer (cadr tuple)))
 		 conn)))
@@ -236,7 +180,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,78 +191,55 @@ 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*))
+  (dolist (f *umls-files*) (translate-umls-file f extension)))
 
-(defun translate-file (file extension)
+(defun translate-umls-file (file extension)
   "Translate a umls file into a format suitable for sql copy cmd"
-  (let ((path (umls-pathname (umls-file-fil file) extension)))
-    (if (probe-file path)
-	(progn
-	  (format t "File ~A already exists: skipping~%" path)
-	  nil)
-	(with-open-file (ostream path :direction :output)
-	  (with-umls-file (line (umls-file-fil file))
-	    (princ (umls-translate file line) ostream)
-	    (princ #\newline ostream))
-	  t))))
+  (translate-files file extension (list file)))
 
 (defun make-noneng-index-file (extension)
   "Make non-english index file"
-  (let* ((outfile (find-umls-file "MRXW.NONENG"))
-	 (path (umls-pathname (umls-file-fil outfile) extension)))
-	
-    (if (probe-file path)
-	(progn
-	  (format t "File ~A already exists: skipping~%" path)
-	  nil)
-	(progn
-	  (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
-		(princ #\newline ostream))))
-	  t))))
+  (translate-files (find-ufile "MRXW.NONENG")
+		   extension (noneng-lang-index-files)))
+
+(defun translate-files (out-ufile extension input-ufiles)
+  "Translate a umls file into a format suitable for sql copy cmd"
+  (let ((output-path (umls-pathname (fil out-ufile) extension)))
+    (if (probe-file output-path)
+	(format t "File ~A already exists: skipping~%" output-path)
+      (with-open-file (ostream output-path :direction :output)
+	(dolist (input-ufile input-ufiles)
+	  (with-umls-file (line (fil input-ufile))
+	    (translate-line out-ufile line ostream)
+	    (princ #\newline ostream)))))))
 
 (defun pg-copy-cmd (file extension)
   "Return postgresql copy statement for a file"  
-  (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
-	  (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
+  (format
+   nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
+   (table file) (umls-pathname (fil file) extension)))
 
 (defun mysql-copy-cmd (file extension)
   "Return mysql copy statement for a file"  
-  (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
-	  (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
-
-(defun umls-translate-old (file line)
-  "Translate a single line for sql output"
-  (string-trim-last-character
-   (concatenate 'string
-		(mapcar2-append-string 
-		 (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-old (custom-colstructs-for-file file) line "|" nil))))
-
-(defun umls-translate (file line)
+  (format
+   nil
+   "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
+   (umls-pathname (fil file) extension) (table file)))
+
+(defun col-value (col value)
+  (if (eq (datatype col) 'sql-u)
+      (let ((ui (parse-ui value "")))
+	(if (stringp ui)
+	    ui
+	  (write-to-string ui)))
+    (escape-backslashes value)))
+
+(defun translate-line (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 (ucols file)) line)
+   (custom-col-values (custom-ucols-for-file file) line nil)))
    
 
 ;;; Routines for analyzing cost of fixed size storage
@@ -332,19 +253,24 @@ This is much faster that using create-umls-db-insert."
 	(unavoidable '())
 	(avoidable '()))
     (dolist (file *umls-files*)
-      (dolist (col (umls-file-colstructs file))
-	(let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
-	       (cwaste (* avwaste (umls-file-rws file))))
-	  (unless (zerop cwaste)
+      (dolist (col (ucols file))
+	(let* ((avwaste (- (cmax col) (av col)))
+	       (cwaste (* avwaste (rws file))))
+	  (when (plusp cwaste)
 	    (if (<= avwaste 6)
 		(progn
 		  (incf totalunavoidable cwaste)
-		  (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
+		  (push (list (fil file) (col col)
+			      avwaste cwaste)
+			unavoidable))
 		(progn
 		  (incf totalavoidable cwaste)
-		  (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
+		  (push (list (fil file) (col col)
+			      avwaste cwaste)
+			avoidable)))
 	    (incf totalwaste cwaste)))))
-    (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
+    (values totalwaste totalavoidable totalunavoidable
+	    (nreverse avoidable) (nreverse unavoidable))))
 
 (defun display-waste ()
   (unless *umls-files*
@@ -368,22 +294,19 @@ This is much faster that using create-umls-db-insert."
   (let ((max 0))
     (declare (fixnum max))
     (dolist (col *umls-cols*)
-      (when (> (umls-col-max col) max)
-	(setq max (umls-col-max col))))
+      (when (> (cmax col) max)
+	(setq max (cmax col))))
     max))
 
 (defun max-umls-row ()
   "Return length of longest row"
-  (if t
-      6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
-      (progn
-	(unless *umls-files*
-	  (init-umls))
-	(let ((rowsizes '()))
-	  (dolist (file *umls-files*)
-	    (let ((row 0)
-		  (fields (umls-file-colstructs file)))
-	      (dolist (field fields)
-		(incf row (1+ (umls-col-max field))))
-	      (push row rowsizes)))
-	  (car (sort rowsizes #'>))))))
+  (unless *umls-files*
+    (init-umls))
+  (let ((rowsizes '()))
+    (dolist (file *umls-files*)
+      (let ((row 0)
+	    (fields (ucols file)))
+	(dolist (field fields)
+	  (incf row (1+ (cmax field))))
+	(push row rowsizes)))
+    (car (sort rowsizes #'>))))