(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "MEASUREMENTS" ( USE "LISP" "PT") ( NICKNAMES
"MT") ( PREFIX-NAME "MT")))
(il:filecreated "18-Dec-88 18:28:53" il:{qv}<idl>next>measurements.\;5 8934
il:|changes| il:|to:| (il:structures measurement percent label measurement-methods ordered numeric constrained-numeric amount counts ordered-non-numeric grade rank ranks non-numeric category)
(il:vars il:measurementscoms) (il:functions measurement-member-p measurement-equal-p measurement-greater-p make-measurement label-member-p grade-member-p print-measurement define-measurement no-such-method numeric-member-p numeric-equal-p numeric-greater-p constrained-numeric-member-p counts-member-p grade-equal-p grade-greater-p rank-member-p rank-equal-p rank-greater-p non-numeric-member-p non-numeric-equal-p category-member-p make-measurement-constructor)
(xcl:file-environments "MEASUREMENTS")
il:|previous| il:|date:| "18-Dec-88 14:47:22" il:{qv}<idl>next>measurements.\;2)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:measurementscoms)
(il:rpaqq il:measurementscoms ((il:* il:|;;| "Measurement objects") (il:functions define-measurement) (il:coms (il:structures measurement measurement-methods) (il:functions print-measurement no-such-method) (il:functions make-measurement) (il:functions measurement-member-p measurement-equal-p measurement-greater-p) (il:coms (il:structures ordered) (il:coms (il:structures numeric) (il:functions numeric-member-p numeric-equal-p numeric-greater-p) (il:coms (il:structures constrained-numeric) (il:functions constrained-numeric-member-p) (il:coms (il:structures amount)) (il:coms (il:structures percent))) (il:coms (il:structures counts) (il:functions counts-member-p))) (il:coms (il:structures ordered-non-numeric) (il:coms (il:structures grade) (il:functions grade-member-p grade-equal-p grade-greater-p)) (il:coms (il:structures rank ranks) (il:functions rank-member-p rank-equal-p rank-greater-p)))) (il:coms (il:structures non-numeric) (il:functions non-numeric-member-p non-numeric-equal-p) (il:coms (il:structures label) (il:functions label-member-p)) (il:coms (il:structures category) (il:functions category-member-p)))) (il:functions make-measurement-constructor) (eval-when (load) (il:p (export (quote (define-measurement measurement make-measurement measurement-p measurement-documentation measurement-member-p measurement-equal-p measurement-greater-p ordered ordered-p numeric numeric-p constrained-numeric constrained-numeric-p amount amount-p percent percent-p ordered-non-numeric ordered-non-numeric-p grade grade-p grade-levels rank make-rank rank-p rank-integer ranks ranks-p non-numeric non-numeric-p category category-p category-levels label label-p)) (find-package "MEASUREMENTS")))) (xcl:file-environments "MEASUREMENTS")))
(il:* il:|;;| "Measurement objects")
(xcl:defdefiner define-measurement il:structures (type &key include methods instance-vars) (let* ((type-package (symbol-package type)) (type-string (string type)) (methods-name (intern (concatenate (quote string) "*" type-string "-METHODS*") type-package)) (methods-alist (quote ((:member-p . "-MEMBER-P") (:equal-p . "-EQUAL-P") (:greater-p . "-GREATER-P")))) (methods (mapcan (function (lambda (pair) (let* ((keyword (car pair)) (suffix (cdr pair)) (supplied (cdr (memq keyword methods)))) (if supplied (let ((value (car supplied))) (if value (il:bquote ((il:\\\, keyword) (quote (il:\\\, value)))))) (il:bquote ((il:\\\, keyword) (quote (il:\\\, (intern (concatenate (quote string) type-string suffix) type-package))))))))) methods-alist))) (il:bquote (progn (defparameter (il:\\\, methods-name) (make-measurement-methods (il:\\\,@ methods))) (defstruct ((il:\\\, type) (:include (il:\\\,@ (if (symbolp include) (list include) include)) (methods (il:\\\, methods-name)))) (il:\\\,@ instance-vars))))))
(defstruct (measurement (:constructor nil) (:copier nil) (:print-function print-measurement)) methods documentation)
(defstruct (measurement-methods (:conc-name "MM-")) member-p equal-p greater-p)
(defun print-measurement (measurement stream print-level) (declare (ignore print-level)) (write-string "#<" stream) (princ (type-of measurement) stream) (write-string " " stream) (prin1 (measurement-documentation measurement) stream) (write-string ">" stream))
(defun no-such-method (&rest args) (declare (ignore args)) (error "No such method"))
(defun make-measurement (type &optional documentation &rest keyword-args) (apply (make-measurement-constructor type) :documentation documentation keyword-args))
(defun measurement-member-p (object measurement) (funcall (mm-member-p (measurement-methods measurement)) object measurement))
(defun measurement-equal-p (x y measurement) (funcall (mm-equal-p (measurement-methods measurement)) x y measurement))
(defun measurement-greater-p (x y measurement) (funcall (mm-greater-p (measurement-methods measurement)) x y measurement))
(define-measurement ordered :include measurement :methods (:greater-p no-such-method :member-p no-such-method :equal-p no-such-method))
(define-measurement numeric :include ordered)
(defun numeric-member-p (x measurement) (declare (ignore measurement)) (numberp x))
(defun numeric-equal-p (x y measurement) (declare (ignore measurement)) (= x y))
(defun numeric-greater-p (x y measurement) (declare (ignore measurement)) (> x y))
(define-measurement constrained-numeric :include numeric :instance-vars ((min :-infinity) (max :+infinity)) :methods (:equal-p numeric-equal-p :greater-p numeric-greater-p))
(defun constrained-numeric-member-p (x measurement) (let ((min (constrained-numeric-min measurement)) (max (constrained-numeric-max measurement))) (and (numberp x) (and (not (eq min :-infinity)) (>= x min)) (and (not (eq max :+infinity)) (<= x max)))))
(define-measurement amount :include (constrained-numeric (min 0)) :methods (:member-p constrained-numeric-member-p :equal-p numeric-equal-p :greater-p numeric-greater-p))
(define-measurement percent :include (constrained-numeric (min 0.0) (max 100.0)) :methods (:member-p constrained-numeric-member-p :equal-p numeric-equal-p :greater-p numeric-greater-p))
(define-measurement counts :include numeric :methods (:equal-p numeric-equal-p :greater-p numeric-greater-p))
(defun counts-member-p (x measurement) (declare (ignore measurement)) (typep x (quote (integer 0))))
(define-measurement ordered-non-numeric :include ordered :methods (:member-p no-such-method :equal-p no-such-method :greater-p no-such-method))
(define-measurement grade :include ordered-non-numeric :instance-vars (levels))
(defun grade-member-p (x measurement) (and (symbolp x) (memq x (grade-levels measurement)) t))
(defun grade-equal-p (x y measurement) (declare (ignore measurement)) (eq x y))
(defun grade-greater-p (x y measurement) (and (memq x (cdr (memq y (grade-levels measurement)))) t))
(defstruct rank integer)
(define-measurement ranks :include ordered-non-numeric)
(defun rank-member-p (x measurement) (declare (ignore measurement)) (rank-p x))
(defun rank-equal-p (x y measurement) (declare (ignore measurement)) (= (rank-integer x) (rank-integer y)))
(defun rank-greater-p (x y measurement) (declare (ignore measurement)) (> (rank-integer x) (rank-integer y)))
(define-measurement non-numeric :include measurement :methods (:greater-p no-such-method))
(defun non-numeric-member-p (x measurement) (declare (ignore measurement)) t)
(defun non-numeric-equal-p (x y measurement) (declare (ignore measurement)) (eq x y))
(define-measurement label :include non-numeric :methods (:equal-p non-numeric-equal-p :greater-p no-such-method))
(defun label-member-p (x measurement) (symbolp x))
(define-measurement category :include non-numeric :instance-vars (levels) :methods (:equal-p non-numeric-equal-p :greater-p no-such-method))
(defun category-member-p (x measurement) (and (symbolp x) (memq x (category-levels measurement)) t))
(defun make-measurement-constructor (type) (intern (concatenate (quote string) "MAKE-" (string type)) (find-package "MEASUREMENTS")))
(eval-when (load)
(export (quote (define-measurement measurement make-measurement measurement-p measurement-documentation measurement-member-p measurement-equal-p measurement-greater-p ordered ordered-p numeric numeric-p constrained-numeric constrained-numeric-p amount amount-p percent percent-p ordered-non-numeric ordered-non-numeric-p grade grade-p grade-levels rank make-rank rank-p rank-integer ranks ranks-p non-numeric non-numeric-p category category-p category-levels label label-p)) (find-package "MEASUREMENTS"))
)
(xcl:define-file-environment "MEASUREMENTS" :package (xcl:defpackage "MEASUREMENTS" (:use "LISP" "PT") (:nicknames "MT") (:prefix-name "MT")) :readtable "XCL" :compiler :compile-file)
(il:putprops il:measurements il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop