(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "E-ARRAY")

(il:filecreated "25-Nov-88 18:32:32" il:{qv}<idl>next>e-array-fns.\;12
 28300  

      il:|changes| il:|to:|  (il:functions select setf-select vector-select setf-vector-select degenerate-adjoin equirank-adjoin take array-adjoin define-monadic-op define-dyadic-op define-reduction-op define-scan-op)
 (il:setfs vector-select) (il:vars il:e-array-fnscoms)

      il:|previous| il:|date:| "25-Nov-88 16:13:17" il:{qv}<idl>next>e-array-fns.\;11)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:e-array-fnscoms)

(il:rpaqq il:e-array-fnscoms ((il:functions array-blt array-fill generic-blt generic-fill) (il:functions select setf-select vector-select setf-vector-select) (il:setfs select vector-select) (il:functions genvector) (il:functions shape ravel reshape) (il:functions array-adjoin degenerate-adjoin equirank-adjoin) (il:functions laminate) (il:functions compress compress-if) (il:functions expand) (il:functions array-reverse array-rotate) (il:functions transpose) (il:functions take drop) (il:define-types earray-ops) (il:coms (il:variables *monadic-functions* *dyadic-functions*) (il:functions define-monadic-op define-dyadic-op) (il:functions array-apply monadic-apply dyadic-apply nadic-apply) (il:functions generic-monadic-apply generic-dyadic-apply)) (il:coms (il:variables *reduction-functions*) (il:functions define-reduction-op) (il:functions array-reduce generic-vector-reduce)) (il:coms (il:variables *scan-functions*) (il:functions define-scan-op) (il:functions array-scan generic-vector-scan)) (il:functions array-sweep inner-product outer-product) (xcl:file-environments "E-ARRAY-FNS")))

(defun array-blt (source destination &key source-iterator destination-iterator) (if (scalarp destination) (error "Destination not an array: ~s" destination)) (if (scalarp source) (array-fill source destination :destination-iterator destination-iterator) (if (and (eq (element-type source) (quote single-float)) (eq (element-type destination) (quote single-float))) (float-blt source source-iterator destination destination-iterator) (generic-blt source source-iterator destination destination-iterator))))

(defun array-fill (scalar destination &key destination-iterator) (if (scalarp destination) (error "Destination not an array: ~s" destination)) (if (eq (element-type destination) (quote single-float)) (float-fill scalar destination destination-iterator) (generic-fill scalar destination destination-iterator)))

(defun generic-blt (source source-iterator destination destination-iterator) (let ((linearized-source (linearize source)) (linearized-destination (linearize destination))) (if (null source-iterator) (let ((source-limit (array-total-size source)) (j 0)) (if (null destination-iterator) (dotimes (i (array-total-size destination)) (if (eq j source-limit) (setq j 0)) (setf (aref linearized-destination i) (aref linearized-source j)) (incf j)) (do ((i (next-index destination-iterator) (next-index destination-iterator))) ((null i)) (if (eq j source-limit) (setq j 0)) (setf (aref linearized-destination i) (aref linearized-source j)) (incf j)))) (let ((j (next-index source-iterator))) (if (null destination-iterator) (dotimes (i (array-total-size destination)) (when (null j) (reset-iterator source-iterator) (setq j (next-index source-iterator))) (setf (aref linearized-destination i) (aref linearized-source j)) (setq j (next-index source-iterator))) (do ((i (next-index destination-iterator) (next-index destination-iterator))) ((null i)) (when (null j) (reset-iterator source-iterator) (setq j (next-index source-iterator))) (setf (aref linearized-destination i) (aref linearized-source j)) (setq j (next-index source-iterator)))))) destination))

(defun generic-fill (scalar destination destination-iterator) (if (null destination-iterator) (fill-array destination scalar) (do ((linearized-destination (linearize destination)) (i (next-index destination-iterator) (next-index destination-iterator))) ((null i)) (setf (aref linearized-destination i) scalar))) destination)

