"Other"))))
-(defun ucon-parents (ucon &key sab include-rb)
- (ucon-ancestors ucon :sab sab :include-rb include-rb
- :ancestors nil))
-
-(defun is-ucon-in-ancestors (ucon ancestors)
- (cond
- ((null ancestors) nil)
- ((atom ancestors) (eql (cui ucon) (cui ancestors)))
- ((listp (car ancestors))
- (or (is-ucon-in-ancestors ucon (car ancestors))
- (is-ucon-in-ancestors ucon (cdr ancestors))))
- (t
- (or (eql (cui ucon) (cui (car ancestors)))
- (is-ucon-in-ancestors ucon (cdr ancestors))))))
-
-
-(defun sorted-ancestor-cuis (anc)
- (sort (remove-duplicates (map 'list 'cui (flatten anc))) #'<))
-
-(defun shared-cuis (a1 a2)
- (let ((cl1 (sorted-ancestor-cuis a1))
- (cl2 (sorted-ancestor-cuis a2))
- (shared nil))
- (dolist (c1 cl1 (nreverse shared))
- (dolist (c2 cl2)
- (cond
- ((eql c1 c2)
- (push c1 shared))
- ((> c2 c1)
- (return)))))))
-
-(defun cdist-ancestors (anc1 anc2)
- (let ((shareds (shared-cuis anc1 anc2)))
- (let ((min most-positive-fixnum)
- (cui-min nil)
- (path-min nil))
- (declare (fixnum min))
- (dolist (shared shareds)
- (multiple-value-bind (d1 p1) (ancestor-distance shared anc1)
- (multiple-value-bind (d2 p2) (ancestor-distance shared anc2)
- (let ((dtotal (+ d1 d2)))
- (declare (fixnum d1 d2 dtotal))
- (when (< dtotal min)
- (format t "~D ~D ~D ~S ~S~%" d1 d2 dtotal p1 p2)
- (setq min dtotal
- cui-min shared
- path-min (append p1 (cdr (reverse p2)))
- ))))))
- (values min cui-min path-min))))
-
-(defun cdist-metric (c1 c2 &key sab include-rb full-ucon (srl *current-srl*))
- (let* ((anc1 (ucon-ancestors c1 :sab sab :include-rb include-rb :full-ucon full-ucon :srl srl))
- (anc2 (ucon-ancestors c2 :sab sab :include-rb include-rb :full-ucon full-ucon :srl srl)))
- (multiple-value-bind (min cui path)
- (cdist-ancestors (list* c1 anc1) (list* c2 anc2))
- (if cui
- (values min cui (append (list c1) path (unless (eql (cui (car (last path))) (cui c2))
- (list c2))))
- (values nil nil nil)))))
-
-
-(defun ancestor-distance (cui ancestors &key (distance 0) path)
- (cond
- ((null ancestors)
- nil)
- ((atom ancestors)
- (when (eql cui (cui ancestors))
- (values distance (nreverse (list* ancestors path)))))
- ((atom (car ancestors))
- (if (eql cui (cui (car ancestors)))
- (values distance (nreverse (list* (car ancestors) path)))
- (ancestor-distance cui (cdr ancestors) :distance distance :path (list* (car ancestors) path))))
- (t
- (let ((%min most-positive-fixnum)
- %path)
- (dolist (a ancestors)
- (multiple-value-bind (d p) (ancestor-distance cui a :distance (1+ distance) :path path)
- (when (and d (< d %min))
- (setq %min d
- %path p))))
- (when (< %min most-positive-fixnum)
- (values %min %path))))))
-
-
-(defun ucon-ancestors (ucon &key sab include-rb ancestors full-ucon (srl *current-srl*))
- "Returns a list of ancestor lists for a concept"
- (unless ucon (return-from ucon-ancestors nil))
- (let ((parent-rels (find-urel-cui
- (cui ucon)
- :without-pfstr2 t
- :srl srl
- :filter (concatenate 'string
- (if sab (format nil "SAB='~A' AND " sab) "")
- (if include-rb
- "(REL='RB' OR REL='PAR')"
- "REL='PAR'"))))
- (parents nil))
- (dolist (rel parent-rels)
- (let ((parent (if full-ucon
- (find-ucon-cui (cui2 rel))
- (make-ucon-cui (cui2 rel)))))
- ;; (format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
- (unless (is-ucon-in-ancestors parent ancestors)
- (push
- (list*
- parent
- (ucon-ancestors parent :sab (sab rel) :ancestors (append (list parent) ancestors)
- :full-ucon full-ucon))
- parents))))
- (nreverse parents)))
-
-
(defgeneric cxt-ancestors (obj))
(defmethod cxt-ancestors ((con ucon))
(loop for term in (s#term con)
(loop for key being the hash-key in sab-codes
collect (list key (gethash key sab-codes)))))
-
(defun ucon-has-sab (ucon sab)
(and (find-if (lambda (uso) (string-equal sab (sab uso))) (s#so ucon)) t))
#:s#so #:s#cxt
#:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel
#: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
- #:pfstr #:pf-ustr #:cdist-metric
+ #:pfstr #:pf-ustr
#:cui-p #:lui-p #:sui-p #:tui-p #:eui-p
#:rel-abbr-info #:filter-urels-by-rel
- #:ucon-ancestors #:ucon-parents
#:mesh-number #:cxt-ancestors #:ucon-ustrs
#:lat-abbr-info #:stt-abbr-info
#:uso-unique-codes #:ucon-has-sab
-
+
;; From sql.lisp
#:*umls-sql-db*
#:umls-sql-user!
#:umls-sql-db!
#:umls-sql-host!
#:umls-sql-type!
-
+
;; From utils.lisp
#:fmt-cui
#:fmt-lui
#:find-ustr-in-ucon
#:*current-srl*
#:parse-cui #:parse-lui #:parse-sui #:parse-tui #:parse-eui
-
+
;; From sql-classes.lisp
-
+
#:find-udef-cui
#:find-usty-cui
#:find-usty-word
#:find-btty-all
#:find-btty-tty
#:find-brel-rel
-
+
;; composite.lisp
#:tui-finding
#:tui-sign-or-symptom
(defpackage #:umlisp-system (:use #:asdf #:cl))
(in-package #:umlisp-system)
-;; need to load uffi for below perform :after method
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package 'uffi)
- (asdf:operate 'asdf:load-op 'uffi)))
-
(defsystem umlisp
- :components
+ :components
((:file "package")
(:file "data-structures" :depends-on ("package"))
(:file "utils" :depends-on ("data-structures"))
(operate 'test-op 'umlisp-tests :force t))
(defmethod perform :after ((o load-op) (c (eql (find-system 'umlisp))))
- (let* ((init-var (uffi:getenv "UMLISPRC"))
- (init-file (or (when init-var (probe-file init-var))
- (probe-file
- (merge-pathnames
- (make-pathname :name ".umlisprc")
- (user-homedir-pathname)))
- #+(or mswin windows win32)
- (probe-file "c:\\etc\\umlisp-init.lisp"))))
+ (let ((init-file (or (probe-file
+ (merge-pathnames
+ (make-pathname :name ".umlisprc")
+ (user-homedir-pathname)))
+ #+(or mswin windows win32)
+ (probe-file "c:\\etc\\umlisp-init.lisp"))))
(when init-file
(format t "loading umlisp init file ~A~%" init-file)
(load init-file))))
projects / umlisp.git / commitdiff