(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "E-ARRAY")
(il:filecreated "25-Nov-88 18:30:38" il:{qv}<idl>next>e-array-iterators.\;7 14522
il:|changes| il:|to:| (il:functions make-iterator handle-general-case handle-range-case) (il:structures index-range)
(il:vars il:e-array-iteratorscoms)
il:|previous| il:|date:| "15-Nov-88 18:47:11" il:{qv}<idl>next>e-array-iterators.\;6)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:e-array-iteratorscoms)
(il:rpaqq il:e-array-iteratorscoms ((il:structures iterator simple-iterator range-iterator general-iterator index-range) (il:functions construct-simple-iterator construct-range-iterator construct-general-iterator) (il:functions simple-next-fn simple-reset-fn range-next-fn range-reset-fn general-next-fn general-reset-fn) (il:functions make-iterator next-index reset-iterator) (il:functions handle-range-case handle-general-case) (il:functions remove-nth permute-sequence) (il:structures meta-iterator) (il:functions make-meta-iterator next-iterator reset-meta-iterator) (xcl:file-environments "E-ARRAY-ITERATORS")))
(defstruct (iterator (:constructor nil)) next-fn reset-fn)
(defstruct (simple-iterator (:include iterator (next-fn (quote simple-next-fn)) (reset-fn (quote simple-reset-fn))) (:fast-accessors t)) (start nil) (end nil) (inc nil) (current nil))
(defstruct (range-iterator (:include iterator (next-fn (quote range-next-fn)) (reset-fn (quote range-reset-fn))) (:fast-accessors t)) (upper nil) (il:* il:\; "Upper Index bounds") (lower nil) (il:* il:\; "Lower index bounds") (multipliers nil) (indices nil) (il:* il:\; "Current indices") (offset nil) (constant nil) (end-iteration nil))
(defstruct (general-iterator (:include iterator (next-fn (quote general-next-fn)) (reset-fn (quote general-reset-fn))) (:fast-accessors t)) (head-indices nil) (multipliers nil) (indices nil) (il:* il:\; "Current indices") (offset nil) (constant nil) (end-iteration nil))
(defstruct index-range low high)
(defun construct-simple-iterator (start end inc &optional old-iterator) (if (not (typep old-iterator (quote simple-iterator))) (make-simple-iterator :start start :end end :inc inc) (progn (setf (simple-iterator-start old-iterator) start) (setf (simple-iterator-end old-iterator) end) (setf (simple-iterator-inc old-iterator) inc) old-iterator)))
(defun construct-range-iterator (upper lower multipliers indices constant &optional old-iterator) (if (not (typep old-iterator (quote range-iterator))) (make-range-iterator :upper upper :lower lower :multipliers multipliers :indices indices :constant constant) (progn (setf (range-iterator-upper old-iterator) upper) (setf (range-iterator-lower old-iterator) lower) (setf (range-iterator-multipliers old-iterator) multipliers) (setf (range-iterator-indices old-iterator) indices) (setf (range-iterator-constant old-iterator) constant) old-iterator)))
(defun construct-general-iterator (head-indices multipliers indices constant &optional old-iterator) (if (not (typep old-iterator (quote general-iterator))) (make-general-iterator :head-indices head-indices :multipliers multipliers :indices indices :constant constant) (progn (setf (general-iterator-head-indices old-iterator) head-indices) (setf (general-iterator-multipliers old-iterator) multipliers) (setf (general-iterator-indices old-iterator) indices) (setf (general-iterator-constant old-iterator) constant) old-iterator)))
(defun simple-next-fn (iterator) (let ((current (simple-iterator-current iterator)) (end (simple-iterator-end iterator)) (inc (simple-iterator-inc iterator))) (when (< current end) (setf (simple-iterator-current iterator) (+ current inc)) current)))
(defun simple-reset-fn (iterator) (setf (simple-iterator-current iterator) (simple-iterator-start iterator)) iterator)
(defun range-next-fn (iterator) (il:* il:|;;| "For the range limited case (no skips or repetitions, etc.) ") (let ((end-iteration (range-iterator-end-iteration iterator)) (upper (range-iterator-upper iterator)) (lower (range-iterator-lower iterator)) (multipliers (range-iterator-multipliers iterator)) (indices (range-iterator-indices iterator)) (offset (range-iterator-offset iterator)) (level 0) rank) (when (not end-iteration) (setq rank (length upper)) (loop (if (< (incf (aref indices level)) (aref upper level)) (return nil)) (setf (aref indices level) (aref lower level)) (incf level) (when (eq level rank) (setf (range-iterator-end-iteration iterator) t) (return nil))) (if (> level 0) (setf (range-iterator-offset iterator) (+ (range-iterator-constant iterator) (do ((sum 0) (i 0 (1+ i))) ((eq i rank) sum) (incf sum (* (aref indices i) (aref multipliers i)))))) (setf (range-iterator-offset iterator) (+ offset (aref multipliers 0)))) offset)))
(defun range-reset-fn (iterator) (il:* il:|;;| "For the simple range limited case (no skips or repetitions, etc.) ") (let ((lower (range-iterator-lower iterator)) (multipliers (range-iterator-multipliers iterator)) (indices (range-iterator-indices iterator))) (replace indices lower) (setf (range-iterator-offset iterator) (+ (range-iterator-constant iterator) (do ((rank (array-total-size lower)) (sum 0) (i 0 (1+ i))) ((eq i rank) sum) (incf sum (* (aref indices i) (aref multipliers i)))))) (setf (range-iterator-end-iteration iterator) nil) iterator))
(defun general-next-fn (iterator) (il:* il:|;;| "For the range limited case (no skips or repetitions, etc.) ") (let ((end-iteration (general-iterator-end-iteration iterator)) (head-indices (general-iterator-head-indices iterator)) (multipliers (general-iterator-multipliers iterator)) (indices (general-iterator-indices iterator)) (offset (general-iterator-offset iterator)) (level 0) zero-index rank) (when (not end-iteration) (setq rank (length head-indices)) (setq zero-index (aref indices 0)) (loop (if (setf (aref indices level) (cdr (aref indices level))) (return nil)) (setf (aref indices level) (aref head-indices level)) (incf level) (when (eq level rank) (setf (general-iterator-end-iteration iterator) t) (return nil))) (if (> level 0) (setf (general-iterator-offset iterator) (+ (general-iterator-constant iterator) (do ((i 1 (1+ i)) (sum 0)) ((eq i rank) sum) (incf sum (* (car (aref indices i)) (aref multipliers i))))))) (+ offset (* (aref multipliers 0) (car zero-index))))))
(defun general-reset-fn (iterator) (il:* il:|;;| "For the simple range limited case (no skips or repetitions, etc.) ") (let ((head-indices (general-iterator-head-indices iterator)) (multipliers (general-iterator-multipliers iterator)) (indices (general-iterator-indices iterator))) (replace indices head-indices) (setf (general-iterator-offset iterator) (+ (general-iterator-constant iterator) (do ((i 1 (1+ i)) (end (array-total-size head-indices)) (sum 0)) ((eq i end) sum) (incf sum (* (car (aref indices i)) (aref multipliers i)))))) (setf (general-iterator-end-iteration iterator) nil) iterator))
(defun make-iterator (array &key dimension level level-map dimension-map old-iterator) (il:* il:|;;| "DIMENSION and LEVEL must be integers") (il:* il:|;;| "LEVEL-MAP must be a sequence of sequences of index objects") (il:* il:|;;| "DIMENSION-MAP must be a sequence of index objects") (if (scalarp array) (error "Not an array: ~s" array)) (if level-map (setq level-map (coerce level-map (quote list)))) (if dimension-map (setq dimension-map (coerce dimension-map (quote list)))) (let ((rank (array-rank array)) (dims (array-dimensions array))) (reset-iterator (cond ((and (not level-map) (not dimension-map) (or (and (not dimension) (not level)) (eq dimension (1- rank)))) (il:* il:|;;| "Simplest case ") (let ((inc (if dimension (array-dimension array dimension) 1)) (offset (if dimension level 0))) (construct-simple-iterator offset (array-total-size array) inc old-iterator))) ((or (and dimension level) dimension-map) (il:* il:|;;| "Simple deflation -- and simple transposition") (let ((scan-dims (scan-dims array)) upper size multipliers constant) (if dimension (il:* il:|;;| "Dimension, level pair") (setq upper (remove-nth dimension dims) size (1- rank) multipliers (remove-nth dimension scan-dims) constant (* level (nth dimension scan-dims))) (il:* il:|;;| "dimension-map") (setq upper (permute-list dims dimension-map) size rank multipliers (permute-list scan-dims dimension-map) constant 0)) (construct-range-iterator (apply (quote vector) (nreverse upper)) (make-array size :initial-element 0) (apply (quote vector) (nreverse multipliers)) (make-array size :initial-element 0) constant old-iterator))) ((and (not dimension) (not level) (not dimension-map)) (il:* il:|;;| "LEVEL-MAP has as many elements as array has dimensions. Each element is either an integer (deflation), nil (all levels), a list of indices, or a list of two elements indicating a range.") (if (not (eq (length level-map) rank)) (error "Malformed level-map: ~s" level-map)) (let ((iterator-rank 0) (general-p nil) (deflation 0)) (dolist (lm level-map) (if (integerp lm) (incf deflation) (progn (incf iterator-rank) (if (typep lm (quote sequence)) (setq general-p t))))) (if (eq deflation rank) (il:* il:|;;| "Effectively a scalar ") (let ((index (let ((sum 0)) (mapc (function (lambda (level mult) (incf sum (* level mult)))) level-map (scan-dims array)) sum)) (size (array-total-size array))) (construct-simple-iterator index size size old-iterator)) (if general-p (handle-general-case array level-map iterator-rank old-iterator) (handle-range-case array level-map iterator-rank old-iterator))))) (t (error "Inconsistent keywords given to make-iterator"))))))
(defmacro next-index (iterator) (once-only (iterator) (il:bquote (funcall (iterator-next-fn (il:\\\, iterator)) (il:\\\, iterator)))))
(defmacro reset-iterator (iterator) (once-only (iterator) (il:bquote (funcall (iterator-reset-fn (il:\\\, iterator)) (il:\\\, iterator)))))
(defun handle-range-case (array level-map iterator-rank &optional old-iterator) (let ((scan-dims (scan-dims array)) (upper (make-vector iterator-rank)) (lower (make-vector iterator-rank)) (multipliers (make-vector iterator-rank)) (index (1- iterator-rank)) (constant 0)) (do* ((i 0 (1+ i)) (lm-tail level-map (cdr lm-tail)) (lm (car lm-tail) (car lm-tail)) (s-dim-tail scan-dims (cdr s-dim-tail)) (multiplier (car s-dim-tail) (car s-dim-tail))) ((null lm-tail)) (cond ((integerp lm) (setq constant (+ constant (* lm multiplier)))) ((or (null lm) (eq lm :all)) (setf (aref upper index) (array-dimension array i)) (setf (aref lower index) 0) (setf (aref multipliers index) multiplier) (decf index)) (t (il:* il:|;;| "Must be the range case") (let ((low (index-range-low lm)) (high (index-range-high lm))) (setf (aref upper index) high) (setf (aref lower index) low) (setf (aref multipliers index) multiplier) (decf index))))) (construct-range-iterator upper lower multipliers (make-vector iterator-rank) constant old-iterator)))
(defun handle-general-case (array level-map iterator-rank &optional old-iterator) (let ((scan-dims (scan-dims array)) (head-indices (make-vector iterator-rank)) (multipliers (make-vector iterator-rank)) (index (1- iterator-rank)) (constant 0)) (do* ((dim 0 (1+ dim)) (lm-tail level-map (cdr lm-tail)) (lm (car lm-tail) (car lm-tail)) (s-dim-tail scan-dims (cdr s-dim-tail)) (multiplier (car s-dim-tail) (car s-dim-tail))) ((null lm-tail)) (if (integerp lm) (setq constant (+ constant (* lm multiplier))) (progn (setf (aref head-indices index) (cond ((or (null lm) (eq lm :all)) (with-collection (dotimes (i (array-dimension array dim)) (collect i)))) ((index-range-p lm) (il:* il:|;;| " the range case") (with-collection (do ((i (index-range-low lm) (1+ i)) (high (index-range-high lm))) ((eq i high)) (collect i)))) (t (il:* il:|;;| "Indices specified in a sequence ") (coerce lm (quote list))))) (setf (aref multipliers index) multiplier) (decf index)))) (construct-general-iterator head-indices multipliers (make-vector iterator-rank) constant old-iterator)))
(defun remove-nth (n list) (with-collection (let ((tail list)) (dotimes (i (length list)) (if (not (eq i n)) (collect (car tail))) (setq tail (cdr tail))))))
(defun permute-sequence (type seq permutation) (let* ((length (length seq)) (result (make-sequence type length))) (if (not (eq length (length permutation))) (error "List and permutation not of equal length")) (dotimes (i length) (setf (elt result (elt permutation i)) (elt seq i))) result))
(defstruct (meta-iterator (:constructor %make-meta-iterator)) size multiplier range-iterator simple-iterator)
(defun make-meta-iterator (array axis &optional last-dimension-p) (if (not (arrayp array)) (error "Not an array: ~s" array)) (if (not (and (integerp axis) (< -1 axis (rank array)))) (error "Axis out of bounds: ~s" axis)) (let* ((rank (rank array)) (dimensions (dimensions array)) (upper (fill (as-vector dimensions t) 0 :start axis :end (if last-dimension-p rank (1+ axis)))) (multipliers (as-vector (scan-dims array) t)) (increment (if last-dimension-p 1 (aref multipliers axis))) (size (if last-dimension-p (reduce (function *) dimensions :start axis :initial-value 1) (dimension array axis))) (range-iterator (make-range-iterator :upper (nreverse upper) :lower (make-vector rank :initial-element 0) :multipliers (nreverse multipliers) :indices (make-vector rank :initial-element 0) :offset 0 :constant 0 :end-iteration (every (function (lambda (elt) (eq elt 0))) upper))) (simple-iterator (make-simple-iterator :inc increment))) (%make-meta-iterator :size size :multiplier increment :range-iterator range-iterator :simple-iterator simple-iterator)))
(defun next-iterator (meta-iterator) (il:* il:|;;| "For the range limited case (no skips or repetitions, etc.) ") (let* ((multiplier (meta-iterator-multiplier meta-iterator)) (size (meta-iterator-size meta-iterator)) (range-iterator (meta-iterator-range-iterator meta-iterator)) (simple-iterator (meta-iterator-simple-iterator meta-iterator)) (constant (next-index range-iterator))) (when constant (setf (simple-iterator-start simple-iterator) constant) (setf (simple-iterator-end simple-iterator) (+ constant (* size multiplier))) (setf (simple-iterator-current simple-iterator) constant) simple-iterator)))
(defun reset-meta-iterator (meta-iterator) (reset-iterator (meta-iterator-range-iterator meta-iterator)) meta-iterator)
(xcl:define-file-environment "E-ARRAY-ITERATORS" :readtable "XCL" :package "E-ARRAY" :compiler :compile-file)
(il:putprops il:e-array-iterators il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop