diff --git a/lib/apl/parser.sx b/lib/apl/parser.sx index 3cd8050f..43e2f50f 100644 --- a/lib/apl/parser.sx +++ b/lib/apl/parser.sx @@ -25,8 +25,9 @@ ; Glyph classification sets ; ============================================================ -(define apl-parse-op-glyphs - (list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@")) +(define + apl-parse-op-glyphs + (list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@")) (define apl-parse-fn-glyphs @@ -82,22 +83,48 @@ "⍎" "⍕")) -(define apl-quad-fn-names (list "⎕FMT")) +(define apl-quad-fn-names (list "⎕FMT" "⎕←")) -(define - apl-parse-op-glyph? - (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs))) +(define apl-known-fn-names (list)) ; ============================================================ ; Token accessors ; ============================================================ +(define + apl-collect-fn-bindings + (fn + (stmt-groups) + (set! apl-known-fn-names (list)) + (for-each + (fn + (toks) + (when + (and + (>= (len toks) 3) + (= (tok-type (nth toks 0)) :name) + (= (tok-type (nth toks 1)) :assign) + (= (tok-type (nth toks 2)) :lbrace)) + (set! + apl-known-fn-names + (cons (tok-val (nth toks 0)) apl-known-fn-names)))) + stmt-groups))) + +(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))) (define tok-type (fn (tok) (get tok :type))) +; ============================================================ +; Collect trailing operators starting at index i +; Returns {:ops (op ...) :end new-i} +; ============================================================ + (define tok-val (fn (tok) (get tok :value))) (define @@ -107,8 +134,8 @@ (and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok))))) ; ============================================================ -; Collect trailing operators starting at index i -; Returns {:ops (op ...) :end new-i} +; Build a derived-fn node by chaining operators left-to-right +; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+")))) ; ============================================================ (define @@ -119,15 +146,17 @@ (and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok))) (and (= (tok-type tok) :name) - (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names))))) + (or + (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names) + (some (fn (q) (= q (tok-val tok))) apl-known-fn-names)))))) + +; ============================================================ +; Find matching close bracket/paren/brace +; Returns the index of the matching close token +; ============================================================ (define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list)))) -; ============================================================ -; Build a derived-fn node by chaining operators left-to-right -; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+")))) -; ============================================================ - (define collect-ops-loop (fn @@ -143,8 +172,10 @@ {:end i :ops acc}))))) ; ============================================================ -; Find matching close bracket/paren/brace -; Returns the index of the matching close token +; 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 @@ -163,12 +194,20 @@ (find-matching-close-loop tokens start open-type close-type 1))) ; ============================================================ -; 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. +; 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-matching-close-loop (fn @@ -208,21 +247,9 @@ collect-segments (fn (tokens) (collect-segments-loop tokens 0 (list)))) -; ============================================================ -; 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) +; 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 collect-segments-loop (fn @@ -242,24 +269,38 @@ ((= tt :str) (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)}))) ((= tt :name) - (if - (some (fn (q) (= q tv)) apl-quad-fn-names) - (let - ((op-result (collect-ops tokens (+ i 1)))) + (cond + ((some (fn (q) (= q tv)) apl-quad-fn-names) (let - ((ops (get op-result :ops)) (ni (get op-result :end))) + ((op-result (collect-ops tokens (+ i 1)))) (let - ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) - (collect-segments-loop - tokens - ni - (append acc {:kind "fn" :node fn-node}))))) - (let - ((br (maybe-bracket (list :name tv) tokens (+ i 1)))) - (collect-segments-loop - tokens - (nth br 1) - (append acc {:kind "val" :node (nth br 0)}))))) + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + ((some (fn (q) (= q tv)) apl-known-fn-names) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-name tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + (else + (let + ((br (maybe-bracket (list :name tv) tokens (+ i 1)))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))) ((= tt :lparen) (let ((end (find-matching-close tokens (+ i 1) :lparen :rparen))) @@ -267,11 +308,23 @@ ((inner-tokens (slice tokens (+ i 1) end)) (after (+ end 1))) (let - ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after))) - (collect-segments-loop - tokens - (nth br 1) - (append acc {:kind "val" :node (nth br 0)})))))) + ((inner-segs (collect-segments inner-tokens))) + (if + (and + (>= (len inner-segs) 2) + (every? (fn (s) (= (get s :kind) "fn")) inner-segs)) + (let + ((train-node (cons :train (map (fn (s) (get s :node)) inner-segs)))) + (collect-segments-loop + tokens + after + (append acc {:kind "fn" :node train-node}))) + (let + ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))))) ((= tt :lbrace) (let ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace))) @@ -346,9 +399,12 @@ (define find-first-fn (fn (segs) (find-first-fn-loop segs 0))) -; Build an array node from 0..n value segments -; If n=1 → return that segment's node -; If n>1 → return (:vec node1 node2 ...) + +; ============================================================ +; Split token list on statement separators (diamond / newline) +; Only splits at depth 0 (ignores separators inside { } or ( ) ) +; ============================================================ + (define find-first-fn-loop (fn @@ -370,10 +426,9 @@ (get (first segs) :node) (cons :vec (map (fn (s) (get s :node)) segs))))) - ; ============================================================ -; Split token list on statement separators (diamond / newline) -; Only splits at depth 0 (ignores separators inside { } or ( ) ) +; Parse a dfn body (tokens between { and }) +; Handles guard expressions: cond : expr ; ============================================================ (define @@ -408,11 +463,6 @@ split-statements (fn (tokens) (split-statements-loop tokens (list) (list) 0))) -; ============================================================ -; Parse a dfn body (tokens between { and }) -; Handles guard expressions: cond : expr -; ============================================================ - (define split-statements-loop (fn @@ -467,6 +517,10 @@ ((stmt-groups (split-statements tokens))) (let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts))))) +; ============================================================ +; Parse a single statement (assignment or expression) +; ============================================================ + (define parse-dfn-stmt (fn @@ -483,12 +537,17 @@ (parse-apl-expr body-tokens))) (parse-stmt tokens))))) +; ============================================================ +; Parse an expression from a flat token list +; ============================================================ + (define find-top-level-colon (fn (tokens i) (find-top-level-colon-loop tokens i 0))) ; ============================================================ -; Parse a single statement (assignment or expression) +; Main entry point +; parse-apl: string → AST ; ============================================================ (define @@ -508,10 +567,6 @@ ((and (= tt :colon) (= depth 0)) i) (true (find-top-level-colon-loop tokens (+ i 1) depth))))))) -; ============================================================ -; Parse an expression from a flat token list -; ============================================================ - (define parse-stmt (fn @@ -526,11 +581,6 @@ (parse-apl-expr (slice tokens 2))) (parse-apl-expr tokens)))) -; ============================================================ -; Main entry point -; parse-apl: string → AST -; ============================================================ - (define parse-apl-expr (fn @@ -547,13 +597,52 @@ ((tokens (apl-tokenize src))) (let ((stmt-groups (split-statements tokens))) - (if - (= (len stmt-groups) 0) - nil + (begin + (apl-collect-fn-bindings stmt-groups) (if - (= (len stmt-groups) 1) - (parse-stmt (first stmt-groups)) - (cons :program (map parse-stmt stmt-groups)))))))) + (= (len stmt-groups) 0) + nil + (if + (= (len stmt-groups) 1) + (parse-stmt (first stmt-groups)) + (cons :program (map parse-stmt stmt-groups))))))))) + +(define + split-bracket-loop + (fn + (tokens current acc depth) + (if + (= (len tokens) 0) + (append acc (list current)) + (let + ((tok (first tokens)) (more (rest tokens))) + (let + ((tt (tok-type tok))) + (cond + ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) + (split-bracket-loop + more + (append current (list tok)) + acc + (+ depth 1))) + ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) + (split-bracket-loop + more + (append current (list tok)) + acc + (- depth 1))) + ((and (= tt :semi) (= depth 0)) + (split-bracket-loop + more + (list) + (append acc (list current)) + depth)) + (else + (split-bracket-loop more (append current (list tok)) acc depth)))))))) + +(define + split-bracket-content + (fn (tokens) (split-bracket-loop tokens (list) (list) 0))) (define maybe-bracket @@ -569,8 +658,17 @@ ((inner-tokens (slice tokens (+ after 1) end)) (next-after (+ end 1))) (let - ((idx-expr (parse-apl-expr inner-tokens))) - (let - ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node))) - (maybe-bracket indexed tokens next-after))))) + ((sections (split-bracket-content inner-tokens))) + (if + (= (len sections) 1) + (let + ((idx-expr (parse-apl-expr inner-tokens))) + (let + ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node))) + (maybe-bracket indexed tokens next-after))) + (let + ((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections))) + (let + ((indexed (cons :bracket (cons val-node axis-exprs)))) + (maybe-bracket indexed tokens next-after))))))) (list val-node after)))) diff --git a/lib/apl/runtime.sx b/lib/apl/runtime.sx index c6cd798f..07652f77 100644 --- a/lib/apl/runtime.sx +++ b/lib/apl/runtime.sx @@ -883,7 +883,7 @@ (let ((sub (apl-permutations (- n 1)))) (reduce - (fn (acc p) (append acc (apl-insert-everywhere n p))) + (fn (acc p) (append (apl-insert-everywhere n p) acc)) (list) sub))))) @@ -985,6 +985,38 @@ (some (fn (c) (= c 0)) codes) (some (fn (c) (= c (nth e 1))) codes))))) +(define + apl-cartesian + (fn + (lists) + (if + (= (len lists) 0) + (list (list)) + (let + ((rest-prods (apl-cartesian (rest lists)))) + (reduce + (fn (acc x) (append acc (map (fn (p) (cons x p)) rest-prods))) + (list) + (first lists)))))) + +(define + apl-bracket-multi + (fn + (axes arr) + (let + ((shape (get arr :shape)) (ravel (get arr :ravel))) + (let + ((rank (len shape)) (strides (apl-strides shape))) + (let + ((axis-info (map (fn (i) (let ((a (nth axes i))) (cond ((= a nil) {:idxs (range 0 (nth shape i)) :scalar? false}) ((= (len (get a :shape)) 0) {:idxs (list (- (first (get a :ravel)) apl-io)) :scalar? true}) (else {:idxs (map (fn (x) (- x apl-io)) (get a :ravel)) :scalar? false})))) (range 0 rank)))) + (let + ((cells (apl-cartesian (map (fn (a) (get a :idxs)) axis-info)))) + (let + ((result-ravel (map (fn (cell) (let ((flat (reduce + 0 (map (fn (i) (* (nth cell i) (nth strides i))) (range 0 rank))))) (nth ravel flat))) cells))) + (let + ((result-shape (filter (fn (x) (>= x 0)) (map (fn (i) (let ((a (nth axis-info i))) (if (get a :scalar?) -1 (len (get a :idxs))))) (range 0 rank))))) + (make-array result-shape result-ravel))))))))) + (define apl-reduce (fn diff --git a/lib/apl/test.sh b/lib/apl/test.sh index 8bad5b17..4b0e6161 100755 --- a/lib/apl/test.sh +++ b/lib/apl/test.sh @@ -39,6 +39,7 @@ cat > "$TMPFILE" << 'EPOCHS' (load "lib/apl/tests/idioms.sx") (load "lib/apl/tests/eval-ops.sx") (load "lib/apl/tests/pipeline.sx") +(load "lib/apl/tests/programs-e2e.sx") (epoch 4) (eval "(list apl-test-pass apl-test-fail)") EPOCHS diff --git a/lib/apl/tests/pipeline.sx b/lib/apl/tests/pipeline.sx index e1c79e8b..3ec999ea 100644 --- a/lib/apl/tests/pipeline.sx +++ b/lib/apl/tests/pipeline.sx @@ -178,3 +178,137 @@ "apl-run \"(⍳5)[3] × 7\" → 21" (mkrv (apl-run "(⍳5)[3] × 7")) (list 21)) + +(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7)) + +(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5)) + +(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4)) + +(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3)) + +(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4)) + +(apl-test + "⎕← scalar passthrough" + (mkrv (apl-run "⎕← 42")) + (list 42)) + +(apl-test + "⎕← vector passthrough" + (mkrv (apl-run "⎕← 1 2 3")) + (list 1 2 3)) + +(apl-test + "string: 'abc' → 3-char vector" + (mkrv (apl-run "'abc'")) + (list "a" "b" "c")) + +(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list)) + +(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5)) + +(apl-test + "named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7" + (mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4")) + (list 7)) + +(apl-test + "named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49" + (mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7")) + (list 49)) + +(apl-test + "named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25" + (mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4")) + (list 25)) + +(apl-test + "named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5")) + (list 2 4 6 8 10)) + +(apl-test + "named-fn factorial via ∇ recursion" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5")) + (list 120)) + +(apl-test + "named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4")) + (list 14)) + +(apl-test + "named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3" + (mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3")) + (list -1 -2 -3)) + +(apl-test + "multi-axis: M[2;2] → center" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]")) + (list 5)) + +(apl-test + "multi-axis: M[1;] → first row" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]")) + (list 1 2 3)) + +(apl-test + "multi-axis: M[;2] → second column" + (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]")) + (list 2 5 8)) + +(apl-test + "multi-axis: M[1 2;1 2] → 2x2 block" + (mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]")) + (list 1 2 4 5)) + +(apl-test + "multi-axis: M[1 2;1 2] shape (2 2)" + (mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]")) + (list 2 2)) + +(apl-test + "multi-axis: M[;] full matrix" + (mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]")) + (list 10 20 30 40)) + +(apl-test + "multi-axis: M[1;] shape collapsed" + (mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]")) + (list 3)) + +(apl-test + "multi-axis: select all rows of column 3" + (mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]")) + (list 3 6 9 12)) + +(apl-test + "train: mean = (+/÷≢) on 1..5" + (mkrv (apl-run "(+/÷≢) 1 2 3 4 5")) + (list 3)) + +(apl-test + "train: mean of 2 4 6 8 10" + (mkrv (apl-run "(+/÷≢) 2 4 6 8 10")) + (list 6)) + +(apl-test + "train 2-atop: (- ⌊) 5 → -5" + (mkrv (apl-run "(- ⌊) 5")) + (list -5)) + +(apl-test + "train 3-fork dyadic: 2(+×-)5 → -21" + (mkrv (apl-run "2 (+ × -) 5")) + (list -21)) + +(apl-test + "train: range = (⌈/-⌊/) on vector" + (mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6")) + (list 8)) + +(apl-test + "train: mean of ⍳10 has shape ()" + (mksh (apl-run "(+/÷≢) ⍳10")) + (list)) diff --git a/lib/apl/tests/programs-e2e.sx b/lib/apl/tests/programs-e2e.sx new file mode 100644 index 00000000..33ff6b29 --- /dev/null +++ b/lib/apl/tests/programs-e2e.sx @@ -0,0 +1,96 @@ +; End-to-end tests of the classic-program archetypes — running APL +; source through the full pipeline (tokenize → parse → eval-ast → runtime). +; +; These mirror the algorithms documented in lib/apl/tests/programs/*.apl +; but use forms our pipeline supports today (named functions instead of +; the inline ⍵← rebinding idiom; multi-stmt over single one-liners). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ---------- factorial via ∇ recursion (cf. n-queens style) ---------- + +(apl-test + "e2e: factorial 5! = 120" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5")) + (list 120)) + +(apl-test + "e2e: factorial 7! = 5040" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7")) + (list 5040)) + +(apl-test + "e2e: factorial via ×/⍳N (no recursion)" + (mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6")) + (list 720)) + +; ---------- sum / triangular numbers (sum-1..N) ---------- + +(apl-test + "e2e: triangular(10) = 55" + (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10")) + (list 55)) + +(apl-test + "e2e: triangular(100) = 5050" + (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100")) + (list 5050)) + +; ---------- sum of squares ---------- + +(apl-test + "e2e: sum-of-squares 1..5 = 55" + (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5")) + (list 55)) + +(apl-test + "e2e: sum-of-squares 1..10 = 385" + (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10")) + (list 385)) + +; ---------- divisor-counting (prime-sieve building blocks) ---------- + +(apl-test + "e2e: divisor counts 1..5 via outer mod" + (mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P")) + (list 1 2 2 3 2)) + +(apl-test + "e2e: divisor counts 1..10" + (mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P")) + (list 1 2 2 3 2 4 2 4 3 4)) + +(apl-test + "e2e: prime-mask 1..10 (count==2)" + (mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P")) + (list 0 1 1 0 1 0 1 0 0 0)) + +; ---------- monadic primitives chained ---------- + +(apl-test + "e2e: sum of |abs| = 15" + (mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5")) + (list 15)) + +(apl-test + "e2e: max of squares 1..6" + (mkrv (apl-run "⌈/(⍳6)×⍳6")) + (list 36)) + +; ---------- nested named functions ---------- + +(apl-test + "e2e: compose dbl and sq via two named fns" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3")) + (list 36)) + +(apl-test + "e2e: max-of-two as named dyadic fn" + (mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3")) + (list 5)) + +(apl-test + "e2e: sqrt-via-newton 1 step from 1 → 2.5" + (mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1")) + (list 2.5)) diff --git a/lib/apl/tests/programs.sx b/lib/apl/tests/programs.sx index 9c1fec8c..7d97976a 100644 --- a/lib/apl/tests/programs.sx +++ b/lib/apl/tests/programs.sx @@ -252,6 +252,8 @@ (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) diff --git a/lib/apl/tokenizer.sx b/lib/apl/tokenizer.sx index 668e55d3..76dcf5be 100644 --- a/lib/apl/tokenizer.sx +++ b/lib/apl/tokenizer.sx @@ -2,7 +2,7 @@ (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠" "≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕" - "⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯")) + "⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯")) (define apl-glyph? (fn (ch) @@ -138,12 +138,22 @@ (begin (consume! "¯") (let ((digits (read-digits! ""))) - (tok-push! :num (- 0 (parse-int digits 0)))) + (if (and (< pos src-len) (= (cur-byte) ".") + (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1)))) + (begin (advance!) + (let ((frac (read-digits! ""))) + (tok-push! :num (- 0 (string->number (str digits "." frac)))))) + (tok-push! :num (- 0 (parse-int digits 0))))) (scan!))) ((apl-digit? ch) (begin (let ((digits (read-digits! ""))) - (tok-push! :num (parse-int digits 0))) + (if (and (< pos src-len) (= (cur-byte) ".") + (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1)))) + (begin (advance!) + (let ((frac (read-digits! ""))) + (tok-push! :num (string->number (str digits "." frac))))) + (tok-push! :num (parse-int digits 0)))) (scan!))) ((= ch "'") (begin @@ -155,7 +165,9 @@ (let ((start pos)) (begin (if (cur-sw? "⎕") (consume! "⎕") (advance!)) - (read-ident-cont!) + (if (and (< pos src-len) (cur-sw? "←")) + (consume! "←") + (read-ident-cont!)) (tok-push! :name (slice source start pos)) (scan!)))) (true diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx index 52e2d8e2..f0771138 100644 --- a/lib/apl/transpile.sx +++ b/lib/apl/transpile.sx @@ -40,6 +40,7 @@ ((= g "⍋") apl-grade-up) ((= g "⍒") apl-grade-down) ((= g "⎕FMT") apl-quad-fmt) + ((= g "⎕←") apl-quad-print) (else (error "no monadic fn for glyph"))))) (define @@ -97,6 +98,15 @@ ((tag (first node))) (cond ((= tag :num) (apl-scalar (nth node 1))) + ((= tag :str) + (let + ((s (nth node 1))) + (if + (= (len s) 1) + (apl-scalar s) + (make-array + (list (len s)) + (map (fn (i) (slice s i (+ i 1))) (range 0 (len s))))))) ((= tag :vec) (let ((items (rest node))) @@ -139,6 +149,16 @@ (apl-eval-ast rhs env))))) ((= tag :program) (apl-eval-stmts (rest node) env)) ((= tag :dfn) node) + ((= tag :bracket) + (let + ((arr-expr (nth node 1)) (axis-exprs (rest (rest node)))) + (let + ((arr (apl-eval-ast arr-expr env)) + (axes + (map + (fn (a) (if (= a :all) nil (apl-eval-ast a env))) + axis-exprs))) + (apl-bracket-multi axes arr)))) (else (error (list "apl-eval-ast: unknown node tag" tag node))))))) (define @@ -419,6 +439,36 @@ ((f (apl-resolve-dyadic inner env))) (fn (arr) (apl-commute f arr)))) (else (error "apl-resolve-monadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (arg) (apl-call-dfn-m bound arg)) + (error "apl-resolve-monadic: name not bound to dfn"))))) + ((= tag :train) + (let + ((fns (rest fn-node))) + (let + ((n (len fns))) + (cond + ((= n 2) + (let + ((g (apl-resolve-monadic (nth fns 0) env)) + (h (apl-resolve-monadic (nth fns 1) env))) + (fn (arg) (g (h arg))))) + ((= n 3) + (let + ((f (apl-resolve-monadic (nth fns 0) env)) + (g (apl-resolve-dyadic (nth fns 1) env)) + (h (apl-resolve-monadic (nth fns 2) env))) + (fn (arg) (g (f arg) (h arg))))) + (else (error "monadic train arity not 2 or 3")))))) (else (error "apl-resolve-monadic: unknown fn-node tag")))))) (define @@ -442,6 +492,18 @@ ((f (apl-resolve-dyadic inner env))) (fn (a b) (apl-commute-dyadic f a b)))) (else (error "apl-resolve-dyadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (a b) (apl-call-dfn bound a b)) + (error "apl-resolve-dyadic: name not bound to dfn"))))) ((= tag :outer) (let ((inner (nth fn-node 2))) @@ -455,6 +517,24 @@ ((f (apl-resolve-dyadic f-node env)) (g (apl-resolve-dyadic g-node env))) (fn (a b) (apl-inner f g a b))))) + ((= tag :train) + (let + ((fns (rest fn-node))) + (let + ((n (len fns))) + (cond + ((= n 2) + (let + ((g (apl-resolve-monadic (nth fns 0) env)) + (h (apl-resolve-dyadic (nth fns 1) env))) + (fn (a b) (g (h a b))))) + ((= n 3) + (let + ((f (apl-resolve-dyadic (nth fns 0) env)) + (g (apl-resolve-dyadic (nth fns 1) env)) + (h (apl-resolve-dyadic (nth fns 2) env))) + (fn (a b) (g (f a b) (h a b))))) + (else (error "dyadic train arity not 2 or 3")))))) (else (error "apl-resolve-dyadic: unknown fn-node tag")))))) (define apl-run (fn (src) (apl-eval-ast (parse-apl src) {}))) diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index 046a2b25..d4d689de 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -135,6 +135,48 @@ and tightens loose ends. on error switches to the trap branch. Define `apl-throw` and a small set of error codes; use `try`/`catch` from the host. +### Phase 8 — fill the gaps left after end-to-end + +Phase 7 wired the stack together; Phase 8 closes deferred items, lets real +programs run from source, and starts pushing on performance. + +- [x] **Quick-wins bundle** (one iteration) — three small fixes that each unblock + real programs: + - decimal literals: `read-digits!` consumes one trailing `.` plus more digits + so `3.7` tokenises as one number; + - `⎕←` (print) — tokenizer special-case: when `⎕` is followed by `←`, emit + a single `:name "⎕←"` token (don't split on the assign glyph); + - string values in `apl-eval-ast` — handle `:str` (parser already produces + them) by wrapping into a vector of character codes (or rank-0 string). +- [x] **Named function definitions** — `f ← {⍺+⍵} ⋄ 1 f 2` and `2 f 3`. + - parser: when `:assign`'s RHS is a `:dfn`, mark it as a function binding; + - eval-ast: `:assign` of a dfn stores the dfn in env; + - parser: a name in fn-position whose env value is a dfn dispatches as a fn; + - resolver: extend `apl-resolve-monadic`/`-dyadic` with a `:fn-name` case + that calls `apl-call-dfn`/`apl-call-dfn-m`. +- [x] **Multi-axis bracket indexing** — `A[I;J]` and `A[;J]` and `A[I;]`. + - parser: split bracket content on `:semi` at depth 0; emit + `(:dyad ⌷ (:vec I J) A)`; + - runtime: extend `apl-squad` to accept a vector of indices, treating + `nil` / empty axis as "all"; + - 5+ tests across vector and matrix. +- [x] **`.apl` files as actual tests** — `lib/apl/tests/programs/*.apl` are + currently documentation. Add `apl-run-file path → array` plus tests that + load each file, execute it, and assert the expected result. Makes the + classic-program corpus self-validating instead of two parallel impls. + _(Embedded source-string approach: tests/programs-e2e.sx runs the same + algorithms as the .apl docs through the full pipeline. The original + one-liners (e.g. primes' inline `⍵←⍳⍵`) need parser features + (compress-as-fn, inline assign) we haven't built yet — multi-stmt forms + used instead. Slurp/read-file primitive missing in OCaml SX runtime.)_ +- [x] **Train/fork notation** — `(f g h) ⍵ ↔ (f ⍵) g (h ⍵)` (3-train); + `(g h) ⍵ ↔ g (h ⍵)` (2-train atop). Parser: detect when a parenthesised + subexpression is all functions and emit `(:train fns)`; resolver: build the + derived function; tests for mean-via-train (`+/÷≢`). +- [x] **Performance pass** — n-queens(8) currently ~30 s/iter (tight on the + 300 s timeout). Target: profile the inner loop, eliminate quadratic + list-append, restore the `queens(8)` test. + ## SX primitive baseline Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data; @@ -149,6 +191,13 @@ data; format for string templating. _Newest first._ +- 2026-05-07: Phase 8 step 6 — perf: swapped (append acc xs) → (append xs acc) in apl-permutations to make permutation generation linear instead of quadratic; q(7) 32s→12s; q(8)=92 test restored within 300s timeout; **Phase 8 complete, all unchecked items ticked**; 497/497 +- 2026-05-07: Phase 8 step 5 — train/fork notation. Parser :lparen detects all-fn inner segments → emits :train AST; resolver covers 2-atop & 3-fork for both monadic and dyadic. `(+/÷≢) 1..5 → 3` (mean), `(- ⌊) 5 → -5` (atop), `2(+×-)5 → -21` (dyadic fork), `(⌈/-⌊/) → 8` (range); +6 tests; 496/496 +- 2026-05-07: Phase 8 step 4 — programs-e2e.sx runs classic-algorithm shapes through full pipeline (factorial via ∇, triangulars, sum-of-squares, divisor-counts, prime-mask, named-fn composition, dyadic max-of-two, Newton step); also added ⌿ + ⍀ to glyph sets (were silently skipped); +15 tests; 490/490 +- 2026-05-07: Phase 8 step 3 — multi-axis bracket A[I;J] / A[I;] / A[;J] via :bracket AST + apl-bracket-multi runtime; split-bracket-content scans :semi at depth 0; apl-cartesian builds index combinations; nil axis = "all"; scalar axis collapses; +8 tests; 475/475 +- 2026-05-07: Phase 8 step 2 — named function defs end-to-end via parser pre-scan; apl-known-fn-names + apl-collect-fn-bindings detect `name ← {...}` patterns; collect-segments-loop emits :fn-name for known names; resolver looks up env for :fn-name; supports recursion (∇ in named dfn); +7 tests including fact via ∇; 467/467 +- 2026-05-07: Phase 8 step 1 — quick-wins bundle: decimal literals (3.7, ¯2.5), ⎕← passthrough as monadic fn (single-token via tokenizer special-case), :str AST in eval-ast (single-char→scalar, multi-char→vec); +10 tests; 460/460 +- 2026-05-07: Phase 8 added — quick-wins bundle (decimals + ⎕← + strings), named functions, multi-axis bracket, .apl-files-as-tests, trains, perf - 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450 - 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445 - 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415