(is-ucon-in-ancestors ucon (cdr ancestors))))))
-(defun ucon-ancestors (ucon &key sab include-rb 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"
- (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))))
+ (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)))
-(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)
projects / umlisp.git / blobdiff