1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Create SQL database for UMLisp
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: sql-create.lisp,v 1.10 2003/05/06 02:19:46 kevin Exp $
12 ;;;; This file, part of UMLisp, is
13 ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
15 ;;;; UMLisp users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the GNU General Public License.
17 ;;;; *************************************************************************
21 (eval-when (:compile-toplevel)
22 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
24 (defun create-table-cmd (file)
25 "Return sql command to create a table"
28 (let ((sqltype (umls-col-sqltype c)))
32 (if (or (string-equal sqltype "VARCHAR")
33 (string-equal sqltype "CHAR"))
34 (format nil "~a (~a)" sqltype (umls-col-max c))
36 (format nil "CREATE TABLE ~a (~{~a~^,~})" (umls-file-table file)
37 (mapcar col-func (umls-cols-for-umls-file file)))))
39 (defun create-custom-table-cmd (tablename sql-cmd)
40 "Return SQL command to create a custom table"
41 (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
43 (defun insert-col-value (col value)
44 (if (null (umls-col-parsefunc col))
46 (format nil "~A" (funcall (umls-col-parsefunc col) value))))
48 (defun insert-values-cmd (file values)
49 "Return sql insert command for a row of values"
52 (let ((q (umls-col-quotechar col)))
53 (concatenate 'string q (insert-col-value col value) q)))))
55 nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
56 (umls-file-table file)
57 (umls-file-fields file)
58 (concat-separated-strings
60 (mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values)
61 (custom-col-values (custom-colstructs-for-file file) values t)))))
64 (defun custom-col-value (col doquote values)
65 (let ((custom-value (funcall (umls-col-custom-value-func col) values)))
67 (let ((q (umls-col-quotechar col)))
68 (concatenate 'string q (escape-backslashes custom-value) q))
69 (escape-backslashes custom-value))))
71 (defun custom-col-values (colstructs values doquote)
72 "Returns a list of string column values for SQL inserts for custom columns"
73 (loop for col in colstructs collect (custom-col-value col doquote values)))
76 (defun remove-custom-cols (cols)
77 "Remove custom cols from a list col umls-cols"
78 (remove-if #'umls-col-custom-value-func cols))
80 (defun find-custom-cols-for-filename (filename)
81 (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
83 (defun find-custom-col (filename col)
84 (find-if (lambda (x) (and (string-equal filename (car x))
85 (string-equal col (cadr x)))) +custom-cols+))
88 (defun custom-colnames-for-filename (filename)
89 (mapcar #'cadr (find-custom-cols-for-filename filename)))
91 (defun custom-colstructs-for-file (file)
92 (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
94 (defun noneng-lang-index-files ()
96 (lambda (f) (and (> (length (umls-file-fil f)) 4)
97 (string-equal (umls-file-fil f) "MRXW." :end1 5)
98 (not (string-equal (umls-file-fil f) "MRXW.ENG"))
99 (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
102 ;;; SQL Command Functions
104 (defun create-index-cmd (colname tablename length)
105 "Return sql create index command"
106 (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
107 (concatenate 'string tablename "_" colname "_X")
109 (if (integerp length) (format nil "(~d)" length) "")))
111 (defun create-all-tables-cmdfile ()
112 "Return sql commands to create all tables. Not need for automated SQL import"
113 (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
115 ;; SQL Execution functions
117 (defun sql-drop-tables (conn)
118 "SQL Databases: drop all tables"
119 (dolist (file *umls-files*)
121 (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn))))
123 (defun sql-create-tables (conn)
124 "SQL Databases: create all tables"
125 (dolist (file *umls-files*)
126 (sql-execute (create-table-cmd file) conn)))
128 (defun sql-create-custom-tables (conn)
129 "SQL Databases: create all custom tables"
130 (dolist (ct +custom-tables+)
131 (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
133 (defun sql-insert-values (conn file)
134 "SQL Databases: inserts all values for a file"
135 (with-umls-file (line (umls-file-fil file))
136 (sql-execute (insert-values-cmd file line) conn)))
138 (defun sql-insert-all-values (conn)
139 "SQL Databases: inserts all values for all files"
140 (dolist (file *umls-files*)
141 (sql-insert-values conn file)))
143 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
144 "SQL Databases: create all indexes"
145 (dolist (idx indexes)
146 (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
148 (defun make-usrl (conn)
149 (sql-execute "drop table if exists USRL" conn)
150 (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
151 (dolist (tuple (mutex-sql-query
152 "select distinct SAB,SRL from MRSO order by SAB asc"))
153 (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
154 (car tuple) (ensure-integer (cadr tuple)))
157 (defun sql-create-special-tables (conn)
160 (defun create-umls-db-by-insert ()
161 "SQL Databases: initializes entire database via SQL insert commands"
164 (with-sql-connection (conn)
165 (sql-drop-tables conn)
166 (sql-create-tables conn)
167 (sql-insert-all-values conn)
168 (sql-create-indexes conn)
169 (sql-create-custom-tables conn)
170 (sql-create-indexes conn +custom-index-cols+)
171 (sql-create-special-tables conn)))
173 (defun create-umls-db (&optional (extension ".trans")
174 (copy-cmd #'mysql-copy-cmd))
175 "SQL Databases: initializes entire database via SQL copy commands.
176 This is much faster that using create-umls-db-insert."
179 (translate-all-files extension)
180 (with-sql-connection (conn)
181 (sql-drop-tables conn)
182 (sql-create-tables conn)
184 #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
186 (sql-create-indexes conn)
187 (sql-create-custom-tables conn)
188 (sql-create-indexes conn +custom-index-cols+)
189 (sql-create-special-tables conn)))
191 (defun translate-all-files (&optional (extension ".trans"))
192 "Copy translated files and return postgresql copy commands to import"
193 (make-noneng-index-file extension)
194 (dolist (f *umls-files*) (translate-umls-file f extension)))
196 (defun translate-file (filename extension files)
197 "Translate a umls file into a format suitable for sql copy cmd"
198 (let ((path (umls-pathname filename extension))
199 (input-files (mklist files)))
200 (if (probe-file path)
201 (format t "File ~A already exists: skipping~%" path)
202 (dolist (input-file input-files)
203 (with-open-file (ostream :direction :output)
204 (with-umls-file (line (umls-file-fil input-file))
205 (umls-translate file line ostream)
206 (princ #\newline ostream)))))))
208 (defun translate-umls-file (file extension)
209 "Translate a umls file into a format suitable for sql copy cmd"
210 (translate-file (umls-file-fil file) extension (umls-file-fil file)))
212 (defun make-noneng-index-file (extension)
213 "Make non-english index file"
214 (translate-file (find-umls-file "MRXW.NONENG") extension
215 (noneng-lang-index-files)))
217 (defun pg-copy-cmd (file extension)
218 "Return postgresql copy statement for a file"
220 nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
221 (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
223 (defun mysql-copy-cmd (file extension)
224 "Return mysql copy statement for a file"
227 "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
228 (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
230 (defun col-value (col value)
231 (if (eq (umls-col-datatype col) 'sql-u)
232 (write-to-string (parse-ui value ""))
233 (escape-backslashes value)))
235 (defun umls-translate (file line strm)
236 "Translate a single line for sql output"
237 (print-separated-strings
239 (mapcar #'col-value (remove-custom-cols (umls-file-colstructs file)) line)
240 (custom-col-values (custom-colstructs-for-file file) line nil)))
243 ;;; Routines for analyzing cost of fixed size storage
246 (defun umls-fixed-size-waste ()
247 "Display storage waste if using all fixed size storage"
253 (dolist (file *umls-files*)
254 (dolist (col (umls-file-colstructs file))
255 (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
256 (cwaste (* avwaste (umls-file-rws file))))
260 (incf totalunavoidable cwaste)
261 (push (list (umls-file-fil file) (umls-col-col col)
265 (incf totalavoidable cwaste)
266 (push (list (umls-file-fil file) (umls-col-col col)
269 (incf totalwaste cwaste)))))
270 (values totalwaste totalavoidable totalunavoidable
271 (nreverse avoidable) (nreverse unavoidable))))
273 (defun display-waste ()
276 (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
277 (format t "Total waste: ~d~%" tw)
278 (format t "Total avoidable: ~d~%" ta)
279 (format t "Total unavoidable: ~d~%" tu)
280 (format t "Avoidable:~%")
282 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
283 (format t "Unavoidable:~%")
285 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
288 (defun max-umls-field ()
289 "Return length of longest field"
293 (declare (fixnum max))
294 (dolist (col *umls-cols*)
295 (when (> (umls-col-max col) max)
296 (setq max (umls-col-max col))))
299 (defun max-umls-row ()
300 "Return length of longest row"
303 (let ((rowsizes '()))
304 (dolist (file *umls-files*)
306 (fields (umls-file-colstructs file)))
307 (dolist (field fields)
308 (incf row (1+ (umls-col-max field))))
309 (push row rowsizes)))
310 (car (sort rowsizes #'>))))