+(defun filter-urels-by-rel (urels rel)
+ (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
+
+
+(defvar +language-abbreviations+
+ '(("BAQ" . "Basque")
+ ("CZE" . "Chech")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("JPN" . "Japanese")
+ ("NOR" . "Norwegian")
+ ("POR" . "Portuguese")
+ ("RUS" . "Russian")
+ ("SPA" . "Spanish")
+ ("SWE" . "Swedish")))
+
+(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-lat-table-init* nil)
+(unless *is-lat-table-init*
+ (dolist (latinfo +language-abbreviations+)
+ (setf (gethash (string-downcase (car latinfo)) *lat-info-table*)
+ (cdr latinfo)))
+ (setq *is-lat-table-init* t))
+
+(defun lat-abbr-info (lat)
+ (aif (nth-value 0 (gethash (string-downcase lat) *lat-info-table*))
+ it
+ lat))
+
+
+
+(defun stt-abbr-info (stt)
+ (when (string-equal "PF" stt)
+ (return-from stt-abbr-info "Preferred"))
+ (when (char-equal #\V (schar stt 0))
+ (setq stt (subseq stt 1)))
+ (loop for c across stt
+ collect
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "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)
+ 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)))))
+
+(defun uso-unique-codes (usos)
+ (let ((sab-codes (make-hash-table :test 'equal)))
+ (dolist (uso usos)
+ (setf (gethash (sab uso) sab-codes) (code uso)))
+ (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))
+
+
+#+scl