"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))
- (declare (fixnum min))
- (dolist (shared shareds)
- (let* ((d1 (ancestor-distance shared anc1))
- (d2 (ancestor-distance shared anc2))
- (dtotal (+ d1 d2)))
- (declare (fixnum d1 d2 dtotal))
- (when (< dtotal min)
- (setq min dtotal
- cui-min shared))))
- (values min cui-min))))
-
-(defun cdist (c1 c2 &key sab include-rb)
- (let* ((anc1 (ucon-ancestors c1 :sab sab :include-rb include-rb))
- (anc2 (ucon-ancestors c2 :sab sab :include-rb include-rb)))
- (multiple-value-bind (min cui)
- (cdist-ancestors anc1 anc2)
- (if cui
- (values min cui)
- (values nil nil)))))
-
-
-(defun ancestor-distance (cui ancestors &key (distance 0))
- (cond
- ((null ancestors)
- nil)
- ((atom ancestors)
- (when (eql cui (cui ancestors))
- distance))
- ((atom (car ancestors))
- (if (eql cui (cui (car ancestors)))
- distance
- (ancestor-distance cui (cdr ancestors) :distance distance)))
- (t
- (let ((min most-positive-fixnum))
- (dolist (a ancestors)
- (let ((d (ancestor-distance cui a :distance (1+ distance))))
- (when (and d (< d min))
- (setq min d))))
- (when (< min most-positive-fixnum)
- min)))))
-
-
-
-(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)))
-
-
(defgeneric cxt-ancestors (obj))
(defmethod cxt-ancestors ((con ucon))
(loop for term in (s#term con)
(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))