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

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))