apl: array model + scalar primitives Phase 2 (+82 tests)

Implement lib/apl/runtime.sx — APL array model and scalar primitive library: - make-array/apl-scalar/apl-vector/enclose/disclose constructors - array-rank/scalar?/array-ref accessors; apl-io=1 (⎕IO default) - broadcast-monadic/broadcast-dyadic engine (scalar↔scalar, scalar↔array, array↔array) - Arithmetic: + - × ÷ ⌈ ⌊ * ⍟ | ! ○ (all monadic+dyadic per APL convention) - Comparison: < ≤ = ≥ > ≠ (return 0/1) - Logical: ~ ∧ ∨ ⍱ ⍲ - Shape: ⍴ (apl-shape), , (apl-ravel), ≢ (apl-tally), ≡ (apl-depth) - ⍳ (apl-iota) with ⎕IO=1 — vector 1..n 82 tests in lib/apl/tests/scalar.sx covering all primitive groups; includes lists-eq helper for ListRef-aware comparison. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-26 14:24:49 +00:00
parent da8ba104a6
commit 4f4b735958
2 changed files with 718 additions and 0 deletions
--- a/lib/apl/runtime.sx
+++ b/lib/apl/runtime.sx
@@ -0,0 +1,349 @@
+; APL Runtime — array model + scalar primitives
+;
+; Array = SX dict {:shape (d1 d2 ...) :ravel (v1 v2 ...)}
+; Scalar: rank 0, shape (), one element in ravel
+; Vector: rank 1, shape (n), n elements in ravel
+; Matrix: rank 2, shape (r c), r*c elements in ravel
+
+; ============================================================
+; Array constructors
+; ============================================================
+
+(define make-array (fn (shape ravel) {:ravel ravel :shape shape}))
+
+(define apl-scalar (fn (v) {:ravel (list v) :shape (list)}))
+
+(define apl-vector (fn (elems) {:ravel elems :shape (list (len elems))}))
+
+; enclose — wrap any value in a rank-0 box
+(define enclose (fn (v) (apl-scalar v)))
+
+; disclose — unwrap rank-0 box, returning the first element
+(define disclose (fn (arr) (first (get arr :ravel))))
+
+; ============================================================
+; Array accessors
+; ============================================================
+
+(define array-rank (fn (arr) (len (get arr :shape))))
+
+(define scalar? (fn (arr) (= (len (get arr :shape)) 0)))
+
+(define array-ref (fn (arr i) (nth (get arr :ravel) i)))
+
+; ============================================================
+; System variables
+; ============================================================
+
+(define apl-io 1)
+
+; ============================================================
+; Broadcast engine
+; ============================================================
+
+(define
+  broadcast-monadic
+  (fn (f arr) (make-array (get arr :shape) (map f (get arr :ravel)))))
+
+(define
+  broadcast-dyadic
+  (fn
+    (f a b)
+    (cond
+      ((and (scalar? a) (scalar? b))
+        (apl-scalar (f (first (get a :ravel)) (first (get b :ravel)))))
+      ((scalar? a)
+        (let
+          ((sv (first (get a :ravel))))
+          (make-array
+            (get b :shape)
+            (map (fn (x) (f sv x)) (get b :ravel)))))
+      ((scalar? b)
+        (let
+          ((sv (first (get b :ravel))))
+          (make-array
+            (get a :shape)
+            (map (fn (x) (f x sv)) (get a :ravel)))))
+      (else
+        (if
+          (equal? (get a :shape) (get b :shape))
+          (make-array (get a :shape) (map f (get a :ravel) (get b :ravel)))
+          (error "length error: shape mismatch"))))))
+
+; ============================================================
+; Arithmetic primitives
+; ============================================================
+
+; Monadic + : identity
+(define apl-plus-m (fn (a) (broadcast-monadic (fn (x) x) a)))
+
+; Dyadic +
+(define apl-add (fn (a b) (broadcast-dyadic (fn (x y) (+ x y)) a b)))
+
+; Monadic - : negate
+(define apl-neg-m (fn (a) (broadcast-monadic (fn (x) (- 0 x)) a)))
+
+; Dyadic -
+(define apl-sub (fn (a b) (broadcast-dyadic (fn (x y) (- x y)) a b)))
+
+; Monadic × : signum
+(define
+  apl-signum
+  (fn
+    (a)
+    (broadcast-monadic
+      (fn (x) (cond ((> x 0) 1) ((< x 0) -1) (else 0)))
+      a)))
+
+; Dyadic ×
+(define apl-mul (fn (a b) (broadcast-dyadic (fn (x y) (* x y)) a b)))
+
+; Monadic ÷ : reciprocal
+(define apl-recip (fn (a) (broadcast-monadic (fn (x) (/ 1 x)) a)))
+
+; Dyadic ÷
+(define apl-div (fn (a b) (broadcast-dyadic (fn (x y) (/ x y)) a b)))
+
+; Monadic ⌈ : ceiling
+(define apl-ceil (fn (a) (broadcast-monadic (fn (x) (ceil x)) a)))
+
+; Dyadic ⌈ : max
+(define
+  apl-max
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) x y)) a b)))
+
+; Monadic ⌊ : floor
+(define apl-floor (fn (a) (broadcast-monadic (fn (x) (floor x)) a)))
+
+; Dyadic ⌊ : min
+(define
+  apl-min
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) x y)) a b)))
+
+; Monadic * : e^x
+(define apl-exp (fn (a) (broadcast-monadic (fn (x) (exp x)) a)))
+
+; Dyadic * : power
+(define apl-pow (fn (a b) (broadcast-dyadic (fn (x y) (pow x y)) a b)))
+
+; Monadic ⍟ : natural log
+(define apl-ln (fn (a) (broadcast-monadic (fn (x) (log x)) a)))
+
+; Dyadic ⍟ : log base (a⍟b = log base a of b)
+(define
+  apl-log
+  (fn (a b) (broadcast-dyadic (fn (x y) (/ (log y) (log x))) a b)))
+
+; Monadic | : absolute value
+(define
+  apl-abs
+  (fn (a) (broadcast-monadic (fn (x) (if (< x 0) (- 0 x) x)) a)))
+
+; Dyadic | : modulo (a|b = b mod a)
+(define
+  apl-mod
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn (x y) (if (= x 0) y (- y (* x (floor (/ y x))))))
+      a
+      b)))
+
+; Monadic ! : factorial
+(define
+  apl-fact
+  (fn
+    (a)
+    (broadcast-monadic
+      (fn
+        (n)
+        (let
+          ((loop nil))
+          (begin
+            (set!
+              loop
+              (fn (i acc) (if (> i n) acc (loop (+ i 1) (* acc i)))))
+            (loop 1 1))))
+      a)))
+
+; Dyadic ! : binomial coefficient n!k  (a=n, b=k => a choose b)
+(define
+  apl-binomial
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn
+        (n k)
+        (let
+          ((loop nil))
+          (begin
+            (set!
+              loop
+              (fn
+                (i num den)
+                (if
+                  (> i k)
+                  (/ num den)
+                  (loop (+ i 1) (* num (- (+ n 1) i)) (* den i)))))
+            (loop 1 1 1))))
+      a
+      b)))
+
+; Monadic ○ : pi times x
+(define
+  apl-pi-times
+  (fn (a) (broadcast-monadic (fn (x) (* 3.14159 x)) a)))
+
+; Dyadic ○ : trig functions (a○b, a=code, b=value)
+(define
+  apl-trig
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn
+        (n x)
+        (cond
+          ((= n 0) (pow (- 1 (* x x)) 0.5))
+          ((= n 1) (sin x))
+          ((= n 2) (cos x))
+          ((= n 3) (tan x))
+          ((= n -1) (asin x))
+          ((= n -2) (acos x))
+          ((= n -3) (atan x))
+          (else (error "circle: unsupported trig code"))))
+      a
+      b)))
+
+; ============================================================
+; Comparison primitives (return 0 or 1)
+; ============================================================
+
+(define
+  apl-lt
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (< x y) 1 0)) a b)))
+
+(define
+  apl-le
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) 1 0)) a b)))
+
+(define
+  apl-eq
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 1 0)) a b)))
+
+(define
+  apl-ge
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) 1 0)) a b)))
+
+(define
+  apl-gt
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (> x y) 1 0)) a b)))
+
+(define
+  apl-ne
+  (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 0 1)) a b)))
+
+; ============================================================
+; Logical primitives
+; ============================================================
+
+; Monadic ~ : logical not
+(define
+  apl-not
+  (fn (a) (broadcast-monadic (fn (x) (if (= x 0) 1 0)) a)))
+
+; Dyadic ∧ : logical and
+(define
+  apl-and
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0))
+      a
+      b)))
+
+; Dyadic ∨ : logical or
+(define
+  apl-or
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0))
+      a
+      b)))
+
+; Dyadic ⍱ : logical nor
+(define
+  apl-nor
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 0 1))
+      a
+      b)))
+
+; Dyadic ⍲ : logical nand
+(define
+  apl-nand
+  (fn
+    (a b)
+    (broadcast-dyadic
+      (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 0 1))
+      a
+      b)))
+
+; ============================================================
+; Shape primitives
+; ============================================================
+
+; Monadic ⍴ : shape — returns shape as a vector array
+(define apl-shape (fn (arr) (apl-vector (get arr :shape))))
+
+; Monadic , : ravel — returns a rank-1 vector of all elements
+(define apl-ravel (fn (arr) (apl-vector (get arr :ravel))))
+
+; Monadic ≢ : tally — first dimension (1 for scalar)
+(define
+  apl-tally
+  (fn
+    (arr)
+    (if
+      (scalar? arr)
+      (apl-scalar 1)
+      (apl-scalar (first (get arr :shape))))))
+
+; Monadic ≡ : depth
+; simple number/string value → 0
+; array containing only non-arrays → 0
+; array containing arrays → 1 + max depth of elements
+(define
+  apl-depth
+  (fn
+    (arr)
+    (define item-depth nil)
+    (set!
+      item-depth
+      (fn
+        (v)
+        (if
+          (and
+            (dict? v)
+            (not (= nil (get v :shape nil)))
+            (not (= nil (get v :ravel nil))))
+          (+ 1 (first (get (apl-depth v) :ravel)))
+          0)))
+    (let
+      ((depths (map item-depth (get arr :ravel))))
+      (apl-scalar (reduce (fn (a b) (if (> a b) a b)) 0 depths)))))
+
+; Monadic ⍳ : iota — vector 1..n (with ⎕IO=1)
+(define
+  apl-iota
+  (fn
+    (n-arr)
+    (let
+      ((n (first (get n-arr :ravel))) (build nil))
+      (begin
+        (set!
+          build
+          (fn (i acc) (if (< i 1) acc (build (- i 1) (cons i acc)))))
+        (apl-vector (build n (list)))))))