X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=class-support.lisp;h=69983a621434a642ecb603a6ee7b65a95b755bc2;hb=08af5459d3ba7d229a8339d242ef742cfe846861;hp=7948dec091732de7c0337687ef34d0f2ca2aa400;hpb=67ee261d341603e293f6b0314d5cd12522fa04c6;p=umlisp.git

diff --git a/class-support.lisp b/class-support.lisp
index 7948dec..69983a6 100644
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -336,89 +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 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")
-                              (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)))
-    (dolist (rel parent-rels)
-      (let ((parent (find-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)))
-           parents))))
-    (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)
@@ -452,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))