(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ANNOTATED-ARRAY" ( USE "LISP" "PT") (
NICKNAMES "AA") ( PREFIX-NAME "AA")))
(il:filecreated "26-Nov-88 18:14:30" il:{qv}<idl>next>annotated-array.\;10 5863
il:|changes| il:|to:| (il:vars il:annotated-arraycoms) (il:functions define-case-by-variate-layout make-annotated-array copy-annotated-array category-member-p within-variate-range number-member-p number-greater-p make-balance make-amount amount-member-p make-counts counts-member-p make-ranks make-grade grade-member-p grade-greater-p make-category annotated-array-adjoin annotation-ref setf-annotation-ref annotated-array-select annotated-array-reduce)
(il:define-types annotated-arrays datasets) (xcl:file-environments "ANNOTATED-ARRAY") (il:structures annotated-array variate variate-methods ordered-variate balance amount counts ranks grade category)
(il:variables *balance-methods* *amount-methods* *counts-methods* *ranks-methods* *grade-methods* *category-methods*)
il:|previous| il:|date:| "26-Nov-88 18:13:25" il:{qv}<idl>next>annotated-array.\;9)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:annotated-arraycoms)
(il:rpaqq il:annotated-arraycoms ((il:coms (il:structures annotated-array) (il:functions make-annotated-array copy-annotated-array)) (il:coms (il:functions annotation-ref setf-annotation-ref) (il:setfs annotation-ref)) (il:coms (il:functions annotated-array-select annotated-array-adjoin annotated-array-reduce)) (eval-when (load compile) (il:p (export (quote (annotated-array annotated-array-p aa-tag aa-dimension-tags aa-level-tags aa-array make-annotated-array annotation-ref)) (find-package "ANNOTATED-ARRAY")))) (xcl:file-environments "ANNOTATED-ARRAY")))
(defstruct (annotated-array (:conc-name "AA-") (:constructor %make-annotated-array) (:copier %copy-annotated-array)) p-list tag (il:* il:|;;| "A vector of length (array-rank array)") dimension-tags (il:* il:|;;| "A vector of length (array-rank array) whose elements are vectors of length") (il:* il:|;;| "(array-dimension array i)") level-tags (il:* il:|;;| "raw data") array)
(defun make-annotated-array (array &key tag dimension-tags level-tags) (%make-annotated-array :tag tag :dimension-tags dimension-tags :level-tags level-tags :array array))
(defun copy-annotated-array (annotated-array) (%make-annotated-array :dimension-tags (copy-seq (aa-dimension-tags annotated-array)) :level-tags (map (quote vector) (function (lambda (level-tag) (copy-seq level-tag))) (aa-level-tags annotated-array)) :array (aa-array annotated-array)))
(defun annotation-ref (annotated-array &optional ea:dimension level) (if (null level) (if (null ea:dimension) (aa-tag annotated-array) (aref (aa-dimension-tags annotated-array) ea:dimension)) (aref (aref (aa-level-tags annotated-array) ea:dimension) level)))
(defun setf-annotation-ref (annotated-array &optional arg1 arg2 arg3) (if (null arg3) (if (null arg2) (setf (aa-tag annotated-array) arg1) (setf (aref (aa-dimension-tags annotated-array) arg1) arg2)) (setf (aref (aref (aa-level-tags annotated-array) arg1) arg2) arg3)))
(defsetf annotation-ref setf-annotation-ref)
(defun annotated-array-select (annotated-array selectors) (let* ((dimension-tags (aa-dimension-tags annotated-array)) (ea:rank (length dimension-tags)) (dimension-mask (ea:array-apply (function (lambda (selector) (not (integerp selector)))) selectors)) (deflation (count nil dimension-mask))) (if (> (- ea:rank deflation) 0) (%make-annotated-array :tag (case deflation (0 nil) (1 (aref dimension-tags (position nil dimension-mask))) (otherwise (il:* il:|;;| "What's sensible for this case?") nil)) :dimension-tags (ea:compress dimension-mask dimension-tags) :level-tags (ea:as-vector (with-collection (let ((old-tags (aa-level-tags annotated-array))) (dotimes (i ea:rank) (let ((level-tag (aref old-tags i)) (selector (aref selectors i))) (unless (integerp selector) (collect (if (eq selector :all) (copy-seq level-tag) (ea:vector-select level-tag selector)))))))))))))
(defun annotated-array-adjoin (annotated-array-1 annotated-array-2 axis) (let* ((dimension-tags-1 (aa-dimension-tags annotated-array-1)) (level-tags-1 (aa-level-tags annotated-array-1)) (rank-1 (ea:total-size dimension-tags-1)) (dimension-tags-2 (aa-dimension-tags annotated-array-2)) (level-tags-2 (aa-level-tags annotated-array-2)) (rank-2 (ea:total-size dimension-tags-2))) (if (fixnum-eq rank-1 rank-2) (when (and (equalp dimension-tags-1 dimension-tags-2) (dotimes (i rank-1 t) (unless (fixnum-eq i axis) (unless (equalp (aref level-tags-1 i) (aref level-tags-2 i)) (return nil))))) (%make-annotated-array :dimension-tags (copy-seq dimension-tags-1) :level-tags (let ((new-level-tags (ea:array-apply (function copy-seq) level-tags-1))) (setf (aref new-level-tags axis) (ea:array-adjoin (aref level-tags-1 axis) (aref level-tags-2 axis))) new-level-tags))))))
(defun annotated-array-reduce (annotated-array axis) (let* ((dimension-tags (aa-dimension-tags annotated-array)) (ea:rank (ea:total-size dimension-tags))) (if (> ea:rank 1) (let ((mask (ea:array-apply (quote /=) (ea:genvector ea:rank) axis))) (%make-annotated-array :tag (aref dimension-tags axis) :dimension-tags (ea:compress mask dimension-tags) :level-tags (ea:array-apply (quote copy-seq) (ea:compress mask (aa-level-tags annotated-array))))))))
(eval-when (load compile)
(export (quote (annotated-array annotated-array-p aa-tag aa-dimension-tags aa-level-tags aa-array make-annotated-array annotation-ref)) (find-package "ANNOTATED-ARRAY"))
)
(xcl:define-file-environment "ANNOTATED-ARRAY" :readtable "XCL" :package (xcl:defpackage "ANNOTATED-ARRAY" (:use "LISP" "PT") (:nicknames "AA") (:prefix-name "AA")) :compiler :compile-file)
(il:putprops il:annotated-array il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop