;;; Copyright (c) 2023 Jeremy Steward ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions are met: ;;; ;;; 1. Redistributions of source code must retain the above copyright notice, ;;; this list of conditions and the following disclaimer. ;;; ;;; 2. Redistributions in binary form must reproduce the above copyright notice, ;;; this list of conditions and the following disclaimer in the documentation ;;; and/or other materials provided with the distribution. ;;; ;;; 3. Neither the name of the copyright holder nor the names of its ;;; contributors may be used to endorse or promote products derived from this ;;; software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;;; CONSEQUENTIAL DAMAGES INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;;; POSSIBILITY OF SUCH DAMAGE. ;; A procecdure which takes an array as an argument as well as an optional ;; start and end index, and makes a full copy of that array data using the same ;; storage-class as the original array. (define array-copy (case-lambda-checked ((array) (let* ((interval (array-interval array)) (start (interval-start interval)) (end (interval-end interval))) (array-copy array start end))) ((array start) (let* ((interval (array-interval array)) (end (interval-end interval))) (array-copy array start end))) (((array array?) (start vector?) (end vector?)) (let* ((storage-class (array-storage-class array)) (rank (vector-length end)) (dim (transduce fixnum-range-fold (map (lambda (i) (fx- (vector-ref end i) (vector-ref start i)))) (collect-vector rank) (range 0 rank)))) (transduce array-fold values (collect-array storage-class dim) (array-slice array start end)))))) ;; Copies the data from `from` into `to` starting at index `at`. If `start` and ;; `end` are provided, these indices demarcate the beginning and end of the ;; interval in `from` over which to copy. ;; ;; It is an error if there is a dimension mismatch in the interval described by ;; `[start end)` and the interval in which to copy the data into `to`. ;; ;; It is also an error if the arrays are not both of the same rank. (define array-copy! (case-lambda-checked ((to at from) (let* ((interval (array-interval from)) (start (interval-start interval)) (end (interval-end interval))) (array-copy! to at from start end))) ((to at from start) (let* ((interval (array-interval from)) (end (interval-end interval))) (array-copy! to at from start end))) (((to array?) (at vector?) (from array?) (start vector?) (end vector?)) (let ((to-rank (array-rank to)) (at-rank (vector-length at)) (from-rank (array-rank from)) (start-rank (vector-length start)) (end-rank (vector-length end))) (unless (= to-rank at-rank from-rank start-rank end-rank) (error 'array-copy! "Rank mismatch - expected all quantities to share the same rank." (cons 'to to-rank) (cons 'at at-rank) (cons 'from from-rank) (cons 'start start-rank) (cons 'end end-rank))) (let* ((rank to-rank) (to-shape (array-shape to)) (from-shape (array-shape from)) (to-interval (make-interval at (transduce fixnum-range-fold (map (lambda (i) (fx+ (vector-ref at i) (fx- (vector-ref end i) (vector-ref start i))))) (collect-vector rank) (range 0 rank)))) (expected-interval (make-interval start end))) (unless (and (>=? vector-index-comparator (interval-start to-interval) (interval-start to-shape)) (<=? vector-index-comparator (interval-end to-interval) (interval-end to-shape))) (error 'array-copy! "Dimension mismatch - expected end index is outside of bounds of to-array." to-interval to-shape)) (unless (and (>=? vector-index-comparator start (interval-start from-shape)) (<=? vector-index-comparator end (interval-end from-shape))) (error 'array-copy! "Dimension mismatch - start and end are not contained within from-shape." from-shape start end)) (let ((from-storage-ref (storage-class-ref (array-storage-class from))) (from-storage-object (array-storage-object from)) (from-stride (array-stride from)) (to-storage-set! (storage-class-set (array-storage-class to))) (to-storage-object (array-storage-object to)) (to-stride (array-stride to))) (for-each interval-fold (compose (zip-interval to-interval) (inspect (lambda (pair) (let ((from-idx (car pair)) (to-idx (cdr pair))) (to-storage-set! to-storage-object (index->offset to-idx to-stride rank) (from-storage-ref from-storage-object (index->offset from-idx from-stride rank))))))) expected-interval))))))) ;; Reshapes an array to the new bounds. It is an error if the new interval does ;; not have the same length as the existing interval. (define-checked (array-reshape (array array?) (dimension vector?)) (let* ((interval (array-interval array)) (array-length (interval-length interval)) (dimension-length (transduce vector-fold values (collect-product) dimension))) (if (fx=? array-length dimension-length) (transduce array-fold values (collect-array (array-storage-class array) dimension) array) (error 'array-reshape "Provided dimension has incompatible length with array." array-length dimension dimension-length)))) ;; Reclassifies the storage of an array by copying the data to a newly ;; constructed array with the provided `new-storage-class`. (define-checked (array-reclassify (array array?) (new-storage-class storage-class?)) (let* ((shape (array-shape array)) (dim (interval-end shape))) (transduce array-fold values (collect-array new-storage-class dim) array))) ;; Appends two arrays together along the provided axis. ;; ;; An error is signaled if the arrays have different ranks, if the provided ;; axis is less than zero or greater than the rank of the arrays, or if the ;; axes outside of `axis` are not equal. (define-checked (array-append (axis non-negative-fixnum?) (arr array?) (brr array?)) (let* ((a-shape (array-shape arr)) (a-end (interval-end a-shape)) (a-rank (vector-length a-end)) (b-shape (array-shape brr)) (b-end (interval-end b-shape)) (b-rank (vector-length b-end))) (unless (fx=? a-rank b-rank) (error 'array-append "Arrays are of different ranks." arr brr)) (unless (fx