(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "VARIATES" ( USE "LISP" "PT") ( NICKNAMES "VR"
) ( PREFIX-NAME "VR")))
(il:filecreated "30-Nov-88 14:40:39" il:{qv}<idl>next>variates.\;9 9960
il:|changes| il:|to:| (il:structures variate precent percent general variate-methods ordered-variate balance amount counts ranks grade category)
(il:vars il:variatescoms) (il:functions print-variate define-variate make-category make-general make-balance make-amount make-percent make-counts make-ranks make-grade percent-member-p make-variate-constructor within-variate-range number-member-p number-greater-p amount-member-p counts-member-p grade-member-p grade-greater-p category-member-p)
(il:variables *percent-methods* *general-methods* *balance-methods* *amount-methods* *counts-methods* *ranks-methods* *grade-methods* *category-methods*)
(il:define-types variates) (xcl:file-environments "VARIATES")
il:|previous| il:|date:| "30-Nov-88 14:04:40" il:{qv}<idl>next>variates.\;8)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:variatescoms)
(il:rpaqq il:variatescoms ((il:* il:|;;| "Variate objects") (il:define-types variates) (il:functions define-variate) (il:structures variate variate-methods ordered-variate) (il:functions print-variate within-variate-range number-member-p number-greater-p) (il:functions make-variate-constructor) (il:coms (il:* il:|;;| "general variate") (il:variables *general-methods*) (il:structures general) (il:functions make-general)) (il:coms (il:* il:|;;| "balances") (il:variables *balance-methods*) (il:structures balance) (il:functions make-balance)) (il:coms (il:* il:|;;| "amounts ") (il:variables *amount-methods*) (il:structures amount) (il:functions make-amount amount-member-p)) (il:coms (il:* il:|;;| "percents ") (il:variables *percent-methods*) (il:structures percent) (il:functions make-percent percent-member-p)) (il:coms (il:* il:|;;| "counts ") (il:variables *counts-methods*) (il:structures counts) (il:functions make-counts counts-member-p)) (il:coms (il:* il:|;;| "ranks ") (il:variables *ranks-methods*) (il:structures ranks) (il:functions make-ranks)) (il:coms (il:* il:|;;| "grades ") (il:variables *grade-methods*) (il:structures grade) (il:functions make-grade grade-member-p grade-greater-p)) (il:coms (il:* il:|;;| "categories ") (il:variables *category-methods*) (il:structures category) (il:functions make-category category-member-p)) (eval-when (load compile) (il:p (export (quote (variates define-variate variate variate-p variate-name variate-documentation variate-methods ordered-variate ordered-variate-p general general-p make-general balance balance-p make-balance amount amount-p make-amount percent percent-p make-percent counts counts-p make-counts ranks ranks-p make-ranks grade grade-p make-grade category category-p make-category)) (find-package "VARIATES")))) (xcl:file-environments "VARIATES")))
(il:* il:|;;| "Variate objects")
(xcl:def-define-type variates "IDL variate(s)")
(xcl:defdefiner define-variate variates (name documentation type &rest keyword-args) (il:bquote (defparameter (il:\\\, name) (funcall (function (il:\\\, (make-variate-constructor type))) :name (quote (il:\\\, name)) :documentation (il:\\\, documentation) (il:\\\,@ keyword-args)))))
(defstruct (variate (:constructor nil) (:copier nil) (:print-function print-variate)) methods name documentation)
(defstruct (variate-methods (:conc-name "VM-")) member-p instance-member-p greater-p)
(defstruct (ordered-variate (:constructor nil) (:copier nil) (:include variate)) min max)
(defun print-variate (variate stream print-level) (declare (ignore print-level)) (write-string "#<" stream) (princ (quote variate) stream) (write-string " " stream) (prin1 (variate-documentation variate) stream) (write-string ", " stream) (prin1 (variate-name variate) stream) (write-string ">" stream))
(defun within-variate-range (x ordered-variate) (and (funcall (vm-member-p (variate-methods ordered-variate)) x) (let ((min (ordered-variate-min ordered-variate)) (max (ordered-variate-max ordered-variate)) (greater-p-fn (vm-greater-p ordered-variate))) (and (or (null min) (not (funcall greater-p-fn min x))) (or (null max) (not (funcall greater-p-fn x max)))))))
(defun number-member-p (x variate) (declare (ignore variate)) (numberp x))
(defun number-greater-p (x y variate) (declare (ignore variate)) (> x y))
(defun make-variate-constructor (type) (intern (concatenate (quote string) "MAKE-" (string type)) (find-package "VARIATES")))
(il:* il:|;;| "general variate")
(defparameter *general-methods* (make-variate-methods :member-p (quote xcl:true) :instance-member-p (quote xcl:true) :greater-p (function (lambda (&rest args) (declare (ignore args)) (error "Unordered variate")))))
(defstruct (general (:constructor %make-general) (:include variate (methods *general-methods*))))
(defun make-general (&key name documentation) (%make-general :name name :documentation (string documentation)))
(il:* il:|;;| "balances")
(defparameter *balance-methods* (make-variate-methods :member-p (quote number-member-p) :instance-member-p (quote within-variate-range) :greater-p (quote number-greater-p)))
(defstruct (balance (:constructor %make-balance) (:include ordered-variate (methods *balance-methods*))))
(defun make-balance (&key name documentation min max) (%make-balance :name name :documentation (string documentation) :min min :max max))
(il:* il:|;;| "amounts ")
(defparameter *amount-methods* (make-variate-methods :member-p (quote amount-member-p) :instance-member-p (quote within-variate-range) :greater-p (quote number-greater-p)))
(defstruct (amount (:constructor %make-amount) (:include ordered-variate (methods *amount-methods*))))
(defun make-amount (&key name documentation (min 0) max) (%make-amount :name name :documentation (string documentation) :min min :max max))
(defun amount-member-p (x variate) (declare (ignore variate)) (typecase x (float (> x 0.0)) (rational (> x 0))))
(il:* il:|;;| "percents ")
(defparameter *percent-methods* (make-variate-methods :member-p (quote amount-member-p) :instance-member-p (quote amount-member-p) :greater-p (quote number-greater-p)))
(defstruct (percent (:constructor %make-percent) (:include ordered-variate (methods *percent-methods*))))
(defun make-percent (&key name documentation (min 0) max) (%make-percent :name name :documentation (string documentation) :min 0.0 :max 1.0))
(defun percent-member-p (x variate) (declare (ignore variate)) (<= 0.0 x 1.0))
(il:* il:|;;| "counts ")
(defparameter *counts-methods* (make-variate-methods :member-p (quote counts-member-p) :instance-member-p (quote within-variate-range) :greater-p (quote number-greater-p)))
(defstruct (counts (:constructor %make-counts) (:include ordered-variate (methods *counts-methods*))))
(defun make-counts (&key name documentation (min 0) max) (%make-counts :name name :documentation (string documentation) :min min :max max))
(defun counts-member-p (x variate) (declare (ignore variate)) (and (integerp x) (> x 0)))
(il:* il:|;;| "ranks ")
(defparameter *ranks-methods* (make-variate-methods :member-p (quote counts-member-p) :instance-member-p (quote within-variate-range) :greater-p (quote number-greater-p)))
(defstruct (ranks (:constructor %make-ranks) (:include ordered-variate (methods *ranks-methods*))))
(defun make-ranks (&key name documentation (min 0) max) (%make-ranks :name name :documentation (string documentation) :min min :max max))
(il:* il:|;;| "grades ")
(defparameter *grade-methods* (make-variate-methods :member-p (quote grade-member-p) :instance-member-p (quote grade-member-p) :greater-p (quote grade-greater-p)))
(defstruct (grade (:constructor %make-grade) (:include ordered-variate (methods *grade-methods*))) ordering)
(defun make-grade (&key name documentation ordering) (%make-grade :name name :documentation (string documentation) :ordering (copy-seq ordering) :min (first ordering) :max (first (last ordering))))
(defun grade-member-p (x variate) (and (member x (grade-ordering variate) :test (function equal)) t))
(defun grade-greater-p (x y variate) (let* ((grade-ordering (grade-ordering variate)) (tail-y (member y grade-ordering :test (function equal))) (tail-x (member x grade-ordering :test (function equal)))) (if (null tail-x) (error "~s is not a member of: ~s" x grade-ordering)) (if (null tail-y) (error "~s is not a member of: ~s" y grade-ordering)) (and (member x tail-y :test (function equal)) t)))
(il:* il:|;;| "categories ")
(defparameter *category-methods* (make-variate-methods :member-p (quote category-member-p) :instance-member-p (quote category-member-p) :greater-p (function (lambda (&rest args) (declare (ignore args)) (error "Order is undefined for categorical variables")))))
(defstruct (category (:constructor %make-category) (:include variate (methods *category-methods*))) labels)
(defun make-category (&key name documentation labels) (%make-category :name name :documentation (string documentation) :labels (copy-seq labels)))
(defun category-member-p (x variate) (and (member x (category-labels variate) :test (function equal)) t))
(eval-when (load compile)
(export (quote (variates define-variate variate variate-p variate-name variate-documentation variate-methods ordered-variate ordered-variate-p general general-p make-general balance balance-p make-balance amount amount-p make-amount percent percent-p make-percent counts counts-p make-counts ranks ranks-p make-ranks grade grade-p make-grade category category-p make-category)) (find-package "VARIATES"))
)
(xcl:define-file-environment "VARIATES" :package (xcl:defpackage "VARIATES" (:use "LISP" "PT") (:nicknames "VR") (:prefix-name "VR")) :readtable "XCL" :compiler :compile-file)
(il:putprops il:variates il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop