r11168: add cdist-metric

[umlisp.git] / class-support.lisp

diff --git a/class-support.lisp b/class-support.lisp
index 1d3f96d0902ba0a5f909812b154af04f8d9948c8..d1172022645d2e0ddb9fcead2236158a9c89e3d8 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -370,68 +370,80 @@
 (defun cdist-ancestors (anc1 anc2)
   (let ((shareds (shared-cuis anc1 anc2)))
     (let ((min most-positive-fixnum)
-          (cui-min nil))
+          (cui-min nil)
+          (path-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)
+        (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)
-        (values nil nil)))))
+          (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))
+(defun ancestor-distance (cui ancestors &key (distance 0) path)
   (cond
    ((null ancestors)
     nil)
    ((atom ancestors)
     (when (eql cui (cui ancestors))
-      distance))
+      (values distance (nreverse (list* ancestors path)))))
    ((atom (car ancestors))
     (if (eql cui (cui (car ancestors)))
-        distance
-      (ancestor-distance cui (cdr ancestors) :distance distance)))
+        (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))
+    (let ((%min most-positive-fixnum)
+          %path)
       (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)))))
+        (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)
+(defun ucon-ancestors (ucon &key sab include-rb ancestors full-ucon (srl *current-srl*))
   "Returns a list of ancestor lists for a concept"
-  (let* ((parent-rels (append (filter-urels-by-rel (s#rel ucon) "par")
-                              (when include-rb
-                                (filter-urels-by-rel (s#rel ucon) "rb"))))
-         (parents nil))
-    (when sab
-      (setq parent-rels (delete-if-not
-                        (lambda (rel) (string-equal sab (sab rel)))
-                        parent-rels)))
+  (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 (find-ucon-cui (cui2 rel))))
-        ;;(format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
+      (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)))
+            (ucon-ancestors parent :sab (sab rel) :ancestors (append (list parent) ancestors)
+                            :full-ucon full-ucon))
            parents))))
     (nreverse parents)))