coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge: loops/apl — APL on SX runtime + transpile + 362 tests

Browse Source
This commit is contained in:
giles
2026-05-07 11:31:17 +00:00
parent f480eb943c d755caeb9a
commit 5a28cf5dd3
25 changed files with 5735 additions and 296 deletions
Download Patch File Download Diff File Expand all files Collapse all files

113
lib/apl/conformance.sh Executable file
View File

@@ -0,0 +1,113 @@
#!/usr/bin/env bash
# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found." >&2
exit 1
fi
SUITES=(structural operators dfn tradfn valence programs system idioms)
OUT_JSON="lib/apl/scoreboard.json"
OUT_MD="lib/apl/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/apl/tests/${suite}.sx"
local TMP
TMP=$(mktemp)
cat > "$TMP" << EPOCHS
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/apl/runtime.sx")
(load "lib/apl/transpile.sx")
(epoch 2)
(eval "(define apl-test-pass 0)")
(eval "(define apl-test-fail 0)")
(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list apl-test-pass apl-test-fail)")
EPOCHS
local OUTPUT
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMP" 2>/dev/null)
rm -f "$TMP"
local LINE
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; s/\)$//')
fi
local P F
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
P=${P:-0}
F=${F:-0}
echo "${P} ${F}"
}
declare -A SUITE_PASS
declare -A SUITE_FAIL
TOTAL_PASS=0
TOTAL_FAIL=0
echo "Running APL conformance suite..." >&2
for s in "${SUITES[@]}"; do
read -r p f < <(run_suite "$s")
SUITE_PASS[$s]=$p
SUITE_FAIL[$s]=$f
TOTAL_PASS=$((TOTAL_PASS + p))
TOTAL_FAIL=$((TOTAL_FAIL + f))
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
done
# scoreboard.json
{
printf '{\n'
printf ' "suites": {\n'
first=1
for s in "${SUITES[@]}"; do
if [ $first -eq 0 ]; then printf ',\n'; fi
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
first=0
done
printf '\n },\n'
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
printf '}\n'
} > "$OUT_JSON"
# scoreboard.md
{
printf '# APL Conformance Scoreboard\n\n'
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
printf '| Suite | Pass | Fail | Total |\n'
printf '|-------|-----:|-----:|------:|\n'
for s in "${SUITES[@]}"; do
p=${SUITE_PASS[$s]}
f=${SUITE_FAIL[$s]}
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
done
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
printf '\n'
printf '## Notes\n\n'
printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
} > "$OUT_MD"
echo "Wrote $OUT_JSON and $OUT_MD" >&2
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
[ "$TOTAL_FAIL" -eq 0 ]

436
lib/apl/parser.sx Normal file
View File

