parse-common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          parse-common.lisp
   6 ;;;; Purpose:       Common, stable parsing routines for UMLisp
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: parse-common.lisp,v 1.3 2002/10/18 03:57:39 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package :umlisp)
  20 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  21
  22 (defun umls-pathname (filename &optional (extension ""))
  23 "Return pathname for a umls filename"
  24   (etypecase filename
  25     (string
  26      (merge-pathnames
  27       (make-pathname :name (concatenate 'string filename extension))
  28       (case (char filename 0)
  29         ((#\M #\m)
  30          *meta-path*)
  31         ((#\L #\l)
  32          *lex-path*)
  33         ((#\S #\s)
  34          *net-path*)
  35         (t
  36          *umls-path*))))
  37     (pathname
  38       filename)))
  39
  40 (defun read-umls-line (strm)
  41   "Read a line from a UMLS stream, split into fields"
  42   (let ((line (read-line strm nil 'eof)))
  43     (if (stringp line) ;; ensure not 'eof
  44         (let* ((len (length line))
  45               (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line
  46                (if (char= #\| (char line (1- len)))
  47                    (subseq line 0 (1- len))
  48                  line)))
  49           (declare (fixnum len))
  50           (delimited-string-to-list maybe-remove-terminal #\|))
  51       line)))
  52
  53
  54 ;;; Find field lengths for LEX and NET files
  55
  56 (defun file-field-lengths (files)
  57   (let ((lengths '()))
  58     (dolist (file files)
  59       (setq file (umls-file-fil file))
  60       (let (max-field count-field num-fields (count-lines 0))
  61         (with-umls-file (fields file)
  62           (unless num-fields
  63             (setq num-fields (length fields))
  64             (setq max-field (make-array num-fields :element-type 'fixnum
  65                                         :initial-element 0))
  66             (setq count-field (make-array num-fields :element-type 'number
  67                                           :initial-element 0)))
  68           (dotimes (i (length fields))
  69             (declare (fixnum i))
  70             (let ((len (length (nth i fields))))
  71               (incf (aref count-field i) len)
  72               (when (> len (aref max-field i))
  73                 (setf (aref max-field i) len))))
  74           (incf count-lines))
  75         (dotimes (i num-fields)
  76           (setf (aref count-field i) (float (/ (aref count-field i) count-lines))))
  77         (push (list file max-field count-field) lengths)))
  78     (nreverse lengths)))
  79
  80 (defun init-field-lengths ()
  81   "Initial colstruct field lengths for files that don't have a measurement.
  82 Currently, these are the LEX and NET files."
  83   (let ((measure-files '()))
  84     (dolist (file *umls-files*)
  85       (let ((filename (umls-file-fil file)))
  86         (unless (or (char= #\M (char filename 0))
  87                     (char= #\m (char filename 0)))
  88           (push file measure-files))))
  89     (let ((length-lists (file-field-lengths measure-files)))
  90       (dolist (length-list length-lists)
  91         (let* ((filename (car length-list))
  92                (max-field (cadr length-list))
  93                (av-field (caddr length-list))
  94                (file (find-umls-file filename)))
  95           (when file
  96             (if (/= (length max-field) (length (umls-file-fields file)))
  97                 (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S"
  98                        max-field file)
  99               (dotimes (i (max (length max-field) (length (umls-file-fields file))))
 100                 (declare (fixnum i))
 101                 (let* ((field (nth i (umls-file-fields file)))
 102                        (col (find-umls-col field filename)))
 103                   (if col
 104                       (progn
 105                         (setf (umls-col-max col) (aref max-field i))
 106                         (setf (umls-col-av col) (aref av-field i))
 107                         (add-datatype-to-col col (datatype-for-col (umls-col-col col))))
 108                   (error "can't find column ~A" field)))))))))))
 109
 110
 111
 112 ;;; UMLS column/file functions
 113
 114 (defun find-col-in-columns (colname filename cols)
 115 "Returns list of umls-col structure for a column name and a filename"
 116   (dolist (col cols)
 117     (when (and (string-equal filename (umls-col-fil col))
 118                (string-equal colname (umls-col-col col)))
 119       (return-from find-col-in-columns col)))
 120   nil)
 121
 122 (defun find-or-make-col-in-columns (colname filename cols)
 123   (let ((col (find-col-in-columns colname filename cols)))
 124     (if col
 125         col
 126       ;; try to find column name without a terminal digit
 127       (let* ((last-char (char colname (1- (length colname))))
 128              (digit (- (char-code last-char) (char-code #\0))))
 129         (if (and (>= digit 0) (<= digit 9))
 130             (let ((base-colname (subseq colname 0 (1- (length colname)))))
 131               (setq col (find-col-in-columns base-colname filename cols))
 132               (if col
 133                   (let ((new-col (make-umls-col
 134                                   :col (copy-seq colname)
 135                                   :des (copy-seq (umls-col-des col))
 136                                   :ref (copy-seq (umls-col-ref col))
 137                                   :min (umls-col-min col)
 138                                   :max (umls-col-max col)
 139                                   :fil (copy-seq (umls-col-fil col))
 140                                   :sqltype (copy-seq (umls-col-sqltype col))
 141                                   :dty (copy-seq (umls-col-dty col))
 142                                   :parsefunc (umls-col-parsefunc col)
 143                                   :quotechar (copy-seq (umls-col-quotechar col))
 144                                   :datatype (umls-col-datatype col)
 145                                   :custom-value-func (umls-col-custom-value-func col))))
 146                     (push new-col *umls-cols*)
 147                     new-col)
 148                 (error "Couldn't find a base column for col ~A in file ~A"
 149                        colname filename)))
 150           (let ((new-col (make-umls-col
 151                           :col (copy-seq colname)
 152                           :des "Unknown"
 153                           :ref ""
 154                           :min nil
 155                           :max nil
 156                           :fil filename
 157                           :sqltype "VARCHAR"
 158                           :dty nil
 159                           :parsefunc #'add-sql-quotes
 160                           :quotechar "'"
 161                           :datatype nil
 162                           :custom-value-func nil)))
 163             (push new-col *umls-cols*)
 164             new-col))))))
 165
 166 (defun find-umls-col (colname filename)
 167   "Returns list of umls-col structure for a column name and a filename"
 168   (find-or-make-col-in-columns colname filename *umls-cols*))
 169
 170 (defun find-umls-file (filename)
 171   "Returns umls-file structure for a filename"
 172   (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*))
 173
 174 (defun umls-cols-for-umls-file (file)
 175   "Returns list of umls-cols for a file structure"
 176   (let ((filename (umls-file-fil file)))
 177     (mapcar (lambda (col) (find-umls-col col filename))
 178             (umls-file-fields file))))
 179
 180
 181 ;;; Routines for analyzing cost of fixed size storage
 182
 183 (defun umls-fixed-size-waste ()
 184   "Display storage waste if using all fixed size storage"
 185   (let ((totalwaste 0)
 186         (totalunavoidable 0)
 187         (totalavoidable 0)
 188         (unavoidable '())
 189         (avoidable '()))
 190     (dolist (file *umls-files*)
 191       (dolist (col (umls-file-colstructs file))
 192         (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
 193                (cwaste (* avwaste (umls-file-rws file))))
 194           (unless (zerop cwaste)
 195             (if (<= avwaste 6)
 196                 (progn
 197                   (incf totalunavoidable cwaste)
 198                   (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
 199               (progn
 200                   (incf totalavoidable cwaste)
 201                   (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
 202             (incf totalwaste cwaste)))))
 203     (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
 204
 205 (defun display-waste ()
 206   (unless *umls-files*
 207     (init-umls))
 208   (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
 209     (format t "Total waste: ~d~%" tw)
 210     (format t "Total avoidable: ~d~%" ta)
 211     (format t "Total unavoidable: ~d~%" tu)
 212     (format t "Avoidable:~%")
 213     (dolist (w al)
 214       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 215     (format t "Unavoidable:~%")
 216     (dolist (w ul)
 217       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 218   ))
 219
 220 (defun max-umls-field ()
 221   "Return length of longest field"
 222   (unless *umls-files*
 223     (init-umls))
 224   (let ((max 0))
 225     (declare (fixnum max))
 226     (dolist (col *umls-cols*)
 227       (when (> (umls-col-max col) max)
 228         (setq max (umls-col-max col))))
 229     max))
 230
 231 (defun max-umls-row ()
 232   "Return length of longest row"
 233   (if t
 234       6000  ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
 235     (progn
 236       (unless *umls-files*
 237         (init-umls))
 238       (let ((rowsizes '()))
 239         (dolist (file *umls-files*)
 240           (let ((row 0)
 241                 (fields (umls-file-colstructs file)))
 242             (dolist (field fields)
 243               (incf row (1+ (umls-col-max field))))
 244             (push row rowsizes)))
 245         (car (sort rowsizes #'>))))))