(defun select (array selectors &optional result) (if (not (vectorp selectors)) (error "Selectors must be a vector: ~s" selectors)) (if (not (eq (total-size selectors) (rank array))) (error "Dimensions mismatch: ~s" selectors)) (let* ((rank (rank array)) (result-dims (with-collection (dotimes (i rank) (let ((selector (aref selectors i))) (ecase (rank selector) (0 (if (eq selector :all) (collect (dimension array i)) (if (not (integerp selector)) (error "Not a valid selector: ~s" selector)))) (1 (collect (total-size selector))))))))) (if (null result-dims) (if (eq rank 0) array (apply (function aref) array (as-list selectors))) (array-blt array (test-result result result-dims (element-type array)) :source-iterator (make-iterator array :level-map selectors)))))

(defun setf-select (array selectors newvalue) (let ((rank (rank array))) (if (eq rank 0) (error "Can't assign into a scalar: ~s" array)) (if (not (vectorp selectors)) (error "Selectors must be a vector: ~s" selectors)) (if (not (eq (total-size selectors) rank)) (error "Dimensionality mismatch: ~s" selectors)) (array-blt newvalue array :destination-iterator (make-iterator array :level-map selectors))))

(defun vector-select (vector indices &optional result) (if (not (vectorp indices)) (error "Selectors must be a vector: ~s" indices)) (array-blt vector (test-result result (list (length indices)) (element-type vector)) :source-iterator (make-iterator vector :level-map (list indices))))

(defun setf-vector-select (vector indices new-value) (if (not (vectorp indices)) (error "Selectors must be a vector: ~s" indices)) (if (not (fixnum-eq (length indices) (length new-value))) (error "Rank mismatch: ~s" new-value)) (array-blt new-value vector :destination-iterator (make-iterator vector :level-map (list indices))))

(defsetf select setf-select)

(defsetf vector-select setf-vector-select)

(defun genvector (n &key (start 0) (step-size 1)) (let ((result (make-array n :element-type (if (or (floatp start) (floatp step-size)) (quote float) t)))) (do ((i 0 (1+ i)) (value start (+ value step-size))) ((eq i n) result) (setf (aref result i) value))))

(defun shape (array &optional result) (let* ((rank (rank array)) (resultdims (list rank))) (setq result (test-result result resultdims)) (dotimes (i rank) (setf (aref result i) (dimension array i))) result))

(defun ravel (array result) (let ((resultdims (list (total-size array))) (resultelttype (element-type array))) (array-blt array (test-result result resultdims resultelttype))))

(defun reshape (shape array &optional result) (il:* il:|;;| "SHAPE must be a vector of non-negative integers -- for convenience scalars are treated as vectors of length 1") (if (not (or (integerp shape) (eq (rank shape) 1))) (error "Shape of incorrect form: ~s" shape)) (let ((resultdims (if (integerp shape) (list shape) (as-list shape)))) (if (null resultdims) (make-scalar array) (array-blt array (test-result result resultdims (element-type array))))))

(defun array-adjoin (array1 array2 &optional axis result) (let ((rank1 (rank array1)) (dims1 (dimensions array1)) (rank2 (rank array2)) (dims2 (dimensions array2))) (if (null axis) (setq axis (max 0 (1- (max rank1 rank2)))) (if (not (and (typep axis (quote (integer 0))) (< axis (max rank1 rank2)))) (error "Incorrect axis specifier: ~s" axis))) (cond ((fixnum-eq 0 (min rank1 rank2)) (degenerate-adjoin array1 array2 axis result)) ((and (fixnum-eq rank1 rank2) (do ((d1 dims1 (cdr d1)) (d2 dims1 (cdr d2)) (i 0 (1+ i))) ((fixnum-eq i rank1) t) (if (not (or (fixnum-eq i axis) (fixnum-eq (car d1) (car d2)))) (return nil)))) (equirank-adjoin array1 array2 axis result)) ((and (fixnum-eq 1 (abs (- rank1 rank2))) (do ((greater (if (> rank1 rank2) dims1 dims2) (cdr greater)) (smaller (if (> rank1 rank2) dims2 dims1)) (i 0 (1+ i))) ((null greater) t) (when (not (fixnum-eq i axis)) (if (not (fixnum-eq (car greater) (car smaller))) (return nil)) (setq smaller (cdr smaller))))) (degenerate-adjoin array1 array2 axis result)) (t (error "Non-conformable arguments")))))