@@ -0,0 +1,436 @@
; APL Parser — right-to-left expression parser
;
; Takes a token list (output of apl-tokenize) and produces an AST.
; APL evaluates right-to-left with no precedence among functions.
; Operators bind to the function immediately to their left in the source.
;
; AST node types:
; (:num n) number literal
; (:str s) string literal
; (:vec n1 n2 ...) strand (juxtaposed literals)
; (:name "x") name reference / alpha / omega
; (:assign "x" expr) assignment x←expr
; (:monad fn arg) monadic function call
; (:dyad fn left right) dyadic function call
; (:derived-fn op fn) derived function: f/ f¨ f⍨
; (:derived-fn2 "." f g) inner product: f.g
; (:outer "∘." fn) outer product: ∘.f
; (:fn-glyph "⍳") function reference
; (:fn-name "foo") named-function reference (dfn variable)
; (:dfn stmt...) {⍺+⍵} anonymous function
; (:guard cond expr) cond:expr guard inside dfn
; (:program stmt...) multi-statement sequence
; ============================================================
; Glyph classification sets
; ============================================================
(define apl-parse-op-glyphs
(list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
(define apl-parse-fn-glyphs
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~"
"<" "≤" "=" "≥" ">" "≠" "∊" "∧" "∨" "⍱" "⍲"
"," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"))
(define apl-parse-op-glyph?
(fn (v)
(some (fn (g) (= g v)) apl-parse-op-glyphs)))
(define apl-parse-fn-glyph?
(fn (v)
(some (fn (g) (= g v)) apl-parse-fn-glyphs)))
; ============================================================
; Token accessors
; ============================================================
(define tok-type
(fn (tok)
(get tok :type)))
(define tok-val
(fn (tok)
(get tok :value)))
(define is-op-tok?
(fn (tok)
(and (= (tok-type tok) :glyph)
(apl-parse-op-glyph? (tok-val tok)))))
(define is-fn-tok?
(fn (tok)
(and (= (tok-type tok) :glyph)
(apl-parse-fn-glyph? (tok-val tok)))))
; ============================================================
; Collect trailing operators starting at index i
; Returns {:ops (op ...) :end new-i}
; ============================================================
(define collect-ops
(fn (tokens i)
(collect-ops-loop tokens i (list))))
(define collect-ops-loop
(fn (tokens i acc)
(if (>= i (len tokens))
{:ops acc :end i}
(let ((tok (nth tokens i)))
(if (is-op-tok? tok)
(collect-ops-loop tokens (+ i 1) (append acc (tok-val tok)))
{:ops acc :end i})))))
; ============================================================
; Build a derived-fn node by chaining operators left-to-right
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
; ============================================================
(define build-derived-fn
(fn (fn-node ops)
(if (= (len ops) 0)
fn-node
(build-derived-fn
(list :derived-fn (first ops) fn-node)
(rest ops)))))
; ============================================================
; Find matching close bracket/paren/brace
; Returns the index of the matching close token
; ============================================================
(define find-matching-close
(fn (tokens start open-type close-type)
(find-matching-close-loop tokens start open-type close-type 1)))
(define find-matching-close-loop
(fn (tokens i open-type close-type depth)
(if (>= i (len tokens))
(len tokens)
(let ((tt (tok-type (nth tokens i))))
(cond
((= tt open-type)
(find-matching-close-loop tokens (+ i 1) open-type close-type (+ depth 1)))
((= tt close-type)
(if (= depth 1)
i
(find-matching-close-loop tokens (+ i 1) open-type close-type (- depth 1))))
(true
(find-matching-close-loop tokens (+ i 1) open-type close-type depth)))))))
; ============================================================
; Segment collection: scan tokens left-to-right, building
; a list of {:kind "val"/"fn" :node ast} segments.
; Operators following function glyphs are merged into
; derived-fn nodes during this pass.
; ============================================================
(define collect-segments
(fn (tokens)
(collect-segments-loop tokens 0 (list))))
(define collect-segments-loop
(fn (tokens i acc)
(if (>= i (len tokens))
acc
(let ((tok (nth tokens i))
(n (len tokens)))
(let ((tt (tok-type tok))
(tv (tok-val tok)))
(cond
; Skip separators
((or (= tt :diamond) (= tt :newline) (= tt :semi))
(collect-segments-loop tokens (+ i 1) acc))
; Number → value segment
((= tt :num)
(collect-segments-loop tokens (+ i 1)
(append acc {:kind "val" :node (list :num tv)})))
; String → value segment
((= tt :str)
(collect-segments-loop tokens (+ i 1)
(append acc {:kind "val" :node (list :str tv)})))
; Name → always a value segment in Phase 1
; (Named functions with operators like f/ are Phase 5)
((= tt :name)
(collect-segments-loop tokens (+ i 1)
(append acc {:kind "val" :node (list :name tv)})))
; Left paren → parse subexpression recursively
((= tt :lparen)
(let ((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
(let ((inner-tokens (slice tokens (+ i 1) end))
(after (+ end 1)))
(collect-segments-loop tokens after
(append acc {:kind "val" :node (parse-apl-expr inner-tokens)})))))
; Left brace → dfn
((= tt :lbrace)
(let ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
(let ((inner-tokens (slice tokens (+ i 1) end))
(after (+ end 1)))
(collect-segments-loop tokens after
(append acc {:kind "fn" :node (parse-dfn inner-tokens)})))))
; Glyph token — need to classify
((= tt :glyph)
(cond
; Alpha (⍺) and Omega (⍵) → values inside dfn context
((or (= tv "⍺") (= tv "⍵"))
(collect-segments-loop tokens (+ i 1)
(append acc {:kind "val" :node (list :name tv)})))
; Nabla (∇) → self-reference function in dfn context
((= tv "∇")
(collect-segments-loop tokens (+ i 1)
(append acc {:kind "fn" :node (list :fn-glyph "∇")})))
; ∘. → outer product (special case: ∘ followed by .)
((and (= tv "∘")
(< (+ i 1) n)
(= (tok-val (nth tokens (+ i 1))) "."))
(if (and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2))))
(let ((fn-tv (tok-val (nth tokens (+ i 2)))))
(let ((op-result (collect-ops tokens (+ i 3))))
(let ((ops (get op-result :ops))
(ni (get op-result :end)))
(let ((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops)))
(collect-segments-loop tokens ni
(append acc {:kind "fn" :node (list :outer "∘." fn-node)}))))))
; ∘. without function — treat ∘ as plain compose operator
; skip the . and continue
(collect-segments-loop tokens (+ i 1)
acc)))
; Function glyph — collect following operators
((apl-parse-fn-glyph? tv)
(let ((op-result (collect-ops tokens (+ i 1))))
(let ((ops (get op-result :ops))
(ni (get op-result :end)))
; Check for inner product: fn . fn
; (ops = ("." ) and next token is also a function glyph)
(if (and (= (len ops) 1)
(= (first ops) ".")
(< ni n)
(is-fn-tok? (nth tokens ni)))
; f.g inner product
(let ((g-tv (tok-val (nth tokens ni))))
(let ((op-result2 (collect-ops tokens (+ ni 1))))
(let ((ops2 (get op-result2 :ops))
(ni2 (get op-result2 :end)))
(let ((g-node (build-derived-fn (list :fn-glyph g-tv) ops2)))
(collect-segments-loop tokens ni2
(append acc {:kind "fn"
:node (list :derived-fn2 "." (list :fn-glyph tv) g-node)}))))))
; Regular function with zero or more operator modifiers
(let ((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
(collect-segments-loop tokens ni
(append acc {:kind "fn" :node fn-node})))))))
; Stray operator glyph — skip (shouldn't appear outside function context)
((apl-parse-op-glyph? tv)
(collect-segments-loop tokens (+ i 1) acc))
; Unknown glyph — skip
(true
(collect-segments-loop tokens (+ i 1) acc))))
; Skip unknown token types
(true
(collect-segments-loop tokens (+ i 1) acc))))))))
; ============================================================
; Build tree from segment list
;
; The segments are in left-to-right order.
; APL evaluates right-to-left, so the LEFTMOST function is
; the outermost (last-evaluated) node.
;
; Patterns:
; [val] → val node
; [fn val ...] → (:monad fn (build-tree rest))
; [val fn val ...] → (:dyad fn val (build-tree rest))
; [val val ...] → (:vec val1 val2 ...) — strand
; ============================================================
; Find the index of the first function segment (returns -1 if none)
(define find-first-fn
(fn (segs)
(find-first-fn-loop segs 0)))
(define find-first-fn-loop
(fn (segs i)
(if (>= i (len segs))
-1
(if (= (get (nth segs i) :kind) "fn")
i
(find-first-fn-loop segs (+ i 1))))))
; Build an array node from 0..n value segments
; If n=1 → return that segment's node
; If n>1 → return (:vec node1 node2 ...)
(define segs-to-array
(fn (segs)
(if (= (len segs) 1)
(get (first segs) :node)
(cons :vec (map (fn (s) (get s :node)) segs)))))
(define build-tree
(fn (segs)
(cond
; Empty → nil
((= (len segs) 0) nil)
; Single segment → return its node directly
((= (len segs) 1) (get (first segs) :node))
; All values → strand
((every? (fn (s) (= (get s :kind) "val")) segs)
(segs-to-array segs))
; Find the first function segment
(true
(let ((fn-idx (find-first-fn segs)))
(cond
; No function found (shouldn't happen given above checks) → strand
((= fn-idx -1) (segs-to-array segs))
; Function is first → monadic call
((= fn-idx 0)
(list :monad
(get (first segs) :node)
(build-tree (rest segs))))
; Function at position fn-idx: left args are segs[0..fn-idx-1]
(true
(let ((left-segs (slice segs 0 fn-idx))
(fn-seg (nth segs fn-idx))
(right-segs (slice segs (+ fn-idx 1))))
(list :dyad
(get fn-seg :node)
(segs-to-array left-segs)
(build-tree right-segs))))))))))
; ============================================================
; Split token list on statement separators (diamond / newline)
; Only splits at depth 0 (ignores separators inside { } or ( ) )
; ============================================================
(define split-statements
(fn (tokens)
(split-statements-loop tokens (list) (list) 0)))
(define split-statements-loop
(fn (tokens current-stmt acc depth)
(if (= (len tokens) 0)
(if (> (len current-stmt) 0)
(append acc (list current-stmt))
acc)
(let ((tok (first tokens))
(rest-toks (rest tokens))
(tt (tok-type (first tokens))))
(cond
; Open brackets increase depth
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
(split-statements-loop rest-toks (append current-stmt tok) acc (+ depth 1)))
; Close brackets decrease depth
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
(split-statements-loop rest-toks (append current-stmt tok) acc (- depth 1)))
; Separators only split at top level (depth = 0)
((and (> depth 0) (or (= tt :diamond) (= tt :newline)))
(split-statements-loop rest-toks (append current-stmt tok) acc depth))
((and (= depth 0) (or (= tt :diamond) (= tt :newline)))
(if (> (len current-stmt) 0)
(split-statements-loop rest-toks (list) (append acc (list current-stmt)) depth)
(split-statements-loop rest-toks (list) acc depth)))
; All other tokens go into current statement
(true
(split-statements-loop rest-toks (append current-stmt tok) acc depth)))))))
; ============================================================
; Parse a dfn body (tokens between { and })
; Handles guard expressions: cond : expr
; ============================================================
(define parse-dfn
(fn (tokens)
(let ((stmt-groups (split-statements tokens)))
(let ((stmts (map parse-dfn-stmt stmt-groups)))
(cons :dfn stmts)))))
(define parse-dfn-stmt
(fn (tokens)
; Check for guard: expr : expr
; A guard has a :colon token not inside parens/braces
(let ((colon-idx (find-top-level-colon tokens 0)))
(if (>= colon-idx 0)
; Guard: cond : expr
(let ((cond-tokens (slice tokens 0 colon-idx))
(body-tokens (slice tokens (+ colon-idx 1))))
(list :guard
(parse-apl-expr cond-tokens)
(parse-apl-expr body-tokens)))
; Regular statement
(parse-stmt tokens)))))
(define find-top-level-colon
(fn (tokens i)
(find-top-level-colon-loop tokens i 0)))
(define find-top-level-colon-loop
(fn (tokens i depth)
(if (>= i (len tokens))
-1
(let ((tok (nth tokens i))
(tt (tok-type (nth tokens i))))
(cond
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
(find-top-level-colon-loop tokens (+ i 1) (+ depth 1)))
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
(find-top-level-colon-loop tokens (+ i 1) (- depth 1)))
((and (= tt :colon) (= depth 0))
i)
(true
(find-top-level-colon-loop tokens (+ i 1) depth)))))))
; ============================================================
; Parse a single statement (assignment or expression)
; ============================================================
(define parse-stmt
(fn (tokens)
(if (and (>= (len tokens) 2)
(= (tok-type (nth tokens 0)) :name)
(= (tok-type (nth tokens 1)) :assign))
; Assignment: name ← expr
(list :assign
(tok-val (nth tokens 0))
(parse-apl-expr (slice tokens 2)))
; Expression
(parse-apl-expr tokens))))
; ============================================================
; Parse an expression from a flat token list
; ============================================================
(define parse-apl-expr
(fn (tokens)
(let ((segs (collect-segments tokens)))
(if (= (len segs) 0)
nil
(build-tree segs)))))
; ============================================================
; Main entry point
; parse-apl: string → AST
; ============================================================
(define parse-apl
(fn (src)
(let ((tokens (apl-tokenize src)))
(let ((stmt-groups (split-statements tokens)))
(if (= (len stmt-groups) 0)
nil
(if (= (len stmt-groups) 1)
(parse-stmt (first stmt-groups))
(cons :program (map parse-stmt stmt-groups))))))))

1522
lib/apl/runtime.sx
View File

File diff suppressed because it is too large Load Diff

15
lib/apl/scoreboard.json Normal file
View File

@@ -0,0 +1,15 @@
{
"suites": {
"structural": {"pass": 94, "fail": 0},
"operators": {"pass": 117, "fail": 0},
"dfn": {"pass": 24, "fail": 0},
"tradfn": {"pass": 20, "fail": 0},
"valence": {"pass": 14, "fail": 0},
"programs": {"pass": 46, "fail": 0},
"system": {"pass": 13, "fail": 0},
"idioms": {"pass": 34, "fail": 0}
},
"total_pass": 362,
"total_fail": 0,
"total": 362
}

20
lib/apl/scoreboard.md Normal file
View File

@@ -0,0 +1,20 @@
# APL Conformance Scoreboard
_Generated by `lib/apl/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| structural | 94 | 0 | 94 |
| operators | 117 | 0 | 117 |
| dfn | 24 | 0 | 24 |
| tradfn | 20 | 0 | 20 |
| valence | 14 | 0 | 14 |
| programs | 46 | 0 | 46 |
| system | 13 | 0 | 13 |
| idioms | 34 | 0 | 34 |
| **Total** | **362** | **0** | **362** |
## Notes
- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.
- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.

27
lib/apl/test.sh
View File

@@ -4,9 +4,9 @@
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
@@ -19,18 +19,31 @@ cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/apl/runtime.sx")
(load "lib/apl/transpile.sx")
(epoch 2)
(load "lib/apl/tests/runtime.sx")
(eval "(define apl-test-pass 0)")
(eval "(define apl-test-fail 0)")
(eval "(define apl-test-fails (list))")
(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (begin (set! apl-test-fail (+ apl-test-fail 1)) (set! apl-test-fails (append apl-test-fails (list {:name name :got got :expected expected})))))))")
(epoch 3)
(load "lib/apl/tests/structural.sx")
(load "lib/apl/tests/operators.sx")
(load "lib/apl/tests/dfn.sx")
(load "lib/apl/tests/tradfn.sx")
(load "lib/apl/tests/valence.sx")
(load "lib/apl/tests/programs.sx")
(load "lib/apl/tests/system.sx")
(load "lib/apl/tests/idioms.sx")
(epoch 4)
(eval "(list apl-test-pass apl-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"

227
lib/apl/tests/dfn.sx Normal file
View File

@@ -0,0 +1,227 @@
; Tests for apl-eval-ast and apl-call-dfn (manual AST construction).
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
(define mknum (fn (n) (list :num n)))
(define mkname (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkdfn1 (fn (body) (list :dfn body)))
(define mkprog (fn (stmts) (cons :program stmts)))
(define mkasg (fn (mkname expr) (list :assign mkname expr)))
(define mkgrd (fn (c e) (list :guard c e)))
(define mkdfn (fn (stmts) (cons :dfn stmts)))
(apl-test
"eval :num literal"
(rv (apl-eval-ast (mknum 42) {}))
(list 42))
(apl-test
"eval :num literal shape"
(sh (apl-eval-ast (mknum 42) {}))
(list))
(apl-test
"eval :dyad +"
(rv (apl-eval-ast (mkdyd "+" (mknum 2) (mknum 3)) {}))
(list 5))
(apl-test
"eval :dyad ×"
(rv (apl-eval-ast (mkdyd "×" (mknum 6) (mknum 7)) {}))
(list 42))
(apl-test
"eval :monad - (negate)"
(rv (apl-eval-ast (mkmon "-" (mknum 7)) {}))
(list -7))
(apl-test
"eval :monad ⌊ (floor)"
(rv (apl-eval-ast (mkmon "⌊" (mknum 3)) {}))
(list 3))
(apl-test
"eval :name ⍵ from env"
(rv (apl-eval-ast (mkname "⍵") {:omega (apl-scalar 99) :alpha nil}))
(list 99))
(apl-test
"eval :name ⍺ from env"
(rv (apl-eval-ast (mkname "⍺") {:omega nil :alpha (apl-scalar 7)}))
(list 7))
(apl-test
"dfn {⍵+1} called monadic"
(rv
(apl-call-dfn-m
(mkdfn1 (mkdyd "+" (mkname "⍵") (mknum 1)))
(apl-scalar 5)))
(list 6))
(apl-test
"dfn {⍺+⍵} called dyadic"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "+" (mkname "⍺") (mkname "⍵")))
(apl-scalar 4)
(apl-scalar 9)))
(list 13))
(apl-test
"dfn {⍺×⍵} dyadic on vectors"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "×" (mkname "⍺") (mkname "⍵")))
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 10 40 90))
(apl-test
"dfn {-⍵} monadic negate"
(rv
(apl-call-dfn-m
(mkdfn1 (mkmon "-" (mkname "⍵")))
(make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"dfn {⍺-⍵} dyadic subtract scalar"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "-" (mkname "⍺") (mkname "⍵")))
(apl-scalar 10)
(apl-scalar 3)))
(list 7))
(apl-test
"dfn {⌈⍺,⍵} not used (just verify : missing) — ceiling of right"
(rv
(apl-call-dfn-m (mkdfn1 (mkmon "⌈" (mkname "⍵"))) (apl-scalar 5)))
(list 5))
(apl-test
"dfn nested dyad"
(rv
(apl-call-dfn
(mkdfn1
(mkdyd "+" (mkname "⍺") (mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 1)
(apl-scalar 3)))
(list 7))
(apl-test
"dfn local assign x←⍵+1; ⍺×x"
(rv
(apl-call-dfn
(mkdfn
(list
(mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 1)))
(mkdyd "×" (mkname "⍺") (mkname "x"))))
(apl-scalar 3)
(apl-scalar 4)))
(list 15))
(apl-test
"dfn guard: 0=⍵:99; ⍵×2 (true branch)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
(mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 0)))
(list 99))
(apl-test
"dfn guard: 0=⍵:99; ⍵×2 (false branch)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
(mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 5)))
(list 10))
(apl-test
"dfn default ⍺←10 used (monadic call)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkasg "⍺" (mknum 10))
(mkdyd "+" (mkname "⍺") (mkname "⍵"))))
(apl-scalar 5)))
(list 15))
(apl-test
"dfn default ⍺←10 ignored when ⍺ given (dyadic call)"
(rv
(apl-call-dfn
(mkdfn
(list
(mkasg "⍺" (mknum 10))
(mkdyd "+" (mkname "⍺") (mkname "⍵"))))
(apl-scalar 100)
(apl-scalar 5)))
(list 105))
(apl-test
"dfn ∇ recursion: factorial via guard"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
(mkdyd
"×"
(mkname "⍵")
(mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
(apl-scalar 5)))
(list 120))
(apl-test
"dfn ∇ recursion: 3 → 6 (factorial)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
(mkdyd
"×"
(mkname "⍵")
(mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
(apl-scalar 3)))
(list 6))
(apl-test
"dfn local: x←⍵+10; y←x×2; y"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 10)))
(mkasg "y" (mkdyd "×" (mkname "x") (mknum 2)))
(mkname "y")))
(apl-scalar 5)))
(list 30))
(apl-test
"dfn first guard wins: many guards"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 1) (mkname "⍵")) (mknum 100))
(mkgrd (mkdyd "=" (mknum 2) (mkname "⍵")) (mknum 200))
(mkgrd (mkdyd "=" (mknum 3) (mkname "⍵")) (mknum 300))
(mknum 0)))
(apl-scalar 2)))
(list 200))

224
lib/apl/tests/idioms.sx Normal file
View File

@@ -0,0 +1,224 @@
; APL idiom corpus — classic Roger Hui / Phil Last idioms expressed
; through our runtime primitives. Each test names the APL one-liner
; and verifies the equivalent runtime call.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ---------- reductions ----------
(apl-test
"+/⍵ — sum"
(mkrv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"(+/⍵)÷⍴⍵ — mean"
(mkrv
(apl-div
(apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5)))
(apl-scalar 5)))
(list 3))
(apl-test
"⌈/⍵ — max"
(mkrv (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9))))
(list 9))
(apl-test
"⌊/⍵ — min"
(mkrv (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9))))
(list 1))
(apl-test
"(⌈/⍵)-⌊/⍵ — range"
(mkrv
(apl-sub
(apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9)))
(apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9)))))
(list 8))
(apl-test
"×/⍵ — product"
(mkrv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 24))
(apl-test
"+\\⍵ — running sum"
(mkrv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
; ---------- sort / order ----------
(apl-test
"⍵[⍋⍵] — sort ascending"
(mkrv (apl-quicksort (make-array (list 5) (list 3 1 4 1 5))))
(list 1 1 3 4 5))
(apl-test
"⌽⍵ — reverse"
(mkrv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
(list 5 4 3 2 1))
(apl-test
"⊃⌽⍵ — last element"
(mkrv
(apl-disclose (apl-reverse (make-array (list 4) (list 10 20 30 40)))))
(list 40))
(apl-test
"1↑⍵ — first element"
(mkrv
(apl-take (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
(list 10))
(apl-test
"1↓⍵ — drop first"
(mkrv
(apl-drop (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
(list 20 30 40))
(apl-test
"¯1↓⍵ — drop last"
(mkrv
(apl-drop (apl-scalar -1) (make-array (list 4) (list 10 20 30 40))))
(list 10 20 30))
; ---------- counts / membership ----------
(apl-test
"≢⍵ — tally"
(mkrv (apl-tally (make-array (list 7) (list 9 8 7 6 5 4 3))))
(list 7))
(apl-test
"+/⍵=v — count occurrences of v"
(mkrv
(apl-reduce
apl-add
(apl-eq (make-array (list 7) (list 1 2 3 2 1 3 2)) (apl-scalar 2))))
(list 3))
(apl-test
"0=N|M — divisibility test"
(mkrv (apl-eq (apl-scalar 0) (apl-mod (apl-scalar 3) (apl-scalar 12))))
(list 1))
; ---------- shape constructors ----------
(apl-test
"N⍴1 — vector of N ones"
(mkrv (apl-reshape (apl-scalar 5) (apl-scalar 1)))
(list 1 1 1 1 1))
(apl-test
"(N N)⍴0 — N×N zero matrix"
(mkrv (apl-reshape (make-array (list 2) (list 3 3)) (apl-scalar 0)))
(list 0 0 0 0 0 0 0 0 0))
(apl-test
"⍳∘.=⍳ — N×N identity matrix"
(mkrv
(apl-outer apl-eq (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
(list 1 0 0 0 1 0 0 0 1))
(apl-test
"⍳∘.×⍳ — multiplication table"
(mkrv
(apl-outer apl-mul (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
(list 1 2 3 2 4 6 3 6 9))
; ---------- numerical idioms ----------
(apl-test
"+\\⍳N — triangular numbers"
(mkrv (apl-scan apl-add (apl-iota (apl-scalar 5))))
(list 1 3 6 10 15))
(apl-test
"+/⍳N=N×(N+1)÷2 — sum of 1..N"
(mkrv (apl-reduce apl-add (apl-iota (apl-scalar 10))))
(list 55))
(apl-test
"×/⍳N — factorial via iota"
(mkrv (apl-reduce apl-mul (apl-iota (apl-scalar 5))))
(list 120))
(apl-test
"2|⍵ — parity (1=odd)"
(mkrv (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 0 1 0 1))
(apl-test
"+/2|⍵ — count odd"
(mkrv
(apl-reduce
apl-add
(apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))))
(list 3))
; ---------- boolean idioms ----------
(apl-test
"∧/⍵ — all-true"
(mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 1 1))))
(list 1))
(apl-test
"∧/⍵ — all-true with zero is false"
(mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 0 1))))
(list 0))
(apl-test
"∨/⍵ — any-true"
(mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 1 0))))
(list 1))
(apl-test
"∨/⍵ — any-true all zero is false"
(mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 0 0))))
(list 0))
; ---------- selection / scaling ----------
(apl-test
"⍵×⍵ — square each"
(mkrv
(apl-mul
(make-array (list 4) (list 1 2 3 4))
(make-array (list 4) (list 1 2 3 4))))
(list 1 4 9 16))
(apl-test
"+/⍵×⍵ — sum of squares"
(mkrv
(apl-reduce
apl-add
(apl-mul
(make-array (list 4) (list 1 2 3 4))
(make-array (list 4) (list 1 2 3 4)))))
(list 30))
(apl-test
"⍵-(+/⍵)÷⍴⍵ — mean-centered"
(mkrv
(apl-sub
(make-array (list 5) (list 2 4 6 8 10))
(apl-div
(apl-reduce apl-add (make-array (list 5) (list 2 4 6 8 10)))
(apl-scalar 5))))
(list -4 -2 0 2 4))
; ---------- shape / structure ----------
(apl-test
",⍵ — ravel"
(mkrv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"⍴⍴⍵ — rank"
(mkrv
(apl-shape (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))))
(list 2))

791
lib/apl/tests/operators.sx Normal file
View File

@@ -0,0 +1,791 @@
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
(apl-test
"reduce +/ vector"
(rv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"reduce x/ vector"
(rv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 24))
(apl-test
"reduce max/ vector"
(rv (apl-reduce apl-max (make-array (list 5) (list 3 1 4 1 5))))
(list 5))
(apl-test
"reduce min/ vector"
(rv (apl-reduce apl-min (make-array (list 3) (list 3 1 4))))
(list 1))
(apl-test
"reduce and/ all true"
(rv (apl-reduce apl-and (make-array (list 3) (list 1 1 1))))
(list 1))
(apl-test
"reduce or/ with true"
(rv (apl-reduce apl-or (make-array (list 3) (list 0 0 1))))
(list 1))
(apl-test
"reduce +/ single element"
(rv (apl-reduce apl-add (make-array (list 1) (list 42))))
(list 42))
(apl-test
"reduce +/ scalar no-op"
(rv (apl-reduce apl-add (apl-scalar 7)))
(list 7))
(apl-test
"reduce +/ shape is scalar"
(sh (apl-reduce apl-add (make-array (list 4) (list 1 2 3 4))))
(list))
(apl-test
"reduce +/ matrix row sums shape"
(sh (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2))
(apl-test
"reduce +/ matrix row sums values"
(rv (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6 15))
(apl-test
"reduce max/ matrix row maxima"
(rv (apl-reduce apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
(list 4 9))
(apl-test
"reduce-first +/ vector same as reduce"
(rv (apl-reduce-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"reduce-first +/ matrix col sums shape"
(sh
(apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3))
(apl-test
"reduce-first +/ matrix col sums values"
(rv
(apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 5 7 9))
(apl-test
"reduce-first max/ matrix col maxima"
(rv
(apl-reduce-first apl-max (make-array (list 3 2) (list 1 9 2 8 3 7))))
(list 3 9))
(apl-test
"scan +\\ vector"
(rv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
(apl-test
"scan x\\ vector cumulative product"
(rv (apl-scan apl-mul (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 6 24 120))
(apl-test
"scan max\\ vector running max"
(rv (apl-scan apl-max (make-array (list 5) (list 3 1 4 1 5))))
(list 3 3 4 4 5))
(apl-test
"scan min\\ vector running min"
(rv (apl-scan apl-min (make-array (list 5) (list 3 1 4 1 5))))
(list 3 1 1 1 1))
(apl-test
"scan +\\ single element"
(rv (apl-scan apl-add (make-array (list 1) (list 42))))
(list 42))
(apl-test
"scan +\\ scalar no-op"
(rv (apl-scan apl-add (apl-scalar 7)))
(list 7))
(apl-test
"scan +\\ vector preserves shape"
(sh (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 5))
(apl-test
"scan +\\ matrix preserves shape"
(sh (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"scan +\\ matrix row-wise"
(rv (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 3 6 4 9 15))
(apl-test
"scan max\\ matrix row-wise running max"
(rv (apl-scan apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
(list 3 3 4 1 5 9))
(apl-test
"scan-first +\\ vector same as scan"
(rv (apl-scan-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
(apl-test
"scan-first +\\ scalar no-op"
(rv (apl-scan-first apl-add (apl-scalar 9)))
(list 9))
(apl-test
"scan-first +\\ matrix preserves shape"
(sh (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"scan-first +\\ matrix col-wise"
(rv (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 5 7 9))
(apl-test
"scan-first max\\ matrix col-wise running max"
(rv (apl-scan-first apl-max (make-array (list 3 2) (list 3 1 4 1 5 9))))
(list 3 1 4 1 5 9))
(apl-test
"each negate vector"
(rv (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"each negate vector preserves shape"
(sh (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"each reciprocal vector"
(rv (apl-each apl-recip (make-array (list 3) (list 1 2 4))))
(list 1 (/ 1 2) (/ 1 4)))
(apl-test
"each abs vector"
(rv (apl-each apl-abs (make-array (list 4) (list -1 2 -3 4))))
(list 1 2 3 4))
(apl-test "each scalar" (rv (apl-each apl-neg-m (apl-scalar 5))) (list -5))
(apl-test
"each scalar shape"
(sh (apl-each apl-neg-m (apl-scalar 5)))
(list))
(apl-test
"each negate matrix shape"
(sh (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"each negate matrix values"
(rv (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 -2 -3 -4 -5 -6))
(apl-test
"each-dyadic scalar+scalar"
(rv (apl-each-dyadic apl-add (apl-scalar 3) (apl-scalar 4)))
(list 7))
(apl-test
"each-dyadic scalar+vector"
(rv
(apl-each-dyadic
apl-add
(apl-scalar 10)
(make-array (list 3) (list 1 2 3))))
(list 11 12 13))
(apl-test
"each-dyadic vector+scalar"
(rv
(apl-each-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(apl-scalar 10)))
(list 11 12 13))
(apl-test
"each-dyadic vector+vector"
(rv
(apl-each-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"each-dyadic mul matrix+matrix shape"
(sh
(apl-each-dyadic
apl-mul
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 2 2) (list 5 6 7 8))))
(list 2 2))
(apl-test
"each-dyadic mul matrix+matrix values"
(rv
(apl-each-dyadic
apl-mul
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 2 2) (list 5 6 7 8))))
(list 5 12 21 32))
(apl-test
"outer product mult table values"
(rv
(apl-outer
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1 2 3 2 4 6 3 6 9))
(apl-test
"outer product mult table shape"
(sh
(apl-outer
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 3 3))
(apl-test
"outer product add table values"
(rv
(apl-outer
apl-add
(make-array (list 2) (list 1 2))
(make-array (list 3) (list 10 20 30))))
(list 11 21 31 12 22 32))
(apl-test
"outer product add table shape"
(sh
(apl-outer
apl-add
(make-array (list 2) (list 1 2))
(make-array (list 3) (list 10 20 30))))
(list 2 3))
(apl-test
"outer product scalar+vector shape"
(sh
(apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"outer product scalar+vector values"
(rv
(apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
(list 5 10 15))
(apl-test
"outer product vector+scalar shape"
(sh
(apl-outer apl-mul (make-array (list 3) (list 1 2 3)) (apl-scalar 10)))
(list 3))
(apl-test
"outer product scalar+scalar"
(rv (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"outer product scalar+scalar shape"
(sh (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
(list))
(apl-test
"outer product equality identity matrix values"
(rv
(apl-outer
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1 0 0 0 1 0 0 0 1))
(apl-test
"outer product matrix+vector rank doubling shape"
(sh
(apl-outer
apl-add
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 3) (list 10 20 30))))
(list 2 2 3))
(apl-test
"outer product matrix+vector rank doubling values"
(rv
(apl-outer
apl-add
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 3) (list 10 20 30))))
(list 11 21 31 12 22 32 13 23 33 14 24 34))
(apl-test
"inner +.× dot product"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list 32))
(apl-test
"inner +.× dot product shape is scalar"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list))
(apl-test
"inner +.× matrix multiply 2x3 * 3x2 shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 2) (list 7 8 9 10 11 12))))
(list 2 2))
(apl-test
"inner +.× matrix multiply 2x3 * 3x2 values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 2) (list 7 8 9 10 11 12))))
(list 58 64 139 154))
(apl-test
"inner +.× identity matrix 2x2"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 2) (list 1 0 0 1))
(make-array (list 2 2) (list 5 6 7 8))))
(list 5 6 7 8))
(apl-test
"inner ∧.= equal vectors"
(rv
(apl-inner
apl-and
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1))
(apl-test
"inner ∧.= unequal vectors"
(rv
(apl-inner
apl-and
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 9 3))))
(list 0))
(apl-test
"inner +.× matrix * vector shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 7 8 9))))
(list 2))
(apl-test
"inner +.× matrix * vector values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 7 8 9))))
(list 50 122))
(apl-test
"inner +.× vector * matrix shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3 2) (list 4 5 6 7 8 9))))
(list 2))
(apl-test
"inner +.× vector * matrix values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3 2) (list 4 5 6 7 8 9))))
(list 40 46))
(apl-test
"inner +.× single-element vectors"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 1) (list 6))
(make-array (list 1) (list 7))))
(list 42))
(apl-test
"commute +⍨ scalar doubles"
(rv (apl-commute apl-add (apl-scalar 5)))
(list 10))
(apl-test
"commute ×⍨ vector squares"
(rv (apl-commute apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 1 4 9 16))
(apl-test
"commute +⍨ vector doubles"
(rv (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
(list 2 4 6))
(apl-test
"commute +⍨ shape preserved"
(sh (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"commute ×⍨ matrix shape preserved"
(sh (apl-commute apl-mul (make-array (list 2 2) (list 1 2 3 4))))
(list 2 2))
(apl-test
"commute-dyadic -⍨ swaps subtraction"
(rv (apl-commute-dyadic apl-sub (apl-scalar 5) (apl-scalar 3)))
(list -2))
(apl-test
"commute-dyadic ÷⍨ swaps division"
(rv (apl-commute-dyadic apl-div (apl-scalar 4) (apl-scalar 12)))
(list 3))
(apl-test
"commute-dyadic -⍨ on vectors"
(rv
(apl-commute-dyadic
apl-sub
(make-array (list 3) (list 10 20 30))
(make-array (list 3) (list 1 2 3))))
(list -9 -18 -27))
(apl-test
"commute-dyadic +⍨ commutative same result"
(rv
(apl-commute-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"commute-dyadic ×⍨ commutative same result"
(rv
(apl-commute-dyadic
apl-mul
(make-array (list 3) (list 2 3 4))
(make-array (list 3) (list 5 6 7))))
(list 10 18 28))
(apl-test
"compose -∘| scalar (negative abs)"
(rv (apl-compose apl-neg-m apl-abs (apl-scalar -7)))
(list -7))
(apl-test
"compose -∘| vector"
(rv
(apl-compose apl-neg-m apl-abs (make-array (list 4) (list -1 2 -3 4))))
(list -1 -2 -3 -4))
(apl-test
"compose ⌊∘- (floor of negate)"
(rv (apl-compose apl-floor apl-neg-m (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"compose -∘| matrix shape preserved"
(sh
(apl-compose apl-neg-m apl-abs (make-array (list 2 2) (list -1 2 -3 4))))
(list 2 2))
(apl-test
"compose-dyadic +∘- equals subtract scalar"
(rv (apl-compose-dyadic apl-add apl-neg-m (apl-scalar 10) (apl-scalar 3)))
(list 7))
(apl-test
"compose-dyadic +∘- equals subtract vector"
(rv
(apl-compose-dyadic
apl-add
apl-neg-m
(make-array (list 3) (list 10 20 30))
(make-array (list 3) (list 1 2 3))))
(list 9 18 27))
(apl-test
"compose-dyadic -∘| (subtract abs)"
(rv (apl-compose-dyadic apl-sub apl-abs (apl-scalar 10) (apl-scalar -3)))
(list 7))
(apl-test
"compose-dyadic ×∘- (multiply by negative)"
(rv
(apl-compose-dyadic
apl-mul
apl-neg-m
(make-array (list 3) (list 2 3 4))
(make-array (list 3) (list 1 2 3))))
(list -2 -6 -12))
(apl-test
"compose-dyadic shape preserved"
(sh
(apl-compose-dyadic
apl-add
apl-neg-m
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 3) (list 1 1 1 1 1 1))))
(list 2 3))
(apl-test
"power n=0 identity"
(rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 0 (apl-scalar 5)))
(list 5))
(apl-test
"power increment by 3"
(rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 3 (apl-scalar 0)))
(list 3))
(apl-test
"power double 4 times = 16"
(rv (apl-power (fn (a) (apl-mul a (apl-scalar 2))) 4 (apl-scalar 1)))
(list 16))
(apl-test
"power on vector +5"
(rv
(apl-power
(fn (a) (apl-add a (apl-scalar 1)))
5
(make-array (list 3) (list 1 2 3))))
(list 6 7 8))
(apl-test
"power on vector preserves shape"
(sh
(apl-power
(fn (a) (apl-add a (apl-scalar 1)))
5
(make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"power on matrix"
(rv
(apl-power
(fn (a) (apl-mul a (apl-scalar 3)))
2
(make-array (list 2 2) (list 1 2 3 4))))
(list 9 18 27 36))
(apl-test
"power-fixed identity stops immediately"
(rv (apl-power-fixed (fn (a) a) (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"power-fixed floor half scalar to 0"
(rv
(apl-power-fixed
(fn (a) (apl-floor (apl-div a (apl-scalar 2))))
(apl-scalar 100)))
(list 0))
(apl-test
"power-fixed shape preserved"
(sh
(apl-power-fixed (fn (a) a) (make-array (list 2 2) (list 1 2 3 4))))
(list 2 2))
(apl-test
"rank tally⍤1 row tallies"
(rv (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 3))
(apl-test
"rank tally⍤1 row tallies shape"
(sh (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2))
(apl-test
"rank neg⍤0 vector scalar cells"
(rv (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"rank neg⍤0 vector preserves shape"
(sh (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"rank neg⍤1 matrix per-row"
(rv (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 -2 -3 -4 -5 -6))
(apl-test
"rank neg⍤1 matrix preserves shape"
(sh (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"rank k>=rank fallthrough"
(rv (apl-rank apl-tally 5 (make-array (list 4) (list 1 2 3 4))))
(list 4))
(apl-test
"rank tally⍤2 whole matrix tally"
(rv
(apl-rank
apl-tally
2
(make-array (list 3 5) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))
(list 3))
(apl-test
"rank reverse⍤1 matrix reverse rows"
(rv (apl-rank apl-reverse 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2 1 6 5 4))
(apl-test
"rank tally⍤1 3x4 row tallies"
(rv
(apl-rank
apl-tally
1
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 4 4 4))
(apl-test
"at-replace single index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 2))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 99 3 4 5))
(apl-test
"at-replace multiple indices vector vals"
(rv
(apl-at-replace
(make-array (list 2) (list 99 88))
(make-array (list 2) (list 2 4))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 99 3 88 5))
(apl-test
"at-replace scalar broadcast"
(rv
(apl-at-replace
(apl-scalar 0)
(make-array (list 3) (list 1 3 5))
(make-array (list 5) (list 10 20 30 40 50))))
(list 0 20 0 40 0))
(apl-test
"at-replace preserves shape"
(sh
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 2))
(make-array (list 5) (list 1 2 3 4 5))))
(list 5))
(apl-test
"at-replace last index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 5))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 99))
(apl-test
"at-replace on matrix linear-index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 99 4 5 6))
(apl-test
"at-apply negate at indices"
(rv
(apl-at-apply
apl-neg-m
(make-array (list 3) (list 1 3 5))
(make-array (list 5) (list 1 2 3 4 5))))
(list -1 2 -3 4 -5))
(apl-test
"at-apply double at index 1"
(rv
(apl-at-apply
(fn (a) (apl-mul a (apl-scalar 2)))
(make-array (list 1) (list 1))
(make-array (list 2) (list 5 10))))
(list 10 10))
(apl-test
"at-apply preserves shape"
(sh
(apl-at-apply
apl-neg-m
(make-array (list 2) (list 1 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"at-apply on matrix linear-index"
(rv
(apl-at-apply
apl-neg-m
(make-array (list 2) (list 1 6))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 2 3 4 5 -6))

340
lib/apl/tests/parse.sx Normal file
View File

@@ -0,0 +1,340 @@
(define apl-test-count 0)
(define apl-test-pass 0)
(define apl-test-fails (list))
(define apl-test
(fn (name actual expected)
(begin
(set! apl-test-count (+ apl-test-count 1))
(if (= actual expected)
(set! apl-test-pass (+ apl-test-pass 1))
(append! apl-test-fails {:name name :actual actual :expected expected})))))
(define tok-types
(fn (src)
(map (fn (t) (get t :type)) (apl-tokenize src))))
(define tok-values
(fn (src)
(map (fn (t) (get t :value)) (apl-tokenize src))))
(define tok-count
(fn (src)
(len (apl-tokenize src))))
(define tok-type-at
(fn (src i)
(get (nth (apl-tokenize src) i) :type)))
(define tok-value-at
(fn (src i)
(get (nth (apl-tokenize src) i) :value)))
(apl-test "empty: no tokens" (tok-count "") 0)
(apl-test "empty: whitespace only" (tok-count " ") 0)
(apl-test "num: zero" (tok-values "0") (list 0))
(apl-test "num: positive" (tok-values "42") (list 42))
(apl-test "num: large" (tok-values "12345") (list 12345))
(apl-test "num: negative" (tok-values "¯5") (list -5))
(apl-test "num: negative zero" (tok-values "¯0") (list 0))
(apl-test "num: strand count" (tok-count "1 2 3") 3)
(apl-test "num: strand types" (tok-types "1 2 3") (list :num :num :num))
(apl-test "num: strand values" (tok-values "1 2 3") (list 1 2 3))
(apl-test "num: neg in strand" (tok-values "1 ¯2 3") (list 1 -2 3))
(apl-test "str: empty" (tok-values "''") (list ""))
(apl-test "str: single char" (tok-values "'a'") (list "a"))
(apl-test "str: word" (tok-values "'hello'") (list "hello"))
(apl-test "str: escaped quote" (tok-values "''''") (list "'"))
(apl-test "str: type" (tok-types "'abc'") (list :str))
(apl-test "name: simple" (tok-values "foo") (list "foo"))
(apl-test "name: type" (tok-types "foo") (list :name))
(apl-test "name: mixed case" (tok-values "MyVar") (list "MyVar"))
(apl-test "name: with digits" (tok-values "x1") (list "x1"))
(apl-test "name: system var" (tok-values "⎕IO") (list "⎕IO"))
(apl-test "name: system var type" (tok-types "⎕IO") (list :name))
(apl-test "glyph: plus" (tok-types "+") (list :glyph))
(apl-test "glyph: plus value" (tok-values "+") (list "+"))
(apl-test "glyph: iota" (tok-values "⍳") (list "⍳"))
(apl-test "glyph: reduce" (tok-values "+/") (list "+" "/"))
(apl-test "glyph: floor" (tok-values "⌊") (list "⌊"))
(apl-test "glyph: rho" (tok-values "⍴") (list "⍴"))
(apl-test "glyph: alpha omega" (tok-types "⍺ ⍵") (list :glyph :glyph))
(apl-test "punct: lparen" (tok-types "(") (list :lparen))
(apl-test "punct: rparen" (tok-types ")") (list :rparen))
(apl-test "punct: brackets" (tok-types "[42]") (list :lbracket :num :rbracket))
(apl-test "punct: braces" (tok-types "{}") (list :lbrace :rbrace))
(apl-test "punct: semi" (tok-types ";") (list :semi))
(apl-test "assign: arrow" (tok-types "x←1") (list :name :assign :num))
(apl-test "diamond: separator" (tok-types "1⋄2") (list :num :diamond :num))
(apl-test "newline: emitted" (tok-types "1\n2") (list :num :newline :num))
(apl-test "comment: skipped" (tok-count "⍝ ignore me") 0)
(apl-test "comment: rest ignored" (tok-count "1 ⍝ note") 1)
(apl-test "colon: bare" (tok-types ":") (list :colon))
(apl-test "keyword: If" (tok-values ":If") (list ":If"))
(apl-test "keyword: type" (tok-types ":While") (list :keyword))
(apl-test "keyword: EndFor" (tok-values ":EndFor") (list ":EndFor"))
(apl-test "expr: +/ ⍳ 5" (tok-types "+/ ⍳ 5") (list :glyph :glyph :glyph :num))
(apl-test "expr: x←42" (tok-count "x←42") 3)
(apl-test "expr: dfn body" (tok-types "{⍺+⍵}")
(list :lbrace :glyph :glyph :glyph :rbrace))
(define apl-tokenize-test-summary
(str "tokenizer " apl-test-pass "/" apl-test-count
(if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))
; ===========================================================================
; Parser tests
; ===========================================================================
; Helper: parse an APL source string and return the AST
(define parse
(fn (src) (parse-apl src)))
; Helper: build an expected AST node using keyword-tagged lists
(define num-node (fn (n) (list :num n)))
(define str-node (fn (s) (list :str s)))
(define name-node (fn (n) (list :name n)))
(define fn-node (fn (g) (list :fn-glyph g)))
(define fn-nm (fn (n) (list :fn-name n)))
(define assign-node (fn (nm expr) (list :assign nm expr)))
(define monad-node (fn (f a) (list :monad f a)))
(define dyad-node (fn (f l r) (list :dyad f l r)))
(define derived-fn (fn (op f) (list :derived-fn op f)))
(define derived-fn2 (fn (op f g) (list :derived-fn2 op f g)))
(define outer-node (fn (f) (list :outer "∘." f)))
(define guard-node (fn (c e) (list :guard c e)))
; ---- numeric literals ----
(apl-test "parse: num literal"
(parse "42")
(num-node 42))
(apl-test "parse: negative num"
(parse "¯3")
(num-node -3))
(apl-test "parse: zero"
(parse "0")
(num-node 0))
; ---- string literals ----
(apl-test "parse: str literal"
(parse "'hello'")
(str-node "hello"))
(apl-test "parse: empty str"
(parse "''")
(str-node ""))
; ---- name reference ----
(apl-test "parse: name"
(parse "x")
(name-node "x"))
(apl-test "parse: system name"
(parse "⎕IO")
(name-node "⎕IO"))
; ---- strands (vec nodes) ----
(apl-test "parse: strand 3 nums"
(parse "1 2 3")
(list :vec (num-node 1) (num-node 2) (num-node 3)))
(apl-test "parse: strand 2 nums"
(parse "1 2")
(list :vec (num-node 1) (num-node 2)))
(apl-test "parse: strand with negatives"
(parse "1 ¯2 3")
(list :vec (num-node 1) (num-node -2) (num-node 3)))
; ---- assignment ----
(apl-test "parse: assignment"
(parse "x←42")
(assign-node "x" (num-node 42)))
(apl-test "parse: assignment with spaces"
(parse "x ← 42")
(assign-node "x" (num-node 42)))
(apl-test "parse: assignment of expr"
(parse "r←2+3")
(assign-node "r" (dyad-node (fn-node "+") (num-node 2) (num-node 3))))
; ---- monadic functions ----
(apl-test "parse: monadic iota"
(parse "⍳5")
(monad-node (fn-node "⍳") (num-node 5)))
(apl-test "parse: monadic iota with space"
(parse "⍳ 5")
(monad-node (fn-node "⍳") (num-node 5)))
(apl-test "parse: monadic negate"
(parse "-3")
(monad-node (fn-node "-") (num-node 3)))
(apl-test "parse: monadic floor"
(parse "⌊2")
(monad-node (fn-node "⌊") (num-node 2)))
(apl-test "parse: monadic of name"
(parse "⍴x")
(monad-node (fn-node "⍴") (name-node "x")))
; ---- dyadic functions ----
(apl-test "parse: dyadic plus"
(parse "2+3")
(dyad-node (fn-node "+") (num-node 2) (num-node 3)))
(apl-test "parse: dyadic times"
(parse "2×3")
(dyad-node (fn-node "×") (num-node 2) (num-node 3)))
(apl-test "parse: dyadic with names"
(parse "x+y")
(dyad-node (fn-node "+") (name-node "x") (name-node "y")))
; ---- right-to-left evaluation ----
(apl-test "parse: right-to-left 2×3+4"
(parse "2×3+4")
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "+") (num-node 3) (num-node 4))))
(apl-test "parse: right-to-left chain"
(parse "1+2×3-4")
(dyad-node (fn-node "+") (num-node 1)
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "-") (num-node 3) (num-node 4)))))
; ---- parenthesized subexpressions ----
(apl-test "parse: parens override order"
(parse "(2+3)×4")
(dyad-node (fn-node "×")
(dyad-node (fn-node "+") (num-node 2) (num-node 3))
(num-node 4)))
(apl-test "parse: nested parens"
(parse "((2+3))")
(dyad-node (fn-node "+") (num-node 2) (num-node 3)))
(apl-test "parse: paren in dyadic right"
(parse "2×(3+4)")
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "+") (num-node 3) (num-node 4))))
; ---- operators → derived functions ----
(apl-test "parse: reduce +"
(parse "+/x")
(monad-node (derived-fn "/" (fn-node "+")) (name-node "x")))
(apl-test "parse: reduce iota"
(parse "+/⍳5")
(monad-node (derived-fn "/" (fn-node "+"))
(monad-node (fn-node "⍳") (num-node 5))))
(apl-test "parse: scan"
(parse "+\\x")
(monad-node (derived-fn "\\" (fn-node "+")) (name-node "x")))
(apl-test "parse: each"
(parse "⍳¨x")
(monad-node (derived-fn "¨" (fn-node "⍳")) (name-node "x")))
(apl-test "parse: commute"
(parse "-⍨3")
(monad-node (derived-fn "⍨" (fn-node "-")) (num-node 3)))
(apl-test "parse: stacked ops"
(parse "+/¨x")
(monad-node (derived-fn "¨" (derived-fn "/" (fn-node "+"))) (name-node "x")))
; ---- outer product ----
(apl-test "parse: outer product monadic"
(parse "∘.×")
(outer-node (fn-node "×")))
(apl-test "parse: outer product dyadic names"
(parse "x ∘.× y")
(dyad-node (outer-node (fn-node "×")) (name-node "x") (name-node "y")))
(apl-test "parse: outer product dyadic strands"
(parse "1 2 3 ∘.× 4 5 6")
(dyad-node (outer-node (fn-node "×"))
(list :vec (num-node 1) (num-node 2) (num-node 3))
(list :vec (num-node 4) (num-node 5) (num-node 6))))
; ---- inner product ----
(apl-test "parse: inner product"
(parse "+.×")
(derived-fn2 "." (fn-node "+") (fn-node "×")))
(apl-test "parse: inner product applied"
(parse "a +.× b")
(dyad-node (derived-fn2 "." (fn-node "+") (fn-node "×"))
(name-node "a") (name-node "b")))
; ---- dfn (anonymous function) ----
(apl-test "parse: simple dfn"
(parse "{⍺+⍵}")
(list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵"))))
(apl-test "parse: monadic dfn"
(parse "{⍵×2}")
(list :dfn (dyad-node (fn-node "×") (name-node "⍵") (num-node 2))))
(apl-test "parse: dfn self-ref"
(parse "{⍵≤1:1 ⋄ ⍵×∇ ⍵-1}")
(list :dfn
(guard-node (dyad-node (fn-node "≤") (name-node "⍵") (num-node 1)) (num-node 1))
(dyad-node (fn-node "×") (name-node "⍵")
(monad-node (fn-node "∇") (dyad-node (fn-node "-") (name-node "⍵") (num-node 1))))))
; ---- dfn applied ----
(apl-test "parse: dfn as function"
(parse "{⍺+⍵} 3")
(monad-node
(list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵")))
(num-node 3)))
; ---- multi-statement ----
(apl-test "parse: diamond separator"
(let ((result (parse "x←1 ⋄ x+2")))
(= (first result) :program))
true)
(apl-test "parse: diamond first stmt"
(let ((result (parse "x←1 ⋄ x+2")))
(nth result 1))
(assign-node "x" (num-node 1)))
(apl-test "parse: diamond second stmt"
(let ((result (parse "x←1 ⋄ x+2")))
(nth result 2))
(dyad-node (fn-node "+") (name-node "x") (num-node 2)))
; ---- combined summary ----
(define apl-parse-test-count (- apl-test-count 46))
(define apl-parse-test-pass (- apl-test-pass 46))
(define apl-test-summary
(str
"tokenizer 46/46 | "
"parser " apl-parse-test-pass "/" apl-parse-test-count
(if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))

306
lib/apl/tests/programs.sx Normal file
View File

@@ -0,0 +1,306 @@
; Tests for classic APL programs (lib/apl/tests/programs/*.apl).
; Programs are showcase APL source; runtime impl is in lib/apl/runtime.sx.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ===== primes (Sieve of Eratosthenes) =====
(apl-test "primes 1 → empty" (mkrv (apl-primes 1)) (list))
(apl-test "primes 2 → just 2" (mkrv (apl-primes 2)) (list 2))
(apl-test "primes 10 → 2 3 5 7" (mkrv (apl-primes 10)) (list 2 3 5 7))
(apl-test
"primes 20 → 2 3 5 7 11 13 17 19"
(mkrv (apl-primes 20))
(list 2 3 5 7 11 13 17 19))
(apl-test
"primes 30"
(mkrv (apl-primes 30))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes 50"
(mkrv (apl-primes 50))
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
(apl-test "primes 7 length" (first (mksh (apl-primes 7))) 4)
(apl-test "primes 100 has 25 primes" (first (mksh (apl-primes 100))) 25)
; ===== compress helper sanity =====
(apl-test
"compress 1 0 1 0 1 / 10 20 30 40 50"
(mkrv
(apl-compress
(make-array (list 5) (list 1 0 1 0 1))
(make-array (list 5) (list 10 20 30 40 50))))
(list 10 30 50))
(apl-test
"compress all-zero mask → empty"
(mkrv
(apl-compress
(make-array (list 3) (list 0 0 0))
(make-array (list 3) (list 1 2 3))))
(list))
(apl-test
"compress all-one mask → full vector"
(mkrv
(apl-compress
(make-array (list 3) (list 1 1 1))
(make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"life: empty 5x5 stays empty"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: horizontal blinker → vertical blinker"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
(apl-test
"life: vertical blinker → horizontal blinker"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: blinker has period 2"
(mkrv
(apl-life-step
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))))
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: 2x2 block stable on 5x5"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: shape preserved"
(mksh
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
(list 5 5))
(apl-test
"life: glider on 6x6 advances"
(mkrv
(apl-life-step
(make-array
(list 6 6)
(list
0
0
0
0
0
0
0
0
1
0
0
0
0
0
0
1
0
0
0
1
1
1
0
0
0
0
0
0
0
0
0
0
0
0
0
0))))
(list
0
0
0
0
0
0
0
0
0
0
0
0
0
1
0
1
0
0
0
0
1
1
0
0
0
0
1
0
0
0
0
0
0
0
0
0))
(apl-test
"mandelbrot c=0 stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0)) 100))
(list 100))
(apl-test
"mandelbrot c=-1 cycle bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1)) 100))
(list 100))
(apl-test
"mandelbrot c=-2 boundary stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -2)) 100))
(list 100))
(apl-test
"mandelbrot c=0.25 boundary stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.25)) 100))
(list 100))
(apl-test
"mandelbrot c=1 escapes at iter 3"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 1)) 100))
(list 3))
(apl-test
"mandelbrot c=0.5 escapes at iter 5"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.5)) 100))
(list 5))
(apl-test
"mandelbrot batched grid (rank-polymorphic)"
(mkrv (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
(list 10 10 10 3 2))
(apl-test
"mandelbrot batched preserves shape"
(mksh (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
(list 5))
(apl-test
"mandelbrot c=-1.5 stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1.5)) 100))
(list 100))
(apl-test "queens 1 → 1 solution" (mkrv (apl-queens 1)) (list 1))
(apl-test "queens 2 → 0 solutions" (mkrv (apl-queens 2)) (list 0))
(apl-test "queens 3 → 0 solutions" (mkrv (apl-queens 3)) (list 0))
(apl-test "queens 4 → 2 solutions" (mkrv (apl-queens 4)) (list 2))
(apl-test "queens 5 → 10 solutions" (mkrv (apl-queens 5)) (list 10))
(apl-test "queens 6 → 4 solutions" (mkrv (apl-queens 6)) (list 4))
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92))
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
(apl-test
"quicksort empty"
(mkrv (apl-quicksort (make-array (list 0) (list))))
(list))
(apl-test
"quicksort single"
(mkrv (apl-quicksort (make-array (list 1) (list 42))))
(list 42))
(apl-test
"quicksort already sorted"
(mkrv (apl-quicksort (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"quicksort reverse sorted"
(mkrv (apl-quicksort (make-array (list 5) (list 5 4 3 2 1))))
(list 1 2 3 4 5))
(apl-test
"quicksort with duplicates"
(mkrv (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2))))
(list 1 1 2 3 4 5 9))
(apl-test
"quicksort all equal"
(mkrv (apl-quicksort (make-array (list 5) (list 7 7 7 7 7))))
(list 7 7 7 7 7))
(apl-test
"quicksort negatives"
(mkrv (apl-quicksort (make-array (list 5) (list -3 1 -1 2 0))))
(list -3 -1 0 1 2))
(apl-test
"quicksort 11-element pi"
(mkrv
(apl-quicksort (make-array (list 11) (list 3 1 4 1 5 9 2 6 5 3 5))))
(list 1 1 2 3 3 4 5 5 5 6 9))
(apl-test
"quicksort preserves length"
(first
(mksh (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2)))))
7)

22
lib/apl/tests/programs/life.apl Normal file
View File

@@ -0,0 +1,22 @@
⍝ Conway's Game of Life — toroidal one-liner
⍝
⍝ The classic Roger Hui formulation:
⍝ life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}
⍝
⍝ Read right-to-left:
⍝ ⊂⍵ : enclose the board (so it's a single scalar item)
⍝ ¯1 0 1 ⌽¨ ⊂⍵ : produce 3 horizontally-shifted copies
⍝ ¯1 0 1 ∘.⊖ … : outer-product with vertical shifts → 3×3 = 9 shifts
⍝ +/ +/ … : sum the 9 boards element-wise → neighbor-count + self
⍝ 3 4 = … : boolean — count is exactly 3 or exactly 4
⍝ 1 ⍵ ∨.∧ … : "alive next" iff (count=3) or (alive AND count=4)
⍝ ⊃ … : disclose back to a 2D board
⍝
⍝ Rules in plain language:
⍝ - dead cell + 3 live neighbors → born
⍝ - live cell + 2 or 3 live neighbors → survives
⍝ - all else → dies
⍝
⍝ Toroidal: edges wrap (rotate is cyclic).
life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}

29
lib/apl/tests/programs/mandelbrot.apl Normal file
View File

@@ -0,0 +1,29 @@
⍝ Mandelbrot — real-axis subset
⍝
⍝ For complex c, the Mandelbrot set is { c : |z_n| stays bounded } where
⍝ z_0 = 0, z_{n+1} = z_n² + c.
⍝ Restricting c (and z) to ℝ gives the segment c ∈ [-2, 1/4]
⍝ where the iteration stays bounded.
⍝
⍝ Rank-polymorphic batched-iteration form:
⍝ mandelbrot ← {⍵ ⍵⍵ ⍺⍺ +,(⍺⍺ × ⍺⍺) }
⍝
⍝ Pseudocode (as we don't have ⎕ system fns yet):
⍝ z ← 0×c ⍝ start at zero
⍝ alive ← 1+0×c ⍝ all "still in"
⍝ for k iterations:
⍝ alive ← alive ∧ 4 ≥ z×z ⍝ still bounded?
⍝ z ← alive × c + z×z ⍝ freeze escaped via mask
⍝ count ← count + alive ⍝ tally surviving iters
⍝
⍝ Examples (count after 100 iterations):
⍝ c=0 : 100 (z stays at 0)
⍝ c=-1 : 100 (cycles 0,-1,0,-1,...)
⍝ c=-2 : 100 (settles at 2 — boundary)
⍝ c=0.25 : 100 (boundary — converges to 0.5)
⍝ c=0.5 : 5 (escapes by iteration 6)
⍝ c=1 : 3 (escapes quickly)
⍝
⍝ Real-axis Mandelbrot set: bounded for c ∈ [-2, 0.25].
mandelbrot ← {z←alive←count←0×⍵ ⋄ {alive←alive∧4≥z×z ⋄ z←alive×⍵+z×z ⋄ count+←alive}⍣⍺⊢⍵}

18
lib/apl/tests/programs/n-queens.apl Normal file
View File

@@ -0,0 +1,18 @@
⍝ N-Queens — count solutions to placing N non-attacking queens on N×N
⍝
⍝ A solution is encoded as a permutation P of 1..N where P[i] is the
⍝ column of the queen in row i. Rows and columns are then automatically
⍝ unique (it's a permutation). We must additionally rule out queens
⍝ sharing a diagonal: |i-j| = |P[i]-P[j]| for any pair.
⍝
⍝ Backtracking via reduce — the classic Roger Hui style:
⍝ queens ← {≢{⍵,¨⍨↓(0=∊(¨⍳⍴⍵)≠.+|⍵)/⍳⍴⍵}/(⍳⍵)⍴⊂⍳⍵}
⍝
⍝ Plain reading:
⍝ permute 1..N, keep those where no two queens share a diagonal.
⍝
⍝ Known solution counts (OEIS A000170):
⍝ N 1 2 3 4 5 6 7 8 9 10
⍝ q(N) 1 0 0 2 10 4 40 92 352 724
queens ← {≢({(i j)←⍺⍵ ⋄ (|i-j)≠|(P[i])-(P[j])}⌿permutations ⍵)}

16
lib/apl/tests/programs/primes.apl Normal file
View File

@@ -0,0 +1,16 @@
⍝ Sieve of Eratosthenes — the classic APL one-liner
⍝ primes ← (2=+⌿0=A∘.|A)/A←⍳N
⍝
⍝ Read right-to-left:
⍝ A ← ⍳N : A is 1..N
⍝ A∘.|A : outer-product residue table — M[i,j] = A[j] mod A[i]
⍝ 0=... : boolean — true where A[i] divides A[j]
⍝ +⌿... : column sums — count of divisors per A[j]
⍝ 2=... : true for numbers with exactly 2 divisors (1 and self) → primes
⍝ .../A : compress — select A[j] where mask[j] is true
⍝
⍝ Examples:
⍝ primes 10 → 2 3 5 7
⍝ primes 30 → 2 3 5 7 11 13 17 19 23 29
primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵}

25
lib/apl/tests/programs/quicksort.apl Normal file
View File

@@ -0,0 +1,25 @@
⍝ Quicksort — the classic Roger Hui one-liner
⍝
⍝ Q ← {1≥≢⍵:⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p←⍵⌷⍨?≢⍵}
⍝
⍝ Read right-to-left:
⍝ ?≢⍵ : pick a random index in 1..length
⍝ ⍵⌷⍨… : take that element as pivot p
⍝ ⍵>p : boolean — elements greater than pivot
⍝ ∇⍵⌿⍨… : recursively sort the > partition
⍝ (p=⍵)/⍵ : keep elements equal to pivot
⍝ ⍵<p : boolean — elements less than pivot
⍝ ∇⍵⌿⍨… : recursively sort the < partition
⍝ , : catenate ⟨less⟩ ⟨equal⟩ ⟨greater⟩
⍝ 1≥≢⍵:⍵ : guard — base case for length ≤ 1
⍝
⍝ Stability: not stable on duplicates (but eq-class is preserved as a block).
⍝ Worst case O(N²) on already-sorted input with deterministic pivot;
⍝ randomized pivot selection gives expected O(N log N).
⍝
⍝ Examples:
⍝ Q 3 1 4 1 5 9 2 6 5 3 5 → 1 1 2 3 3 4 5 5 5 6 9
⍝ Q ⍳0 → ⍬ (empty)
⍝ Q ,42 → 42
quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p}

369
lib/apl/tests/scalar.sx Normal file
View File

@@ -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))))

608
lib/apl/tests/structural.sx Normal file
View File

@@ -0,0 +1,608 @@
;; lib/apl/tests/structural.sx — Phase 3: structural primitives
;; Tests for: apl-reshape, apl-ravel, apl-transpose, apl-transpose-dyadic
;; Loaded after runtime.sx; shares apl-test / apl-test-pass / apl-test-fail.
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
;; ---------------------------------------------------------------------------
;; 1. Ravel (monadic ,)
;; ---------------------------------------------------------------------------
(apl-test "ravel scalar" (rv (apl-ravel (apl-scalar 5))) (list 5))
(apl-test
"ravel vector"
(rv (apl-ravel (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"ravel matrix"
(rv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"ravel shape is rank-1"
(sh (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6))
;; ---------------------------------------------------------------------------
;; 2. Reshape (dyadic ⍴)
;; ---------------------------------------------------------------------------
(apl-test
"reshape 2x3 ravel"
(rv
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 6) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"reshape 2x3 shape"
(sh
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 6) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"reshape cycle 6 from 1 2"
(rv
(apl-reshape
(make-array (list 1) (list 6))
(make-array (list 2) (list 1 2))))
(list 1 2 1 2 1 2))
(apl-test
"reshape cycle 2x3 from 1 2"
(rv
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 2) (list 1 2))))
(list 1 2 1 2 1 2))
(apl-test
"reshape scalar fill"
(rv (apl-reshape (make-array (list 1) (list 4)) (apl-scalar 7)))
(list 7 7 7 7))
(apl-test
"reshape truncate"
(rv
(apl-reshape
(make-array (list 1) (list 3))
(make-array (list 6) (list 10 20 30 40 50 60))))
(list 10 20 30))
(apl-test
"reshape matrix to vector"
(sh
(apl-reshape
(make-array (list 1) (list 6))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6))
(apl-test
"reshape 2x2x3"
(sh
(apl-reshape
(make-array (list 3) (list 2 2 3))
(make-array (list 12) (range 1 13))))
(list 2 2 3))
(apl-test
"reshape to empty"
(rv
(apl-reshape
(make-array (list 1) (list 0))
(make-array (list 3) (list 1 2 3))))
(list))
;; ---------------------------------------------------------------------------
;; 3. Monadic transpose (⍉)
;; ---------------------------------------------------------------------------
(apl-test
"transpose scalar shape"
(sh (apl-transpose (apl-scalar 99)))
(list))
(apl-test
"transpose scalar ravel"
(rv (apl-transpose (apl-scalar 99)))
(list 99))
(apl-test
"transpose vector shape"
(sh (apl-transpose (make-array (list 3) (list 3 1 4))))
(list 3))
(apl-test
"transpose vector ravel"
(rv (apl-transpose (make-array (list 3) (list 3 1 4))))
(list 3 1 4))
(apl-test
"transpose 2x3 shape"
(sh (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2))
(apl-test
"transpose 2x3 ravel"
(rv (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 4 2 5 3 6))
(apl-test
"transpose 3x3"
(rv (apl-transpose (make-array (list 3 3) (list 1 2 3 4 5 6 7 8 9))))
(list 1 4 7 2 5 8 3 6 9))
(apl-test
"transpose 1x4 shape"
(sh (apl-transpose (make-array (list 1 4) (list 1 2 3 4))))
(list 4 1))
(apl-test
"transpose twice identity"
(rv
(apl-transpose
(apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6)))))
(list 1 2 3 4 5 6))
(apl-test
"transpose 3d shape"
(sh (apl-transpose (make-array (list 2 3 4) (range 0 24))))
(list 4 3 2))
;; ---------------------------------------------------------------------------
;; 4. Dyadic transpose (perm⍉arr)
;; ---------------------------------------------------------------------------
(apl-test
"dyadic-transpose identity"
(rv
(apl-transpose-dyadic
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"dyadic-transpose swap 2x3"
(rv
(apl-transpose-dyadic
(make-array (list 2) (list 2 1))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 4 2 5 3 6))
(apl-test
"dyadic-transpose swap shape"
(sh
(apl-transpose-dyadic
(make-array (list 2) (list 2 1))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2))
(apl-test
"dyadic-transpose 3d shape"
(sh
(apl-transpose-dyadic
(make-array (list 3) (list 2 1 3))
(make-array (list 2 3 4) (range 0 24))))
(list 3 2 4))
(apl-test
"take 3 from front"
(rv (apl-take (apl-scalar 3) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3))
(apl-test
"take 0"
(rv (apl-take (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list))
(apl-test
"take -2 from back"
(rv (apl-take (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
(list 4 5))
(apl-test
"take over-take pads with 0"
(rv (apl-take (apl-scalar 7) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5 0 0))
(apl-test
"take matrix 1 row 2 cols shape"
(sh
(apl-take
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2))
(apl-test
"take matrix 1 row 2 cols ravel"
(rv
(apl-take
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2))
(apl-test
"take matrix negative row"
(rv
(apl-take
(make-array (list 2) (list -1 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6))
(apl-test
"drop 2 from front"
(rv (apl-drop (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 3 4 5))
(apl-test
"drop -2 from back"
(rv (apl-drop (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3))
(apl-test
"drop all"
(rv (apl-drop (apl-scalar 5) (make-array (list 5) (list 1 2 3 4 5))))
(list))
(apl-test
"drop 0"
(rv (apl-drop (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"drop matrix 1 row shape"
(sh
(apl-drop
(make-array (list 2) (list 1 0))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 3))
(apl-test
"drop matrix 1 row ravel"
(rv
(apl-drop
(make-array (list 2) (list 1 0))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6))
(apl-test
"reverse vector"
(rv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
(list 5 4 3 2 1))
(apl-test
"reverse scalar identity"
(rv (apl-reverse (apl-scalar 42)))
(list 42))
(apl-test
"reverse matrix last axis"
(rv (apl-reverse (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2 1 6 5 4))
(apl-test
"reverse-first matrix"
(rv (apl-reverse-first (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6 1 2 3))
(apl-test
"reverse-first vector identity"
(rv (apl-reverse-first (make-array (list 4) (list 1 2 3 4))))
(list 4 3 2 1))
(apl-test
"rotate vector left by 2"
(rv (apl-rotate (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 3 4 5 1 2))
(apl-test
"rotate vector right by 1 (negative)"
(rv (apl-rotate (apl-scalar -1) (make-array (list 5) (list 1 2 3 4 5))))
(list 5 1 2 3 4))
(apl-test
"rotate by 0 is identity"
(rv (apl-rotate (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"rotate matrix last axis"
(rv
(apl-rotate (apl-scalar 1) (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3 1 5 6 4))
(apl-test
"rotate-first matrix"
(rv
(apl-rotate-first
(apl-scalar 1)
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6 1 2 3))
(apl-test
"cat v,v ravel"
(rv
(apl-catenate
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 1 2 3 4 5))
(apl-test
"cat v,v shape"
(sh
(apl-catenate
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 5))
(apl-test
"cat scalar,v"
(rv (apl-catenate (apl-scalar 99) (make-array (list 3) (list 1 2 3))))
(list 99 1 2 3))
(apl-test
"cat v,scalar"
(rv (apl-catenate (make-array (list 3) (list 1 2 3)) (apl-scalar 99)))
(list 1 2 3 99))
(apl-test
"cat matrix last-axis shape"
(sh
(apl-catenate
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 2) (list 7 8 9 10))))
(list 2 5))
(apl-test
"cat matrix last-axis ravel"
(rv
(apl-catenate
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 2) (list 7 8 9 10))))
(list 1 2 3 7 8 4 5 6 9 10))
(apl-test
"cat-first v,v shape"
(sh
(apl-catenate-first
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 5))
(apl-test
"cat-first matrix shape"
(sh
(apl-catenate-first
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
(list 5 3))
(apl-test
"cat-first matrix ravel"
(rv
(apl-catenate-first
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
(list 1 2 3 4 5 6 11 12 13 14 15 16 17 18 19))
(apl-test
"squad scalar into vector"
(rv
(apl-squad (apl-scalar 2) (make-array (list 5) (list 10 20 30 40 50))))
(list 20))
(apl-test
"squad first element"
(rv (apl-squad (apl-scalar 1) (make-array (list 3) (list 10 20 30))))
(list 10))
(apl-test
"squad last element"
(rv
(apl-squad (apl-scalar 5) (make-array (list 5) (list 10 20 30 40 50))))
(list 50))
(apl-test
"squad fully specified matrix element"
(rv
(apl-squad
(make-array (list 2) (list 2 3))
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 7))
(apl-test
"squad partial row of matrix shape"
(sh
(apl-squad
(apl-scalar 2)
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 4))
(apl-test
"squad partial row of matrix ravel"
(rv
(apl-squad
(apl-scalar 2)
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 5 6 7 8))
(apl-test
"squad partial 3d slice shape"
(sh (apl-squad (apl-scalar 1) (make-array (list 2 3 4) (range 1 25))))
(list 3 4))
(apl-test
"grade-up basic"
(rv (apl-grade-up (make-array (list 5) (list 3 1 4 1 5))))
(list 2 4 1 3 5))
(apl-test
"grade-up shape"
(sh (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
(list 4))
(apl-test
"grade-up no duplicates"
(rv (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
(list 2 4 3 1))
(apl-test
"grade-up already sorted"
(rv (apl-grade-up (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"grade-up reverse sorted"
(rv (apl-grade-up (make-array (list 3) (list 3 2 1))))
(list 3 2 1))
(apl-test
"grade-down basic"
(rv (apl-grade-down (make-array (list 5) (list 3 1 4 1 5))))
(list 5 3 1 2 4))
(apl-test
"grade-down no duplicates"
(rv (apl-grade-down (make-array (list 4) (list 4 1 3 2))))
(list 1 3 4 2))
(apl-test
"grade-up single element"
(rv (apl-grade-up (make-array (list 1) (list 42))))
(list 1))
(apl-test
"enclose shape is scalar"
(sh (apl-enclose (make-array (list 3) (list 1 2 3))))
(list))
(apl-test
"enclose ravel length is 1"
(len (rv (apl-enclose (make-array (list 3) (list 1 2 3)))))
1)
(apl-test
"enclose inner ravel"
(rv (first (rv (apl-enclose (make-array (list 3) (list 1 2 3))))))
(list 1 2 3))
(apl-test
"disclose of enclose round-trips ravel"
(rv (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
(list 10 20 30))
(apl-test
"disclose of enclose round-trips shape"
(sh (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
(list 3))
(apl-test
"disclose scalar ravel"
(rv (apl-disclose (apl-scalar 42)))
(list 42))
(apl-test
"disclose vector ravel"
(rv (apl-disclose (make-array (list 3) (list 5 6 7))))
(list 5))
(apl-test
"disclose matrix returns first row"
(rv (apl-disclose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3))
(apl-test
"member basic"
(rv
(apl-member
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 2 3))))
(list 0 1 1))
(apl-test
"member all absent"
(rv
(apl-member
(make-array (list 3) (list 4 5 6))
(make-array (list 3) (list 1 2 3))))
(list 0 0 0))
(apl-test
"member scalar"
(rv (apl-member (apl-scalar 5) (make-array (list 3) (list 1 5 9))))
(list 1))
(apl-test
"member shape preserved"
(sh
(apl-member
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 1 3 5))))
(list 2 3))
(apl-test
"member matrix ravel"
(rv
(apl-member
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 1 3 5))))
(list 1 0 1 0 1 0))
(apl-test
"index-of basic"
(rv
(apl-index-of
(make-array (list 4) (list 10 20 30 40))
(make-array (list 3) (list 20 40 10))))
(list 2 4 1))
(apl-test
"index-of not-found"
(rv
(apl-index-of
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 5 2))))
(list 4 2))
(apl-test
"index-of scalar right"
(rv
(apl-index-of (make-array (list 3) (list 10 20 30)) (apl-scalar 20)))
(list 2))
(apl-test
"without basic"
(rv
(apl-without
(make-array (list 5) (list 1 2 3 4 5))
(make-array (list 2) (list 2 4))))
(list 1 3 5))
(apl-test
"without shape"
(sh
(apl-without
(make-array (list 5) (list 1 2 3 4 5))
(make-array (list 2) (list 2 4))))
(list 3))
(apl-test
"without nothing removed"
(rv
(apl-without
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list 1 2 3))
(apl-test
"without all removed"
(rv
(apl-without
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list))

48
lib/apl/tests/system.sx Normal file
View File

@@ -0,0 +1,48 @@
; Tests for APL ⎕ system functions.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
(apl-test "⎕IO returns 1" (mkrv (apl-quad-io)) (list 1))
(apl-test "⎕ML returns 1" (mkrv (apl-quad-ml)) (list 1))
(apl-test "⎕FR returns 1248" (mkrv (apl-quad-fr)) (list 1248))
(apl-test "⎕TS shape is 7" (mksh (apl-quad-ts)) (list 7))
(apl-test "⎕TS year is 1970 default" (first (mkrv (apl-quad-ts))) 1970)
(apl-test "⎕FMT scalar 42" (apl-quad-fmt (apl-scalar 42)) "42")
(apl-test "⎕FMT scalar negative" (apl-quad-fmt (apl-scalar -7)) "-7")
(apl-test
"⎕FMT empty vector"
(apl-quad-fmt (make-array (list 0) (list)))
"")
(apl-test
"⎕FMT singleton vector"
(apl-quad-fmt (make-array (list 1) (list 42)))
"42")
(apl-test
"⎕FMT vector"
(apl-quad-fmt (make-array (list 5) (list 1 2 3 4 5)))
"1 2 3 4 5")
(apl-test
"⎕FMT matrix 2x3"
(apl-quad-fmt (make-array (list 2 3) (list 1 2 3 4 5 6)))
"1 2 3\n4 5 6\n")
(apl-test
"⎕← (print) returns its arg"
(mkrv (apl-quad-print (apl-scalar 99)))
(list 99))
(apl-test
"⎕← preserves shape"
(mksh (apl-quad-print (make-array (list 3) (list 1 2 3))))
(list 3))

127
lib/apl/tests/tradfn.sx Normal file
View File

@@ -0,0 +1,127 @@
; Tests for apl-call-tradfn (manual structure construction).
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
(define mknum (fn (n) (list :num n)))
(define mknm (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkasg (fn (n e) (list :assign n e)))
(define mkbr (fn (e) (list :branch e)))
(define mkif (fn (c t e) (list :if c t e)))
(define mkwhile (fn (c b) (list :while c b)))
(define mkfor (fn (v i b) (list :for v i b)))
(define mksel (fn (v cs d) (list :select v cs d)))
(apl-test
"tradfn R←L+W simple add"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7)))
(list 12))
(apl-test
"tradfn R←L×W"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"tradfn monadic R←-W"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
(list -9))
(apl-test
"tradfn →0 exits early"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknm "W")) (mkbr (mknum 0)) (mkasg "R" (mknum 999))) :alpha nil} nil (apl-scalar 7)))
(list 7))
(apl-test
"tradfn branch to line 3 skips line 2"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 3)) (mkasg "R" (mknum 999)) (mkasg "R" (mknum 42))) :alpha nil} nil (apl-scalar 0)))
(list 42))
(apl-test
"tradfn local var t←W+1; R←t×2"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "t" (mkdyd "+" (mknm "W") (mknum 1))) (mkasg "R" (mkdyd "×" (mknm "t") (mknum 2)))) :alpha nil} nil (apl-scalar 5)))
(list 12))
(apl-test
"tradfn vector args"
(mkrv
(apl-call-tradfn
{:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"}
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"tradfn unset result returns nil"
(apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 0))) :alpha nil} nil (apl-scalar 5))
nil)
(apl-test
"tradfn run-off end returns result"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "W") (mknum 3)))) :alpha nil} nil (apl-scalar 7)))
(list 21))
(apl-test
"tradfn loop sum 1+2+...+5 via branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1))) (mkbr (mkdyd "×" (mkdyd "≤" (mknm "i") (mknm "W")) (mknum 3)))) :alpha nil} nil (apl-scalar 5)))
(list 15))
(apl-test
"tradfn :If true branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 1))
(apl-test
"tradfn :If false branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 100)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 0))
(apl-test
"tradfn :While sum 1..N"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkwhile (mkdyd "≤" (mknm "i") (mknm "W")) (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1)))))) :alpha nil} nil (apl-scalar 10)))
(list 55))
(apl-test
"tradfn :For sum elements"
(mkrv
(apl-call-tradfn
{:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil}
nil
(make-array (list 4) (list 10 20 30 40))))
(list 100))
(apl-test
"tradfn :For with empty vector"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 99)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil} nil (make-array (list 0) (list))))
(list 99))
(apl-test
"tradfn :Select dispatch hit"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200))) (list (mknum 3) (mkasg "R" (mknum 300)))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 2)))
(list 200))
(apl-test
"tradfn :Select default block"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200)))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil (apl-scalar 99)))
(list -1))
(apl-test
"tradfn nested :If"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkif (mkdyd ">" (mknm "W") (mknum 10)) (list (mkasg "R" (mknum 2))) (list (mkasg "R" (mknum 1))))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 1))
(apl-test
"tradfn :If assigns persist outside"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 42))) (list)) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 1)))) :alpha nil} nil (apl-scalar 5)))
(list 43))
(apl-test
"tradfn :For factorial 1..5"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 1)) (mkfor "x" (mkmon "⍳" (mknm "W")) (list (mkasg "R" (mkdyd "×" (mknm "R") (mknm "x")))))) :alpha nil} nil (apl-scalar 5)))
(list 120))

81
lib/apl/tests/valence.sx Normal file
View File

@@ -0,0 +1,81 @@
; Tests for valence detection (apl-dfn-valence, apl-tradfn-valence)
; and unified dispatch (apl-call).
(define mkrv (fn (arr) (get arr :ravel)))
(define mknum (fn (n) (list :num n)))
(define mknm (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkasg (fn (n e) (list :assign n e)))
(define mkdfn (fn (stmts) (cons :dfn stmts)))
(apl-test
"dfn-valence niladic body=42"
(apl-dfn-valence (mkdfn (list (mknum 42))))
:niladic)
(apl-test
"dfn-valence monadic body=⍵+1"
(apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1)))))
:monadic)
(apl-test
"dfn-valence dyadic body=⍺+⍵"
(apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵")))))
:dyadic)
(apl-test
"dfn-valence dyadic mentions ⍺ via local"
(apl-dfn-valence (mkdfn (list (mkasg "x" (mknm "⍺")) (mknm "x"))))
:dyadic)
(apl-test
"dfn-valence dyadic deep nest"
(apl-dfn-valence
(mkdfn (list (mkmon "-" (mkdyd "×" (mknm "⍺") (mknm "⍵"))))))
:dyadic)
(apl-test "tradfn-valence niladic" (apl-tradfn-valence {:result "R" :omega nil :stmts (list) :alpha nil}) :niladic)
(apl-test "tradfn-valence monadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha nil}) :monadic)
(apl-test "tradfn-valence dyadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha "L"}) :dyadic)
(apl-test
"apl-call dfn niladic"
(mkrv (apl-call (mkdfn (list (mknum 42))) nil nil))
(list 42))
(apl-test
"apl-call dfn monadic"
(mkrv
(apl-call
(mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1))))
nil
(apl-scalar 5)))
(list 6))
(apl-test
"apl-call dfn dyadic"
(mkrv
(apl-call
(mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵"))))
(apl-scalar 3)
(apl-scalar 4)))
(list 7))
(apl-test
"apl-call tradfn dyadic"
(mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"apl-call tradfn monadic"
(mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
(list -9))
(apl-test
"apl-call tradfn niladic returns nil result"
(apl-call {:result "R" :omega nil :stmts (list) :alpha nil} nil nil)
nil)

168
lib/apl/tokenizer.sx Normal file
View File

@@ -0,0 +1,168 @@
(define apl-glyph-set
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
"∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
"⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
(define apl-glyph?
(fn (ch)
(some (fn (g) (= g ch)) apl-glyph-set)))
(define apl-digit?
(fn (ch)
(and (string? ch) (>= ch "0") (<= ch "9"))))
(define apl-alpha?
(fn (ch)
(and (string? ch)
(or (and (>= ch "a") (<= ch "z"))
(and (>= ch "A") (<= ch "Z"))
(= ch "_")))))
(define apl-tokenize
(fn (source)
(let ((pos 0)
(src-len (len source))
(tokens (list)))
(define tok-push!
(fn (type value)
(append! tokens {:type type :value value})))
(define cur-sw?
(fn (ch)
(and (< pos src-len) (starts-with? (slice source pos) ch))))
(define cur-byte
(fn ()
(if (< pos src-len) (nth source pos) nil)))
(define advance!
(fn ()
(set! pos (+ pos 1))))
(define consume!
(fn (ch)
(set! pos (+ pos (len ch)))))
(define find-glyph
(fn ()
(let ((rem (slice source pos)))
(let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
(if (> (len matches) 0) (first matches) nil)))))
(define read-digits!
(fn (acc)
(if (and (< pos src-len) (apl-digit? (cur-byte)))
(let ((ch (cur-byte)))
(begin
(advance!)
(read-digits! (str acc ch))))
acc)))
(define read-ident-cont!
(fn ()
(when (and (< pos src-len)
(let ((ch (cur-byte)))
(or (apl-alpha? ch) (apl-digit? ch))))
(begin
(advance!)
(read-ident-cont!)))))
(define read-string!
(fn (acc)
(cond
((>= pos src-len) acc)
((cur-sw? "'")
(if (and (< (+ pos 1) src-len) (cur-sw? "'"))
(begin
(advance!)
(advance!)
(read-string! (str acc "'")))
(begin (advance!) acc)))
(true
(let ((ch (cur-byte)))
(begin
(advance!)
(read-string! (str acc ch))))))))
(define skip-line!
(fn ()
(when (and (< pos src-len) (not (cur-sw? "\n")))
(begin
(advance!)
(skip-line!)))))
(define scan!
(fn ()
(when (< pos src-len)
(let ((ch (cur-byte)))
(cond
((or (= ch " ") (= ch "\t") (= ch "\r"))
(begin (advance!) (scan!)))
((= ch "\n")
(begin (advance!) (tok-push! :newline nil) (scan!)))
((cur-sw? "⍝")
(begin (skip-line!) (scan!)))
((cur-sw? "⋄")
(begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
((= ch "(")
(begin (advance!) (tok-push! :lparen nil) (scan!)))
((= ch ")")
(begin (advance!) (tok-push! :rparen nil) (scan!)))
((= ch "[")
(begin (advance!) (tok-push! :lbracket nil) (scan!)))
((= ch "]")
(begin (advance!) (tok-push! :rbracket nil) (scan!)))
((= ch "{")
(begin (advance!) (tok-push! :lbrace nil) (scan!)))
((= ch "}")
(begin (advance!) (tok-push! :rbrace nil) (scan!)))
((= ch ";")
(begin (advance!) (tok-push! :semi nil) (scan!)))
((cur-sw? "←")
(begin (consume! "←") (tok-push! :assign nil) (scan!)))
((= ch ":")
(let ((start pos))
(begin
(advance!)
(if (and (< pos src-len) (apl-alpha? (cur-byte)))
(begin
(read-ident-cont!)
(tok-push! :keyword (slice source start pos)))
(tok-push! :colon nil))
(scan!))))
((and (cur-sw? "¯")
(< (+ pos (len "¯")) src-len)
(apl-digit? (nth source (+ pos (len "¯")))))
(begin
(consume! "¯")
(let ((digits (read-digits! "")))
(tok-push! :num (- 0 (parse-int digits 0))))
(scan!)))
((apl-digit? ch)
(begin
(let ((digits (read-digits! "")))
(tok-push! :num (parse-int digits 0)))
(scan!)))
((= ch "'")
(begin
(advance!)
(let ((s (read-string! "")))
(tok-push! :str s))
(scan!)))
((or (apl-alpha? ch) (cur-sw? "⎕"))
(let ((start pos))
(begin
(if (cur-sw? "⎕") (consume! "⎕") (advance!))
(read-ident-cont!)
(tok-push! :name (slice source start pos))
(scan!))))
(true
(let ((g (find-glyph)))
(if g
(begin (consume! g) (tok-push! :glyph g) (scan!))
(begin (advance!) (scan!))))))))))
(scan!)
tokens)))

371
lib/apl/transpile.sx Normal file
View File

@@ -0,0 +1,371 @@
; APL transpile / AST evaluator
;
; Walks parsed AST nodes and evaluates against the runtime.
; Entry points:
; apl-eval-ast : node × env → value
; apl-eval-stmts : stmt-list × env → value (handles guards, locals, ⍺← default)
; apl-call-dfn : dfn-ast × ⍺ × ⍵ → value (dyadic)
; apl-call-dfn-m : dfn-ast × ⍵ → value (monadic)
;
; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega",
; the dfn-ast itself under "nabla" (for ∇ recursion),
; user names under their literal name.
(define
apl-monadic-fn
(fn
(g)
(cond
((= g "+") apl-plus-m)
((= g "-") apl-neg-m)
((= g "×") apl-signum)
((= g "÷") apl-recip)
((= g "⌈") apl-ceil)
((= g "⌊") apl-floor)
((= g "⍳") apl-iota)
((= g "|") apl-abs)
((= g "*") apl-exp)
((= g "⍟") apl-ln)
((= g "!") apl-fact)
((= g "○") apl-pi-times)
((= g "~") apl-not)
((= g "≢") apl-tally)
((= g "⍴") apl-shape)
((= g "≡") apl-depth)
((= g "⊂") apl-enclose)
((= g "⊃") apl-disclose)
((= g ",") apl-ravel)
((= g "⌽") apl-reverse)
((= g "⊖") apl-reverse-first)
((= g "⍋") apl-grade-up)
((= g "⍒") apl-grade-down)
(else (error "no monadic fn for glyph")))))
(define
apl-dyadic-fn
(fn
(g)
(cond
((= g "+") apl-add)
((= g "-") apl-sub)
((= g "×") apl-mul)
((= g "÷") apl-div)
((= g "⌈") apl-max)
((= g "⌊") apl-min)
((= g "*") apl-pow)
((= g "⍟") apl-log)
((= g "|") apl-mod)
((= g "!") apl-binomial)
((= g "○") apl-trig)
((= g "<") apl-lt)
((= g "≤") apl-le)
((= g "=") apl-eq)
((= g "≥") apl-ge)
((= g ">") apl-gt)
((= g "≠") apl-ne)
((= g "∧") apl-and)
((= g "∨") apl-or)
((= g "⍱") apl-nor)
((= g "⍲") apl-nand)
((= g ",") apl-catenate)
((= g "⍪") apl-catenate-first)
((= g "⍴") apl-reshape)
((= g "↑") apl-take)
((= g "↓") apl-drop)
((= g "⌷") apl-squad)
((= g "⌽") apl-rotate)
((= g "⊖") apl-rotate-first)
((= g "∊") apl-member)
((= g "⍳") apl-index-of)
((= g "~") apl-without)
(else (error "no dyadic fn for glyph")))))
(define
apl-truthy?
(fn
(v)
(let
((rv (get v :ravel)))
(if (and (= (len rv) 1) (= (first rv) 0)) false true))))
(define
apl-eval-ast
(fn
(node env)
(let
((tag (first node)))
(cond
((= tag :num) (apl-scalar (nth node 1)))
((= tag :vec)
(let
((items (rest node)))
(let
((vals (map (fn (n) (apl-eval-ast n env)) items)))
(make-array
(list (len vals))
(map (fn (v) (first (get v :ravel))) vals)))))
((= tag :name)
(let
((nm (nth node 1)))
(cond
((= nm "⍺") (get env "alpha"))
((= nm "⍵") (get env "omega"))
(else (get env nm)))))
((= tag :monad)
(let
((fn-node (nth node 1)) (arg (nth node 2)))
(let
((g (nth fn-node 1)))
(if
(= g "∇")
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
((apl-monadic-fn g) (apl-eval-ast arg env))))))
((= tag :dyad)
(let
((fn-node (nth node 1))
(lhs (nth node 2))
(rhs (nth node 3)))
(let
((g (nth fn-node 1)))
(if
(= g "∇")
(apl-call-dfn
(get env "nabla")
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))
((apl-dyadic-fn g)
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))))))
((= tag :program) (apl-eval-stmts (rest node) env))
((= tag :dfn) node)
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
(define
apl-eval-stmts
(fn
(stmts env)
(if
(= (len stmts) 0)
nil
(let
((stmt (first stmts)) (more (rest stmts)))
(let
((tag (first stmt)))
(cond
((= tag :guard)
(let
((cond-val (apl-eval-ast (nth stmt 1) env)))
(if
(apl-truthy? cond-val)
(apl-eval-ast (nth stmt 2) env)
(apl-eval-stmts more env))))
((and (= tag :assign) (= (nth stmt 1) "⍺"))
(if
(get env "alpha")
(apl-eval-stmts more env)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env "alpha" v)))))
((= tag :assign)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env (nth stmt 1) v))))
((= (len more) 0) (apl-eval-ast stmt env))
(else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env)))))))))
(define
apl-call-dfn
(fn
(dfn-ast alpha omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha}))
(apl-eval-stmts stmts env))))
(define
apl-call-dfn-m
(fn
(dfn-ast omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
(apl-eval-stmts stmts env))))
(define
apl-tradfn-eval-block
(fn
(stmts env)
(if
(= (len stmts) 0)
env
(let
((stmt (first stmts)))
(apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env))))))
(define
apl-tradfn-eval-while
(fn
(cond-expr body env)
(let
((cond-val (apl-eval-ast cond-expr env)))
(if
(apl-truthy? cond-val)
(apl-tradfn-eval-while
cond-expr
body
(apl-tradfn-eval-block body env))
env))))
(define
apl-tradfn-eval-for
(fn
(var-name items body env)
(if
(= (len items) 0)
env
(let
((env-with-var (assoc env var-name (apl-scalar (first items)))))
(apl-tradfn-eval-for
var-name
(rest items)
body
(apl-tradfn-eval-block body env-with-var))))))
(define
apl-tradfn-eval-select
(fn
(val cases default-block env)
(if
(= (len cases) 0)
(apl-tradfn-eval-block default-block env)
(let
((c (first cases)))
(let
((case-val (apl-eval-ast (first c) env)))
(if
(= (first (get val :ravel)) (first (get case-val :ravel)))
(apl-tradfn-eval-block (rest c) env)
(apl-tradfn-eval-select val (rest cases) default-block env)))))))
(define
apl-tradfn-eval-stmt
(fn
(stmt env)
(let
((tag (first stmt)))
(cond
((= tag :assign)
(assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env)))
((= tag :if)
(let
((cond-val (apl-eval-ast (nth stmt 1) env)))
(if
(apl-truthy? cond-val)
(apl-tradfn-eval-block (nth stmt 2) env)
(apl-tradfn-eval-block (nth stmt 3) env))))
((= tag :while)
(apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env))
((= tag :for)
(let
((iter-val (apl-eval-ast (nth stmt 2) env)))
(apl-tradfn-eval-for
(nth stmt 1)
(get iter-val :ravel)
(nth stmt 3)
env)))
((= tag :select)
(let
((val (apl-eval-ast (nth stmt 1) env)))
(apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env)))
(else (begin (apl-eval-ast stmt env) env))))))
(define
apl-tradfn-loop
(fn
(stmts line env result-name)
(cond
((= line 0) (get env result-name))
((> line (len stmts)) (get env result-name))
(else
(let
((stmt (nth stmts (- line 1))))
(let
((tag (first stmt)))
(cond
((= tag :branch)
(let
((target (apl-eval-ast (nth stmt 1) env)))
(let
((target-num (first (get target :ravel))))
(apl-tradfn-loop stmts target-num env result-name))))
(else
(apl-tradfn-loop
stmts
(+ line 1)
(apl-tradfn-eval-stmt stmt env)
result-name)))))))))
(define
apl-call-tradfn
(fn
(tradfn alpha omega)
(let
((stmts (get tradfn :stmts))
(result-name (get tradfn :result))
(alpha-name (get tradfn :alpha))
(omega-name (get tradfn :omega)))
(let
((env-a (if alpha-name (assoc {} alpha-name alpha) {})))
(let
((env-ao (if omega-name (assoc env-a omega-name omega) env-a)))
(apl-tradfn-loop stmts 1 env-ao result-name))))))
(define
apl-ast-mentions-list?
(fn
(lst target)
(if
(= (len lst) 0)
false
(if
(apl-ast-mentions? (first lst) target)
true
(apl-ast-mentions-list? (rest lst) target)))))
(define
apl-ast-mentions?
(fn
(node target)
(cond
((not (list? node)) false)
((= (len node) 0) false)
((and (= (first node) :name) (= (nth node 1) target)) true)
(else (apl-ast-mentions-list? (rest node) target)))))
(define
apl-dfn-valence
(fn
(dfn-ast)
(let
((body (rest dfn-ast)))
(cond
((apl-ast-mentions-list? body "⍺") :dyadic)
((apl-ast-mentions-list? body "⍵") :monadic)
(else :niladic)))))
(define
apl-tradfn-valence
(fn
(tradfn)
(cond
((get tradfn :alpha) :dyadic)
((get tradfn :omega) :monadic)
(else :niladic))))
(define
apl-call
(fn
(f alpha omega)
(cond
((and (list? f) (> (len f) 0) (= (first f) :dfn))
(if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega)))
((dict? f) (apl-call-tradfn f alpha omega))
(else (error "apl-call: not a function")))))