(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "E-ARRAY")
(il:filecreated "19-Nov-88 13:03:13" il:{qv}<idl>next>e-array-arith.\;5 6040
il:|changes| il:|to:| (il:vars il:e-array-arithcoms) (il:functions binary-op-macro unary-op-macro reduction-op-macro scan-op-macro)
(xcl:file-environments "E-ARRAY-ARITH")
il:|previous| il:|date:| "16-Nov-88 10:29:49" il:{qv}<idl>next>e-array-arith.\;4)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:e-array-arithcoms)
(il:rpaqq il:e-array-arithcoms ((il:functions binary-op-macro unary-op-macro reduction-op-macro scan-op-macro) (earray-ops (+ dyadic) (+ reduction) (+ scan) (- dyadic) (- monadic) (- reduction) (- scan) (* dyadic) (* reduction) (/ dyadic) (/ monadic) (/ reduction)) (earray-ops (max dyadic) (max reduction) (max scan) (min dyadic) (min reduction) (min scan)) (il:coms (il:functions mean variance sample-variance) (earray-ops (mean reduction) (variance reduction) (sample-variance reduction))) (xcl:file-environments "E-ARRAY-ARITH")))
(defmacro binary-op-macro (op array1 array2 result) (once-only (op array1 array2 result) (il:bquote (let ((linearized-array1 (linearize (il:\\\, array1))) (linearized-array2 (linearize (il:\\\, array2))) (linearized-result (linearize (il:\\\, result)))) (if (scalarp (il:\\\, array1)) (if (scalarp (il:\\\, array2)) (setq (il:\\\, result) ((il:\\\, op) (il:\\\, array1) (il:\\\, array2))) (dotimes (i (array-total-size (il:\\\, result))) (setf (aref linearized-result i) ((il:\\\, op) (il:\\\, array1) (aref linearized-array2 i))))) (if (scalarp (il:\\\, array2)) (dotimes (i (array-total-size (il:\\\, result))) (setf (aref linearized-result i) ((il:\\\, op) (aref linearized-array1 i) (il:\\\, array2)))) (dotimes (i (array-total-size (il:\\\, result))) (setf (aref linearized-result i) ((il:\\\, op) (aref linearized-array1 i) (aref linearized-array2 i)))))) (il:\\\, result)))))
(defmacro unary-op-macro (op array result) (once-only (op array result) (il:bquote (let ((linearized-array (linearize (il:\\\, array))) (linearized-result (linearize (il:\\\, result)))) (if (scalarp (il:\\\, array)) (setq (il:\\\, result) ((il:\\\, op) (il:\\\, array))) (dotimes (i (array-total-size (il:\\\, result))) (setf (aref linearized-result i) ((il:\\\, op) (aref linearized-array i))))) (il:\\\, result)))))
(defmacro reduction-op-macro (op vector &optional identity) (once-only (op vector identity) (il:bquote (let ((size (total-size (il:\\\, vector))) (index 0) (result (il:\\\, identity))) (case size (0 nil) (1 (setq result (il:\\\, (if identity (il:bquote ((il:\\\, op) result (aref (il:\\\, vector) 0))) (il:bquote (aref (il:\\\, vector) 0)))))) (otherwise (setq result (aref (il:\\\, vector) 0)) (setq index 1) (loop (if (eq index size) (return nil)) (setq result ((il:\\\, op) result (aref (il:\\\, vector) index))) (incf index)))) result))))
(defmacro scan-op-macro (op vector result &optional identity) (once-only (op vector result identity) (il:bquote (let ((size (total-size (il:\\\, vector))) (index 0) (accumulator (il:\\\, identity))) (case size (0 nil) (1 (setf (aref (il:\\\, result) 0) (il:\\\, (if identity (il:bquote ((il:\\\, op) accumulator (aref (il:\\\, vector) 0))) (il:bquote (aref (il:\\\, vector) 0)))))) (otherwise (setq accumulator (aref (il:\\\, vector) 0)) (setf (aref (il:\\\, result) 0) accumulator) (setq index 1) (loop (if (eq index size) (return accumulator)) (setq accumulator ((il:\\\, op) accumulator (aref (il:\\\, vector) index))) (setf (aref (il:\\\, result) index) accumulator) (incf index)))) (il:\\\, result)))))
(define-dyadic-op + (array1 array2 result) (binary-op-macro + array1 array2 result))
(define-reduction-op + (vector) (reduction-op-macro + vector 0))
(define-scan-op + (vector result) (scan-op-macro + vector result 0))
(define-dyadic-op - (array1 array2 result) (binary-op-macro - array1 array2 result))
(define-monadic-op - (array result) (unary-op-macro - array result))
(define-reduction-op - (vector) (reduction-op-macro - vector))
(define-scan-op - (vector result) (scan-op-macro - vector result))
(define-dyadic-op * (array1 array2 result) (binary-op-macro * array1 array2 result))
(define-reduction-op * (vector) (reduction-op-macro * vector 1))
(define-dyadic-op / (array1 array2 result) (binary-op-macro / array1 array2 result))
(define-monadic-op / (array result) (unary-op-macro / array result))
(define-reduction-op / (vector) (reduction-op-macro / vector))
(define-dyadic-op max (array1 array2 result) (binary-op-macro max array1 array2 result))
(define-reduction-op max (vector) (reduction-op-macro max vector))
(define-scan-op max (vector result) (scan-op-macro max vector result))
(define-dyadic-op min (array1 array2 result) (binary-op-macro min array1 array2 result))
(define-reduction-op min (vector) (reduction-op-macro min vector))
(define-scan-op min (vector result) (scan-op-macro min vector result))
(defun mean (vector) (/ (array-reduce (quote +) vector) (total-size vector)))
(defun variance (vector) (macrolet ((sqr (x) (once-only (x) (il:bquote (* (il:\\\, x) (il:\\\, x)))))) (let ((m (mean vector)) (size (total-size vector)) (result 0) (index 0)) (loop (if (eq index size) (return (/ result size))) (setq result (+ result (sqr (- (aref vector index) m)))) (incf index)))))
(defun sample-variance (vector) (macrolet ((sqr (x) (once-only (x) (il:bquote (* (il:\\\, x) (il:\\\, x)))))) (let ((m (mean vector)) (size (total-size vector)) (result 0) (index 0)) (loop (if (eq index size) (return (/ result (1- size)))) (setq result (+ result (sqr (- (aref vector index) m)))) (incf index)))))
(define-reduction-op mean (vector) (mean vector))
(define-reduction-op variance (vector) (variance vector))
(define-reduction-op sample-variance (vector) (sample-variance vector))
(xcl:define-file-environment "E-ARRAY-ARITH" :package "E-ARRAY" :readtable "XCL" :compiler :compile-file)
(il:putprops il:e-array-arith il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop