Skip to content

Commit

Permalink
Fix array-append for non-zero based intervals.
Browse files Browse the repository at this point in the history 
Closes #972.
  • Loading branch information
@ashinn
ashinn committed May 27, 2024
1 parent a8939fe commit 2b1d2d9
Show file tree
Hide file tree
Showing 3 changed files with 78 additions and 52 deletions.
38 changes: 19 additions & 19 deletions lib/srfi/231/base.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))))
Expand Down
22 changes: 21 additions & 1 deletion lib/srfi/231/test.sld
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand Down
70 changes: 38 additions & 32 deletions lib/srfi/231/transforms.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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)))
Expand All @@ -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)

Expand Down

1 comment on commit 2b1d2d9

@gambiteer
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Now there's this failure:

(array-append
 0
 (list 
  (make-array (make-interval '#(0)) list)
  (make-array (make-interval '#(0)) list)))

Please sign in to comment.