From 2b1d2d99a8d4807d8224d0ac2356659ed23c0f5f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 27 May 2024 23:01:34 +0900 Subject: [PATCH] Fix array-append for non-zero based intervals. Closes #972. --- lib/srfi/231/base.scm | 38 ++++++++++---------- lib/srfi/231/test.sld | 22 +++++++++++- lib/srfi/231/transforms.scm | 70 ++++++++++++++++++++----------------- 3 files changed, 78 insertions(+), 52 deletions(-) diff --git a/lib/srfi/231/base.scm b/lib/srfi/231/base.scm index 7c302e5d..27b3a755 100644 --- a/lib/srfi/231/base.scm +++ b/lib/srfi/231/base.scm @@ -162,25 +162,25 @@ (values ivc (vector-ref ivc 0))))) (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 (f i)))) - ((>= i end) acc)))) - ((2) - (let ((end0 (interval-upper-bound iv 0)) - (start1 (interval-lower-bound iv 1)) - (end1 (interval-upper-bound iv 1))) - (do ((i (interval-lower-bound iv 0) (+ i 1)) - (acc knil - (do ((j start1 (+ j 1)) - (acc acc (kons acc (f i j)))) - ((>= j end1) acc)))) - ((>= i end0) acc)))) - (else - (if (interval-empty? iv) - knil + (if (interval-empty? iv) + knil + (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 (f i)))) + ((>= i end) acc)))) + ((2) + (let ((end0 (interval-upper-bound iv 0)) + (start1 (interval-lower-bound iv 1)) + (end1 (interval-upper-bound iv 1))) + (do ((i (interval-lower-bound iv 0) (+ i 1)) + (acc knil + (do ((j start1 (+ j 1)) + (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 (kons acc (apply f (interval-cursor-get ivc))))) diff --git a/lib/srfi/231/test.sld b/lib/srfi/231/test.sld index bd5b30f6..d0a62d00 100644 --- a/lib/srfi/231/test.sld +++ b/lib/srfi/231/test.sld @@ -3255,7 +3255,7 @@ (make-array (make-interval '#(2 3)) list))) ) - (test-group "stack/block" + (test-group "stack/block/append" (let* ((a (make-array (make-interval '#(4 10)) list)) (a-column @@ -3315,6 +3315,26 @@ (list (list*->array 2 '((12 13))) (list*->array 2 '((14))) (list*->array 2 '((15 16 17))))))))) + (test-assert + (array-append + 1 + (list + (list->array + (make-interval (quote #(1 -9 -1 3)) + (quote #(5 -8 5 8))) + '(0 4 9 1 7 4 5 9 5 2 2 2 2 5 7 1 5 2 1 1 5 4 6 1 1 2 5 2 5 3 5 7 1 6 9 5 4 4 6 2 2 8 4 6 5 4 2 5 9 7 1 8 4 0 6 9 8 7 9 8 0 9 4 0 0 4 4 5 8 3 7 8 0 4 4 7 1 1 1 1 2 9 1 5 7 0 5 0 4 4 5 0 3 7 1 2 9 5 7 7 6 0 2 5 4 9 0 6 1 2 2 4 4 6 4 3 0 1 8 6)) + (list->array + (make-interval (quote #(1 -8 -1 3)) + (quote #(5 -6 5 8))) + '(3 1 9 0 4 3 7 4 6 2 9 9 4 7 2 4 4 4 7 4 6 9 5 3 4 3 6 8 1 4 2 3 0 6 5 9 1 4 0 9 7 9 0 5 7 5 4 1 0 6 4 6 5 1 4 4 6 2 3 3 3 5 0 5 8 3 8 1 3 1 2 6 5 5 2 6 5 3 3 3 4 5 9 7 9 7 4 1 9 8 7 8 4 9 5 3 0 0 1 9 8 9 8 4 7 3 9 3 5 0 9 7 4 6 8 4 3 0 7 7 7 0 9 7 3 2 7 6 9 2 0 1 0 1 1 9 7 7 1 9 7 0 9 9 0 0 7 6 5 2 9 2 9 4 9 3 7 6 1 8 9 4 4 4 5 7 2 4 6 0 3 0 7 4 3 6 3 0 3 2 2 4 4 0 1 9 3 9 8 5 7 3 9 8 9 2 4 1 8 4 4 5 6 9 3 7 2 8 2 9 0 4 6 6 7 4 2 2 3 1 7 0 8 4 8 7 6 4 3 9 2 7 1 1 9 0 1 8 3 1)) + (list->array + (make-interval (quote #(1 -6 -1 3)) + (quote #(5 -6 5 8))) + '()) + (list->array + (make-interval (quote #(1 -6 -1 3)) + (quote #(5 -5 5 8))) + '(3 1 6 2 8 0 8 1 2 6 7 2 9 4 6 5 2 4 5 4 5 2 6 6 0 6 4 2 1 3 4 6 9 6 7 2 4 8 4 3 5 5 8 0 6 4 6 3 7 6 3 4 1 6 2 3 1 9 1 0 3 1 5 0 3 5 8 1 8 0 2 3 1 5 0 4 9 5 3 2 0 7 6 5 5 9 4 8 5 3 2 5 1 4 8 4 5 7 4 6 1 5 8 2 0 1 5 0 8 3 0 4 6 1 7 1 7 1 6 9))))) ) '(test-group "assign/product" diff --git a/lib/srfi/231/transforms.scm b/lib/srfi/231/transforms.scm index 20d8c688..2e5c304c 100644 --- a/lib/srfi/231/transforms.scm +++ b/lib/srfi/231/transforms.scm @@ -452,20 +452,22 @@ (apply list->array domain (vector->list vec) o)) (define (array-assign! destination source) - (assert (and (mutable-array? destination) (array? source) - (interval= (array-domain destination) (array-domain source)))) - (let ((getter (array-getter source)) - (setter (array-setter destination))) - (interval-for-each - (case (array-dimension destination) - ((1) (lambda (i) (setter (getter i) i))) - ((2) (lambda (i j) (setter (getter i j) i j))) - ((3) (lambda (i j k) (setter (getter i j k) i j k))) - (else - (lambda multi-index - (apply setter (apply getter multi-index) multi-index)))) - (array-domain source)) - destination)) + (let ((dest-domain (array-domain destination)) + (source-domain (array-domain source))) + (assert (and (mutable-array? destination) (array? source) + (interval= dest-domain source-domain))) + (let ((getter (array-getter source)) + (setter (array-setter destination))) + (interval-for-each + (case (array-dimension destination) + ((1) (lambda (i) (setter (getter i) i))) + ((2) (lambda (i j) (setter (getter i j) i j))) + ((3) (lambda (i j k) (setter (getter i j k) i j k))) + (else + (lambda multi-index + (apply setter (apply getter multi-index) multi-index)))) + (array-domain source)) + destination))) (define (reshape-without-copy array new-domain) (let* ((domain (array-domain array)) @@ -612,7 +614,8 @@ (pair? arrays) (every array? arrays) (< -1 axis (array-dimension (car arrays))))) - (let* ((a (car arrays)) + (let* ((arrays (remove array-empty? arrays)) + (a (car arrays)) (a-domain (array-domain a)) (storage (if (pair? o) (car o) generic-storage-class)) (mutable? (if (and (pair? o) (pair? (cdr o))) @@ -634,29 +637,32 @@ (vector-ref c-hi axis) (cdr arrays))) (let* ((c-domain (make-interval c-lo c-hi)) - (c (make-specialized-array/default c-domain storage safe?)) - (b-trans (make-vector (array-dimension a) 0))) + (c (make-specialized-array/default c-domain storage safe?))) (array-assign! (array-extract c (make-interval c-lo (interval-widths a-domain))) (array-translate a (vector-map - a-lo))) (let lp ((arrays (cdr arrays)) (b-offset (- (interval-upper-bound a-domain axis) (interval-lower-bound a-domain axis)))) - (if (null? arrays) - (if mutable? c (array-freeze! c)) - (let* ((b (car arrays)) - (b-domain (array-domain b)) - (b-offset2 (+ b-offset (interval-width b-domain axis))) - (b-lo (make-vector (interval-dimension b-domain) 0)) - (b-hi (interval-widths b-domain))) - (vector-set! b-lo axis b-offset) - (vector-set! b-hi axis b-offset2) - (vector-set! b-trans axis (- b-offset)) - (let ((view (array-translate - (array-extract c (make-interval b-lo b-hi)) - b-trans))) - (array-assign! view b) - (lp (cdr arrays) b-offset2))))))))) + (cond + ((null? arrays) + (if mutable? c (array-freeze! c))) + (else + (let* ((b (car arrays)) + (b-domain (array-domain b)) + (b-offset2 (+ b-offset (interval-width b-domain axis))) + (b-lo (make-vector (interval-dimension b-domain) 0)) + (b-hi (interval-widths b-domain))) + (vector-set! b-lo axis b-offset) + (vector-set! b-hi axis b-offset2) + (let ((dest-view (array-extract c (make-interval b-lo b-hi))) + (b-trans + (vector-map - (interval-lower-bounds->vector b-domain)))) + (vector-set! b-trans axis (+ (vector-ref b-trans axis) + b-offset)) + (array-assign! dest-view (array-translate b b-trans)) + (lp (cdr arrays) b-offset2)) + )))))))) (define array-append! array-append)