Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fix reshape zero-dimensional and empty arrays.

Browse source 
Issue #986.
This commit is contained in:
Alex Shinn 2024-05-30 22:37:06 +09:00
parent 5e74c5ff54
commit 414a23139f
3 changed files with 65 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
lib/srfi/231/base.scm
View file

@ -447,27 +447,27 @@
;; possible multi-indices in domain in lexicographic order would
;; produce 0 through volume-1).
(define (invert-default-index domain raw-index)
(let lp ((index raw-index)
(i 0)
(scale (/ (interval-volume domain)
(max 1
(- (interval-upper-bound domain 0)
(interval-lower-bound domain 0)))))
(res '()))
(cond
((>= (+ i 1) (interval-dimension domain))
(reverse (cons (+ index (interval-lower-bound domain i)) res)))
(else
(let ((digit (quotient index scale)))
(lp (- index (* digit scale))
(+ i 1)
(/ scale
(max 1
(- (interval-upper-bound domain (+ i 1))
(interval-lower-bound domain (+ i 1)))))
(cons (+ digit
(interval-lower-bound domain i))
res)))))))
(cond
((or (zero? (interval-dimension domain)) (interval-empty? domain))
(interval-lower-bounds->list domain))
(else
(let lp ((index raw-index)
(i 0)
(scale (/ (interval-volume domain)
(max 1 (interval-width domain 0))))
(res '()))
(cond
((>= (+ i 1) (interval-dimension domain))
(reverse (cons (+ index (interval-lower-bound domain i)) res)))
(else
(let ((digit (quotient index scale)))
(lp (- index (* digit scale))
(+ i 1)
(/ scale
(max 1 (interval-width domain (+ i 1))))
(cons (+ digit
(interval-lower-bound domain i))
res)))))))))
;; Specialized arrays

20
lib/srfi/231/test.sld
View file

@ -3766,6 +3766,26 @@
'#(#f #f #t #t))
'#(1 1 2 1))
(make-interval '#(4))))
'(test #t
(specialized-array-reshape
(array-sample (array-copy (make-array (make-interval '#(3 4)) list))
'#(2 1))
(make-interval '#(8))
#t))
(test '(() ())
(array->list*
(specialized-array-reshape
(make-specialized-array (make-interval '#(1 2 0 4)))
(make-interval '#(2 0 4)))))
(test 'foo
(array->list*
(specialized-array-reshape ;; Reshape to a zero-dimensional array
(array-extract ;; Restrict to the first element
(make-specialized-array-from-data ;; One-dimensional array
(vector 'foo 'bar 'baz))
(make-interval '#(1)))
(make-interval '#()))))
)
(test-group "curry tests"

45
lib/srfi/231/transforms.scm
View file

@ -525,33 +525,36 @@
(apply tmp-indexer multi-index)))))
(new-coeffs (indexer->coeffs new-indexer new-domain #t))
(flat-indexer (coeffs->indexer new-coeffs new-domain))
(new-indexer (coeffs->indexer new-coeffs new-domain))
(body (array-body array))
(storage (array-storage-class array))
(res
(%make-specialized new-domain storage body new-coeffs flat-indexer
(array-safe? array) (array-setter array)
(array-adjacent? array))))
(let ((multi-index (interval-lower-bounds->list domain))
(orig-default-indexer (default-indexer domain)))
(let lp ((i 0)
(ls multi-index))
(let ((reshaped-index
(invert-default-index
new-domain
(apply orig-default-indexer multi-index))))
(cond
((not (equal? (apply flat-indexer reshaped-index)
(apply orig-indexer multi-index)))
#f)
((null? ls)
res)
((= (+ 1 (interval-lower-bound domain i))
(interval-upper-bound domain i))
(lp (+ i 1) (cdr ls)))
(else
(set-car! ls (+ 1 (car ls)))
(lp (+ i 1) (cdr ls)))))))))
(cond
((interval-empty? new-domain)
(and (interval-empty? domain) res))
(else
(let ((multi-index (interval-lower-bounds->list domain))
(orig-default-indexer (default-indexer domain)))
(let lp ((i 0)
(ls multi-index))
(let ((reshaped-index
(invert-default-index
new-domain
(apply orig-default-indexer multi-index))))
(cond
((not (equal? (apply flat-indexer reshaped-index)
(apply orig-indexer multi-index)))
#f)
((null? ls)
res)
((= (+ 1 (interval-lower-bound domain i))
(interval-upper-bound domain i))
(lp (+ i 1) (cdr ls)))
(else
(set-car! ls (+ 1 (car ls)))
(lp (+ i 1) (cdr ls)))))))))))
(define (specialized-array-reshape array new-domain . o)
(assert (and (specialized-array? array)