"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)
(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))
projects / umlisp.git / blobdiff