(defun degenerate-adjoin (array1 array2 axis result) (let ((larger (if (> (rank array1) (rank array2)) array1 array2))) (setq result (test-result result (if (eq 0 (rank larger)) (quote (2)) (let ((r-dims (copy-list (dimensions larger)))) (incf (nth axis r-dims)) r-dims)) (common-type (element-type array2) (element-type array1)))) (array-blt array1 result :destination-iterator (if (eq array1 larger) (make-iterator result :level-map (let ((map (make-list (rank result)))) (setf (nth axis map) (make-index-range :low 0 :high (1- (dimension result axis)))) map)) (make-iterator result :dimension axis :level 0))) (array-blt array2 result :destination-iterator (if (eq array2 larger) (make-iterator result :level-map (let ((map (make-list (rank result)))) (setf (nth axis map) (make-index-range :low 1 :high (dimension result axis))) map)) (make-iterator result :dimension axis :level (1- (dimension result axis))))) result))

(defun equirank-adjoin (array1 array2 axis result) (setq result (test-result result (let ((dims (copy-list (dimensions array1)))) (incf (nth axis dims) (dimension array2 axis)) dims) (common-type (element-type array1) (element-type array2)))) (array-blt array1 result :destination-iterator (make-iterator result :level-map (let ((map (make-list (rank result)))) (setf (nth axis map) (make-index-range :low 0 :high (dimension array1 axis))) map))) (array-blt array2 result :destination-iterator (make-iterator result :level-map (let ((map (make-list (rank result)))) (setf (nth axis map) (make-index-range :low (dimension array1 axis) :high (dimension result axis))) map))) result)

(defun laminate (array1 array2 &optional (axis -0.5) result) (let ((rank1 (rank array1)) (rank2 (rank array2))) (if (not (and (floatp axis) (< axis (max rank1 rank2)))) (error "Incorrect axis specifier: ~S" axis)) (if (or (eq 0 (min rank1 rank2)) (and (eq rank1 rank2) (dotimes (i rank1 t) (if (not (eq (dimension array1 i) (dimension array2 i))) (return nil))))) (let* ((extradim (ceiling axis)) (larger (if (> (rank array1) (rank array2)) array1 array2)) (rank (rank larger))) (setq result (test-result result (let ((larger-dims (dimensions larger)) (dims (make-list (1+ rank)))) (replace dims larger-dims :end1 extradim :end2 extradim) (setf (nth extradim dims) 2) (replace dims larger-dims :start1 (1+ extradim) :end1 (1+ rank) :start2 extradim :end2 rank) dims) (common-type (element-type array2) (element-type array1)))) (array-blt array1 result :destination-iterator (make-iterator result :dimension extradim :level 0)) (array-blt array2 result :destination-iterator (make-iterator result :dimension extradim :level 1)) result) (error "Non-conformable arguments"))))

(defun compress (compression array &optional (axis (1- (rank array))) result) (il:* il:|;;;| "as in the APL compression operator, AXIS is optional, defaults to last dimension") (let ((rank (rank array)) (dims (dimensions array)) (size (dimension array axis))) (if (scalarp compression) (il:* il:|;;| "Expand scalars") (setq compression (reshape rank compression))) (if (not (and (eq (rank compression) 1) (eq (total-size compression) size))) (error "Compression vector of incorrect form: ~s" compression)) (array-blt array (test-result result (let ((result-dims (copy-list dims))) (setf (nth axis result-dims) (- size (count nil compression))) result-dims) (element-type array)) :source-iterator (make-iterator array :level-map (let ((map (make-list (rank array)))) (setf (nth axis map) (with-collection (dotimes (i size) (if (aref compression i) (collect i))))) map)))))

(defun compress-if (predicate array &optional (axis (1- (rank array))) result) (il:* il:|;;;| "as in the APL compression operator, AXIS is optional, defaults to last dimension") (il:* il:|;;;| "PREDICATE will be called with three args; index, array, axis") (compress (let ((temp (make-array (dimension array axis)))) (dotimes (i (dimension array axis)) (setf (aref temp i) (funcall predicate i array axis))) temp) array axis))

(defun expand (expansion array &optional (axis (1- (rank array))) result) (let ((rank (rank array))) (if (not (and (vectorp expansion) (eq (count-if (function identity) expansion) (dimension array axis)))) (error "Expansion vector of incorrect form: ~s" expansion)) (setq result (test-result result (let ((result-dims (copy-list (dimensions array)))) (setf (nth axis result-dims) (total-size expansion)) result-dims) (element-type array))) (array-blt array result :destination-iterator (make-iterator result :level-map (let ((map (make-list (rank array)))) (setf (nth axis map) (with-collection (dotimes (i (total-size expansion)) (if (aref expansion i) (collect i))))) map)))))

