class-support.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     classes-support.lisp
   6 ;;;; Purpose:  Support for UMLisp classes
   7 ;;;; Author:   Kevin M. Rosenberg
   8 ;;;; Created:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2006 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
  21 ;;; Formatting routines
  22
  23 (defgeneric fmt-cui (c))
  24 (defmethod fmt-cui ((c ucon))
  25   (fmt-cui (cui c)))
  26
  27 (when *has-fixnum-class*
  28   (defmethod fmt-cui ((c fixnum))
  29     (prefixed-fixnum-string c #\C 7)))
  30
  31 (defmethod fmt-cui ((c integer))
  32     (prefixed-integer-string c #\C 7))
  33
  34 (defmethod fmt-cui ((c string))
  35   (if (eql (aref c 0) #\C)
  36       c
  37       (fmt-cui (parse-integer c))))
  38
  39 (defmethod fmt-cui ((c null))
  40   (format nil "nil"))
  41
  42 (defgeneric fmt-lui (c))
  43 (defmethod fmt-lui ((l uterm))
  44   (fmt-lui (lui l)))
  45
  46 (when *has-fixnum-class*
  47   (defmethod fmt-lui ((l fixnum))
  48     (prefixed-fixnum-string l #\L 7)))
  49
  50 (defmethod fmt-lui ((l integer))
  51   (prefixed-integer-string l #\L 7))
  52
  53 (defmethod fmt-lui ((l string))
  54   (if (eql (aref l 0) #\L)
  55       l
  56       (fmt-lui (parse-integer l))))
  57
  58 (defgeneric fmt-sui (s))
  59 (defmethod fmt-sui ((s ustr))
  60   (fmt-sui (sui s)))
  61
  62 (when *has-fixnum-class*
  63   (defmethod fmt-sui ((s fixnum))
  64     (prefixed-fixnum-string s #\S 7)))
  65
  66 (defmethod fmt-sui ((s integer))
  67   (prefixed-integer-string s #\S 7))
  68
  69 (defmethod fmt-sui ((s string))
  70   (if (eql (aref s 0) #\S)
  71       s
  72       (fmt-sui (parse-integer s))))
  73
  74 (defgeneric fmt-tui (tui))
  75 (when *has-fixnum-class*
  76   (defmethod fmt-tui ((tui fixnum))
  77     (prefixed-fixnum-string tui #\T 3)))
  78
  79 (defmethod fmt-tui ((tui integer))
  80   (prefixed-integer-string tui #\T 3))
  81
  82 (defmethod fmt-tui ((tui string))
  83   (if (eql (aref tui 0) #\T)
  84       tui
  85     (fmt-tui (parse-integer tui))))
  86
  87 (defgeneric fmt-aui (aui))
  88 (when *has-fixnum-class*
  89   (defmethod fmt-aui ((aui fixnum))
  90     (if (>= aui 10000000)
  91       (prefixed-fixnum-string aui #\A 8)
  92       (prefixed-fixnum-string aui #\A 7))))
  93
  94 (defmethod fmt-aui ((aui integer))
  95   (if (>= aui 10000000)
  96     (prefixed-integer-string aui #\A 8)
  97     (prefixed-integer-string aui #\A 7)))
  98
  99 (defmethod fmt-aui ((aui string))
 100   (if (eql (aref aui 0) #\A)
 101       aui
 102       (fmt-aui (parse-integer aui))))
 103
 104 (defgeneric fmt-eui (e))
 105 (when *has-fixnum-class*
 106   (defmethod fmt-eui ((e fixnum))
 107     (prefixed-fixnum-string e #\E 7)))
 108
 109 (defmethod fmt-eui ((e integer))
 110   (prefixed-integer-string e #\E 7))
 111
 112 (defmethod fmt-eui ((e string))
 113   (if (eql (aref e 0) #\E)
 114       e
 115       (fmt-eui (parse-integer e))))
 116
 117 (defmethod fmt-eui ((e null))
 118   (format nil "nil"))
 119
 120 (defun cui-p (ui)
 121   "Check if a string is a CUI"
 122   (check-ui ui #\C 7))
 123
 124 (defun lui-p (ui)
 125   "Check if a string is a LUI"
 126   (check-ui ui #\L 7))
 127
 128 (defun sui-p (ui)
 129   "Check if a string is a SUI"
 130   (check-ui ui #\S 7))
 131
 132 (defun tui-p (ui)
 133   (check-ui ui #\T 3))
 134
 135 (defun eui-p (ui)
 136   (check-ui ui #\E 7))
 137
 138 (defun check-ui (ui start-char len)
 139   (when (and (stringp ui)
 140              (= (length ui) (1+ len))
 141              (char-equal start-char (schar ui 0))
 142              (ignore-errors (parse-integer ui :start 1)))
 143     t))
 144
 145
 146 ;;; Generic display functions
 147
 148 (eval-when (:compile-toplevel :load-toplevel :execute)
 149 (defun english-term-p (obj)
 150   "Returns two values: T/NIL if term is english and T/NIL if obj is a TERM"
 151   (if (eq (hyperobject::class-name (hyperobject::class-of obj)) 'uterm)
 152       (values (string-equal (lat obj) "ENG") t)
 153     (values nil nil))))
 154
 155 (defun english-term-filter (obj)
 156   "Retrns NIL if object is a term and not english"
 157   (multiple-value-bind (is-english is-term) (english-term-p obj)
 158       (or (not is-term) is-english)))
 159
 160 (defun print-umlsclass (obj &key (stream *standard-output*)
 161                         (vid :compact-text)
 162                         (file-wrapper nil) (english-only t) (subobjects nil)
 163                         (refvars nil) (link-printer nil))
 164   (view obj :stream stream :vid vid :subobjects subobjects
 165         :file-wrapper file-wrapper
 166         :filter (if english-only nil #'english-term-filter)
 167         :link-printer link-printer
 168         :refvars refvars))
 169
 170 (defmacro define-lookup-display (newfuncname lookup-func)
 171   "Defines functions for looking up and displaying objects"
 172   `(defun ,newfuncname  (keyval &key (stream *standard-output*) (vid :compact-text)
 173                          (file-wrapper t) (english-only nil) (subobjects nil))
 174      (let ((obj (funcall ,lookup-func keyval)))
 175        (print-umlsclass obj :stream stream :vid vid
 176                         :file-wrapper file-wrapper :english-only english-only
 177                         :subobjects subobjects)
 178        obj)))
 179
 180 (define-lookup-display display-con #'find-ucon-cui)
 181 (define-lookup-display display-term #'find-uterm-lui)
 182 (define-lookup-display display-str #'find-ustr-sui)
 183
 184 (defun ucon-has-tui (ucon tui)
 185   "Returns T if UCON has a semantic type of TUI."
 186   (some #'(lambda (usty) (= tui (tui usty))) (s#sty ucon)))
 187
 188 (defgeneric suistr (lo))
 189 (defmethod suistr ((lo ulo))
 190   "Return the string for a ulo object"
 191   (find-string-sui (sui lo)))
 192
 193 (defgeneric pf-ustr (obj))
 194 (defmethod pf-ustr ((ucon ucon))
 195   "Return the preferred ustr for a ucon"
 196   (pf-ustr
 197    (find-if (lambda (uterm) (string= "P" (ts uterm))) (s#term ucon))))
 198
 199 (defmethod pf-ustr ((uterm uterm))
 200   "Return the preferred ustr for a uterm"
 201   (find-if (lambda (ustr) (string= "PF" (stt ustr))) (s#str uterm)))
 202
 203 (defgeneric mesh-number (obj))
 204 (defmethod mesh-number ((con ucon))
 205   (mesh-number (pf-ustr con)))
 206
 207 (defmethod mesh-number ((ustr ustr))
 208   (let ((codes
 209          (map-and-remove-nils
 210           (lambda (sat)
 211             (when (and (string-equal "MSH" (sab sat))
 212                        (string-equal "MN" (atn sat)))
 213               (atv sat)))
 214           (s#sat ustr))))
 215     (if (= 1 (length codes))
 216         (car codes)
 217       codes)))
 218
 219 (defun ucon-ustrs (ucon)
 220   "Return lists of strings for a concept"
 221   (let (res)
 222     (dolist (term (s#term ucon) (nreverse res))
 223       (dolist (str (s#str term))
 224         (push str res)))))
 225
 226
 227 (defmethod pfstr ((uterm uterm))
 228   "Return the preferred string for a uterm"
 229   (dolist (ustr (s#str uterm))
 230     (when (string= "PF" (stt ustr))
 231       (return-from pfstr (str ustr)))))
 232
 233 (defmethod pfstr ((ustr ustr))
 234   "Return the preferred string for a ustr, which is the string itself"
 235   (str ustr))
 236
 237 (defun remove-non-english-terms (uterms)
 238   (remove-if-not #'english-term-p uterms))
 239
 240 (defun remove-english-terms (uterms)
 241   (remove-if #'english-term-p uterms))
 242
 243
 244 (defvar +relationship-abbreviations+
 245   '(("RB" "Broader" "has a broader relationship")
 246     ("RN" "Narrower" "has a narrower relationship")
 247     ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
 248     ("RL" "Like" "the two concepts are similar or 'alike'.  In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source")
 249     ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
 250     ("SY" "Source Synonymy" "source asserted synonymy")
 251     ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
 252     ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
 253     ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
 254     ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
 255     ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
 256
 257 (defvar *rel-info-table* (make-hash-table :size 30 :test 'equal))
 258 (defvar *is-rel-table-init* nil)
 259 (unless *is-rel-table-init*
 260   (dolist (relinfo +relationship-abbreviations+)
 261     (setf (gethash (string-downcase (car relinfo)) *rel-info-table*)
 262       (cdr relinfo)))
 263   (setq *is-rel-table-init* t))
 264
 265 (defun rel-abbr-info (rel)
 266   (nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
 267
 268 (defun filter-urels-by-rel (urels rel)
 269   (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
 270
 271
 272 (defvar +language-abbreviations+
 273     '(("BAQ" . "Basque")
 274       ("CZE" . "Chech")
 275       ("DAN" . "Danish")
 276       ("DUT" . "Dutch")
 277       ("ENG" . "English")
 278       ("FIN" . "Finnish")
 279       ("FRE" . "French")
 280       ("GER" . "German")
 281       ("HEB" . "Hebrew")
 282       ("HUN" . "Hungarian")
 283       ("ITA" . "Italian")
 284       ("JPN" . "Japanese")
 285       ("NOR" . "Norwegian")
 286       ("POR" . "Portuguese")
 287       ("RUS" . "Russian")
 288       ("SPA" . "Spanish")
 289       ("SWE" . "Swedish")))
 290
 291 (defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
 292 (defvar *is-lat-table-init* nil)
 293 (unless *is-lat-table-init*
 294   (dolist (latinfo +language-abbreviations+)
 295     (setf (gethash (string-downcase (car latinfo)) *lat-info-table*)
 296       (cdr latinfo)))
 297   (setq *is-lat-table-init* t))
 298
 299 (defun lat-abbr-info (lat)
 300   (aif (nth-value 0 (gethash (string-downcase lat) *lat-info-table*))
 301        it
 302        lat))
 303
 304
 305
 306 (defun stt-abbr-info (stt)
 307   (when (string-equal "PF" stt)
 308     (return-from stt-abbr-info "Preferred"))
 309   (when (char-equal #\V (schar stt 0))
 310     (setq stt (subseq stt 1)))
 311   (loop for c across stt
 312       collect
 313         (cond
 314          ((char-equal #\C c)
 315           "Upper/lower case")
 316          ((char-equal #\W c)
 317           "Word order")
 318          ((char-equal #\S c)
 319           "Singular")
 320          ((char-equal #\P c)
 321           "Plural")
 322          ((char-equal #\O c)
 323           "Other"))))
 324
 325
 326 (defun ucon-parents (con &optional sab)
 327   (ucon-ancestors con sab t))
 328
 329 (defun ucon-ancestors (ucon &optional sab single-level)
 330   "Returns a list of ancestor lists for a concept"
 331   (let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
 332          (anc nil))
 333     (when sab
 334       (setq parent-rels (delete-if-not
 335                          (lambda (rel) (string-equal sab (sab rel)))
 336                          parent-rels)))
 337     (dolist (rel parent-rels (nreverse anc))
 338       (let ((parent (find-ucon-cui (cui2 rel))))
 339         (push
 340          (if single-level
 341              (list parent)
 342            (list* parent (car (ucon-ancestors parent (sab rel) nil))))
 343          anc)))))
 344
 345 (defgeneric cxt-ancestors (obj))
 346 (defmethod cxt-ancestors ((con ucon))
 347   (loop for term in (s#term con)
 348       append (cxt-ancestors term)))
 349
 350
 351 (defmethod cxt-ancestors ((term uterm))
 352   (loop for str in (s#str term)
 353       append (cxt-ancestors str)))
 354
 355 (defmethod cxt-ancestors ((str ustr))
 356   "Return the ancestory contexts of a ustr"
 357   (let* ((anc (remove-if-not
 358                (lambda (cxt) (string-equal "ANC" (cxl cxt)))
 359                (s#cxt str)))
 360          (num-contexts (if anc
 361                            (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
 362                          0))
 363          (anc-lists '()))
 364     (dotimes (i num-contexts (nreverse anc-lists))
 365       (let* ((anc-this-cxn (remove-if-not
 366                             (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
 367         (push
 368          (sort anc-this-cxn (lambda (a b) (< (rank a) (rank b))))
 369          anc-lists)))))
 370
 371
 372 #+scl
 373 (dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
 374     (let ((cl (find-class c)))
 375       (clos:finalize-inheritance cl)))
 376
 377