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

Fix array-inner-product, fail fast for empty arrays.

Browse source 
Closes #982.
This commit is contained in:
Alex Shinn 2024-05-29 21:42:20 +09:00
parent 648f6b9de6
commit 832d82c494
2 changed files with 30 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -3583,7 +3583,23 @@
(myarray= (apply array-outer-product append arrays) (myarray= (apply array-outer-product append arrays)
(make-array (apply my-interval-cartesian-product (make-array (apply my-interval-cartesian-product
(map array-domain arrays)) (map array-domain arrays))
list)))))) list)))))
(test '((((0 0) (0 0)) ((0 0) (0 1)) ((0 0) (0 2)) ((0 0) (0 3)))
(((1 0) (0 0)) ((1 0) (0 1)) ((1 0) (0 2)) ((1 0) (0 3)))
(((2 0) (0 0)) ((2 0) (0 1)) ((2 0) (0 2)) ((2 0) (0 3)))
(((3 0) (0 0)) ((3 0) (0 1)) ((3 0) (0 2)) ((3 0) (0 3))))
(array->list*
(array-inner-product (make-array (make-interval '#(4 1)) list)
list
list
(make-array (make-interval '#(1 4)) list))))
(test-error
(array-inner-product (make-array (make-interval '#(4 0)) list)
list
list
(make-array (make-interval '#(0 4)) list))))
(test-group "reshape tests" (test-group "reshape tests"
(specialized-array-default-safe? #t) (specialized-array-default-safe? #t)

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

@ -325,11 +325,23 @@
(apply getter2 (drop multi-index dim1))))))) (apply getter2 (drop multi-index dim1)))))))
(define (array-inner-product A f g B) (define (array-inner-product A f g B)
(assert (and (array? A) (array? B)
(procedure? f) (procedure? g)
(positive? (array-dimension A))
(positive? (array-dimension B))
(let ((A-dim (array-dimension A))
(A-dom (array-domain A))
(B-dom (array-domain B)))
(and (not (zero? (interval-width B-dom 0)))
(eqv? (interval-lower-bound A-dom (- A-dim 1))
(interval-lower-bound B-dom 0))
(eqv? (interval-upper-bound A-dom (- A-dim 1))
(interval-upper-bound B-dom 0))))))
(array-outer-product (array-outer-product
(lambda (a b) (array-reduce f (array-map g a b))) (lambda (a b) (array-reduce f (array-map g a b)))
(array-copy (array-curry A 1)) (array-copy (array-curry A 1))
(array-copy (array-copy
(array-curry (array-permute B (index-rotate (array-dimension B) 1)))))) (array-curry (array-permute B (index-rotate (array-dimension B) 1)) 1))))
(define (same-dimensions? ls) (define (same-dimensions? ls)
(or (null? ls) (or (null? ls)