(defun array-reverse (array &optional (axis (1- (rank array))) result) (let ((dims (dimensions array))) (array-blt array (test-result result dims (element-type array)) :destination-iterator (make-iterator array :level-map (let ((map (make-list (rank array)))) (setf (nth axis map) (with-collection (do* ((limit (dimension array axis)) (i (1- limit) (1- i))) ((< i 0)) (collect i)))) map)))))

(defun array-rotate (scalar array &optional (axis (1- (rank array))) result) (if (not (integerp scalar)) (error "Not an integer: ~S" scalar)) (let ((dims (dimensions array))) (array-blt array (test-result result dims (element-type array)) :destination-iterator (make-iterator array :level-map (let ((dim (dimension array axis)) (map (make-list (rank array)))) (setf (nth axis map) (with-collection (let ((i (if (> scalar 0) scalar (+ dim scalar)))) (dotimes (j dim) (collect i) (if (eq (incf i) dim) (setq i 0)))))) map)))))

(defun transpose (array &optional permutation result) (il:* il:|;;;| "Implements the so called Generic transpose") (if (and permutation (not (and (eq (rank permutation) 1) (eq (total-size permutation) (rank array))))) (error "Permutation of incorrect form: ~S" permutation)) (let ((permlst (if (null permutation) (with-collection (do ((i (1- (rank array)) (1- i))) ((< i 0)) (collect i))) (as-list permutation)))) (array-blt array (test-result result (permute-list (dimensions array) permlst) (element-type array)) :destination-iterator (make-iterator array :dimension-map permlst))))

(defun take (take-vector array &optional result) (let ((rank (rank array)) (dims (dimensions array))) (if (scalarp take-vector) (setq take-vector (reshape rank take-vector))) (if (not (and (eq (rank take-vector) 1) (eq (total-size take-vector) rank))) (error "Take-vector of incorrect form: ~s" take-vector)) (setq result (test-result result (map (quote list) (quote abs) take-vector) (element-type array))) (array-blt array result :source-iterator (make-iterator array :level-map (with-collection (dotimes (i rank) (collect (let ((v (aref take-vector i)) (dim (dimension array i))) (cond ((> v 0) (with-collection (dotimes (j (min dim v)) (collect j)))) ((< v 0) (with-collection (do ((j (max 0 (+ dim v)) (1+ j))) ((eq j dim)) (collect j)))))))))) :destination-iterator (make-iterator result :level-map (with-collection (dotimes (i rank) (collect (make-index-range :low 0 :high (min (dimension array i) (abs (aref take-vector i)))))))))))

(defun drop (drop-vector array &optional result) (let ((rank (rank array)) (dims (dimensions array))) (if (scalarp drop-vector) (setq drop-vector (reshape rank drop-vector))) (if (not (and (eq (rank drop-vector) 1) (eq (total-size drop-vector) rank))) (error "Drop-vector of incorrect form: ~s" drop-vector)) (array-blt array (test-result result (map (quote list) (function (lambda (dim drop) (max 0 (- dim (abs drop))))) dims drop-vector) (element-type array)) :source-iterator (make-iterator array :level-map (with-collection (dotimes (i rank) (collect (let ((dim (dimension array i)) (v (aref drop-vector i))) (cond ((> v 0) (with-collection (do ((j v (1+ j))) ((eq j dim)) (collect j)))) ((< v 0) (with-collection (dotimes (j (+ dim v)) (collect j)))))))))))))

(xcl:def-define-type earray-ops "Extended array operator")

(defvar *monadic-functions* (make-hash-table :test (quote eq)))

(defvar *dyadic-functions* (make-hash-table :test (quote eq)))

(xcl:defdefiner (define-monadic-op (:name (lambda (form) (list (second form) (quote monadic))))) earray-ops (op args &body body) (let ((fn-name (intern (concatenate (quote string) "MONADIC" "-" (string op)) (find-package "E-ARRAY")))) (il:bquote (progn (setf (symbol-function (quote (il:\\\, fn-name))) (function (lambda (il:\\\, args) (il:\\\,@ body)))) (setf (gethash (quote (il:\\\, op)) *monadic-functions*) (quote (il:\\\, fn-name)))))))

