- ((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)
- append (cxt-ancestors term)))
-
-
-(defmethod cxt-ancestors ((term uterm))
- (loop for str in (s#str term)
- append (cxt-ancestors str)))
-
-(defmethod cxt-ancestors ((str ustr))
- "Return the ancestory contexts of a ustr"
- (let* ((anc (remove-if-not
- (lambda (cxt) (string-equal "ANC" (cxl cxt)))
- (s#cxt str)))
- (num-contexts (if anc
- (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
- 0))
- (anc-lists '()))
- (dotimes (i num-contexts (nreverse anc-lists))
- (let* ((anc-this-cxn (remove-if-not
- (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
- (push
- (sort anc-this-cxn (lambda (a b) (< (rank a) (rank b))))
- anc-lists)))))