;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: class-support.lisp,v 1.18 2003/07/21 00:53:27 kevin Exp $
+;;;; $Id: class-support.lisp,v 1.19 2003/07/21 08:41:44 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
"Return the string for a ulo object"
(find-string-sui (sui lo)))
+(defgeneric pf-ustr (obj))
+(defmethod pf-ustr ((ucon ucon))
+ "Return the preferred ustr for a ucon"
+ (pf-ustr
+ (find-if (lambda (uterm) (string= "P" (ts uterm))) (s#term ucon))))
+
+(defmethod pf-ustr ((uterm uterm))
+ "Return the preferred ustr for a uterm"
+ (find-if (lambda (ustr) (string= "PF" (stt ustr))) (s#str uterm)))
+
+(defgeneric mesh-number (obj))
+(defmethod mesh-number ((con ucon))
+ (mesh-number (pf-ustr con)))
+
+(defmethod mesh-number ((ustr ustr))
+ (let ((codes
+ (filter (lambda (sat)
+ (when (and (string-equal "MSH" (sab sat))
+ (string-equal "MN" (atn sat)))
+ (atv sat)))
+ (s#sat ustr))))
+ (if (= 1 (length codes))
+ (car codes)
+ codes)))
+
+(defun ucon-ustrs (ucon)
+ "Return lists of strings for a concept"
+ (let (res)
+ (dolist (term (s#term ucon) (nreverse res))
+ (dolist (str (s#str term))
+ (push str res)))))
+
+
(defmethod pfstr ((uterm uterm))
"Return the preferred string for a uterm"
(dolist (ustr (s#str uterm))
(defun rel-abbr-info (rel)
(nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
-
-
-#+(or scl)
+(defun filter-urels-by-rel (urels rel)
+ (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
+
+
+(defvar +language-abbreviations+
+ '(("BAQ" . "Basque")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("NOR" . "Norwegian")
+ ("POR" . "Portuguese")
+ ("RUS" . "Russian")
+ ("SPA" . "Spanish")
+ ("SWE" . "Swedish")))
+
+(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-lat-table-init* nil)
+(unless *is-lat-table-init*
+ (dolist (latinfo +language-abbreviations+)
+ (setf (gethash (string-downcase (car latinfo)) *lat-info-table*)
+ (cdr latinfo)))
+ (setq *is-lat-table-init* t))
+
+(defun lat-abbr-info (lat)
+ (nth-value 0 (gethash (string-downcase lat) *lat-info-table*)))
+
+
+(defun stt-abbr-info (stt)
+ (when (string-equal "PF" stt)
+ (return-from stt-abbr-info "Preferred"))
+ (when (char-equal #\V (schar stt 0))
+ (setq stt (subseq stt 1)))
+ (loop for c across stt
+ collect
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "Other"))))
+
+
+(defun ucon-parents (con &optional sab)
+ (ucon-ancestors con sab t))
+
+(defun ucon-ancestors (ucon &optional sab single-level)
+ "Returns a list of ancestor lists for a concept"
+ (let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
+ (anc nil))
+ (when sab
+ (setq parent-rels (delete-if-not
+ (lambda (rel) (string-equal sab (sab rel)))
+ parent-rels)))
+ (dolist (rel parent-rels (nreverse anc))
+ (let ((parent (find-ucon-cui (cui2 rel))))
+ (push
+ (if single-level
+ (list parent)
+ (list* parent (car (ucon-ancestors parent (sab rel) nil))))
+ anc)))))
+
+(defgeneric cxt-ancestors (obj))
+(defmethod cxt-ancestors ((con ucon))
+ (loop for term in (s#term con)
+ append (cxt-ancestors term)))
+
+
+(defmethod cxt-ancestors ((term uterm))
+ (loop for str in (s#str term)
+ append (cxt-ancestors str)))
+
+(defmethod cxt-ancestors ((str ustr))
+ "Return the ancestory contexts of a ustr"
+ (let* ((anc (remove-if-not
+ (lambda (cxt) (string-equal "ANC" (cxl cxt)))
+ (s#cxt str)))
+ (num-contexts (if anc
+ (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
+ 0))
+ (anc-lists '()))
+ (dotimes (i num-contexts (nreverse anc-lists))
+ (let* ((anc-this-cxn (remove-if-not
+ (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
+ (push
+ (sort anc-this-cxn (lambda (a b) (< (rnk a) (rnk b))))
+ anc-lists)))))
+
+
+#+scl
(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))
- #+cmu
- (let ((cl (pcl:find-class c)))
- (pcl:finalize-inheritance cl))
- #+scl
(let ((cl (find-class c)))
(clos:finalize-inheritance cl)))
+
+
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.27 2003/07/21 00:53:27 kevin Exp $
+;;;; $Id: package.lisp,v 1.28 2003/07/21 08:41:44 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
#:s#def #:s#sty #:s#term #:s#str #:s#atx #:s#lo #:s#sat #:s#rel #:s#coc
#:s#so #:s#cxt
#:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel
- #:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui
+ #:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui #:hcd #:stt #:str
;; From class-support.lisp
#:ucon-has-tui
#:english-term-p #:remove-non-english-terms #:remove-english-terms
#:fmt-cui #:fmt-tui #:fmt-sui #:fmt-eui #:fmt-tui
#:display-con #:display-term #:display-str
- #:uterm-pfstr
+ #:pfstr #:pf-ustr
#:cui-p #:lui-p #:sui-p #:tui-p #:eui-p
- #:rel-abbr-info
+ #:rel-abbr-info #:filter-urels-by-rel
+ #:ucon-ancestors #:ucon-parents
+ #:mesh-number #:cxt-ancestors #:ucon-ustrs
+ #:lat-abbr-info #:stt-abbr-info
;; From sql.lisp
#:umls-sql-user!
projects / umlisp.git / commitdiff