(xcl:defdefiner (define-dyadic-op (:name (lambda (form) (list (second form) (quote dyadic))))) earray-ops (op args &body body) (let ((fn-name (intern (concatenate (quote string) "DYADIC" "-" (string op)) (find-package "E-ARRAY")))) (il:bquote (progn (setf (symbol-function (quote (il:\\\, fn-name))) (function (lambda (il:\\\, args) (il:\\\,@ body)))) (setf (gethash (quote (il:\\\, op)) *dyadic-functions*) (quote (il:\\\, fn-name)))))))

(defmacro array-apply (&rest args) (let* ((fn (car args)) (rest (cdr args)) (end-array-position (or (position-if (function (lambda (arg) (memq arg (quote (:result-element-type :result))))) rest) (length rest))) (arrays (butlast rest (- (length rest) end-array-position))) (key-args (subseq rest end-array-position)) (result (cadr (memq :result key-args))) (result-element-type (cadr (memq :result-element-type key-args)))) (case (length arrays) (0 (warn "No array arguments to array-apply: ~s" (il:bquote (array-apply (il:\\\,@ args)))) nil) (1 (il:bquote (monadic-apply (il:\\\, fn) (il:\\\, (car arrays)) (il:\\\,@ (if (or result result-element-type) (il:bquote ((il:\\\, result))))) (il:\\\,@ (if result-element-type (il:bquote ((il:\\\, result-element-type)))))))) (2 (il:bquote (dyadic-apply (il:\\\, fn) (il:\\\, (car arrays)) (il:\\\, (cadr arrays)) (il:\\\,@ (if (or result result-element-type) (il:bquote ((il:\\\, result))))) (il:\\\,@ (if result-element-type (il:bquote ((il:\\\, result-element-type)))))))) (otherwise (il:bquote (nadic-apply (il:\\\, fn) (list (il:\\\,@ arrays)) (il:\\\,@ (if (or result result-element-type) (il:bquote ((il:\\\, result))))) (il:\\\,@ (if result-element-type (il:bquote ((il:\\\, result-element-type)))))))))))

(defun monadic-apply (fn array &optional result result-element-type) (setq result (test-result result (dimensions array) result-element-type)) (let ((monadic-fn (gethash fn *monadic-functions*))) (if monadic-fn (funcall monadic-fn fn array result) (generic-monadic-apply fn array result))))

(defun dyadic-apply (fn array1 array2 &optional result result-element-type) (if (not (conformable-p array1 array2)) (error "Args not conformable")) (setq result (test-result result (or (dimensions array1) (dimensions array2)) result-element-type)) (let ((dyadic-fn (gethash fn *dyadic-functions*))) (if dyadic-fn (funcall dyadic-fn array1 array2 result) (generic-dyadic-apply fn array1 array2 result))))

(defun nadic-apply (op array-lst &optional result result-element-type) (if (let ((last nil)) (dolist (a array-lst) (when (arrayp a) (if (not (conformable-p last a)) (return t)) (setq last a)))) (error "Args not conformable")) (setq result (test-result result (let ((last nil)) (dolist (a array-lst) (if (arrayp a) (setq last a))) (array-dimensions last)) result-element-type)) (if (some (function arrayp) array-lst) (let* ((limit (dolist (a array-lst) (if (arrayp a) (return (array-total-size a))))) (linearized-arrays (mapcar (function (lambda (x) (linearize x))) array-lst)) (linearize-result (linearize result)) (args (copy-list linearized-arrays))) (dotimes (i limit) (do ((l-arrays linearized-arrays (cdr l-arrays)) (elts args (cdr elts))) ((null l-arrays)) (if (arrayp (car l-arrays)) (rplaca elts (aref (car l-arrays) i)))) (setf (aref linearize-result i) (apply op args))) result) (apply op array-lst)))

(defun generic-monadic-apply (op array result) (if (scalarp array) (funcall op array) (let ((linearized-array (linearize array)) (linearized-result (linearize result))) (dotimes (i (array-total-size result)) (setf (aref linearized-result i) (funcall op (aref linearized-array i)))) result)))

