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