diff --git a/lib/apl/runtime.sx b/lib/apl/runtime.sx new file mode 100644 index 00000000..43addb91 --- /dev/null +++ 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))))))) diff --git a/lib/apl/tests/scalar.sx b/lib/apl/tests/scalar.sx new file mode 100644 index 00000000..26a2c1e2 --- /dev/null +++ b/lib/apl/tests/scalar.sx @@ -0,0 +1,369 @@ +; APL scalar primitives test suite +; Requires: lib/apl/runtime.sx + +; ============================================================ +; Test framework +; ============================================================ + +(define apl-rt-count 0) +(define apl-rt-pass 0) +(define apl-rt-fails (list)) + +; Element-wise list comparison (handles both List and ListRef) +(define + lists-eq + (fn + (a b) + (if + (and (= (len a) 0) (= (len b) 0)) + true + (if + (not (= (len a) (len b))) + false + (if + (not (= (first a) (first b))) + false + (lists-eq (rest a) (rest b))))))) + +(define + apl-rt-test + (fn + (name actual expected) + (begin + (set! apl-rt-count (+ apl-rt-count 1)) + (if + (equal? actual expected) + (set! apl-rt-pass (+ apl-rt-pass 1)) + (append! apl-rt-fails {:actual actual :expected expected :name name}))))) + +; Test that a ravel equals a plain list (handles ListRef vs List) +(define + ravel-test + (fn + (name arr expected-list) + (begin + (set! apl-rt-count (+ apl-rt-count 1)) + (let + ((actual (get arr :ravel))) + (if + (lists-eq actual expected-list) + (set! apl-rt-pass (+ apl-rt-pass 1)) + (append! apl-rt-fails {:actual actual :expected expected-list :name name})))))) + +; Test a scalar ravel value (single-element list) +(define + scalar-test + (fn (name arr expected-val) (ravel-test name arr (list expected-val)))) + +; ============================================================ +; Array constructor tests +; ============================================================ + +(apl-rt-test + "scalar: shape is empty list" + (get (apl-scalar 5) :shape) + (list)) + +(apl-rt-test + "scalar: ravel has one element" + (get (apl-scalar 5) :ravel) + (list 5)) + +(apl-rt-test "scalar: rank 0" (array-rank (apl-scalar 5)) 0) + +(apl-rt-test "scalar? returns true for scalar" (scalar? (apl-scalar 5)) true) + +(apl-rt-test "scalar: zero" (get (apl-scalar 0) :ravel) (list 0)) + +(apl-rt-test + "vector: shape is (3)" + (get (apl-vector (list 1 2 3)) :shape) + (list 3)) + +(apl-rt-test + "vector: ravel matches input" + (get (apl-vector (list 1 2 3)) :ravel) + (list 1 2 3)) + +(apl-rt-test "vector: rank 1" (array-rank (apl-vector (list 1 2 3))) 1) + +(apl-rt-test + "scalar? returns false for vector" + (scalar? (apl-vector (list 1 2 3))) + false) + +(apl-rt-test + "make-array: rank 2" + (array-rank (make-array (list 2 3) (list 1 2 3 4 5 6))) + 2) + +(apl-rt-test + "make-array: shape" + (get (make-array (list 2 3) (list 1 2 3 4 5 6)) :shape) + (list 2 3)) + +(apl-rt-test + "array-ref: first element" + (array-ref (apl-vector (list 10 20 30)) 0) + 10) + +(apl-rt-test + "array-ref: last element" + (array-ref (apl-vector (list 10 20 30)) 2) + 30) + +(apl-rt-test "enclose: wraps in rank-0" (scalar? (enclose 42)) true) + +(apl-rt-test + "enclose: ravel contains value" + (get (enclose 42) :ravel) + (list 42)) + +(apl-rt-test "disclose: unwraps rank-0" (disclose (enclose 42)) 42) + +; ============================================================ +; Shape primitive tests +; ============================================================ + +(ravel-test "⍴ scalar: returns empty" (apl-shape (apl-scalar 5)) (list)) + +(ravel-test + "⍴ vector: returns (3)" + (apl-shape (apl-vector (list 1 2 3))) + (list 3)) + +(ravel-test + "⍴ matrix: returns (2 3)" + (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6))) + (list 2 3)) + +(ravel-test + ", ravel scalar: vector of 1" + (apl-ravel (apl-scalar 5)) + (list 5)) + +(apl-rt-test + ", ravel vector: same elements" + (get (apl-ravel (apl-vector (list 1 2 3))) :ravel) + (list 1 2 3)) + +(apl-rt-test + ", ravel matrix: all elements" + (get (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))) :ravel) + (list 1 2 3 4 5 6)) + +(scalar-test "≢ tally scalar: 1" (apl-tally (apl-scalar 5)) 1) + +(scalar-test + "≢ tally vector: first dimension" + (apl-tally (apl-vector (list 1 2 3))) + 3) + +(scalar-test + "≢ tally matrix: first dimension" + (apl-tally (make-array (list 2 3) (list 1 2 3 4 5 6))) + 2) + +(scalar-test + "≡ depth flat vector: 0" + (apl-depth (apl-vector (list 1 2 3))) + 0) + +(scalar-test "≡ depth scalar: 0" (apl-depth (apl-scalar 5)) 0) + +(scalar-test + "≡ depth nested (enclose in vector): 1" + (apl-depth (enclose (apl-vector (list 1 2 3)))) + 1) + +; ============================================================ +; ⍳ iota tests +; ============================================================ + +(apl-rt-test + "⍳5 shape is (5)" + (get (apl-iota (apl-scalar 5)) :shape) + (list 5)) + +(ravel-test "⍳5 ravel is 1..5" (apl-iota (apl-scalar 5)) (list 1 2 3 4 5)) + +(ravel-test "⍳1 ravel is (1)" (apl-iota (apl-scalar 1)) (list 1)) + +(ravel-test "⍳0 ravel is empty" (apl-iota (apl-scalar 0)) (list)) + +(apl-rt-test "apl-io is 1" apl-io 1) + +; ============================================================ +; Arithmetic broadcast tests +; ============================================================ + +(scalar-test + "+ scalar scalar: 3+4=7" + (apl-add (apl-scalar 3) (apl-scalar 4)) + 7) + +(ravel-test + "+ vector scalar: +10" + (apl-add (apl-vector (list 1 2 3)) (apl-scalar 10)) + (list 11 12 13)) + +(ravel-test + "+ scalar vector: 10+" + (apl-add (apl-scalar 10) (apl-vector (list 1 2 3))) + (list 11 12 13)) + +(ravel-test + "+ vector vector" + (apl-add (apl-vector (list 1 2 3)) (apl-vector (list 4 5 6))) + (list 5 7 9)) + +(scalar-test "- negate monadic" (apl-neg-m (apl-scalar 5)) -5) + +(scalar-test "- dyadic 10-3=7" (apl-sub (apl-scalar 10) (apl-scalar 3)) 7) + +(scalar-test "× signum positive" (apl-signum (apl-scalar 7)) 1) + +(scalar-test "× signum negative" (apl-signum (apl-scalar -3)) -1) + +(scalar-test "× signum zero" (apl-signum (apl-scalar 0)) 0) + +(scalar-test "× dyadic 3×4=12" (apl-mul (apl-scalar 3) (apl-scalar 4)) 12) + +(scalar-test "÷ reciprocal 1÷4=0.25" (apl-recip (apl-scalar 4)) 0.25) + +(scalar-test + "÷ dyadic 10÷4=2.5" + (apl-div (apl-scalar 10) (apl-scalar 4)) + 2.5) + +(scalar-test "⌈ ceiling 2.3→3" (apl-ceil (apl-scalar 2.3)) 3) + +(scalar-test "⌈ max 3 5 → 5" (apl-max (apl-scalar 3) (apl-scalar 5)) 5) + +(scalar-test "⌊ floor 2.7→2" (apl-floor (apl-scalar 2.7)) 2) + +(scalar-test "⌊ min 3 5 → 3" (apl-min (apl-scalar 3) (apl-scalar 5)) 3) + +(scalar-test "* exp monadic e^0=1" (apl-exp (apl-scalar 0)) 1) + +(scalar-test + "* pow dyadic 2^10=1024" + (apl-pow (apl-scalar 2) (apl-scalar 10)) + 1024) + +(scalar-test "⍟ ln 1=0" (apl-ln (apl-scalar 1)) 0) + +(scalar-test "| abs positive" (apl-abs (apl-scalar 5)) 5) + +(scalar-test "| abs negative" (apl-abs (apl-scalar -5)) 5) + +(scalar-test "| mod 3|7=1" (apl-mod (apl-scalar 3) (apl-scalar 7)) 1) + +(scalar-test "! factorial 5!=120" (apl-fact (apl-scalar 5)) 120) + +(scalar-test "! factorial 0!=1" (apl-fact (apl-scalar 0)) 1) + +(scalar-test + "! binomial 4 choose 2 = 6" + (apl-binomial (apl-scalar 4) (apl-scalar 2)) + 6) + +(scalar-test "○ pi×0=0" (apl-pi-times (apl-scalar 0)) 0) + +(scalar-test "○ trig sin(0)=0" (apl-trig (apl-scalar 1) (apl-scalar 0)) 0) + +(scalar-test "○ trig cos(0)=1" (apl-trig (apl-scalar 2) (apl-scalar 0)) 1) + +; ============================================================ +; Comparison tests +; ============================================================ + +(scalar-test "< less: 3<5 → 1" (apl-lt (apl-scalar 3) (apl-scalar 5)) 1) + +(scalar-test "< less: 5<3 → 0" (apl-lt (apl-scalar 5) (apl-scalar 3)) 0) + +(scalar-test + "≤ le equal: 3≤3 → 1" + (apl-le (apl-scalar 3) (apl-scalar 3)) + 1) + +(scalar-test "= eq: 5=5 → 1" (apl-eq (apl-scalar 5) (apl-scalar 5)) 1) + +(scalar-test "= ne: 5=6 → 0" (apl-eq (apl-scalar 5) (apl-scalar 6)) 0) + +(scalar-test "≥ ge: 5≥3 → 1" (apl-ge (apl-scalar 5) (apl-scalar 3)) 1) + +(scalar-test "> gt: 5>3 → 1" (apl-gt (apl-scalar 5) (apl-scalar 3)) 1) + +(scalar-test "≠ ne: 5≠3 → 1" (apl-ne (apl-scalar 5) (apl-scalar 3)) 1) + +(ravel-test + "comparison vector broadcast: 1 2 3 < 2 → 1 0 0" + (apl-lt (apl-vector (list 1 2 3)) (apl-scalar 2)) + (list 1 0 0)) + +; ============================================================ +; Logical tests +; ============================================================ + +(scalar-test "~ not 0 → 1" (apl-not (apl-scalar 0)) 1) + +(scalar-test "~ not 1 → 0" (apl-not (apl-scalar 1)) 0) + +(ravel-test + "~ not vector: 1 0 1 0 → 0 1 0 1" + (apl-not (apl-vector (list 1 0 1 0))) + (list 0 1 0 1)) + +(scalar-test + "∧ and 1∧1 → 1" + (apl-and (apl-scalar 1) (apl-scalar 1)) + 1) + +(scalar-test + "∧ and 1∧0 → 0" + (apl-and (apl-scalar 1) (apl-scalar 0)) + 0) + +(scalar-test "∨ or 0∨1 → 1" (apl-or (apl-scalar 0) (apl-scalar 1)) 1) + +(scalar-test "∨ or 0∨0 → 0" (apl-or (apl-scalar 0) (apl-scalar 0)) 0) + +(scalar-test + "⍱ nor 0⍱0 → 1" + (apl-nor (apl-scalar 0) (apl-scalar 0)) + 1) + +(scalar-test + "⍱ nor 1⍱0 → 0" + (apl-nor (apl-scalar 1) (apl-scalar 0)) + 0) + +(scalar-test + "⍲ nand 1⍲1 → 0" + (apl-nand (apl-scalar 1) (apl-scalar 1)) + 0) + +(scalar-test + "⍲ nand 1⍲0 → 1" + (apl-nand (apl-scalar 1) (apl-scalar 0)) + 1) + +; ============================================================ +; plus-m identity test +; ============================================================ + +(scalar-test "+ monadic identity: +5 → 5" (apl-plus-m (apl-scalar 5)) 5) + +; ============================================================ +; Summary +; ============================================================ + +(define + apl-scalar-summary + (str + "scalar " + apl-rt-pass + "/" + apl-rt-count + (if (= (len apl-rt-fails) 0) "" (str " FAILS: " apl-rt-fails))))