(defun generic-dyadic-apply (op array1 array2 result) (let ((linearized-array1 (linearize array1)) (linearized-array2 (linearize array2)) (linearized-result (linearize result))) (if (scalarp array1) (if (scalarp array2) (setq result (funcall op array1 array2)) (dotimes (i (array-total-size result)) (setf (aref linearized-result i) (funcall op array1 (aref linearized-array2 i))))) (if (scalarp array2) (dotimes (i (array-total-size result)) (setf (aref linearized-result i) (funcall op (aref linearized-array1 i) array2))) (dotimes (i (array-total-size result)) (setf (aref linearized-result i) (funcall op (aref linearized-array1 i) (aref linearized-array2 i)))))) result))

(defvar *reduction-functions* (make-hash-table :test (quote eq)))

(xcl:defdefiner (define-reduction-op (:name (lambda (form) (list (second form) (quote reduction))))) earray-ops (op args &body body) (let ((fn-name (intern (concatenate (quote string) "REDUCTION" "-" (string op)) (find-package "E-ARRAY")))) (il:bquote (progn (setf (symbol-function (quote (il:\\\, fn-name))) (function (lambda (il:\\\, args) (il:\\\,@ body)))) (setf (gethash (quote (il:\\\, op)) *reduction-functions*) (quote (il:\\\, fn-name)))))))

(defun array-reduce (fn array &optional (axis (1- (rank array))) result (result-element-type (element-type array))) (if (not (and (integerp axis) (< -1 axis (rank array)))) (error "Incorrect Axis specifier: ~s" axis)) (let ((reduction-fn (gethash fn *reduction-functions*))) (if (eq 1 (rank array)) (if (null reduction-fn) (generic-vector-reduce fn array) (funcall reduction-fn array)) (let ((meta-iterator (make-meta-iterator array axis)) (vector (make-array (dimension array axis) :element-type (element-type array))) linearized-result) (setq result (test-result result (remove-nth axis (dimensions array)) result-element-type)) (setq linearized-result (linearize result)) (dotimes (i (total-size result)) (array-blt array vector :source-iterator (next-iterator meta-iterator)) (setf (aref linearized-result i) (if (null reduction-fn) (generic-vector-reduce fn vector) (funcall reduction-fn vector)))) result))))

(defun generic-vector-reduce (fn vector) (let ((size (total-size vector))) (if (> size 0) (do ((result (aref vector 0)) (i 1 (1+ i))) ((eq i size) result) (setq result (funcall fn result (aref vector i)))))))

(defvar *scan-functions* (make-hash-table :test (quote eq)))

(xcl:defdefiner (define-scan-op (:name (lambda (form) (list (second form) (quote scan))))) earray-ops (op args &body body) (let ((fn-name (intern (concatenate (quote string) "SCAN" "-" (string op)) (find-package "E-ARRAY")))) (il:bquote (progn (setf (symbol-function (quote (il:\\\, fn-name))) (function (lambda (il:\\\, args) (il:\\\,@ body)))) (setf (gethash (quote (il:\\\, op)) *scan-functions*) (quote (il:\\\, fn-name)))))))

(defun array-scan (fn array &optional (axis (1- (rank array))) result (result-element-type (element-type array))) (if (not (and (integerp axis) (< -1 axis (rank array)))) (error "Incorrect Axis specifier: ~s" axis)) (setq result (test-result result (dimensions array) result-element-type)) (let ((scan-fn (gethash fn *scan-functions*))) (if (eq 1 (rank array)) (if (null scan-fn) (generic-vector-scan fn array result) (funcall scan-fn array result)) (let ((meta-iterator (make-meta-iterator array axis)) (source (make-array (dimension array axis) :element-type (element-type array))) (sink (make-array (dimension array axis) :element-type (element-type array))) iterator) (loop (if (null (setq iterator (next-iterator meta-iterator))) (return result)) (array-blt array source :source-iterator iterator) (if (null scan-fn) (generic-vector-scan fn source sink) (funcall scan-fn source sink)) (array-blt sink result :destination-iterator (reset-iterator iterator)))))))

(defun generic-vector-scan (fn source sink) (let ((size (total-size source))) (when (> size 0) (setf (aref sink 0) (aref source 0)) (do ((result (aref source 0)) (i 1 (1+ i))) ((eq i size) sink) (setq result (funcall fn result (aref source i))) (setf (aref sink i) result)))))

