;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          sql-create
;;;; Purpose:       Create SQL database for UMLisp
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id: sql-create.lisp,v 1.4 2002/11/07 23:19:02 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;;
;;;; UMLisp users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License.
;;;; *************************************************************************

(in-package :umlisp)
(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)))
	     (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))))))

(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 (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 (custom-colstructs-for-file file) values "," t)))
     )))

(defun custom-col-values (colstructs values delim doquote)
  "Returns 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 remove-custom-cols (cols)
  "Remove custom cols from a list col umls-cols"
  (remove-if #'umls-col-custom-value-func cols))

(defun find-custom-cols-for-filename (filename)
  (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))

(defun find-custom-col (filename col)
  (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 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*))

;;; 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)
	      "")))

(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*))

(defun sql-create-tables (conn)
  "SQL Databases: create all tables" 
  (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))

(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+))
  
(defun sql-insert-values (conn file)
  "SQL Databases: inserts all values for a file"  
  (with-umls-file (line (umls-file-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*))

(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))

(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"))
    (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" 
			 (car tuple) (ensure-integer (cadr tuple)))
		 conn)))

(defun sql-create-special-tables (conn)
  (make-usrl conn))

(defun create-umls-db-by-insert ()
  "SQL Databases: initializes entire database via SQL insert commands"
  (init-umls)
  (init-hash-table)
  (with-sql-connection (conn)
    (sql-drop-tables conn)
    (sql-create-tables conn)
    (sql-insert-all-values conn)
    (sql-create-indexes conn)
    (sql-create-custom-tables conn)
    (sql-create-indexes conn +custom-index-cols+)
    (sql-create-special-tables conn)))

(defun create-umls-db (&optional (extension ".trans") 
		       (copy-cmd #'mysql-copy-cmd))
  "SQL Databases: initializes entire database via SQL copy commands. 
This is much faster that using create-umls-db-insert."
  (init-umls)
  (init-hash-table)
  (translate-all-files extension)
  (with-sql-connection (conn)
    (sql-drop-tables conn)
    (sql-create-tables conn)
    (mapcar 
     #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn)) 
     *umls-files*)
    (sql-create-indexes conn)
    (sql-create-custom-tables conn)
    (sql-create-indexes conn +custom-index-cols+)
    (sql-create-special-tables 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*))

(defun translate-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))))

(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))))

(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)))

(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 (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 (custom-colstructs-for-file file) line "|" nil))))
   

;;; Routines for analyzing cost of fixed size storage


(defun umls-fixed-size-waste ()
  "Display storage waste if using all fixed size storage"
  (let ((totalwaste 0)
	(totalunavoidable 0)
	(totalavoidable 0)
	(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)
	    (if (<= avwaste 6)
		(progn
		  (incf totalunavoidable cwaste)
		  (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
		(progn
		  (incf totalavoidable cwaste)
		  (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
	    (incf totalwaste cwaste)))))
    (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))

(defun display-waste ()
  (unless *umls-files*
    (init-umls))
  (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
    (format t "Total waste: ~d~%" tw)
    (format t "Total avoidable: ~d~%" ta)
    (format t "Total unavoidable: ~d~%" tu)
    (format t "Avoidable:~%")
    (dolist (w al)
      (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
    (format t "Unavoidable:~%")
    (dolist (w ul)
      (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
    ))

(defun max-umls-field ()
  "Return length of longest field"
  (unless *umls-files*
    (init-umls))
  (let ((max 0))
    (declare (fixnum max))
    (dolist (col *umls-cols*)
      (when (> (umls-col-max col) max)
	(setq max (umls-col-max 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 #'>))))))