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

Closes #982.
ashinn · May 29, 2024 · 832d82c · 832d82c
1 parent 648f6b9
commit 832d82c
Show file tree

Hide file tree

Showing 2 changed files with 30 additions and 2 deletions.
diff --git a/lib/srfi/231/test.sld b/lib/srfi/231/test.sld
@@ -3583,7 +3583,23 @@
                 (myarray= (apply array-outer-product append arrays)
                           (make-array (apply my-interval-cartesian-product
                                              (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"
         (specialized-array-default-safe? #t)

diff --git a/lib/srfi/231/transforms.scm b/lib/srfi/231/transforms.scm
@@ -325,11 +325,23 @@
                       (apply getter2 (drop multi-index dim1)))))))
 
 (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
    (lambda (a b) (array-reduce f (array-map g a b)))
    (array-copy (array-curry A 1))
    (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)
   (or (null? ls)