(defun array-sweep (fn array sweeper &optional (axis (1- (rank array))) result (result-element-type (element-type array))) (if (not (and (integerp axis) (< -1 axis (rank array)))) (error "Incorrect Axis specifier: ~s" axis)) (setq result (test-result result (dimensions array) result-element-type)) (if (or (scalarp array) (scalarp sweeper)) (dyadic-apply fn array sweeper result result-element-type) (let ((linearized-sweeper (linearize sweeper)) (meta-iterator (make-meta-iterator array axis)) (temp (make-array (dimension array axis) :element-type (element-type array))) iterator) (dotimes (i (total-size sweeper)) (setq iterator (next-iterator meta-iterator)) (array-blt array temp :source-iterator iterator) (dyadic-apply fn temp (aref linearized-sweeper i) temp nil) (array-blt temp result :destination-iterator (reset-iterator iterator))) result)))

(defun inner-product (fn1 fn2 array1 array2 &optional result (result-element-type t) (itermediate-result-type t)) (let* ((dims1 (dimensions array1)) (dims2 (dimensions array2)) (result-dims (append (ldiff dims1 (last dims1)) (cdr dims2)))) (if (not (or (null dims1) (null dims2) (eq (car (last dims1)) (car dims2)))) (error "Arrays not conformable")) (setq result (test-result result result-dims result-element-type)) (if (scalarp result) (array-reduce fn1 (dyadic-apply fn2 array1 array2)) (let ((intermediate-result (make-array (if (scalarp array2) (car (last dims1)) (car dims2)) :element-type itermediate-result-type)) (linearized-result (linearize result))) (cond ((scalarp array1) (let ((meta-iterator (make-meta-iterator array2 0)) (temp-vector (make-array (car dims2) :element-type (element-type array2)))) (dotimes (i (array-total-size result)) (array-blt array2 temp-vector :source-iterator (next-iterator meta-iterator)) (setf (aref linearized-result i) (array-reduce fn1 (dyadic-apply fn2 array1 temp-vector intermediate-result)))))) ((scalarp array2) (let ((meta-iterator (make-meta-iterator array1 (1- (array-rank array1)))) (temp-vector (make-array (car (last dims1)) :element-type (element-type array1)))) (dotimes (i (array-total-size result)) (array-blt array1 temp-vector :source-iterator (next-iterator meta-iterator)) (setf (aref linearized-result i) (array-reduce fn1 (dyadic-apply fn2 temp-vector array2 intermediate-result)))))) (t (let ((meta-iterator1 (make-meta-iterator array1 (1- (array-rank array1)))) (meta-iterator2 (make-meta-iterator array2 0)) (temp-vector1 (make-array (car (last dims1)) :element-type (element-type array1))) (temp-vector2 (make-array (car dims2) :element-type (element-type array2))) (i 0) iterator1 iterator2) (loop (if (null (setq iterator1 (next-iterator meta-iterator1))) (return nil)) (array-blt array1 temp-vector1 :source-iterator iterator1) (loop (if (null (setq iterator2 (next-iterator meta-iterator2))) (return nil)) (array-blt array2 temp-vector2 :source-iterator iterator2) (setf (aref linearized-result i) (array-reduce fn1 (dyadic-apply fn2 temp-vector1 temp-vector2 intermediate-result))) (incf i)) (reset-meta-iterator meta-iterator2))))) result))))

(defun outer-product (fn array1 array2 &optional result result-element-type) (let ((resultdims (append (dimensions array1) (dimensions array2)))) (setq result (test-result result resultdims result-element-type)) (if (or (scalarp array1) (scalarp array2)) (dyadic-apply fn array1 array2 result) (let ((linearized-array1 (linearize array1)) (result-meta-iterator (make-meta-iterator result (rank array1) t)) (temp-array (make-array (dimensions array2) :element-type (element-type result)))) (dotimes (i (array-total-size array1)) (dyadic-apply fn (aref linearized-array1 i) array2 temp-array) (array-blt temp-array result :destination-iterator (next-iterator result-meta-iterator))) result))))

(xcl:define-file-environment "E-ARRAY-FNS" :readtable "XCL" :package "E-ARRAY" :compiler :compile-file)
(il:putprops il:e-array-fns il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop