apl: inner product f.g (+12 tests, 163/163)

2026-05-06 22:09:13 +00:00
parent 4332b4032f
commit d67e04a9ad
3 changed files with 165 additions and 2 deletions
--- a/lib/apl/runtime.sx
+++ b/lib/apl/runtime.sx
@@ -1016,3 +1016,45 @@
                (fn (y) (disclose (f (apl-scalar x) (apl-scalar y))))
                b-ravel))
            a-ravel))))))
+
+(define
+  apl-inner
+  (fn
+    (f g a b)
+    (let
+      ((a-shape (get a :shape))
+        (b-shape (get b :shape))
+        (a-ravel (get a :ravel))
+        (b-ravel (get b :ravel)))
+      (let
+        ((a-rank (len a-shape)) (b-rank (len b-shape)))
+        (if
+          (and (= a-rank 0) (= b-rank 0))
+          (apl-scalar (disclose (g a b)))
+          (let
+            ((inner-dim (last a-shape))
+              (a-pre (take a-shape (- a-rank 1)))
+              (b-post (rest b-shape)))
+            (let
+              ((a-pre-size (reduce * 1 a-pre))
+                (b-post-size (reduce * 1 b-post))
+                (new-shape (append a-pre b-post)))
+              (make-array
+                new-shape
+                (flatten
+                  (map
+                    (fn
+                      (i)
+                      (map
+                        (fn
+                          (j)
+                          (let
+                            ((pairs (map (fn (k) (disclose (g (apl-scalar (nth a-ravel (+ (* i inner-dim) k))) (apl-scalar (nth b-ravel (+ (* k b-post-size) j)))))) (range 0 inner-dim))))
+                            (reduce
+                              (fn
+                                (x y)
+                                (disclose (f (apl-scalar x) (apl-scalar y))))
+                              (first pairs)
+                              (rest pairs))))
+                        (range 0 b-post-size)))
+                    (range 0 a-pre-size)))))))))))