From 3c6431cdf9bfae4984e3a7664962aa4a436bd5ff Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 18 Sep 2006 02:20:12 +0000 Subject: [PATCH] r11173: move cdist-metric to umlsquery package --- class-support.lisp | 113 --------------------------------------------- package.lisp | 15 +++--- umlisp.asd | 21 +++------ 3 files changed, 14 insertions(+), 135 deletions(-) diff --git a/class-support.lisp b/class-support.lisp index d117202..69983a6 100644 --- a/class-support.lisp +++ b/class-support.lisp @@ -336,118 +336,6 @@ "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) @@ -481,7 +369,6 @@ (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)) diff --git a/package.lisp b/package.lisp index 1aeef5e..b8c85ce 100644 --- a/package.lisp +++ b/package.lisp @@ -40,20 +40,19 @@ #: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! @@ -61,7 +60,7 @@ #:umls-sql-db! #:umls-sql-host! #:umls-sql-type! - + ;; From utils.lisp #:fmt-cui #:fmt-lui @@ -72,9 +71,9 @@ #: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 @@ -168,7 +167,7 @@ #:find-btty-all #:find-btty-tty #:find-brel-rel - + ;; composite.lisp #:tui-finding #:tui-sign-or-symptom diff --git a/umlisp.asd b/umlisp.asd index 44aa906..03e5301 100644 --- a/umlisp.asd +++ b/umlisp.asd @@ -19,13 +19,8 @@ (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")) @@ -45,14 +40,12 @@ (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)))) -- 2.34.1