From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Sat, 16 Sep 2006 23:02:11 +0000 (+0000)
Subject: r11167: added cdist fn
X-Git-Tag: v2006ac.2~51
X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=commitdiff_plain;h=61a8511de3b01b68d68b75331ffa67c362a6fe19

r11167: added cdist fn
---

diff --git a/class-support.lisp b/class-support.lisp
index 709d462..1d3f96d 100644
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -352,6 +352,68 @@
         (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))
+      (declare (fixnum min))
+      (dolist (shared shareds)
+        (let* ((d1 (ancestor-distance shared anc1))
+               (d2 (ancestor-distance shared anc2))
+               (dtotal (+ d1 d2)))
+          (declare (fixnum d1 d2 dtotal))
+          (when (< dtotal min)
+            (setq min dtotal
+                  cui-min shared))))
+      (values min cui-min))))
+
+(defun cdist (c1 c2 &key sab include-rb)
+  (let* ((anc1 (ucon-ancestors c1 :sab sab :include-rb include-rb))
+         (anc2 (ucon-ancestors c2 :sab sab :include-rb include-rb)))
+    (multiple-value-bind (min cui)
+        (cdist-ancestors anc1 anc2)
+      (if cui
+          (values min cui)
+        (values nil nil)))))
+               
+
+(defun ancestor-distance (cui ancestors &key (distance 0))
+  (cond
+   ((null ancestors)
+    nil)
+   ((atom ancestors)
+    (when (eql cui (cui ancestors))
+      distance))
+   ((atom (car ancestors))
+    (if (eql cui (cui (car ancestors)))
+        distance
+      (ancestor-distance cui (cdr ancestors) :distance distance)))
+   (t
+    (let ((min most-positive-fixnum))
+      (dolist (a ancestors)
+        (let ((d (ancestor-distance cui a :distance (1+ distance))))
+          (when (and d (< d min))
+            (setq min d))))
+      (when (< min most-positive-fixnum)
+        min)))))
+
+    
+        
 (defun ucon-ancestors (ucon &key sab include-rb ancestors)
   "Returns a list of ancestor lists for a concept"
   (let* ((parent-rels (append (filter-urels-by-rel (s#rel ucon) "par")
@@ -364,7 +426,7 @@
 			 parent-rels)))
     (dolist (rel parent-rels)
       (let ((parent (find-ucon-cui (cui2 rel))))
-        ;; (format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
+        ;;(format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
         (unless (is-ucon-in-ancestors parent ancestors)
           (push
            (list*
@@ -374,49 +436,6 @@
     (nreverse parents)))
 
 
-(defun find-minimum-distance (anc1 anc2 &key (distance 0) (minimum 0) path)
-  (cond
-   ((or (null anc1) (null anc2) nil))
-   ((and (atom (car anc1)) (atom (car anc2)))
-    (when (eql (cui ucon1) (cui ucon2))
-      (return-from find-minimum-distance (values distance path)))
-    (incf distance)
-    (when (> distance minimum)
-      (return-from find-minimum-distance nil))
-    (multiple-value-bind (dist1 path1)
-        (find-minimum-distance anc1 (cdr anc2)
-                               :distance distance :minimum minimum
-                               :path (list* anc1 path))
-      (when (and dist1 (< dist1 minimum))
-         (setf minimum dist1
-               path path1)))
-    (multiple-value-bind (dist2 path2)
-        (find-minimum-distance (cdr anc1) anc2
-                               :distance distance :minimum minimum
-                               :path (list* anc2 path))
-      (when (and dist2 (< dist2 minimum))
-        (setf minimum dist2
-              path path2)))
-    (return-from find-minimum-distance (values distance path))
-    
-
-    (min2 (find-minimum-distance
-           (cdr anc1) anc2
-           :distance distance :minimum minimum
-           :path (list* anc2 path)))
-    (when (and min2 (< min2 minimum))
-      (setf minimum min2
-            path (list* anc2 path))))))
-
-
-
-(defun ucon-cdist (ucon1 ucon2 &key include-rb sab)
-  "Compute James Cimino's CDist metric"
-  (let ((anc1 (ucon-ancestors ucon1 :include-rb include-rb :sab sab))
-        (anc2 (ucon-ancestors ucon2 :include-rb include-rb :sab sab)))
-    (find-minimum-distance (list ucon1 anc1) (list ucon2 anc2))))
-
-
 (defgeneric cxt-ancestors (obj))
 (defmethod cxt-ancestors ((con ucon))
   (loop for term in (s#term con)