apl: rank f⍤k cell decomposition (+10 tests, 201/201)

2026-05-07 00:00:14 +00:00
parent 4dbd3a0b34
commit 9eecbde61e
3 changed files with 86 additions and 2 deletions
--- a/lib/apl/runtime.sx
+++ b/lib/apl/runtime.sx
@@ -1083,3 +1083,28 @@
          (equal? (get next :ravel) (get x :ravel)))
        x
        (apl-power-fixed f next)))))
+
+(define
+  apl-rank
+  (fn
+    (f k arr)
+    (let
+      ((shape (get arr :shape)) (ravel (get arr :ravel)))
+      (let
+        ((rank (len shape)))
+        (if
+          (>= k rank)
+          (f arr)
+          (let
+            ((frame-shape (take shape (- rank k)))
+              (cell-shape (drop shape (- rank k))))
+            (let
+              ((frame-size (reduce * 1 frame-shape))
+                (cell-size (reduce * 1 cell-shape)))
+              (let
+                ((cells (map (fn (i) (let ((start (* i cell-size))) (make-array cell-shape (map (fn (j) (nth ravel (+ start j))) (range 0 cell-size))))) (range 0 frame-size))))
+                (let
+                  ((results (map (fn (c) (f c)) cells)))
+                  (make-array
+                    (append frame-shape (get (first results) :shape))
+                    (flatten (map (fn (r) (get r :ravel)) results))))))))))))