Fix array-stack, interval folds and list*->array.

Issue #900.

lib/srfi/231.sld

@@ -17,6 +17,7 @@
    interval-upper-bounds->list interval-lower-bounds->vector
    interval-upper-bounds->vector interval= interval-volume
    interval-subset? interval-contains-multi-index? interval-projections
+   interval-fold-left interval-fold-right
    interval-for-each interval-dilate interval-intersect
    interval-translate interval-permute
    interval-scale interval-cartesian-product
@@ -49,5 +50,6 @@
    array->list* list*->array array->vector* vector*->array
    array-assign! array-ref array-set! array-decurry
    specialized-array-reshape
+   array-copy! array-stack! array-decurry! array-append! array-block!
    )
   (include "231/transforms.scm"))

lib/srfi/231/base.scm

@@ -133,12 +133,12 @@
                           (vector-ref ivc 3))
          (values ivc (vector-ref ivc 0)))))
 
-(define (interval-fold kons knil iv)
+(define (interval-fold-left f kons knil iv)
   (case (interval-dimension iv)
     ((1)
      (let ((end (interval-upper-bound iv 0)))
        (do ((i (interval-lower-bound iv 0) (+ i 1))
-            (acc knil (kons acc i)))
+            (acc knil (kons acc (f i))))
            ((>= i end) acc))))
     ((2)
      (let ((end0 (interval-upper-bound iv 0))
@@ -147,17 +147,28 @@
        (do ((i (interval-lower-bound iv 0) (+ i 1))
             (acc knil
                  (do ((j start1 (+ j 1))
-                      (acc acc (kons acc i j)))
+                      (acc acc (kons acc (f i j))))
                      ((>= j end1) acc))))
            ((>= i end0) acc))))
     (else
      (let ((ivc (interval-cursor iv)))
        (let lp ((acc knil))
-         (let ((acc (apply kons acc (interval-cursor-get ivc))))
+         (let ((acc (kons acc (apply f (interval-cursor-get ivc)))))
            (if (interval-cursor-next! ivc)
                (lp acc)
                acc)))))))
 
+(define (interval-fold kons knil iv)
+  (interval-fold-left list (lambda (acc idx) (apply kons acc idx)) knil iv))
+
+(define (interval-fold-right f kons knil iv)
+  (let ((ivc (interval-cursor iv)))
+    (let lp ()
+      (let ((item (apply f (interval-cursor-get ivc))))
+        (if (interval-cursor-next! ivc)
+            (kons item (lp))
+            (kons item knil))))))
+
 (define (interval-for-each f iv)
   (interval-fold (lambda (acc . multi-index) (apply f multi-index)) #f iv)
   (if #f #f))

lib/srfi/231/base.sld

@@ -16,6 +16,7 @@
    interval-upper-bounds->list interval-lower-bounds->vector
    interval-upper-bounds->vector interval= interval-volume
    interval-subset? interval-contains-multi-index? interval-projections
+   interval-fold-left interval-fold-right
    interval-for-each interval-dilate interval-intersect
    interval-translate interval-permute
    interval-scale interval-cartesian-product

lib/srfi/231/test.sld

@@ -1,35 +1,33 @@
-#|
+;; Adapted from original SRFI reference test suite:
-Adapted from original SRFI reference test suite:
 
-SRFI 179: Nonempty Intervals and Generalized Arrays (Updated)
+;; SRFI 179: Nonempty Intervals and Generalized Arrays (Updated)
 
-Copyright 2016, 2018, 2020 Bradley J Lucier.
+;; Copyright 2016, 2018, 2020 Bradley J Lucier.
-All Rights Reserved.
+;; All Rights Reserved.
 
-Permission is hereby granted, free of charge,
+;; Permission is hereby granted, free of charge,
-to any person obtaining a copy of this software
+;; to any person obtaining a copy of this software
-and associated documentation files (the "Software"),
+;; and associated documentation files (the "Software"),
-to deal in the Software without restriction,
+;; to deal in the Software without restriction,
-including without limitation the rights to use, copy,
+;; including without limitation the rights to use, copy,
-modify, merge, publish, distribute, sublicense,
+;; modify, merge, publish, distribute, sublicense,
-and/or sell copies of the Software, and to permit
+;; and/or sell copies of the Software, and to permit
-persons to whom the Software is furnished to do so,
+;; persons to whom the Software is furnished to do so,
-subject to the following conditions:
+;; subject to the following conditions:
 
-The above copyright notice and this permission notice
+;; The above copyright notice and this permission notice
-(including the next paragraph) shall be included in
+;; (including the next paragraph) shall be included in
-all copies or substantial portions of the Software.
+;; all copies or substantial portions of the Software.
 
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF
-ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
+;; ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
-LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+;; LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
-FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO
+;; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO
-EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
+;; EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
-FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
+;; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
-AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;; AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-OTHER DEALINGS IN THE SOFTWARE.
+;; OTHER DEALINGS IN THE SOFTWARE.
-|#
 
 ;;; A test program for SRFI 179:
 ;;; Nonempty Intervals and Generalized Arrays (Updated)
@@ -3052,6 +3050,40 @@ OTHER DEALINGS IN THE SOFTWARE.
                         (make-array (make-interval '#(2 3)) list)))
         )
 
+      (test-group "stack/block"
+        (let* ((a
+                (make-array (make-interval '#(4 10)) list))
+               (a-column
+                (array-getter ;; the getter of ...
+                 (array-curry ;; a 1-D array of the columns of A
+                  (array-permute a '#(1 0))
+                  1))))
+          (test '(((0 1)   (0 2)   (0 5)   (0 8))
+                  ((1 1)   (1 2)   (1 5)   (1 8))
+                  ((2 1)   (2 2)   (2 5)   (2 8))
+                  ((3 1)   (3 2)   (3 5)   (3 8)))
+              (array->list*
+               (array-stack ;; stack into a new 2-D array ...
+                1           ;; along axis 1 (i.e., columns) ...
+                (map a-column '(1 2 5 8)))) ;; the columns of A you want
+            ))
+        '(test '((0 1 4 6 7 8)
+                (2 3 5 9 10 11)
+                (12 13 14 15 16 17))
+            (array->list*
+             (array-block (list*->array
+                           2
+                           (list (list (list*->array 2 '((0 1)
+                                                         (2 3)))
+                                       (list*->array 2 '((4)
+                                                         (5)))
+                                       (list*->array 2 '((6 7 8)
+                                                         (9 10 11))))
+                                 (list (list*->array 2 '((12 13)))
+                                       (list*->array 2 '((14)))
+                                       (list*->array 2 '((15 16 17)))))))))
+        )
+
       (test-group "assign/product"
         (do ((d 1 (fx+ d 1)))
             ((= d 6))

lib/srfi/231/transforms.scm

@@ -102,6 +102,8 @@
           (%array-setter-set! res #f))
         res))))
 
+(define array-copy! array-copy)
+
 (define (array-curry array inner-dimension)
   (call-with-values
       (lambda () (interval-projections (array-domain array) inner-dimension))
@@ -492,14 +494,15 @@
       (append-map flatten ls)
       ls))
 
-(define (list*->array nested-ls . o)
+(define (list*->array dimension nested-ls . o)
-  (let lp ((ls nested-ls) (lens '()))
+  (let lp ((ls nested-ls) (lens '()) (d dimension))
     (cond
-     ((pair? ls) (lp (car ls) (cons (length ls) lens)))
+     ((positive? d)
+      (lp (car ls) (cons (length ls) lens) (- d 1)))
      (else
       (apply list->array
-             (flatten nested-ls)
              (make-interval (list->vector (reverse lens)))
+             (flatten nested-ls)
              o)))))
 
 (define (array->list* a)
@@ -543,14 +546,15 @@
       (append-map flatten-vec vec)
       (vector->list vec)))
 
-(define (vector*->array nested-vec . o)
+(define (vector*->array dimension nested-vec . o)
-  (let lp ((vec nested-vec) (lens '()))
+  (let lp ((vec nested-vec) (lens '()) (d dimension))
     (cond
-     ((vector? vec) (lp (vector-ref vec 0) (cons (vector-length vec) lens)))
+     ((positive? d)
+      (lp (vector-ref vec 0) (cons (vector-length vec) lens) (- d 1)))
      (else
       (apply list->array
-             (flatten-vec nested-vec)
              (make-interval (list->vector (reverse lens)))
+             (flatten-vec nested-vec)
              o)))))
 
 (define (dimensions-compatible? a-domain b-domain axis)
@@ -609,31 +613,46 @@
                   (array-assign! view b)
                   (lp (cdr arrays) b-offset2)))))))))
 
-(define (array-stack axis a . o)
+(define array-append! array-append)
+
+(define (array-stack axis arrays . o)
   (assert (and (exact-integer? axis)
-               (array? a)
+               (pair? arrays)
-               (< -1 axis (array-dimension a))
+               (every array? arrays)
-               (every array? o)
+               (<= 0 axis (array-dimension (car arrays)))))
-               (every (lambda (b) (interval= (array-domain a) (array-domain b))) o)))
+  (let ((a (car arrays))
-  (let* ((a-lbs (interval-lower-bounds->list (array-domain a)))
+        (storage (if (pair? o) (car o) generic-storage-class))
-         (a-ubs (interval-upper-bounds->list (array-domain a)))
+        (mutable? (if (and (pair? o) (pair? (cdr o)))
-         (domain
+                      (cadr o)
-          (make-interval
+                      (specialized-array-default-mutable?)))
-           `#(,@(take a-lbs axis) 0 ,@(drop a-lbs axis))
+        (safe? (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
-           `#(,@(take a-ubs axis) ,(+ 1 (length o)) ,@(drop a-ubs axis))))
+                   (car (cddr o))
-         (res (make-specialized-array domain
+                   (specialized-array-default-safe?))))
-                                      (or (array-storage-class a)
+    (assert (every (lambda (b)
-                                          generic-storage-class)))
+                     (interval= (array-domain a)
-         (perm `#(,axis ,@(delete axis (iota (+ 1 (array-dimension a))))))
+                                (array-domain b)))
-         (permed (if (zero? axis) res (array-permute res perm)))
+                   (cdr arrays)))
-         (curried (array-curry permed 1))
+    (let* ((a-lbs (interval-lower-bounds->list (array-domain a)))
-         (get-view (array-getter curried)))
+           (a-ubs (interval-upper-bounds->list (array-domain a)))
-    (let lp ((ls (cons a o)) (i 0))
+           (domain
-      (cond
+            (make-interval
-       ((null? ls) res)
+             `#(,@(take a-lbs axis) 0 ,@(drop a-lbs axis))
-       (else
+             `#(,@(take a-ubs axis) ,(length arrays) ,@(drop a-ubs axis))))
-        (array-assign! (get-view i) (car ls))
+           (res (make-specialized-array domain
-        (lp (cdr ls) (+ i 1)))))))
+                                        (or (array-storage-class a)
+                                            generic-storage-class)))
+           (perm `#(,axis ,@(delete axis (iota (+ 1 (array-dimension a))))))
+           (permed (if (zero? axis) res (array-permute res perm)))
+           (curried (array-curry permed 1))
+           (get-view (array-getter curried)))
+      (let lp ((ls arrays) (i 0))
+        (cond
+         ((null? ls) res)
+         (else
+          (array-assign! (get-view i) (car ls))
+          (lp (cdr ls) (+ i 1))))))))
+
+(define array-stack! array-stack)
 
 (define (array-block a . o)
   (let ((storage (if (pair? o) (car o) generic-storage-class))
@@ -656,6 +675,8 @@
         (error "TODO: array-block copy data unimplemented")
         res))))
 
+(define array-block! array-block)
+
 (define (array-decurry a . o)
   (let* ((storage (if (pair? o) (car o) generic-storage-class))
          (mutable? (if (and (pair? o) (pair? (cdr o)))
@@ -675,3 +696,5 @@
     ;; curried view from a to the res.
     (array-for-each array-assign! curried-res a)
     res))
+
+(define array-decurry! array-decurry)