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