X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=class-support.lisp;h=7892abed792da14ea9dfcb75bcccce4e51593dbf;hb=28aeae6f894ac1e2b4ded59af9371b373e38a701;hp=3847eb5ef2813d876b4e41be5b76692a7ac20f4f;hpb=011a13e252a94773802021a264400f696d3b3598;p=umlisp.git diff --git a/class-support.lisp b/class-support.lisp index 3847eb5..7892abe 100644 --- a/class-support.lisp +++ b/class-support.lisp @@ -7,10 +7,8 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; -;;;; $Id$ -;;;; ;;;; This file, part of UMLisp, is -;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. +;;;; Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. @@ -26,10 +24,14 @@ (when *has-fixnum-class* (defmethod fmt-cui ((c fixnum)) - (prefixed-fixnum-string c #\C 7))) + (if (>= c 10000000) + (prefixed-fixnum-string c #\C 8) + (prefixed-fixnum-string c #\C 7)))) (defmethod fmt-cui ((c integer)) - (prefixed-integer-string c #\C 7)) + (if (>= c 10000000) + (prefixed-fixnum-string c #\C 8) + (prefixed-fixnum-string c #\C 7))) (defmethod fmt-cui ((c string)) (if (eql (aref c 0) #\C) @@ -45,10 +47,14 @@ (when *has-fixnum-class* (defmethod fmt-lui ((l fixnum)) - (prefixed-fixnum-string l #\L 7))) + (if (>= l 10000000) + (prefixed-fixnum-string l #\L 8) + (prefixed-fixnum-string l #\L 7)))) (defmethod fmt-lui ((l integer)) - (prefixed-integer-string l #\L 7)) + (if (>= l 10000000) + (prefixed-fixnum-string l #\L 8) + (prefixed-fixnum-string l #\L 7))) (defmethod fmt-lui ((l string)) (if (eql (aref l 0) #\L) @@ -61,10 +67,14 @@ (when *has-fixnum-class* (defmethod fmt-sui ((s fixnum)) - (prefixed-fixnum-string s #\S 7))) - + (if (>= s 10000000) + (prefixed-fixnum-string s #\S 8) + (prefixed-fixnum-string s #\S 7)))) + (defmethod fmt-sui ((s integer)) - (prefixed-integer-string s #\S 7)) + (if (>= s 10000000) + (prefixed-fixnum-string s #\S 8) + (prefixed-fixnum-string s #\S 7))) (defmethod fmt-sui ((s string)) (if (eql (aref s 0) #\S) @@ -150,9 +160,9 @@ (defun check-ui (ui start-char len) (when (and (stringp ui) - (= (length ui) (1+ len)) - (char-equal start-char (schar ui 0)) - (ignore-errors (parse-integer ui :start 1))) + (= (length ui) (1+ len)) + (char-equal start-char (schar ui 0)) + (ignore-errors (parse-integer ui :start 1))) t)) @@ -171,23 +181,23 @@ (or (not is-term) is-english))) (defun print-umlsclass (obj &key (stream *standard-output*) - (vid :compact-text) - (file-wrapper nil) (english-only t) (subobjects nil) - (refvars nil) (link-printer nil)) + (vid :compact-text) + (file-wrapper nil) (english-only t) (subobjects nil) + (refvars nil) (link-printer nil)) (view obj :stream stream :vid vid :subobjects subobjects - :file-wrapper file-wrapper - :filter (if english-only nil #'english-term-filter) - :link-printer link-printer - :refvars refvars)) + :file-wrapper file-wrapper + :filter (if english-only nil #'english-term-filter) + :link-printer link-printer + :refvars refvars)) (defmacro define-lookup-display (newfuncname lookup-func) "Defines functions for looking up and displaying objects" `(defun ,newfuncname (keyval &key (stream *standard-output*) (vid :compact-text) - (file-wrapper t) (english-only nil) (subobjects nil)) + (file-wrapper t) (english-only nil) (subobjects nil)) (let ((obj (funcall ,lookup-func keyval))) (print-umlsclass obj :stream stream :vid vid - :file-wrapper file-wrapper :english-only english-only - :subobjects subobjects) + :file-wrapper file-wrapper :english-only english-only + :subobjects subobjects) obj))) (define-lookup-display display-con #'find-ucon-cui) @@ -214,14 +224,14 @@ (defmethod mesh-number ((ustr ustr)) (let ((codes - (map-and-remove-nils - (lambda (sat) - (when (and (string-equal "MSH" (sab sat)) - (string-equal "MN" (atn sat))) - (atv sat))) - (s#sat ustr)))) + (map-and-remove-nils + (lambda (sat) + (when (and (string-equal "MSH" (sab sat)) + (string-equal "MN" (atn sat))) + (atv sat))) + (s#sat ustr)))) (if (= 1 (length codes)) - (car codes) + (car codes) codes))) (defun ucon-ustrs (ucon) @@ -229,7 +239,7 @@ (let (res) (dolist (term (s#term ucon) (nreverse res)) (dolist (str (s#str term)) - (push str res))))) + (push str res))))) (defmethod pfstr ((uterm uterm)) @@ -318,44 +328,17 @@ (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")))) - - -(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))))) + (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 uso-unique-codes (usos) (let ((sab-codes (make-hash-table :test 'equal)))