GUEST-plan: deferred work shipped — pieces A B C D

Replace the single-pass body run with table-2-slg-iter / table-3-slg-iter:
each iteration stores the current vals in cache and re-runs the body;
loop until vals length stops growing. The cache thus grows
monotonically until no new answers appear.

For simple cycles (single tabled relation) this is sound and
terminating — len comparison is O(1) and the cache only grows.

Limitation: mutually-recursive tabled relations have INDEPENDENT
iteration loops. Each runs to its own fixed point in isolation; the
two don't coordinate. True SLG uses a worklist that cross-fires
re-iteration when any subgoal's cache grows. Left as a future
refinement.

All 5 SLG tests still pass (Fibonacci unchanged, 3 cyclic-patho
cases unchanged).

lib/apl/parser.sx

@@ -25,9 +25,8 @@
 ; Glyph classification sets
 ; ============================================================
 
-(define
+(define apl-parse-op-glyphs
-  apl-parse-op-glyphs
+  (list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
-  (list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
 
 (define
   apl-parse-fn-glyphs
@@ -83,48 +82,22 @@
     "⍎"
     "⍕"))
 
-(define apl-quad-fn-names (list "⎕FMT" "⎕←"))
+(define apl-quad-fn-names (list "⎕FMT"))
 
-(define apl-known-fn-names (list))
+(define
+  apl-parse-op-glyph?
+  (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
 
 ; ============================================================
 ; 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
@@ -134,8 +107,8 @@
     (and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
 
 ; ============================================================
-; Build a derived-fn node by chaining operators left-to-right
+; Collect trailing operators starting at index i
-; (+/¨  →  (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
+; Returns {:ops (op ...) :end new-i}
 ; ============================================================
 
 (define
@@ -146,17 +119,15 @@
       (and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
       (and
         (= (tok-type tok) :name)
-        (or
+        (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)))))
-          (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
@@ -172,10 +143,8 @@
           {:end i :ops acc})))))
 
 ; ============================================================
-; Segment collection: scan tokens left-to-right, building
+; Find matching close bracket/paren/brace
-; a list of {:kind "val"/"fn" :node ast} segments.
+; Returns the index of the matching close token
-; Operators following function glyphs are merged into
-; derived-fn nodes during this pass.
 ; ============================================================
 
 (define
@@ -194,20 +163,12 @@
     (find-matching-close-loop tokens start open-type close-type 1)))
 
 ; ============================================================
-; Build tree from segment list
+; Segment collection: scan tokens left-to-right, building
-;
+; a list of {:kind "val"/"fn" :node ast} segments.
-; The segments are in left-to-right order.
+; Operators following function glyphs are merged into
-; APL evaluates right-to-left, so the LEFTMOST function is
+; derived-fn nodes during this pass.
-; 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
@@ -247,9 +208,21 @@
   collect-segments
   (fn (tokens) (collect-segments-loop tokens 0 (list))))
 
-; Build an array node from 0..n value segments
+; ============================================================
-; If n=1 → return that segment's node
+; Build tree from segment list
-; If n>1 → return (:vec node1 node2 ...)
+;
+; 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
   collect-segments-loop
   (fn
@@ -269,38 +242,24 @@
             ((= tt :str)
               (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
             ((= tt :name)
-              (cond
+              (if
-                ((some (fn (q) (= q tv)) apl-quad-fn-names)
+                (some (fn (q) (= q tv)) apl-quad-fn-names)
+                (let
+                  ((op-result (collect-ops tokens (+ i 1))))
                   (let
-                    ((op-result (collect-ops tokens (+ i 1))))
+                    ((ops (get op-result :ops)) (ni (get op-result :end)))
                     (let
-                      ((ops (get op-result :ops))
+                      ((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
-                        (ni (get op-result :end)))
+                      (collect-segments-loop
-                      (let
+                        tokens
-                        ((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
+                        ni
-                        (collect-segments-loop
+                        (append acc {:kind "fn" :node fn-node})))))
-                          tokens
+                (let
-                          ni
+                  ((br (maybe-bracket (list :name tv) tokens (+ i 1))))
-                          (append acc {:kind "fn" :node fn-node}))))))
+                  (collect-segments-loop
-                ((some (fn (q) (= q tv)) apl-known-fn-names)
+                    tokens
-                  (let
+                    (nth br 1)
-                    ((op-result (collect-ops tokens (+ i 1))))
+                    (append acc {:kind "val" :node (nth br 0)})))))
-                    (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)))
@@ -308,23 +267,11 @@
                   ((inner-tokens (slice tokens (+ i 1) end))
                     (after (+ end 1)))
                   (let
-                    ((inner-segs (collect-segments inner-tokens)))
+                    ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
-                    (if
+                    (collect-segments-loop
-                      (and
+                      tokens
-                        (>= (len inner-segs) 2)
+                      (nth br 1)
-                        (every? (fn (s) (= (get s :kind) "fn")) inner-segs))
+                      (append acc {:kind "val" :node (nth br 0)}))))))
-                      (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)))
@@ -399,12 +346,9 @@
 
 (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
-; Split token list on statement separators (diamond / newline)
+; If n>1 → return (:vec node1 node2 ...)
-; Only splits at depth 0 (ignores separators inside { } or ( ) )
-; ============================================================
-
 (define
   find-first-fn-loop
   (fn
@@ -426,9 +370,10 @@
       (get (first segs) :node)
       (cons :vec (map (fn (s) (get s :node)) segs)))))
 
+
 ; ============================================================
-; Parse a dfn body (tokens between { and })
+; Split token list on statement separators (diamond / newline)
-; Handles guard expressions: cond : expr
+; Only splits at depth 0 (ignores separators inside { } or ( ) )
 ; ============================================================
 
 (define
@@ -463,6 +408,11 @@
   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
@@ -517,10 +467,6 @@
       ((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
@@ -537,17 +483,12 @@
             (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)))
 
 ; ============================================================
-; Main entry point
+; Parse a single statement (assignment or expression)
-; parse-apl: string → AST
 ; ============================================================
 
 (define
@@ -567,6 +508,10 @@
           ((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
@@ -581,6 +526,11 @@
         (parse-apl-expr (slice tokens 2)))
       (parse-apl-expr tokens))))
 
+; ============================================================
+; Main entry point
+; parse-apl: string → AST
+; ============================================================
+
 (define
   parse-apl-expr
   (fn
@@ -597,52 +547,13 @@
       ((tokens (apl-tokenize src)))
       (let
         ((stmt-groups (split-statements tokens)))
-        (begin
+        (if
-          (apl-collect-fn-bindings stmt-groups)
+          (= (len stmt-groups) 0)
+          nil
           (if
-            (= (len stmt-groups) 0)
+            (= (len stmt-groups) 1)
-            nil
+            (parse-stmt (first stmt-groups))
-            (if
+            (cons :program (map parse-stmt stmt-groups))))))))
-              (= (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
@@ -658,17 +569,8 @@
           ((inner-tokens (slice tokens (+ after 1) end))
             (next-after (+ end 1)))
           (let
-            ((sections (split-bracket-content inner-tokens)))
+            ((idx-expr (parse-apl-expr inner-tokens)))
-            (if
+            (let
-              (= (len sections) 1)
+              ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
-              (let
+              (maybe-bracket indexed tokens next-after)))))
-                ((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))))

lib/apl/runtime.sx

@@ -883,7 +883,7 @@
       (let
         ((sub (apl-permutations (- n 1))))
         (reduce
-          (fn (acc p) (append (apl-insert-everywhere n p) acc))
+          (fn (acc p) (append acc (apl-insert-everywhere n p)))
           (list)
           sub)))))
 
@@ -985,38 +985,6 @@
         (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

lib/apl/test.sh

@@ -39,7 +39,6 @@ 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

lib/apl/tests/pipeline.sx

@@ -178,137 +178,3 @@
   "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))

lib/apl/tests/programs-e2e.sx

@@ -1,96 +0,0 @@
-; 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))

lib/apl/tests/programs.sx

@@ -252,8 +252,6 @@
 
 (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)

lib/apl/tokenizer.sx

@@ -2,7 +2,7 @@
   (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
         "≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
         "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
-        "⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
+        "⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
 
 (define apl-glyph?
   (fn (ch)
@@ -138,22 +138,12 @@
                  (begin
                    (consume! "¯")
                    (let ((digits (read-digits! "")))
-                     (if (and (< pos src-len) (= (cur-byte) ".")
+                     (tok-push! :num (- 0 (parse-int digits 0))))
-                              (< (+ 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! "")))
-                     (if (and (< pos src-len) (= (cur-byte) ".")
+                     (tok-push! :num (parse-int digits 0)))
-                              (< (+ 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
@@ -165,9 +155,7 @@
                  (let ((start pos))
                    (begin
                      (if (cur-sw? "⎕") (consume! "⎕") (advance!))
-                     (if (and (< pos src-len) (cur-sw? "←"))
+                     (read-ident-cont!)
-                       (consume! "←")
-                       (read-ident-cont!))
                      (tok-push! :name (slice source start pos))
                      (scan!))))
                 (true

lib/apl/transpile.sx

@@ -40,7 +40,6 @@
       ((= 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
@@ -98,15 +97,6 @@
       ((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)))
@@ -149,16 +139,6 @@
                 (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
@@ -439,36 +419,6 @@
                   ((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
@@ -492,18 +442,6 @@
                   ((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)))
@@ -517,24 +455,6 @@
               ((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) {})))

lib/datalog/aggregates.sx

@@ -1,157 +0,0 @@
-;; lib/datalog/aggregates.sx — count / sum / min / max / findall.
-;;
-;; Surface form (always 3-arg after the relation name):
-;;
-;;   (count   Result  Var  GoalLit)
-;;   (sum     Result  Var  GoalLit)
-;;   (min     Result  Var  GoalLit)
-;;   (max     Result  Var  GoalLit)
-;;   (findall List    Var  GoalLit)
-;;
-;; Parsed naturally because arg-position compounds are already allowed
-;; (Phase 4 needs them for arithmetic). At evaluation time the aggregator
-;; runs `dl-find-bindings` on `GoalLit` under the current subst, collects
-;; the distinct values of `Var`, and binds `Result`.
-;;
-;; Aggregation is non-monotonic — `count(C, X, p(X))` shrinks as p loses
-;; tuples. The stratifier (lib/datalog/strata.sx) treats every aggregate's
-;; goal relation as a negation-like edge so the inner relation is fully
-;; derived before the aggregate fires.
-;;
-;; Empty input: count → 0, sum → 0, min/max → no binding (rule fails).
-
-(define dl-aggregate-rels (list "count" "sum" "min" "max" "findall"))
-
-(define
-  dl-aggregate?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (>= (len lit) 4)
-      (let ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel dl-aggregate-rels)))))))
-
-;; Apply aggregation operator to a list of (already-distinct) numeric or
-;; symbolic values. Returns the aggregated value, or :empty if min/max
-;; has no input.
-(define
-  dl-do-aggregate
-  (fn
-    (op vals)
-    (cond
-      ((= op "count") (len vals))
-      ((= op "sum") (dl-sum-vals vals 0))
-      ((= op "findall") vals)
-      ((= op "min")
-        (cond
-          ((= (len vals) 0) :empty)
-          (else (dl-min-vals vals 1 (first vals)))))
-      ((= op "max")
-        (cond
-          ((= (len vals) 0) :empty)
-          (else (dl-max-vals vals 1 (first vals)))))
-      (else (error (str "datalog: unknown aggregate " op))))))
-
-(define
-  dl-sum-vals
-  (fn
-    (vals acc)
-    (cond
-      ((= (len vals) 0) acc)
-      (else (dl-sum-vals (rest vals) (+ acc (first vals)))))))
-
-(define
-  dl-min-vals
-  (fn
-    (vals i cur)
-    (cond
-      ((>= i (len vals)) cur)
-      (else
-        (let ((v (nth vals i)))
-          (dl-min-vals vals (+ i 1) (if (< v cur) v cur)))))))
-
-(define
-  dl-max-vals
-  (fn
-    (vals i cur)
-    (cond
-      ((>= i (len vals)) cur)
-      (else
-        (let ((v (nth vals i)))
-          (dl-max-vals vals (+ i 1) (if (> v cur) v cur)))))))
-
-;; Membership check by deep equality (so 30 == 30.0 etc).
-(define
-  dl-val-member?
-  (fn
-    (v xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-tuple-equal? v (first xs)) true)
-      (else (dl-val-member? v (rest xs))))))
-
-;; Evaluate an aggregate body lit under `subst`. Returns the list of
-;; extended substitutions (0 or 1 element).
-(define
-  dl-eval-aggregate
-  (fn
-    (lit db subst)
-    (let
-      ((op (dl-rel-name lit))
-        (result-var (nth lit 1))
-        (agg-var (nth lit 2))
-        (goal (nth lit 3)))
-      (cond
-        ((not (dl-var? agg-var))
-          (error (str "datalog aggregate (" op
-                      "): second arg must be a variable, got " agg-var)))
-        ((not (and (list? goal) (> (len goal) 0)
-                   (symbol? (first goal))))
-          (error (str "datalog aggregate (" op
-                      "): third arg must be a positive literal, got "
-                      goal)))
-        ((not (dl-member-string?
-                (symbol->string agg-var)
-                (dl-vars-of goal)))
-          (error (str "datalog aggregate (" op
-                      "): aggregation variable " agg-var
-                      " does not appear in the goal " goal
-                      " — without it every match contributes the same "
-                      "(unbound) value and the result is meaningless")))
-        (else
-          (let ((vals (list)))
-            (do
-              (for-each
-                (fn
-                  (s)
-                  (let ((v (dl-apply-subst agg-var s)))
-                    (when (not (dl-val-member? v vals))
-                      (append! vals v))))
-                (dl-find-bindings (list goal) db subst))
-              (let ((agg-val (dl-do-aggregate op vals)))
-                (cond
-                  ((= agg-val :empty) (list))
-                  (else
-                    (let ((s2 (dl-unify result-var agg-val subst)))
-                      (if (nil? s2) (list) (list s2)))))))))))))
-
-
-;; Stratification edges from aggregates: like negation, the goal's
-;; relation must be in a strictly lower stratum so that the aggregate
-;; fires only after the underlying tuples are settled.
-(define
-  dl-aggregate-dep-edge
-  (fn
-    (lit)
-    (cond
-      ((dl-aggregate? lit)
-        (let ((goal (nth lit 3)))
-          (cond
-            ((and (list? goal) (> (len goal) 0))
-              (let ((rel (dl-rel-name goal)))
-                (if (nil? rel) nil {:rel rel :neg true})))
-            (else nil))))
-      (else nil))))

lib/datalog/api.sx

@@ -1,303 +0,0 @@
-;; lib/datalog/api.sx — SX-data embedding API.
-;;
-;; Where Phase 1's `dl-program` takes a Datalog source string,
-;; this module exposes a parser-free API that consumes SX data
-;; directly. Two rule shapes are accepted:
-;;
-;;   - dict:   {:head <literal> :body (<literal> ...)}
-;;   - list:   (<head-elements...> <- <body-literal> ...)
-;;             — `<-` is an SX symbol used as the rule arrow.
-;;
-;; Examples:
-;;
-;;   (dl-program-data
-;;     '((parent tom bob) (parent tom liz) (parent bob ann))
-;;     '((ancestor X Y <- (parent X Y))
-;;       (ancestor X Z <- (parent X Y) (ancestor Y Z))))
-;;
-;;   (dl-query db '(ancestor tom X))   ; same query API as before
-;;
-;; Variables follow the parser convention: SX symbols whose first
-;; character is uppercase or `_` are variables.
-
-(define
-  dl-rule
-  (fn (head body) {:head head :body body}))
-
-(define
-  dl-rule-arrow?
-  (fn
-    (x)
-    (and (symbol? x) (= (symbol->string x) "<-"))))
-
-(define
-  dl-find-arrow
-  (fn
-    (rl i n)
-    (cond
-      ((>= i n) nil)
-      ((dl-rule-arrow? (nth rl i)) i)
-      (else (dl-find-arrow rl (+ i 1) n)))))
-
-;; Given a list of the form (head-elt ... <- body-lit ...) returns
-;; {:head (head-elt ...) :body (body-lit ...)}. If no arrow is
-;; present, the whole list is treated as the head and the body is
-;; empty (i.e. a fact written rule-style).
-(define
-  dl-rule-from-list
-  (fn
-    (rl)
-    (let ((n (len rl)))
-      (let ((idx (dl-find-arrow rl 0 n)))
-        (cond
-          ((nil? idx) {:head rl :body (list)})
-          (else
-            (let
-              ((head (slice rl 0 idx))
-                (body (slice rl (+ idx 1) n)))
-              {:head head :body body})))))))
-
-;; Coerce a rule given as either a dict or a list-with-arrow to a dict.
-(define
-  dl-coerce-rule
-  (fn
-    (r)
-    (cond
-      ((dict? r) r)
-      ((list? r) (dl-rule-from-list r))
-      (else (error (str "dl-coerce-rule: expected dict or list, got " r))))))
-
-;; Build a db from SX data lists.
-(define
-  dl-program-data
-  (fn
-    (facts rules)
-    (let ((db (dl-make-db)))
-      (do
-        (for-each (fn (lit) (dl-add-fact! db lit)) facts)
-        (for-each
-          (fn (r) (dl-add-rule! db (dl-coerce-rule r)))
-          rules)
-        db))))
-
-;; Add a single fact at runtime, then re-saturate the db so derived
-;; tuples reflect the change. Returns the db.
-(define
-  dl-assert!
-  (fn
-    (db lit)
-    (do
-      (dl-add-fact! db lit)
-      (dl-saturate! db)
-      db)))
-
-;; Remove a fact and re-saturate. Mixed relations (which have BOTH
-;; user-asserted facts AND rules) are supported via :edb-keys provenance
-;; — explicit facts are marked at dl-add-fact! time, the saturator uses
-;; dl-add-derived! which doesn't mark them, so the retract pass can
-;; safely wipe IDB-derived tuples while preserving the user's EDB.
-;;
-;; Effect:
-;;   - remove tuples matching `lit` from :facts and :edb-keys
-;;   - for every relation that has a rule (i.e. potentially IDB or
-;;     mixed), drop the IDB-derived portion (anything not in :edb-keys)
-;;     so the saturator can re-derive cleanly
-;;   - re-saturate
-(define
-  dl-retract!
-  (fn
-    (db lit)
-    (let
-      ((rel-key (dl-rel-name lit)))
-      (do
-        ;; Drop the matching tuple from its relation list, its facts-keys,
-        ;; its first-arg index, AND from :edb-keys (if present).
-        (when
-          (has-key? (get db :facts) rel-key)
-          (let
-            ((existing (get (get db :facts) rel-key))
-              (kept (list))
-              (kept-keys {})
-              (kept-index {})
-              (edb-rel (cond
-                         ((has-key? (get db :edb-keys) rel-key)
-                           (get (get db :edb-keys) rel-key))
-                         (else nil)))
-              (kept-edb {}))
-            (do
-              (for-each
-                (fn
-                  (t)
-                  (when
-                    (not (dl-tuple-equal? t lit))
-                    (do
-                      (append! kept t)
-                      (let ((tk (dl-tuple-key t)))
-                        (do
-                          (dict-set! kept-keys tk true)
-                          (when
-                            (and (not (nil? edb-rel))
-                                 (has-key? edb-rel tk))
-                            (dict-set! kept-edb tk true))))
-                      (when
-                        (>= (len t) 2)
-                        (let ((k (dl-arg-key (nth t 1))))
-                          (do
-                            (when
-                              (not (has-key? kept-index k))
-                              (dict-set! kept-index k (list)))
-                            (append! (get kept-index k) t)))))))
-                existing)
-              (dict-set! (get db :facts) rel-key kept)
-              (dict-set! (get db :facts-keys) rel-key kept-keys)
-              (dict-set! (get db :facts-index) rel-key kept-index)
-              (when
-                (not (nil? edb-rel))
-                (dict-set! (get db :edb-keys) rel-key kept-edb)))))
-        ;; For each rule-head relation, strip the IDB-derived tuples
-        ;; (anything not marked in :edb-keys) so the saturator can
-        ;; cleanly re-derive without leaving stale tuples that depended
-        ;; on the now-removed fact.
-        (let ((rule-heads (dl-rule-head-rels db)))
-          (for-each
-            (fn
-              (k)
-              (when
-                (has-key? (get db :facts) k)
-                (let
-                  ((existing (get (get db :facts) k))
-                    (kept (list))
-                    (kept-keys {})
-                    (kept-index {})
-                    (edb-rel (cond
-                               ((has-key? (get db :edb-keys) k)
-                                 (get (get db :edb-keys) k))
-                               (else {}))))
-                  (do
-                    (for-each
-                      (fn
-                        (t)
-                        (let ((tk (dl-tuple-key t)))
-                          (when
-                            (has-key? edb-rel tk)
-                            (do
-                              (append! kept t)
-                              (dict-set! kept-keys tk true)
-                              (when
-                                (>= (len t) 2)
-                                (let ((kk (dl-arg-key (nth t 1))))
-                                  (do
-                                    (when
-                                      (not (has-key? kept-index kk))
-                                      (dict-set! kept-index kk (list)))
-                                    (append! (get kept-index kk) t))))))))
-                      existing)
-                    (dict-set! (get db :facts) k kept)
-                    (dict-set! (get db :facts-keys) k kept-keys)
-                    (dict-set! (get db :facts-index) k kept-index)))))
-            rule-heads))
-        (dl-saturate! db)
-        db))))
-
-;; ── Convenience: single-call source + query ───────────────────
-;; (dl-eval source query-source) parses both, builds a db, saturates,
-;; runs the query, returns the substitution list. The query source
-;; should be `?- goal[, goal ...].` — the parser produces a clause
-;; with :query containing a list of literals which is fed straight
-;; to dl-query.
-(define
-  dl-eval
-  (fn
-    (source query-source)
-    (let
-      ((db (dl-program source))
-        (queries (dl-parse query-source)))
-      (cond
-        ((= (len queries) 0) (error "dl-eval: query string is empty"))
-        ((not (has-key? (first queries) :query))
-          (error "dl-eval: second arg must be a `?- ...` query clause"))
-        (else
-          (dl-query db (get (first queries) :query)))))))
-
-;; (dl-eval-magic source query-source) — like dl-eval but routes a
-;; single-positive-literal query through `dl-magic-query` for goal-
-;; directed evaluation. Multi-literal query bodies fall back to the
-;; standard dl-query path (magic-sets is currently only wired for
-;; single-positive goals). The caller's source is parsed afresh
-;; each call so successive invocations are independent.
-(define
-  dl-eval-magic
-  (fn
-    (source query-source)
-    (let
-      ((db (dl-program source))
-        (queries (dl-parse query-source)))
-      (cond
-        ((= (len queries) 0) (error "dl-eval-magic: query string is empty"))
-        ((not (has-key? (first queries) :query))
-          (error
-            "dl-eval-magic: second arg must be a `?- ...` query clause"))
-        (else
-          (let
-            ((qbody (get (first queries) :query)))
-            (cond
-              ((and (= (len qbody) 1)
-                    (list? (first qbody))
-                    (> (len (first qbody)) 0)
-                    (symbol? (first (first qbody))))
-                (dl-magic-query db (first qbody)))
-              (else (dl-query db qbody)))))))))
-
-;; List rules whose head's relation matches `rel-name`. Useful for
-;; inspection ("show me how this relation is derived") without
-;; exposing the internal `:rules` list.
-(define
-  dl-rules-of
-  (fn
-    (db rel-name)
-    (let ((out (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (when
-              (= (dl-rel-name (get rule :head)) rel-name)
-              (append! out rule)))
-          (dl-rules db))
-        out))))
-
-(define
-  dl-rule-head-rels
-  (fn
-    (db)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let ((h (dl-rel-name (get rule :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h seen)))
-                (append! seen h))))
-          (dl-rules db))
-        seen))))
-
-;; Wipe every relation that has at least one rule (i.e. every IDB
-;; relation) — leaves EDB facts and rule definitions intact. Useful
-;; before a follow-up `dl-saturate!` if you want a clean restart, or
-;; for inspection of the EDB-only baseline.
-(define
-  dl-clear-idb!
-  (fn
-    (db)
-    (let ((rule-heads (dl-rule-head-rels db)))
-      (do
-        (for-each
-          (fn
-            (k)
-            (do
-              (dict-set! (get db :facts) k (list))
-              (dict-set! (get db :facts-keys) k {})
-              (dict-set! (get db :facts-index) k {})))
-          rule-heads)
-        db))))

lib/datalog/builtins.sx

@@ -1,406 +0,0 @@
-;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
-;;
-;; Built-in predicates filter / extend candidate substitutions during
-;; rule evaluation. They are not stored facts and do not participate in
-;; the Herbrand base.
-;;
-;;   (< a b)  (<= a b)  (> a b)  (>= a b)   ; numeric (or string) compare
-;;   (= a b)                                  ; unify (binds vars)
-;;   (!= a b)                                ; ground-only inequality
-;;   (is X expr)                              ; bind X to expr's value
-;;
-;; Arithmetic expressions are SX-list compounds:
-;;   (+ a b)  (- a b)  (* a b)  (/ a b)
-;; or numbers / variables (must be bound at evaluation time).
-
-(define
-  dl-comparison?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
-
-(define
-  dl-eq?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "=")))))) 
-
-(define
-  dl-is?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (and (not (nil? rel)) (= rel "is")))))) 
-
-;; Evaluate an arithmetic expression under subst. Returns the numeric
-;; result, or raises if any operand is unbound or non-numeric.
-(define
-  dl-eval-arith
-  (fn
-    (expr subst)
-    (let
-      ((w (dl-walk expr subst)))
-      (cond
-        ((number? w) w)
-        ((dl-var? w)
-          (error (str "datalog arith: unbound variable " (symbol->string w))))
-        ((list? w)
-          (let
-            ((rel (dl-rel-name w)) (args (rest w)))
-            (cond
-              ((not (= (len args) 2))
-                (error (str "datalog arith: need 2 args, got " w)))
-              (else
-                (let
-                  ((a (dl-eval-arith (first args) subst))
-                    (b (dl-eval-arith (nth args 1) subst)))
-                  (cond
-                    ((= rel "+") (+ a b))
-                    ((= rel "-") (- a b))
-                    ((= rel "*") (* a b))
-                    ((= rel "/")
-                      (cond
-                        ((= b 0)
-                          (error
-                            (str "datalog arith: division by zero in "
-                                 w)))
-                        (else (/ a b))))
-                    (else (error (str "datalog arith: unknown op " rel)))))))))
-        (else (error (str "datalog arith: not a number — " w)))))))
-
-;; Comparable types — both operands must be the same primitive type
-;; (both numbers, both strings). `!=` is the exception: it's defined
-;; for any pair (returns true iff not equal) since dl-tuple-equal?
-;; handles type-mixed comparisons.
-(define
-  dl-compare-typeok?
-  (fn
-    (rel a b)
-    (cond
-      ((= rel "!=") true)
-      ((and (number? a) (number? b)) true)
-      ((and (string? a) (string? b)) true)
-      (else false))))
-
-(define
-  dl-eval-compare
-  (fn
-    (lit subst)
-    (let
-      ((rel (dl-rel-name lit))
-        (a (dl-walk (nth lit 1) subst))
-        (b (dl-walk (nth lit 2) subst)))
-      (cond
-        ((or (dl-var? a) (dl-var? b))
-          (error
-            (str
-              "datalog: comparison "
-              rel
-              " has unbound argument; "
-              "ensure prior body literal binds the variable")))
-        ((not (dl-compare-typeok? rel a b))
-          (error
-            (str "datalog: comparison " rel " requires same-type "
-                 "operands (both numbers or both strings), got "
-                 a " and " b)))
-        (else
-          (let
-            ((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
-            (if ok subst nil)))))))
-
-(define
-  dl-eval-eq
-  (fn
-    (lit subst)
-    (dl-unify (nth lit 1) (nth lit 2) subst)))
-
-(define
-  dl-eval-is
-  (fn
-    (lit subst)
-    (let
-      ((target (nth lit 1)) (expr (nth lit 2)))
-      (let
-        ((value (dl-eval-arith expr subst)))
-        (dl-unify target value subst)))))
-
-(define
-  dl-eval-builtin
-  (fn
-    (lit subst)
-    (cond
-      ((dl-comparison? lit) (dl-eval-compare lit subst))
-      ((dl-eq? lit) (dl-eval-eq lit subst))
-      ((dl-is? lit) (dl-eval-is lit subst))
-      (else (error (str "dl-eval-builtin: not a built-in: " lit))))))
-
-;; ── Safety analysis ──────────────────────────────────────────────
-;;
-;; Walks body literals left-to-right tracking a "bound" set. The check
-;; understands these literal kinds:
-;;
-;;   positive non-built-in    → adds its vars to bound
-;;   (is X expr)              → vars(expr) ⊆ bound, then add X (if var)
-;;   <,<=,>,>=,!=             → all vars ⊆ bound (no binding)
-;;   (= a b) where:
-;;       both non-vars        → constraint check, no binding
-;;       a var, b not         → bind a
-;;       b var, a not         → bind b
-;;       both vars            → at least one in bound; bind the other
-;;   {:neg lit}               → all vars ⊆ bound (Phase 7 enforces fully)
-;;
-;; At end, head vars (minus `_`) must be ⊆ bound.
-
-(define
-  dl-vars-not-in
-  (fn
-    (vs bound)
-    (let
-      ((out (list)))
-      (do
-        (for-each
-          (fn
-            (v)
-            (when (not (dl-member-string? v bound)) (append! out v)))
-          vs)
-        out))))
-
-;; Filter a list of variable-name strings to exclude anonymous-renamed
-;; vars (`_` in source → `_anon*` by dl-rename-anon-term). Used by
-;; the negation safety check, where anonymous vars are existential
-;; within the negated literal.
-(define
-  dl-non-anon-vars
-  (fn
-    (vs)
-    (let
-      ((out (list)))
-      (do
-        (for-each
-          (fn
-            (v)
-            (when
-              (not (and (>= (len v) 5)
-                        (= (slice v 0 5) "_anon")))
-              (append! out v)))
-          vs)
-        out))))
-
-(define
-  dl-rule-check-safety
-  (fn
-    (rule)
-    (let
-      ((head (get rule :head))
-        (body (get rule :body))
-        (bound (list))
-        (err nil))
-      (do
-        (define
-          dl-add-bound!
-          (fn
-            (vs)
-            (for-each
-              (fn
-                (v)
-                (when (not (dl-member-string? v bound)) (append! bound v)))
-              vs)))
-        (define
-          dl-process-eq!
-          (fn
-            (lit)
-            (let
-              ((a (nth lit 1)) (b (nth lit 2)))
-              (let
-                ((va (dl-var? a)) (vb (dl-var? b)))
-                (cond
-                  ((and (not va) (not vb)) nil)
-                  ((and va (not vb))
-                    (dl-add-bound! (list (symbol->string a))))
-                  ((and (not va) vb)
-                    (dl-add-bound! (list (symbol->string b))))
-                  (else
-                    (let
-                      ((sa (symbol->string a)) (sb (symbol->string b)))
-                      (cond
-                        ((dl-member-string? sa bound)
-                          (dl-add-bound! (list sb)))
-                        ((dl-member-string? sb bound)
-                          (dl-add-bound! (list sa)))
-                        (else
-                          (set!
-                            err
-                            (str
-                              "= between two unbound variables "
-                              (list sa sb)
-                              " — at least one must be bound by an "
-                              "earlier positive body literal")))))))))))
-        (define
-          dl-process-cmp!
-          (fn
-            (lit)
-            (let
-              ((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
-              (let
-                ((missing (dl-vars-not-in needed bound)))
-                (when
-                  (> (len missing) 0)
-                  (set!
-                    err
-                    (str
-                      "comparison "
-                      (dl-rel-name lit)
-                      " requires bound variable(s) "
-                      missing
-                      " (must be bound by an earlier positive "
-                      "body literal)")))))))
-        (define
-          dl-process-is!
-          (fn
-            (lit)
-            (let
-              ((tgt (nth lit 1)) (expr (nth lit 2)))
-              (let
-                ((needed (dl-vars-of expr)))
-                (let
-                  ((missing (dl-vars-not-in needed bound)))
-                  (cond
-                    ((> (len missing) 0)
-                      (set!
-                        err
-                        (str
-                          "is RHS uses unbound variable(s) "
-                          missing
-                          " — bind them via a prior positive body "
-                          "literal")))
-                    (else
-                      (when
-                        (dl-var? tgt)
-                        (dl-add-bound! (list (symbol->string tgt)))))))))))
-        (define
-          dl-process-neg!
-          (fn
-            (lit)
-            (let
-              ((inner (get lit :neg)))
-              (let
-                ((inner-rn
-                   (cond
-                     ((and (list? inner) (> (len inner) 0))
-                       (dl-rel-name inner))
-                     (else nil)))
-                  ;; Anonymous variables (`_` in source → `_anon*` after
-                  ;; renaming) are existentially quantified within the
-                  ;; negated literal — they don't need to be bound by
-                  ;; an earlier body lit, since `not p(X, _)` is a
-                  ;; valid idiom for "no Y exists s.t. p(X, Y)". Filter
-                  ;; them out of the safety check.
-                  (needed (dl-non-anon-vars (dl-vars-of inner)))
-                  (missing (dl-vars-not-in needed bound)))
-                (cond
-                  ((and (not (nil? inner-rn)) (dl-reserved-rel? inner-rn))
-                    (set! err
-                      (str "negated literal uses reserved name '"
-                           inner-rn
-                           "' — nested `not(...)` / negated built-ins are "
-                           "not supported; introduce an intermediate "
-                           "relation and negate that")))
-                  ((> (len missing) 0)
-                    (set! err
-                      (str "negation refers to unbound variable(s) "
-                           missing
-                           " — they must be bound by an earlier "
-                           "positive body literal"))))))))
-        (define
-          dl-process-agg!
-          (fn
-            (lit)
-            (let
-              ((result-var (nth lit 1)))
-              ;; Aggregate goal vars are existentially quantified within
-              ;; the aggregate; nothing required from outer context. The
-              ;; result var becomes bound after the aggregate fires.
-              (when
-                (dl-var? result-var)
-                (dl-add-bound! (list (symbol->string result-var)))))))
-
-        (define
-          dl-process-lit!
-          (fn
-            (lit)
-            (when
-              (nil? err)
-              (cond
-                ((and (dict? lit) (has-key? lit :neg))
-                  (dl-process-neg! lit))
-                ;; A bare dict that is not a recognised negation is
-                ;; almost certainly a typo (e.g. `{:negs ...}` instead
-                ;; of `{:neg ...}`). Without this guard the dict would
-                ;; silently fall through every clause; the head safety
-                ;; check would then flag the head variables as unbound
-                ;; even though the real bug is the malformed body lit.
-                ((dict? lit)
-                  (set! err
-                    (str "body literal is a dict but lacks :neg — "
-                         "the only dict-shaped body lit recognised is "
-                         "{:neg <positive-lit>} for stratified "
-                         "negation, got " lit)))
-                ((dl-aggregate? lit) (dl-process-agg! lit))
-                ((dl-eq? lit) (dl-process-eq! lit))
-                ((dl-is? lit) (dl-process-is! lit))
-                ((dl-comparison? lit) (dl-process-cmp! lit))
-                ((and (list? lit) (> (len lit) 0))
-                  (let ((rn (dl-rel-name lit)))
-                    (cond
-                      ((and (not (nil? rn)) (dl-reserved-rel? rn))
-                        (set! err
-                          (str "body literal uses reserved name '" rn
-                               "' — built-ins / aggregates have their own "
-                               "syntax; nested `not(...)` is not supported "
-                               "(use stratified negation via an "
-                               "intermediate relation)")))
-                      (else (dl-add-bound! (dl-vars-of lit))))))
-                (else
-                  ;; Anything that's not a dict, not a list, or an
-                  ;; empty list. Numbers / strings / symbols as body
-                  ;; lits don't make sense — surface the type.
-                  (set! err
-                    (str "body literal must be a positive lit, "
-                         "built-in, aggregate, or {:neg ...} dict, "
-                         "got " lit)))))))
-        (for-each dl-process-lit! body)
-        (when
-          (nil? err)
-          (let
-            ((head-vars (dl-vars-of head)) (missing (list)))
-            (do
-              (for-each
-                (fn
-                  (v)
-                  (when
-                    (and (not (dl-member-string? v bound)) (not (= v "_")))
-                    (append! missing v)))
-                head-vars)
-              (when
-                (> (len missing) 0)
-                (set!
-                  err
-                  (str
-                    "head variable(s) "
-                    missing
-                    " do not appear in any positive body literal"))))))
-        err))))

lib/datalog/conformance.conf

@@ -1,32 +0,0 @@
-# Datalog conformance config — sourced by lib/guest/conformance.sh.
-
-LANG_NAME=datalog
-MODE=dict
-
-PRELOADS=(
-  lib/datalog/tokenizer.sx
-  lib/datalog/parser.sx
-  lib/datalog/unify.sx
-  lib/datalog/db.sx
-  lib/datalog/builtins.sx
-  lib/datalog/aggregates.sx
-  lib/datalog/strata.sx
-  lib/datalog/eval.sx
-  lib/datalog/api.sx
-  lib/datalog/magic.sx
-  lib/datalog/demo.sx
-)
-
-SUITES=(
-  "tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
-  "parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
-  "unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
-  "eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
-  "builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
-  "semi_naive:lib/datalog/tests/semi_naive.sx:(dl-semi-naive-tests-run!)"
-  "negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
-  "aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
-  "api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
-  "magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
-  "demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
-)

lib/datalog/conformance.sh

@@ -1,3 +0,0 @@
-#!/usr/bin/env bash
-# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
-exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

lib/datalog/datalog.sx

@@ -1,97 +0,0 @@
-;; lib/datalog/datalog.sx — public API documentation index.
-;;
-;; This file is reference-only — `load` is an epoch-protocol command,
-;; not an SX function, so it cannot reload a list of files from inside
-;; another `.sx` file. To set up a fresh sx_server session with all
-;; modules in scope, issue these loads in order:
-;;
-;;   (load "lib/datalog/tokenizer.sx")
-;;   (load "lib/datalog/parser.sx")
-;;   (load "lib/datalog/unify.sx")
-;;   (load "lib/datalog/db.sx")
-;;   (load "lib/datalog/builtins.sx")
-;;   (load "lib/datalog/aggregates.sx")
-;;   (load "lib/datalog/strata.sx")
-;;   (load "lib/datalog/eval.sx")
-;;   (load "lib/datalog/api.sx")
-;;   (load "lib/datalog/magic.sx")
-;;   (load "lib/datalog/demo.sx")
-;;
-;; (lib/datalog/conformance.sh runs this load list automatically.)
-;;
-;; ── Public API surface ─────────────────────────────────────────────
-;;
-;;   Source / data:
-;;     (dl-tokenize "src")              → token list
-;;     (dl-parse "src")                 → parsed clauses
-;;     (dl-program "src")               → db built from a source string
-;;     (dl-program-data facts rules)    → db from SX data lists; rules
-;;                                        accept either dict form or
-;;                                        list form with `<-` arrow
-;;
-;;   Construction (mutates db):
-;;     (dl-make-db)                     empty db
-;;     (dl-add-fact! db lit)            rejects non-ground
-;;     (dl-add-rule! db rule)           rejects unsafe rules
-;;     (dl-rule head body)              dict-rule constructor
-;;     (dl-add-clause! db clause)       parser output → fact or rule
-;;     (dl-load-program! db src)        string source
-;;     (dl-set-strategy! db strategy)   :semi-naive default; :magic
-;;                                        is informational, use
-;;                                        dl-magic-query for actual
-;;                                        magic-sets evaluation
-;;
-;;   Mutation:
-;;     (dl-assert! db lit)              add + re-saturate
-;;     (dl-retract! db lit)             drop EDB, wipe IDB, re-saturate
-;;     (dl-clear-idb! db)               wipe rule-headed relations
-;;
-;;   Query / inspection:
-;;     (dl-saturate! db)                stratified semi-naive default
-;;     (dl-saturate-naive! db)          reference (slow on chains)
-;;     (dl-saturate-rules! db rules)    per-rule-set semi-naive worker
-;;     (dl-query db goal)               list of substitution dicts
-;;     (dl-relation db rel-name)        tuple list for a relation
-;;     (dl-rules db)                    rule list
-;;     (dl-fact-count db)               total ground tuples
-;;     (dl-summary db)                  {<rel>: count} for inspection
-;;
-;;   Single-call convenience:
-;;     (dl-eval source query-source)         parse, run, return substs
-;;     (dl-eval-magic source query-source)   single-goal → magic-sets
-;;
-;;   Magic-sets (lib/datalog/magic.sx):
-;;     (dl-adorn-goal goal)             "b/f" adornment string
-;;     (dl-rule-sips rule head-adn)     SIPS analysis per body lit
-;;     (dl-magic-rewrite rules rel adn args)
-;;                                       rewritten rule list + seed
-;;     (dl-magic-query db query-goal)    end-to-end magic-sets query
-;;
-;; ── Body literal kinds ─────────────────────────────────────────────
-;;
-;;   Positive             (rel arg ... arg)
-;;   Negation             {:neg (rel arg ...)}
-;;   Comparison           (< X Y), (<= X Y), (> X Y), (>= X Y),
-;;                        (= X Y), (!= X Y)
-;;   Arithmetic           (is Z (+ X Y)) and (- * /)
-;;   Aggregation          (count R V Goal),  (sum R V Goal),
-;;                        (min R V Goal),    (max R V Goal),
-;;                        (findall L V Goal)
-;;
-;; ── Variable conventions ───────────────────────────────────────────
-;;
-;;   Variables: SX symbols whose first char is uppercase A–Z or '_'.
-;;   Anonymous '_' is renamed to a fresh _anon<N> per occurrence at
-;;   rule/query load time so multiple '_' don't unify.
-;;
-;; ── Demo programs ──────────────────────────────────────────────────
-;;
-;;   See lib/datalog/demo.sx — federation, content, permissions, and
-;;   the canonical "cooking posts by people I follow (transitively)"
-;;   example.
-;;
-;; ── Status ─────────────────────────────────────────────────────────
-;;
-;;   See plans/datalog-on-sx.md — phase-by-phase progress log and
-;;   roadmap. Run `bash lib/datalog/conformance.sh` to refresh
-;;   `lib/datalog/scoreboard.{json,md}`.

lib/datalog/db.sx

@@ -1,575 +0,0 @@
-;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
-;;
-;; A db is a mutable dict:
-;;   {:facts {<rel-name-string> -> (literal ...)}
-;;    :rules ({:head literal :body (literal ...)} ...)}
-;;
-;; Facts are stored as full literals `(rel arg ... arg)` so they unify
-;; directly against rule body literals. Each relation's tuple list is
-;; deduplicated on insert.
-;;
-;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
-;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
-;; which is order-aware and understands built-in predicates.
-
-(define
-  dl-make-db
-  (fn ()
-    {:facts {}
-     :facts-keys {}
-     :facts-index {}
-     :edb-keys {}
-     :rules (list)
-     :strategy :semi-naive}))
-
-;; Record (rel-key, tuple-key) as user-asserted EDB. dl-add-fact! calls
-;; this when an explicit fact is added; the saturator (which uses
-;; dl-add-derived!) does NOT, so derived tuples never appear here.
-;; dl-retract! consults :edb-keys to know which tuples must survive
-;; the wipe-and-resaturate round-trip.
-(define
-  dl-mark-edb!
-  (fn
-    (db rel-key tk)
-    (let
-      ((edb (get db :edb-keys)))
-      (do
-        (when
-          (not (has-key? edb rel-key))
-          (dict-set! edb rel-key {}))
-        (dict-set! (get edb rel-key) tk true)))))
-
-(define
-  dl-edb-fact?
-  (fn
-    (db rel-key tk)
-    (let
-      ((edb (get db :edb-keys)))
-      (and (has-key? edb rel-key)
-           (has-key? (get edb rel-key) tk)))))
-
-;; Evaluation strategy. Default :semi-naive (used by dl-saturate!).
-;; :naive selects dl-saturate-naive! (slower but easier to reason
-;; about). :magic is a marker — goal-directed magic-sets evaluation
-;; is invoked separately via `dl-magic-query`; setting :magic here
-;; is purely informational. Any other value is rejected so typos
-;; don't silently fall back to the default.
-(define
-  dl-strategy-values
-  (list :semi-naive :naive :magic))
-
-(define
-  dl-set-strategy!
-  (fn
-    (db strategy)
-    (cond
-      ((not (dl-keyword-member? strategy dl-strategy-values))
-        (error (str "dl-set-strategy!: unknown strategy " strategy
-                    " — must be one of " dl-strategy-values)))
-      (else
-        (do
-          (dict-set! db :strategy strategy)
-          db)))))
-
-(define
-  dl-keyword-member?
-  (fn
-    (k xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= k (first xs)) true)
-      (else (dl-keyword-member? k (rest xs))))))
-
-(define
-  dl-get-strategy
-  (fn
-    (db)
-    (if (has-key? db :strategy) (get db :strategy) :semi-naive)))
-
-(define
-  dl-rel-name
-  (fn
-    (lit)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
-      ((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
-        (symbol->string (first lit)))
-      (else nil))))
-
-(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
-
-(define
-  dl-member-string?
-  (fn
-    (s xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) s) true)
-      (else (dl-member-string? s (rest xs))))))
-
-(define
-  dl-builtin?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (let
-        ((rel (dl-rel-name lit)))
-        (cond
-          ((nil? rel) false)
-          (else (dl-member-string? rel dl-builtin-rels)))))))
-
-(define
-  dl-positive-lit?
-  (fn
-    (lit)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg)) false)
-      ((dl-builtin? lit) false)
-      ((and (list? lit) (> (len lit) 0)) true)
-      (else false))))
-
-(define
-  dl-tuple-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-tuple-equal-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-tuple-equal? (nth a i) (nth b i))) false)
-      (else (dl-tuple-equal-list? a b (+ i 1))))))
-
-(define
-  dl-tuple-member?
-  (fn
-    (lit lits)
-    (dl-tuple-member-aux? lit lits 0 (len lits))))
-
-(define
-  dl-tuple-member-aux?
-  (fn
-    (lit lits i n)
-    (cond
-      ((>= i n) false)
-      ((dl-tuple-equal? lit (nth lits i)) true)
-      (else (dl-tuple-member-aux? lit lits (+ i 1) n)))))
-
-(define
-  dl-ensure-rel!
-  (fn
-    (db rel-key)
-    (let
-      ((facts (get db :facts))
-        (fk (get db :facts-keys))
-        (fi (get db :facts-index)))
-      (do
-        (when
-          (not (has-key? facts rel-key))
-          (dict-set! facts rel-key (list)))
-        (when
-          (not (has-key? fk rel-key))
-          (dict-set! fk rel-key {}))
-        (when
-          (not (has-key? fi rel-key))
-          (dict-set! fi rel-key {}))
-        (get facts rel-key)))))
-
-;; First-arg index helpers. Tuples are keyed by their first-after-rel
-;; arg's `(str ...)`; when that arg is a constant, dl-match-positive
-;; uses the index instead of scanning the full relation.
-(define
-  dl-arg-key
-  (fn
-    (v)
-    (str v)))
-
-(define
-  dl-index-add!
-  (fn
-    (db rel-key lit)
-    (let
-      ((idx (get db :facts-index))
-        (n (len lit)))
-      (when
-        (and (>= n 2) (has-key? idx rel-key))
-        (let
-          ((rel-idx (get idx rel-key))
-            (k (dl-arg-key (nth lit 1))))
-          (do
-            (when
-              (not (has-key? rel-idx k))
-              (dict-set! rel-idx k (list)))
-            (append! (get rel-idx k) lit)))))))
-
-(define
-  dl-index-lookup
-  (fn
-    (db rel-key arg-val)
-    (let
-      ((idx (get db :facts-index)))
-      (cond
-        ((not (has-key? idx rel-key)) (list))
-        (else
-          (let ((rel-idx (get idx rel-key))
-                (k (dl-arg-key arg-val)))
-            (if (has-key? rel-idx k) (get rel-idx k) (list))))))))
-
-(define dl-tuple-key (fn (lit) (str lit)))
-
-(define
-  dl-rel-tuples
-  (fn
-    (db rel-key)
-    (let
-      ((facts (get db :facts)))
-      (if (has-key? facts rel-key) (get facts rel-key) (list)))))
-
-;; Reserved relation names: built-in / aggregate / negation / arrow.
-;; Rules and facts may not have these as their head's relation, since
-;; the saturator treats them specially or they are not relation names
-;; at all.
-(define
-  dl-reserved-rel-names
-  (list "not" "count" "sum" "min" "max" "findall" "is"
-        "<" "<=" ">" ">=" "=" "!=" "+" "-" "*" "/" ":-" "?-"))
-
-(define
-  dl-reserved-rel?
-  (fn
-    (name) (dl-member-string? name dl-reserved-rel-names)))
-
-;; Internal: append a derived tuple to :facts without the public
-;; validation pass and without marking :edb-keys. Used by the saturator
-;; (eval.sx) and magic-sets (magic.sx). Returns true if the tuple was
-;; new, false if already present.
-(define
-  dl-add-derived!
-  (fn
-    (db lit)
-    (let
-      ((rel-key (dl-rel-name lit)))
-      (let
-        ((tuples (dl-ensure-rel! db rel-key))
-          (key-dict (get (get db :facts-keys) rel-key))
-          (tk (dl-tuple-key lit)))
-        (cond
-          ((has-key? key-dict tk) false)
-          (else
-            (do
-              (dict-set! key-dict tk true)
-              (append! tuples lit)
-              (dl-index-add! db rel-key lit)
-              true)))))))
-
-;; A simple term — number, string, or symbol — i.e. anything legal
-;; as an EDB fact arg. Compound (list) args belong only in body
-;; literals where they encode arithmetic / aggregate sub-goals.
-(define
-  dl-simple-term?
-  (fn
-    (term)
-    (or (number? term) (string? term) (symbol? term))))
-
-(define
-  dl-args-simple?
-  (fn
-    (lit i n)
-    (cond
-      ((>= i n) true)
-      ((not (dl-simple-term? (nth lit i))) false)
-      (else (dl-args-simple? lit (+ i 1) n)))))
-
-(define
-  dl-add-fact!
-  (fn
-    (db lit)
-    (cond
-      ((not (and (list? lit) (> (len lit) 0)))
-        (error (str "dl-add-fact!: expected literal list, got " lit)))
-      ((dl-reserved-rel? (dl-rel-name lit))
-        (error (str "dl-add-fact!: '" (dl-rel-name lit)
-                    "' is a reserved name (built-in / aggregate / negation)")))
-      ((not (dl-args-simple? lit 1 (len lit)))
-        (error (str "dl-add-fact!: fact args must be numbers, strings, "
-                    "or symbols — compound args (e.g. arithmetic "
-                    "expressions) are body-only and aren't evaluated "
-                    "in fact position. got " lit)))
-      ((not (dl-ground? lit (dl-empty-subst)))
-        (error (str "dl-add-fact!: expected ground literal, got " lit)))
-      (else
-        (let
-          ((rel-key (dl-rel-name lit)) (tk (dl-tuple-key lit)))
-          (do
-            ;; Always mark EDB origin — even if the tuple key was already
-            ;; present (e.g. previously derived), so an explicit assert
-            ;; promotes it to EDB and protects it from the IDB wipe.
-            (dl-mark-edb! db rel-key tk)
-            (dl-add-derived! db lit)))))))
-
-;; The full safety check lives in builtins.sx (it has to know which
-;; predicates are built-ins). dl-add-rule! calls it via forward
-;; reference; load builtins.sx alongside db.sx in any setup that
-;; adds rules. The fallback below is used if builtins.sx isn't loaded.
-(define
-  dl-rule-check-safety
-  (fn
-    (rule)
-    (let
-      ((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
-      (do
-        (for-each
-          (fn
-            (lit)
-            (when
-              (and
-                (list? lit)
-                (> (len lit) 0)
-                (not (and (dict? lit) (has-key? lit :neg))))
-              (for-each
-                (fn
-                  (v)
-                  (when
-                    (not (dl-member-string? v body-vars))
-                    (append! body-vars v)))
-                (dl-vars-of lit))))
-          (get rule :body))
-        (let
-          ((missing (list)))
-          (do
-            (for-each
-              (fn
-                (v)
-                (when
-                  (and
-                    (not (dl-member-string? v body-vars))
-                    (not (= v "_")))
-                  (append! missing v)))
-              head-vars)
-            (cond
-              ((> (len missing) 0)
-                (str
-                  "head variable(s) "
-                  missing
-                  " do not appear in any body literal"))
-              (else nil))))))))
-
-(define
-  dl-rename-anon-term
-  (fn
-    (term next-name)
-    (cond
-      ((and (symbol? term) (= (symbol->string term) "_"))
-        (next-name))
-      ((list? term)
-        (map (fn (x) (dl-rename-anon-term x next-name)) term))
-      (else term))))
-
-(define
-  dl-rename-anon-lit
-  (fn
-    (lit next-name)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg))
-        {:neg (dl-rename-anon-term (get lit :neg) next-name)})
-      ((list? lit) (dl-rename-anon-term lit next-name))
-      (else lit))))
-
-(define
-  dl-make-anon-renamer
-  (fn
-    (start)
-    (let ((counter start))
-      (fn () (do (set! counter (+ counter 1))
-                 (string->symbol (str "_anon" counter)))))))
-
-;; Scan a rule for variables already named `_anon<N>` (which would
-;; otherwise collide with the renamer's output). Returns the max N
-;; seen, or 0 if none. The renamer then starts at that max + 1, so
-;; freshly-introduced anonymous names can't shadow a user-written
-;; `_anon<N>` symbol.
-(define
-  dl-max-anon-num
-  (fn
-    (term acc)
-    (cond
-      ((symbol? term)
-        (let ((s (symbol->string term)))
-          (cond
-            ((and (>= (len s) 6) (= (slice s 0 5) "_anon"))
-              (let ((n (dl-try-parse-int (slice s 5 (len s)))))
-                (cond
-                  ((nil? n) acc)
-                  ((> n acc) n)
-                  (else acc))))
-            (else acc))))
-      ((dict? term)
-        (cond
-          ((has-key? term :neg)
-            (dl-max-anon-num (get term :neg) acc))
-          (else acc)))
-      ((list? term) (dl-max-anon-num-list term acc 0))
-      (else acc))))
-
-(define
-  dl-max-anon-num-list
-  (fn
-    (xs acc i)
-    (cond
-      ((>= i (len xs)) acc)
-      (else
-        (dl-max-anon-num-list xs (dl-max-anon-num (nth xs i) acc) (+ i 1))))))
-
-;; Cheap "is this string a decimal int" check. Returns the number or
-;; nil. Avoids relying on host parse-number, which on non-int strings
-;; might raise rather than return nil.
-(define
-  dl-try-parse-int
-  (fn
-    (s)
-    (cond
-      ((= (len s) 0) nil)
-      ((not (dl-all-digits? s 0 (len s))) nil)
-      (else (parse-number s)))))
-
-(define
-  dl-all-digits?
-  (fn
-    (s i n)
-    (cond
-      ((>= i n) true)
-      ((let ((c (slice s i (+ i 1))))
-         (not (and (>= c "0") (<= c "9"))))
-        false)
-      (else (dl-all-digits? s (+ i 1) n)))))
-
-(define
-  dl-rename-anon-rule
-  (fn
-    (rule)
-    (let
-      ((start (dl-max-anon-num (get rule :head)
-                (dl-max-anon-num-list (get rule :body) 0 0))))
-      (let ((next-name (dl-make-anon-renamer start)))
-        {:head (dl-rename-anon-term (get rule :head) next-name)
-         :body (map (fn (lit) (dl-rename-anon-lit lit next-name))
-                    (get rule :body))}))))
-
-(define
-  dl-add-rule!
-  (fn
-    (db rule)
-    (cond
-      ((not (dict? rule))
-        (error (str "dl-add-rule!: expected rule dict, got " rule)))
-      ((not (has-key? rule :head))
-        (error (str "dl-add-rule!: rule missing :head, got " rule)))
-      ((not (and (list? (get rule :head))
-                 (> (len (get rule :head)) 0)
-                 (symbol? (first (get rule :head)))))
-        (error (str "dl-add-rule!: head must be a non-empty list "
-                    "starting with a relation-name symbol, got "
-                    (get rule :head))))
-      ((not (dl-args-simple? (get rule :head) 1 (len (get rule :head))))
-        (error (str "dl-add-rule!: rule head args must be variables or "
-                    "constants — compound terms (e.g. `(*(X, 2))`) are "
-                    "not legal in head position; introduce an `is`-bound "
-                    "intermediate in the body. got " (get rule :head))))
-      ((not (list? (if (has-key? rule :body) (get rule :body) (list))))
-        (error (str "dl-add-rule!: body must be a list of literals, got "
-                    (get rule :body))))
-      ((dl-reserved-rel? (dl-rel-name (get rule :head)))
-        (error (str "dl-add-rule!: '" (dl-rel-name (get rule :head))
-                    "' is a reserved name (built-in / aggregate / negation)")))
-      (else
-        (let ((rule (dl-rename-anon-rule rule)))
-          (let
-            ((err (dl-rule-check-safety rule)))
-            (cond
-              ((not (nil? err)) (error (str "dl-add-rule!: " err)))
-              (else
-                (let
-                  ((rules (get db :rules)))
-                  (do (append! rules rule) true))))))))))
-
-(define
-  dl-add-clause!
-  (fn
-    (db clause)
-    (cond
-      ((has-key? clause :query) false)
-      ((and (has-key? clause :body) (= (len (get clause :body)) 0))
-        (dl-add-fact! db (get clause :head)))
-      (else (dl-add-rule! db clause)))))
-
-(define
-  dl-load-program!
-  (fn
-    (db source)
-    (let
-      ((clauses (dl-parse source)))
-      (do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
-
-(define
-  dl-program
-  (fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
-
-(define dl-rules (fn (db) (get db :rules)))
-
-(define
-  dl-fact-count
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts)) (total 0))
-      (do
-        (for-each
-          (fn (k) (set! total (+ total (len (get facts k)))))
-          (keys facts))
-        total))))
-
-;; Returns {<rel-name>: tuple-count} for debugging. Includes
-;; relations with any tuples plus all rule-head relations (so empty
-;; IDB shows as 0). Skips empty EDB-only entries that are placeholders
-;; from internal `dl-ensure-rel!` calls.
-(define
-  dl-summary
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts))
-        (out {})
-        (rule-heads (list)))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let ((h (dl-rel-name (get rule :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h rule-heads)))
-                (append! rule-heads h))))
-          (dl-rules db))
-        (for-each
-          (fn
-            (k)
-            (let ((c (len (get facts k))))
-              (when
-                (or (> c 0) (dl-member-string? k rule-heads))
-                (dict-set! out k c))))
-          (keys facts))
-        ;; Add rule heads that have no facts (yet).
-        (for-each
-          (fn
-            (k)
-            (when (not (has-key? out k)) (dict-set! out k 0)))
-          rule-heads)
-        out))))

lib/datalog/demo.sx

@@ -1,162 +0,0 @@
-;; lib/datalog/demo.sx — example programs over rose-ash-shaped data.
-;;
-;; Phase 10 prototypes Datalog as a rose-ash query language. Wiring
-;; the EDB to actual PostgreSQL is out of scope for this loop (it
-;; would touch service code outside lib/datalog/), but the programs
-;; below show the shape of queries we want, and the test suite runs
-;; them against synthetic in-memory tuples loaded via dl-program-data.
-;;
-;; Seven thematic demos:
-;;
-;;   1. Federation — follow graph, transitive reach, mutuals, FOAF.
-;;   2. Content    — posts, tags, likes, popularity, "for you" feed.
-;;   3. Permissions — group membership and resource access.
-;;   4. Cooking-posts — canonical "posts about cooking by people I
-;;                      follow (transitively)" multi-domain query.
-;;   5. Tag co-occurrence — distinct (T1, T2) pairs with counts.
-;;   6. Shortest path  — weighted-DAG path enumeration + min agg.
-;;   7. Org chart      — transitive subordinate + headcount per mgr.
-
-;; ── Demo 1: federation follow graph ─────────────────────────────
-;; EDB: (follows ACTOR-A ACTOR-B) — A follows B.
-;; IDB:
-;;   (mutual A B)            — A follows B and B follows A
-;;   (reachable A B)         — transitive follow closure
-;;   (foaf A C)              — friend of a friend (mutual filter)
-(define
-  dl-demo-federation-rules
-  (quote
-    ((mutual A B <- (follows A B) (follows B A))
-     (reachable A B <- (follows A B))
-     (reachable A C <- (follows A B) (reachable B C))
-     (foaf A C <- (follows A B) (follows B C) (!= A C)))))
-
-;; ── Demo 2: content recommendation ──────────────────────────────
-;; EDB:
-;;   (authored ACTOR POST)
-;;   (tagged POST TAG)
-;;   (liked ACTOR POST)
-;; IDB:
-;;   (post-likes POST N)            — count of likes per post
-;;   (popular POST)                 — posts with >= 3 likes
-;;   (tagged-by-mutual ACTOR POST)  — post tagged TOPIC by someone
-;;                                    A's mutuals follow.
-(define
-  dl-demo-content-rules
-  (quote
-    ((post-likes P N <- (authored Author P) (count N L (liked L P)))
-     (popular P <- (authored Author P) (post-likes P N) (>= N 3))
-     (interesting Me P
-       <-
-       (follows Me Buddy)
-       (authored Buddy P)
-       (popular P)))))
-
-;; ── Demo 3: role-based permissions ──────────────────────────────
-;; EDB:
-;;   (member ACTOR GROUP)
-;;   (subgroup CHILD PARENT)
-;;   (allowed GROUP RESOURCE)
-;; IDB:
-;;   (in-group ACTOR GROUP)         — direct or via subgroup chain
-;;   (can-access ACTOR RESOURCE)    — actor inherits group permission
-(define
-  dl-demo-perm-rules
-  (quote
-    ((in-group A G <- (member A G))
-     (in-group A G <- (member A H) (subgroup-trans H G))
-     (subgroup-trans X Y <- (subgroup X Y))
-     (subgroup-trans X Z <- (subgroup X Y) (subgroup-trans Y Z))
-     (can-access A R <- (in-group A G) (allowed G R)))))
-
-;; ── Demo 4: cooking-posts (the canonical Phase 10 query) ────────
-;; "Posts about cooking by people I follow (transitively)."
-;; Combines federation (follows + transitive reach), authoring,
-;; tagging — the rose-ash multi-domain join.
-;;
-;; EDB:
-;;   (follows ACTOR-A ACTOR-B)
-;;   (authored ACTOR POST)
-;;   (tagged POST TAG)
-(define
-  dl-demo-cooking-rules
-  (quote
-    ((reach Me Them <- (follows Me Them))
-     (reach Me Them <- (follows Me X) (reach X Them))
-     (cooking-post-by-network Me P
-       <-
-       (reach Me Author)
-       (authored Author P)
-       (tagged P cooking)))))
-
-;; ── Demo 5: tag co-occurrence ───────────────────────────────────
-;; "Posts tagged with both T1 AND T2." Useful for narrowed-down
-;; recommendations like "vegetarian cooking" posts.
-;;
-;; EDB:
-;;   (tagged POST TAG)
-;; IDB:
-;;   (cotagged POST T1 T2)        — post has both T1 and T2 (T1 != T2)
-;;   (popular-pair T1 T2 N)       — count of posts cotagged (T1, T2)
-(define
-  dl-demo-tag-cooccur-rules
-  (quote
-    ((cotagged P T1 T2 <- (tagged P T1) (tagged P T2) (!= T1 T2))
-     ;; Distinct (T1, T2) pairs that occur somewhere.
-     (tag-pair T1 T2 <- (cotagged P T1 T2))
-     (tag-pair-count T1 T2 N
-       <-
-       (tag-pair T1 T2)
-       (count N P (cotagged P T1 T2))))))
-
-;; ── Demo 6: weighted-DAG shortest path ─────────────────────────
-;; "What's the cheapest way from X to Y?" Edge weights with `is`
-;; arithmetic to sum costs, then `min` aggregation to pick the
-;; shortest. Termination requires the graph to be a DAG (cycles
-;; would produce infinite distances without a bound; programs
-;; built on this should add a depth filter `(<, D, MAX)` if cycles
-;; are possible).
-;;
-;; EDB:
-;;   (edge FROM TO COST)
-;; IDB:
-;;   (path FROM TO COST)            — any path
-;;   (shortest FROM TO COST)        — minimum cost path
-(define
-  dl-demo-shortest-path-rules
-  (quote
-    ((path X Y W <- (edge X Y W))
-     (path X Z W
-       <-
-       (edge X Y W1)
-       (path Y Z W2)
-       (is W (+ W1 W2)))
-     (shortest X Y W <- (path X Y _) (min W C (path X Y C))))))
-
-;; ── Demo 7: org chart + transitive headcount ───────────────────
-;; Manager graph: each employee has a single manager. Compute the
-;; transitive subordinate set and headcount per manager.
-;;
-;; EDB:
-;;   (manager EMP MGR)            — EMP reports directly to MGR
-;; IDB:
-;;   (subordinate MGR EMP)        — EMP is in MGR's subtree
-;;   (headcount MGR N)            — number of subordinates under MGR
-(define
-  dl-demo-org-rules
-  (quote
-    ((subordinate Mgr Emp <- (manager Emp Mgr))
-     (subordinate Mgr Emp
-       <- (manager Mid Mgr) (subordinate Mid Emp))
-     (headcount Mgr N
-       <- (subordinate Mgr Anyone) (count N E (subordinate Mgr E))))))
-
-;; ── Loader stub ──────────────────────────────────────────────────
-;; Wiring to PostgreSQL would replace these helpers with calls into
-;; rose-ash's internal HTTP RPC (fetch_data → /internal/data/...).
-;; The shape returned by dl-load-from-edb! is the same in either case.
-(define
-  dl-demo-make
-  (fn
-    (facts rules)
-    (dl-program-data facts rules)))

lib/datalog/eval.sx

@@ -1,512 +0,0 @@
-;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
-;;
-;; Two saturators are exposed:
-;;   `dl-saturate-naive!` — re-joins each rule against the full DB every
-;;     iteration. Reference implementation; useful for differential tests.
-;;   `dl-saturate!`       — semi-naive default. Tracks per-relation delta
-;;     sets and substitutes one positive body literal per rule with the
-;;     delta of its relation, joining the rest against the previous-
-;;     iteration DB. Same fixpoint, dramatically less work on recursive
-;;     rules.
-;;
-;; Body literal kinds:
-;;   positive (rel arg ... arg)  → match against EDB+IDB tuples
-;;   built-in (< X Y), (is X e)  → constraint via dl-eval-builtin
-;;   negation {:neg lit}         → Phase 7
-
-(define
-  dl-match-positive
-  (fn
-    (lit db subst)
-    (let
-      ((rel (dl-rel-name lit)) (results (list)))
-      (cond
-        ((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
-        (else
-          (let
-            ;; If the first argument walks to a non-variable (constant
-            ;; or already-bound var), use the first-arg index for
-            ;; this relation. Otherwise scan the full tuple list.
-            ((tuples
-               (cond
-                 ((>= (len lit) 2)
-                   (let ((walked (dl-walk (nth lit 1) subst)))
-                     (cond
-                       ((dl-var? walked) (dl-rel-tuples db rel))
-                       (else (dl-index-lookup db rel walked)))))
-                 (else (dl-rel-tuples db rel)))))
-            (do
-              (for-each
-                (fn
-                  (tuple)
-                  (let
-                    ((s (dl-unify lit tuple subst)))
-                    (when (not (nil? s)) (append! results s))))
-                tuples)
-              results)))))))
-
-;; Match a positive literal against the delta set for its relation only.
-(define
-  dl-match-positive-delta
-  (fn
-    (lit delta subst)
-    (let
-      ((rel (dl-rel-name lit)) (results (list)))
-      (let
-        ((tuples (if (has-key? delta rel) (get delta rel) (list))))
-        (do
-          (for-each
-            (fn
-              (tuple)
-              (let
-                ((s (dl-unify lit tuple subst)))
-                (when (not (nil? s)) (append! results s))))
-            tuples)
-          results)))))
-
-;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
-(define
-  dl-match-negation
-  (fn
-    (inner db subst)
-    (let
-      ((walked (dl-apply-subst inner subst))
-        (matches (dl-match-positive inner db subst)))
-      (cond
-        ((= (len matches) 0) (list subst))
-        (else (list))))))
-
-(define
-  dl-match-lit
-  (fn
-    (lit db subst)
-    (cond
-      ((and (dict? lit) (has-key? lit :neg))
-        (dl-match-negation (get lit :neg) db subst))
-      ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
-      ((dl-builtin? lit)
-        (let
-          ((s (dl-eval-builtin lit subst)))
-          (if (nil? s) (list) (list s))))
-      ((and (list? lit) (> (len lit) 0))
-        (dl-match-positive lit db subst))
-      (else (error (str "datalog: unknown body-literal shape: " lit))))))
-
-(define
-  dl-find-bindings
-  (fn (lits db subst) (dl-fb-aux lits db subst 0 (len lits))))
-
-(define
-  dl-fb-aux
-  (fn
-    (lits db subst i n)
-    (cond
-      ((nil? subst) (list))
-      ((>= i n) (list subst))
-      (else
-        (let
-          ((options (dl-match-lit (nth lits i) db subst))
-            (results (list)))
-          (do
-            (for-each
-              (fn
-                (s)
-                (for-each
-                  (fn (s2) (append! results s2))
-                  (dl-fb-aux lits db s (+ i 1) n)))
-              options)
-            results))))))
-
-;; Naive: apply each rule against full DB until no new tuples.
-(define
-  dl-apply-rule!
-  (fn
-    (db rule)
-    (let
-      ((head (get rule :head)) (body (get rule :body)) (new? false))
-      (do
-        (for-each
-          (fn
-            (s)
-            (let
-              ((derived (dl-apply-subst head s)))
-              (when (dl-add-derived! db derived) (set! new? true))))
-          (dl-find-bindings body db (dl-empty-subst)))
-        new?))))
-
-;; Returns true iff one more saturation step would derive no new
-;; tuples (i.e. the db is at fixpoint). Useful in tests that want
-;; to assert "no work left" after a saturation call. Works under
-;; either saturator since both compute the same fixpoint.
-(define
-  dl-saturated?
-  (fn
-    (db)
-    (let ((any-new false))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (when (not any-new)
-              (for-each
-                (fn
-                  (s)
-                  (let ((derived (dl-apply-subst (get rule :head) s)))
-                    (when
-                      (and (not any-new)
-                           (not (dl-tuple-member?
-                                  derived
-                                  (dl-rel-tuples
-                                    db (dl-rel-name derived)))))
-                      (set! any-new true))))
-                (dl-find-bindings (get rule :body) db (dl-empty-subst)))))
-          (dl-rules db))
-        (not any-new)))))
-
-(define
-  dl-saturate-naive!
-  (fn
-    (db)
-    (let
-      ((changed true))
-      (do
-        (define
-          dl-snloop
-          (fn
-            ()
-            (when
-              changed
-              (do
-                (set! changed false)
-                (for-each
-                  (fn (r) (when (dl-apply-rule! db r) (set! changed true)))
-                  (dl-rules db))
-                (dl-snloop)))))
-        (dl-snloop)
-        db))))
-
-;; ── Semi-naive ───────────────────────────────────────────────────
-
-;; Take a snapshot dict {rel -> tuples} of every relation currently in
-;; the DB. Used as initial delta for the first iteration.
-(define
-  dl-snapshot-facts
-  (fn
-    (db)
-    (let
-      ((facts (get db :facts)) (out {}))
-      (do
-        (for-each
-          (fn (k) (dict-set! out k (dl-copy-list (get facts k))))
-          (keys facts))
-        out))))
-
-(define
-  dl-copy-list
-  (fn
-    (xs)
-    (let
-      ((out (list)))
-      (do (for-each (fn (x) (append! out x)) xs) out))))
-
-;; Does any relation in `delta` have ≥1 tuple?
-(define
-  dl-delta-empty?
-  (fn
-    (delta)
-    (let
-      ((ks (keys delta)) (any-non-empty false))
-      (do
-        (for-each
-          (fn
-            (k)
-            (when
-              (> (len (get delta k)) 0)
-              (set! any-non-empty true)))
-          ks)
-        (not any-non-empty)))))
-
-;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
-;; is matched against the per-relation delta only. The other positive
-;; literals match against the snapshot DB (db.facts read at iteration
-;; start). Built-ins and negations behave as in `dl-match-lit`.
-(define
-  dl-find-bindings-semi
-  (fn
-    (lits db delta delta-idx subst)
-    (dl-fbs-aux lits db delta delta-idx 0 subst)))
-
-(define
-  dl-fbs-aux
-  (fn
-    (lits db delta delta-idx i subst)
-    (cond
-      ((nil? subst) (list))
-      ((>= i (len lits)) (list subst))
-      (else
-        (let
-          ((lit (nth lits i))
-            (options
-              (cond
-                ((and (dict? lit) (has-key? lit :neg))
-                  (dl-match-negation (get lit :neg) db subst))
-                ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
-                ((dl-builtin? lit)
-                  (let
-                    ((s (dl-eval-builtin lit subst)))
-                    (if (nil? s) (list) (list s))))
-                ((and (list? lit) (> (len lit) 0))
-                  (if
-                    (= i delta-idx)
-                    (dl-match-positive-delta lit delta subst)
-                    (dl-match-positive lit db subst)))
-                (else (error (str "datalog: unknown body-lit: " lit)))))
-            (results (list)))
-          (do
-            (for-each
-              (fn
-                (s)
-                (for-each
-                  (fn (s2) (append! results s2))
-                  (dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
-              options)
-            results))))))
-
-;; Collect candidate head tuples from a rule using delta. Walks every
-;; positive body position and unions the resulting heads. For rules
-;; with no positive body literal, falls back to a naive single-pass
-;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
-(define
-  dl-collect-rule-candidates
-  (fn
-    (rule db delta)
-    (let
-      ((head (get rule :head))
-        (body (get rule :body))
-        (out (list))
-        (saw-pos false))
-      (do
-        (define
-          dl-cri
-          (fn
-            (i)
-            (when
-              (< i (len body))
-              (do
-                (let
-                  ((lit (nth body i)))
-                  (when
-                    (dl-positive-lit? lit)
-                    (do
-                      (set! saw-pos true)
-                      (for-each
-                        (fn (s) (append! out (dl-apply-subst head s)))
-                        (dl-find-bindings-semi
-                          body
-                          db
-                          delta
-                          i
-                          (dl-empty-subst))))))
-                (dl-cri (+ i 1))))))
-        (dl-cri 0)
-        (when
-          (not saw-pos)
-          (for-each
-            (fn (s) (append! out (dl-apply-subst head s)))
-            (dl-find-bindings body db (dl-empty-subst))))
-        out))))
-
-;; Add a list of candidate tuples to db; collect newly-added ones into
-;; the new-delta dict (keyed by relation name).
-(define
-  dl-commit-candidates!
-  (fn
-    (db candidates new-delta)
-    (for-each
-      (fn
-        (lit)
-        (when
-          (dl-add-derived! db lit)
-          (let
-            ((rel (dl-rel-name lit)))
-            (do
-              (when
-                (not (has-key? new-delta rel))
-                (dict-set! new-delta rel (list)))
-              (append! (get new-delta rel) lit)))))
-      candidates)))
-
-(define
-  dl-saturate-rules!
-  (fn
-    (db rules)
-    (let
-      ((delta (dl-snapshot-facts db)))
-      (do
-        (define
-          dl-sr-step
-          (fn
-            ()
-            (let
-              ((pending (list)) (new-delta {}))
-              (do
-                (for-each
-                  (fn
-                    (rule)
-                    (for-each
-                      (fn (cand) (append! pending cand))
-                      (dl-collect-rule-candidates rule db delta)))
-                  rules)
-                (dl-commit-candidates! db pending new-delta)
-                (cond
-                  ((dl-delta-empty? new-delta) nil)
-                  (else (do (set! delta new-delta) (dl-sr-step))))))))
-        (dl-sr-step)
-        db))))
-
-;; Stratified driver: rejects non-stratifiable programs at saturation
-;; time, then iterates strata in increasing order, running semi-naive on
-;; the rules whose head sits in that stratum.
-(define
-  dl-saturate!
-  (fn
-    (db)
-    (let
-      ((err (dl-check-stratifiable db)))
-      (cond
-        ((not (nil? err)) (error (str "dl-saturate!: " err)))
-        (else
-          (let
-            ((strata (dl-compute-strata db)))
-            (let
-              ((grouped (dl-group-rules-by-stratum db strata)))
-              (let
-                ((groups (get grouped :groups))
-                  (max-s (get grouped :max)))
-                (do
-                  (define
-                    dl-strat-loop
-                    (fn
-                      (s)
-                      (when
-                        (<= s max-s)
-                        (let
-                          ((sk (str s)))
-                          (do
-                            (when
-                              (has-key? groups sk)
-                              (dl-saturate-rules! db (get groups sk)))
-                            (dl-strat-loop (+ s 1)))))))
-                  (dl-strat-loop 0)
-                  db)))))))))
-
-;; ── Querying ─────────────────────────────────────────────────────
-
-;; Coerce a query argument to a list of body literals. A single literal
-;; like `(p X)` (positive — head is a symbol) or `{:neg ...}` becomes
-;; `((p X))`. A list of literals like `((p X) (q X))` is returned as-is.
-(define
-  dl-query-coerce
-  (fn
-    (goal)
-    (cond
-      ((and (dict? goal) (has-key? goal :neg)) (list goal))
-      ((and (list? goal) (> (len goal) 0) (symbol? (first goal)))
-        (list goal))
-      ((list? goal) goal)
-      (else (error (str "dl-query: unrecognised goal shape: " goal))))))
-
-(define
-  dl-query
-  (fn
-    (db goal)
-    (do
-      (dl-saturate! db)
-      ;; Rename anonymous '_' vars in each goal literal so multiple
-      ;; occurrences do not unify together. Keep the user-facing var
-      ;; list (taken before renaming) so projected results retain user
-      ;; names.
-      (let
-        ((goals (dl-query-coerce goal))
-          ;; Start the renamer past any `_anon<N>` symbols the user
-          ;; may have written in the query — avoids collision.
-          (renamer
-            (dl-make-anon-renamer (dl-max-anon-num-list goal 0 0))))
-        (let
-          ((user-vars (dl-query-user-vars goals))
-            (renamed (map (fn (g) (dl-rename-anon-lit g renamer)) goals)))
-          (let
-            ((substs (dl-find-bindings renamed db (dl-empty-subst)))
-              (results (list)))
-            (do
-              (for-each
-                (fn
-                  (s)
-                  (let
-                    ((proj (dl-project-subst s user-vars)))
-                    (when
-                      (not (dl-tuple-member? proj results))
-                      (append! results proj))))
-                substs)
-              results)))))))
-
-(define
-  dl-query-user-vars
-  (fn
-    (goals)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (g)
-            (cond
-              ((and (dict? g) (has-key? g :neg))
-                (for-each
-                  (fn
-                    (v)
-                    (when
-                      (and (not (= v "_")) (not (dl-member-string? v seen)))
-                      (append! seen v)))
-                  (dl-vars-of (get g :neg))))
-              ((dl-aggregate? g)
-                ;; Only the result var (first arg of the aggregate
-                ;; literal) is user-facing. The aggregated var and
-                ;; any vars in the inner goal are internal.
-                (let ((r (nth g 1)))
-                  (when
-                    (dl-var? r)
-                    (let ((rn (symbol->string r)))
-                      (when
-                        (and (not (= rn "_"))
-                             (not (dl-member-string? rn seen)))
-                        (append! seen rn))))))
-              (else
-                (for-each
-                  (fn
-                    (v)
-                    (when
-                      (and (not (= v "_")) (not (dl-member-string? v seen)))
-                      (append! seen v)))
-                  (dl-vars-of g)))))
-          goals)
-        seen))))
-
-(define
-  dl-project-subst
-  (fn
-    (subst names)
-    (let
-      ((out {}))
-      (do
-        (for-each
-          (fn
-            (n)
-            (let
-              ((sym (string->symbol n)))
-              (let
-                ((v (dl-walk sym subst)))
-                (dict-set! out n (dl-apply-subst v subst)))))
-          names)
-        out))))
-
-(define dl-relation (fn (db name) (dl-rel-tuples db name)))

lib/datalog/magic.sx

@@ -1,464 +0,0 @@
-;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
-;;
-;; First step of the magic-sets transformation (Phase 6). Right now
-;; the saturator does not consume these — they are introspection
-;; helpers that future magic-set rewriting will build on top of.
-;;
-;; Definitions:
-;;   - An *adornment* of an n-ary literal is an n-character string
-;;     of "b" (bound — value already known at the call site) and
-;;     "f" (free — to be derived).
-;;   - SIPS (Sideways Information Passing Strategy) walks the body
-;;     of an adorned rule left-to-right tracking which variables
-;;     have been bound so far, computing each body literal's
-;;     adornment in turn.
-;;
-;; Usage:
-;;
-;;   (dl-adorn-goal '(ancestor tom X))
-;;     => "bf"
-;;
-;;   (dl-rule-sips
-;;     {:head (ancestor X Z)
-;;      :body ((parent X Y) (ancestor Y Z))}
-;;     "bf")
-;;   => ({:lit (parent X Y) :adornment "bf"}
-;;       {:lit (ancestor Y Z) :adornment "bf"})
-
-;; Per-arg adornment under the current bound-var name set.
-(define
-  dl-adorn-arg
-  (fn
-    (arg bound)
-    (cond
-      ((dl-var? arg)
-        (if (dl-member-string? (symbol->string arg) bound) "b" "f"))
-      (else "b"))))
-
-;; Adornment for the args of a literal (after the relation name).
-(define
-  dl-adorn-args
-  (fn
-    (args bound)
-    (cond
-      ((= (len args) 0) "")
-      (else
-        (str
-          (dl-adorn-arg (first args) bound)
-          (dl-adorn-args (rest args) bound))))))
-
-;; Adornment of a top-level goal under the empty bound-var set.
-(define
-  dl-adorn-goal
-  (fn (goal) (dl-adorn-args (rest goal) (list))))
-
-;; Adornment of a literal under an explicit bound set.
-(define
-  dl-adorn-lit
-  (fn (lit bound) (dl-adorn-args (rest lit) bound)))
-
-;; The set of variable names made bound by walking a positive
-;; literal whose adornment is known. Free positions add their
-;; vars to the bound set.
-(define
-  dl-vars-bound-by-lit
-  (fn
-    (lit bound)
-    (let ((args (rest lit)) (out (list)))
-      (do
-        (for-each
-          (fn (a)
-            (when
-              (and (dl-var? a)
-                   (not (dl-member-string? (symbol->string a) bound))
-                   (not (dl-member-string? (symbol->string a) out)))
-              (append! out (symbol->string a))))
-          args)
-        out))))
-
-;; Walk the rule body left-to-right tracking bound vars seeded by the
-;; head adornment. Returns a list of {:lit :adornment} entries.
-;;
-;; Negation, comparison, and built-ins are passed through with their
-;; adornment computed from the current bound set; they don't add new
-;; bindings (except `is`, which binds its left arg if a var). Aggregates
-;; are treated like is — the result var becomes bound.
-(define
-  dl-init-head-bound
-  (fn
-    (head adornment)
-    (let ((args (rest head)) (out (list)))
-      (do
-        (define
-          dl-ihb-loop
-          (fn
-            (i)
-            (when
-              (< i (len args))
-              (do
-                (let
-                  ((c (slice adornment i (+ i 1)))
-                    (a (nth args i)))
-                  (when
-                    (and (= c "b") (dl-var? a))
-                    (let ((n (symbol->string a)))
-                      (when
-                        (not (dl-member-string? n out))
-                        (append! out n)))))
-                (dl-ihb-loop (+ i 1))))))
-        (dl-ihb-loop 0)
-        out))))
-
-(define
-  dl-rule-sips
-  (fn
-    (rule head-adornment)
-    (let
-      ((bound (dl-init-head-bound (get rule :head) head-adornment))
-        (out (list)))
-      (do
-        (for-each
-          (fn
-            (lit)
-            (cond
-              ((and (dict? lit) (has-key? lit :neg))
-                (let ((target (get lit :neg)))
-                  (append!
-                    out
-                    {:lit lit :adornment (dl-adorn-lit target bound)})))
-              ((dl-builtin? lit)
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    ;; `is` binds its left arg (if var) once RHS is ground.
-                    (when
-                      (and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
-                      (let ((n (symbol->string (nth lit 1))))
-                        (when
-                          (not (dl-member-string? n bound))
-                          (append! bound n)))))))
-              ((and (list? lit) (dl-aggregate? lit))
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    ;; Result var (first arg) becomes bound.
-                    (when (dl-var? (nth lit 1))
-                      (let ((n (symbol->string (nth lit 1))))
-                        (when
-                          (not (dl-member-string? n bound))
-                          (append! bound n)))))))
-              ((and (list? lit) (> (len lit) 0))
-                (let ((adn (dl-adorn-lit lit bound)))
-                  (do
-                    (append! out {:lit lit :adornment adn})
-                    (for-each
-                      (fn (n)
-                        (when (not (dl-member-string? n bound))
-                          (append! bound n)))
-                      (dl-vars-bound-by-lit lit bound)))))))
-          (get rule :body))
-        out))))
-
-;; ── Magic predicate naming + bound-args extraction ─────────────
-;; These are building blocks for the magic-sets *transformation*
-;; itself. The transformation (which generates rewritten rules
-;; with magic_<rel>^<adornment> filters) is future work — for now
-;; these helpers can be used to inspect what such a transformation
-;; would produce.
-
-;; "magic_p^bf" given relation "p" and adornment "bf".
-(define
-  dl-magic-rel-name
-  (fn (rel adornment) (str "magic_" rel "^" adornment)))
-
-;; A magic predicate literal:
-;;   (magic_<rel>^<adornment> arg1 arg2 ...)
-(define
-  dl-magic-lit
-  (fn
-    (rel adornment bound-args)
-    (cons (string->symbol (dl-magic-rel-name rel adornment)) bound-args)))
-
-;; Extract bound args (those at "b" positions in `adornment`) from a
-;; literal `(rel arg1 arg2 ... argN)`. Returns the list of arg values.
-(define
-  dl-bound-args
-  (fn
-    (lit adornment)
-    (let ((args (rest lit)) (out (list)))
-      (do
-        (define
-          dl-ba-loop
-          (fn
-            (i)
-            (when
-              (< i (len args))
-              (do
-                (when
-                  (= (slice adornment i (+ i 1)) "b")
-                  (append! out (nth args i)))
-                (dl-ba-loop (+ i 1))))))
-        (dl-ba-loop 0)
-        out))))
-
-;; ── Magic-sets rewriter ─────────────────────────────────────────
-;;
-;; Given the original rule list and a query (rel, adornment) pair,
-;; generates the magic-rewritten program: a list of rules that
-;; (a) gate each original rule with a `magic_<rel>^<adn>` filter and
-;; (b) propagate the magic relation through SIPS so that only
-;; query-relevant tuples are derived. Seed facts are returned
-;; separately and must be added to the db at evaluation time.
-;;
-;; Output: {:rules <rewritten-rules> :seed <magic-seed-literal>}
-;;
-;; The rewriter only rewrites IDB rules; EDB facts pass through.
-;; Built-in predicates and negation in body literals are kept in
-;; place but do not generate propagation rules of their own.
-
-(define
-  dl-magic-pair-key
-  (fn (rel adornment) (str rel "^" adornment)))
-
-(define
-  dl-magic-rewrite
-  (fn
-    (rules query-rel query-adornment query-args)
-    (let
-      ((seen (list))
-        (queue (list))
-        (out (list)))
-      (do
-        (define
-          dl-mq-mark!
-          (fn
-            (rel adornment)
-            (let ((k (dl-magic-pair-key rel adornment)))
-              (when
-                (not (dl-member-string? k seen))
-                (do
-                  (append! seen k)
-                  (append! queue {:rel rel :adn adornment}))))))
-
-        (define
-          dl-mq-rewrite-rule!
-          (fn
-            (rule adn)
-            (let
-              ((head (get rule :head))
-                (body (get rule :body))
-                (sips (dl-rule-sips rule adn)))
-              (let
-                ((magic-filter
-                   (dl-magic-lit
-                     (dl-rel-name head)
-                     adn
-                     (dl-bound-args head adn))))
-                (do
-                  ;; Adorned rule: head :- magic-filter, body...
-                  (let ((new-body (list)))
-                    (do
-                      (append! new-body magic-filter)
-                      (for-each
-                        (fn (lit) (append! new-body lit))
-                        body)
-                      (append! out {:head head :body new-body})))
-                  ;; Propagation rules for each positive non-builtin
-                  ;; body literal at position i.
-                  (define
-                    dl-mq-prop-loop
-                    (fn
-                      (i)
-                      (when
-                        (< i (len body))
-                        (do
-                          (let
-                            ((lit (nth body i))
-                              (sip-entry (nth sips i)))
-                            (when
-                              (and (list? lit)
-                                   (> (len lit) 0)
-                                   (not (and (dict? lit) (has-key? lit :neg)))
-                                   (not (dl-builtin? lit))
-                                   (not (dl-aggregate? lit)))
-                              (let
-                                ((lit-adn (get sip-entry :adornment))
-                                  (lit-rel (dl-rel-name lit)))
-                                (let
-                                  ((prop-head
-                                     (dl-magic-lit
-                                       lit-rel
-                                       lit-adn
-                                       (dl-bound-args lit lit-adn))))
-                                  (let ((prop-body (list)))
-                                    (do
-                                      (append! prop-body magic-filter)
-                                      (define
-                                        dl-mq-prefix-loop
-                                        (fn
-                                          (j)
-                                          (when
-                                            (< j i)
-                                            (do
-                                              (append!
-                                                prop-body
-                                                (nth body j))
-                                              (dl-mq-prefix-loop (+ j 1))))))
-                                      (dl-mq-prefix-loop 0)
-                                      (append!
-                                        out
-                                        {:head prop-head :body prop-body})
-                                      (dl-mq-mark! lit-rel lit-adn)))))))
-                          (dl-mq-prop-loop (+ i 1))))))
-                  (dl-mq-prop-loop 0))))))
-
-        (dl-mq-mark! query-rel query-adornment)
-
-        (let ((idx 0))
-          (define
-            dl-mq-process
-            (fn
-              ()
-              (when
-                (< idx (len queue))
-                (let ((item (nth queue idx)))
-                  (do
-                    (set! idx (+ idx 1))
-                    (let
-                      ((rel (get item :rel)) (adn (get item :adn)))
-                      (for-each
-                        (fn
-                          (rule)
-                          (when
-                            (= (dl-rel-name (get rule :head)) rel)
-                            (dl-mq-rewrite-rule! rule adn)))
-                        rules))
-                    (dl-mq-process))))))
-          (dl-mq-process))
-
-        {:rules out
-         :seed
-         (dl-magic-lit
-           query-rel
-           query-adornment
-           query-args)}))))
-
-;; ── Top-level magic-sets driver ─────────────────────────────────
-;;
-;; (dl-magic-query db query-goal) — run `query-goal` under magic-sets
-;; evaluation. Builds a fresh internal db with:
-;;   - the caller's EDB facts (relations not headed by any rule),
-;;   - the magic seed fact, and
-;;   - the rewritten rules.
-;; Saturates and queries, returning the substitution list. The
-;; caller's db is untouched.
-;;
-;; Useful primarily as a perf alternative for queries that only
-;; need a small slice of a recursive relation. Equivalent to
-;; dl-query for any single fully-stratifiable program.
-
-(define
-  dl-magic-rule-heads
-  (fn
-    (rules)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (r)
-            (let ((h (dl-rel-name (get r :head))))
-              (when
-                (and (not (nil? h)) (not (dl-member-string? h seen)))
-                (append! seen h))))
-          rules)
-        seen))))
-
-;; True iff any rule's body contains a literal kind that the magic
-;; rewriter doesn't propagate magic to — i.e. an aggregate or a
-;; negation. Used by dl-magic-query to decide whether to pre-saturate
-;; the source db (for correctness on stratified programs) or skip
-;; that step (preserving full magic-sets efficiency for pure
-;; positive programs).
-(define
-  dl-rule-has-nonprop-lit?
-  (fn
-    (body i n)
-    (cond
-      ((>= i n) false)
-      ((let ((lit (nth body i)))
-         (or (and (dict? lit) (has-key? lit :neg))
-             (dl-aggregate? lit)))
-        true)
-      (else (dl-rule-has-nonprop-lit? body (+ i 1) n)))))
-
-(define
-  dl-rules-need-presaturation?
-  (fn
-    (rules)
-    (cond
-      ((= (len rules) 0) false)
-      ((let ((body (get (first rules) :body)))
-         (dl-rule-has-nonprop-lit? body 0 (len body)))
-        true)
-      (else (dl-rules-need-presaturation? (rest rules))))))
-
-(define
-  dl-magic-query
-  (fn
-    (db query-goal)
-    ;; Magic-sets only applies to positive non-builtin / non-aggregate
-    ;; literals against rule-defined relations. For other goal shapes
-    ;; (built-ins, aggregates, EDB-only relations) the seed is either
-    ;; non-ground or unused; fall back to dl-query.
-    (cond
-      ((not (and (list? query-goal)
-                 (> (len query-goal) 0)
-                 (symbol? (first query-goal))))
-        (error (str "dl-magic-query: goal must be a positive literal "
-                    "(non-empty list with a symbol head), got " query-goal)))
-      ((or (dl-builtin? query-goal)
-           (dl-aggregate? query-goal)
-           (and (dict? query-goal) (has-key? query-goal :neg)))
-        (dl-query db query-goal))
-      (else
-        (do
-          ;; If the rule set has aggregates or negation, pre-saturate
-          ;; the source db before copying facts. The magic rewriter
-          ;; passes aggregate body lits and negated lits through
-          ;; unchanged (no magic propagation generated for them) — so
-          ;; if their inner-goal relation is IDB, it would be empty in
-          ;; the magic db. Pre-saturating ensures equivalence with
-          ;; `dl-query` for every stratified program. Pure positive
-          ;; programs skip this and keep the full magic-sets perf win
-          ;; from goal-directed re-derivation.
-          (when
-            (dl-rules-need-presaturation? (dl-rules db))
-            (dl-saturate! db))
-          (let
-            ((query-rel (dl-rel-name query-goal))
-              (query-adn (dl-adorn-goal query-goal)))
-            (let
-              ((query-args (dl-bound-args query-goal query-adn))
-                (rules (dl-rules db)))
-              (let
-                ((rewritten (dl-magic-rewrite rules query-rel query-adn query-args))
-                  (mdb (dl-make-db))
-                  (rule-heads (dl-magic-rule-heads rules)))
-            (do
-              ;; Copy ALL existing facts. EDB-only relations bring their
-              ;; tuples; mixed EDB+IDB relations bring both their EDB
-              ;; portion and any pre-saturated IDB tuples (which the
-              ;; rewritten rules would re-derive anyway). Skipping facts
-              ;; for rule-headed relations would leave the magic run
-              ;; without the EDB portion of mixed relations.
-              (for-each
-                (fn
-                  (rel)
-                  (for-each
-                    (fn (t) (dl-add-fact! mdb t))
-                    (dl-rel-tuples db rel)))
-                (keys (get db :facts)))
-              ;; Seed + rewritten rules.
-              (dl-add-fact! mdb (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! mdb r)) (get rewritten :rules))
-              (dl-query mdb query-goal))))))))))

lib/datalog/parser.sx

@@ -1,252 +0,0 @@
-;; lib/datalog/parser.sx — Datalog tokens → AST
-;;
-;; Output shapes:
-;;   Literal (positive)  := (relname arg ... arg)        — SX list
-;;   Literal (negative)  := {:neg (relname arg ... arg)} — dict
-;;   Argument            := var-symbol | atom-symbol | number | string
-;;                        | (op-name arg ... arg)        — arithmetic compound
-;;   Fact                := {:head literal :body ()}
-;;   Rule                := {:head literal :body (lit ... lit)}
-;;   Query               := {:query (lit ... lit)}
-;;   Program             := list of facts / rules / queries
-;;
-;; Variables and constants are both SX symbols; the evaluator dispatches
-;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
-;;
-;; The parser permits nested compounds in arg position to support
-;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
-;; rejects compounds whose head is not an arithmetic operator.
-
-(define
-  dl-pp-peek
-  (fn
-    (st)
-    (let
-      ((i (get st :idx)) (tokens (get st :tokens)))
-      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
-
-(define
-  dl-pp-peek2
-  (fn
-    (st)
-    (let
-      ((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
-      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
-
-(define
-  dl-pp-advance!
-  (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
-
-(define
-  dl-pp-at?
-  (fn
-    (st type value)
-    (let
-      ((t (dl-pp-peek st)))
-      (and
-        (= (get t :type) type)
-        (or (= value nil) (= (get t :value) value))))))
-
-(define
-  dl-pp-error
-  (fn
-    (st msg)
-    (let
-      ((t (dl-pp-peek st)))
-      (error
-        (str
-          "Parse error at pos "
-          (get t :pos)
-          ": "
-          msg
-          " (got "
-          (get t :type)
-          " '"
-          (if (= (get t :value) nil) "" (get t :value))
-          "')")))))
-
-(define
-  dl-pp-expect!
-  (fn
-    (st type value)
-    (let
-      ((t (dl-pp-peek st)))
-      (if
-        (dl-pp-at? st type value)
-        (do (dl-pp-advance! st) t)
-        (dl-pp-error
-          st
-          (str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
-
-;; Argument: variable, atom, number, string, or compound (relname/op + parens).
-(define
-  dl-pp-parse-arg
-  (fn
-    (st)
-    (let
-      ((t (dl-pp-peek st)))
-      (let
-        ((ty (get t :type)) (vv (get t :value)))
-        (cond
-          ((= ty "number") (do (dl-pp-advance! st) vv))
-          ((= ty "string") (do (dl-pp-advance! st) vv))
-          ((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
-          ;; Negative numeric literal: `-` op directly followed by a
-          ;; number (no `(`) is parsed as a single negative number.
-          ;; This keeps `(-X Y)` (compound) and `-N` (literal) distinct.
-          ((and (= ty "op") (= vv "-")
-                (= (get (dl-pp-peek2 st) :type) "number"))
-            (do
-              (dl-pp-advance! st)
-              (let
-                ((n (get (dl-pp-peek st) :value)))
-                (do (dl-pp-advance! st) (- 0 n)))))
-          ((or (= ty "atom") (= ty "op"))
-            (do
-              (dl-pp-advance! st)
-              (if
-                (dl-pp-at? st "punct" "(")
-                (do
-                  (dl-pp-advance! st)
-                  (let
-                    ((args (dl-pp-parse-arg-list st)))
-                    (do
-                      (dl-pp-expect! st "punct" ")")
-                      (cons (string->symbol vv) args))))
-                (string->symbol vv))))
-          (else (dl-pp-error st "expected term")))))))
-
-;; Comma-separated args inside parens.
-(define
-  dl-pp-parse-arg-list
-  (fn
-    (st)
-    (let
-      ((args (list)))
-      (do
-        (append! args (dl-pp-parse-arg st))
-        (define
-          dl-pp-arg-loop
-          (fn
-            ()
-            (when
-              (dl-pp-at? st "punct" ",")
-              (do
-                (dl-pp-advance! st)
-                (append! args (dl-pp-parse-arg st))
-                (dl-pp-arg-loop)))))
-        (dl-pp-arg-loop)
-        args))))
-
-;; A positive literal: relname (atom or op) followed by optional (args).
-(define
-  dl-pp-parse-positive
-  (fn
-    (st)
-    (let
-      ((t (dl-pp-peek st)))
-      (let
-        ((ty (get t :type)) (vv (get t :value)))
-        (if
-          (or (= ty "atom") (= ty "op"))
-          (do
-            (dl-pp-advance! st)
-            (if
-              (dl-pp-at? st "punct" "(")
-              (do
-                (dl-pp-advance! st)
-                (let
-                  ((args (dl-pp-parse-arg-list st)))
-                  (do
-                    (dl-pp-expect! st "punct" ")")
-                    (cons (string->symbol vv) args))))
-              (list (string->symbol vv))))
-          (dl-pp-error st "expected literal head"))))))
-
-;; A body literal: positive, or not(positive).
-(define
-  dl-pp-parse-body-lit
-  (fn
-    (st)
-    (let
-      ((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
-      (if
-        (and
-          (= (get t1 :type) "atom")
-          (= (get t1 :value) "not")
-          (= (get t2 :type) "punct")
-          (= (get t2 :value) "("))
-        (do
-          (dl-pp-advance! st)
-          (dl-pp-advance! st)
-          (let
-            ((inner (dl-pp-parse-positive st)))
-            (do (dl-pp-expect! st "punct" ")") {:neg inner})))
-        (dl-pp-parse-positive st)))))
-
-;; Comma-separated body literals.
-(define
-  dl-pp-parse-body
-  (fn
-    (st)
-    (let
-      ((lits (list)))
-      (do
-        (append! lits (dl-pp-parse-body-lit st))
-        (define
-          dl-pp-body-loop
-          (fn
-            ()
-            (when
-              (dl-pp-at? st "punct" ",")
-              (do
-                (dl-pp-advance! st)
-                (append! lits (dl-pp-parse-body-lit st))
-                (dl-pp-body-loop)))))
-        (dl-pp-body-loop)
-        lits))))
-
-;; Single clause: fact, rule, or query. Consumes trailing dot.
-(define
-  dl-pp-parse-clause
-  (fn
-    (st)
-    (cond
-      ((dl-pp-at? st "op" "?-")
-        (do
-          (dl-pp-advance! st)
-          (let
-            ((body (dl-pp-parse-body st)))
-            (do (dl-pp-expect! st "punct" ".") {:query body}))))
-      (else
-        (let
-          ((head (dl-pp-parse-positive st)))
-          (cond
-            ((dl-pp-at? st "op" ":-")
-              (do
-                (dl-pp-advance! st)
-                (let
-                  ((body (dl-pp-parse-body st)))
-                  (do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
-            (else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
-
-(define
-  dl-parse-program
-  (fn
-    (tokens)
-    (let
-      ((st {:tokens tokens :idx 0}) (clauses (list)))
-      (do
-        (define
-          dl-pp-prog-loop
-          (fn
-            ()
-            (when
-              (not (dl-pp-at? st "eof" nil))
-              (do
-                (append! clauses (dl-pp-parse-clause st))
-                (dl-pp-prog-loop)))))
-        (dl-pp-prog-loop)
-        clauses))))
-
-(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))

lib/datalog/scoreboard.json

@@ -1,20 +0,0 @@
-{
-  "lang": "datalog",
-  "total_passed": 276,
-  "total_failed": 0,
-  "total": 276,
-  "suites": [
-    {"name":"tokenize","passed":31,"failed":0,"total":31},
-    {"name":"parse","passed":23,"failed":0,"total":23},
-    {"name":"unify","passed":29,"failed":0,"total":29},
-    {"name":"eval","passed":44,"failed":0,"total":44},
-    {"name":"builtins","passed":26,"failed":0,"total":26},
-    {"name":"semi_naive","passed":8,"failed":0,"total":8},
-    {"name":"negation","passed":12,"failed":0,"total":12},
-    {"name":"aggregates","passed":23,"failed":0,"total":23},
-    {"name":"api","passed":22,"failed":0,"total":22},
-    {"name":"magic","passed":37,"failed":0,"total":37},
-    {"name":"demo","passed":21,"failed":0,"total":21}
-  ],
-  "generated": "2026-05-11T09:40:12+00:00"
-}

lib/datalog/scoreboard.md

@@ -1,17 +0,0 @@
-# datalog scoreboard
-
-**276 / 276 passing** (0 failure(s)).
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| tokenize | 31 | 31 | ok |
-| parse | 23 | 23 | ok |
-| unify | 29 | 29 | ok |
-| eval | 44 | 44 | ok |
-| builtins | 26 | 26 | ok |
-| semi_naive | 8 | 8 | ok |
-| negation | 12 | 12 | ok |
-| aggregates | 23 | 23 | ok |
-| api | 22 | 22 | ok |
-| magic | 37 | 37 | ok |
-| demo | 21 | 21 | ok |

lib/datalog/strata.sx

@@ -1,323 +0,0 @@
-;; lib/datalog/strata.sx — dependency graph, SCC analysis, stratum assignment.
-;;
-;; A program is stratifiable iff no cycle in its dependency graph passes
-;; through a negative edge. The stratum of relation R is the depth at which
-;; R can first be evaluated:
-;;
-;;   stratum(R) = max over edges (R → S) of:
-;;       stratum(S)         if the edge is positive
-;;       stratum(S) + 1     if the edge is negative
-;;
-;; All relations in the same SCC share a stratum (and the SCC must have only
-;; positive internal edges, else the program is non-stratifiable).
-
-;; Build dep graph: dict {head-rel-name -> ({:rel str :neg bool} ...)}.
-(define
-  dl-build-dep-graph
-  (fn
-    (db)
-    (let ((g {}))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let
-              ((head-rel (dl-rel-name (get rule :head))))
-              (when
-                (not (nil? head-rel))
-                (do
-                  (when
-                    (not (has-key? g head-rel))
-                    (dict-set! g head-rel (list)))
-                  (let ((existing (get g head-rel)))
-                    (for-each
-                      (fn
-                        (lit)
-                        (cond
-                          ((dl-aggregate? lit)
-                            (let
-                              ((edge (dl-aggregate-dep-edge lit)))
-                              (when
-                                (not (nil? edge))
-                                (append! existing edge))))
-                          (else
-                            (let
-                              ((target
-                                 (cond
-                                   ((and (dict? lit) (has-key? lit :neg))
-                                     (dl-rel-name (get lit :neg)))
-                                   ((dl-builtin? lit) nil)
-                                   ((and (list? lit) (> (len lit) 0))
-                                     (dl-rel-name lit))
-                                   (else nil)))
-                                (neg?
-                                  (and (dict? lit) (has-key? lit :neg))))
-                              (when
-                                (not (nil? target))
-                                (append!
-                                  existing
-                                  {:rel target :neg neg?}))))))
-                      (get rule :body)))))))
-          (dl-rules db))
-        g))))
-
-;; All relations referenced — heads of rules + EDB names + body relations.
-(define
-  dl-all-relations
-  (fn
-    (db)
-    (let ((seen (list)))
-      (do
-        (for-each
-          (fn
-            (k)
-            (when (not (dl-member-string? k seen)) (append! seen k)))
-          (keys (get db :facts)))
-        (for-each
-          (fn
-            (rule)
-            (do
-              (let ((h (dl-rel-name (get rule :head))))
-                (when
-                  (and (not (nil? h)) (not (dl-member-string? h seen)))
-                  (append! seen h)))
-              (for-each
-                (fn
-                  (lit)
-                  (let
-                    ((t
-                       (cond
-                         ((dl-aggregate? lit)
-                           (let ((edge (dl-aggregate-dep-edge lit)))
-                             (if (nil? edge) nil (get edge :rel))))
-                         ((and (dict? lit) (has-key? lit :neg))
-                           (dl-rel-name (get lit :neg)))
-                         ((dl-builtin? lit) nil)
-                         ((and (list? lit) (> (len lit) 0))
-                           (dl-rel-name lit))
-                         (else nil))))
-                    (when
-                      (and (not (nil? t)) (not (dl-member-string? t seen)))
-                      (append! seen t))))
-                (get rule :body))))
-          (dl-rules db))
-        seen))))
-
-;; reach: dict {from: dict {to: edge-info}} where edge-info is
-;;   {:any bool :neg bool}
-;; meaning "any path from `from` to `to`" and "exists a negative-passing
-;; path from `from` to `to`".
-;;
-;; Floyd-Warshall over the dep graph. The 'neg' flag propagates through
-;; concatenation: if any edge along the path is negative, the path's
-;; flag is true.
-(define
-  dl-build-reach
-  (fn
-    (graph nodes)
-    (let ((reach {}))
-      (do
-        (for-each
-          (fn (n) (dict-set! reach n {}))
-          nodes)
-        (for-each
-          (fn
-            (head)
-            (when
-              (has-key? graph head)
-              (for-each
-                (fn
-                  (edge)
-                  (let
-                    ((target (get edge :rel)) (n (get edge :neg)))
-                    (let ((row (get reach head)))
-                      (cond
-                        ((has-key? row target)
-                          (let ((cur (get row target)))
-                            (dict-set!
-                              row
-                              target
-                              {:any true :neg (or n (get cur :neg))})))
-                        (else
-                          (dict-set! row target {:any true :neg n}))))))
-                (get graph head))))
-          nodes)
-        (for-each
-          (fn
-            (k)
-            (for-each
-              (fn
-                (i)
-                (let ((row-i (get reach i)))
-                  (when
-                    (has-key? row-i k)
-                    (let ((ik (get row-i k)) (row-k (get reach k)))
-                      (for-each
-                        (fn
-                          (j)
-                          (when
-                            (has-key? row-k j)
-                            (let ((kj (get row-k j)))
-                              (let
-                                ((combined-neg (or (get ik :neg) (get kj :neg))))
-                                (cond
-                                  ((has-key? row-i j)
-                                    (let ((cur (get row-i j)))
-                                      (dict-set!
-                                        row-i
-                                        j
-                                        {:any true
-                                         :neg (or combined-neg (get cur :neg))})))
-                                  (else
-                                    (dict-set!
-                                      row-i
-                                      j
-                                      {:any true :neg combined-neg})))))))
-                        nodes)))))
-              nodes))
-          nodes)
-        reach))))
-
-;; Returns nil on success, or error message string on failure.
-(define
-  dl-check-stratifiable
-  (fn
-    (db)
-    (let
-      ((graph (dl-build-dep-graph db))
-        (nodes (dl-all-relations db)))
-      (let ((reach (dl-build-reach graph nodes)) (err nil))
-        (do
-          (for-each
-            (fn
-              (rule)
-              (when
-                (nil? err)
-                (let ((head-rel (dl-rel-name (get rule :head))))
-                  (for-each
-                    (fn
-                      (lit)
-                      (cond
-                        ((and (dict? lit) (has-key? lit :neg))
-                          (let ((tgt (dl-rel-name (get lit :neg))))
-                            (when
-                              (and (not (nil? tgt))
-                                   (dl-reach-cycle? reach head-rel tgt))
-                              (set!
-                                err
-                                (str "non-stratifiable: relation " head-rel
-                                     " transitively depends through negation on "
-                                     tgt
-                                     " which depends back on " head-rel)))))
-                        ((dl-aggregate? lit)
-                          (let ((edge (dl-aggregate-dep-edge lit)))
-                            (when
-                              (not (nil? edge))
-                              (let ((tgt (get edge :rel)))
-                                (when
-                                  (and (not (nil? tgt))
-                                       (dl-reach-cycle? reach head-rel tgt))
-                                  (set!
-                                    err
-                                    (str "non-stratifiable: relation "
-                                         head-rel
-                                         " aggregates over " tgt
-                                         " which depends back on "
-                                         head-rel))))))))) 
-                    (get rule :body)))))
-            (dl-rules db))
-          err)))))
-
-(define
-  dl-reach-cycle?
-  (fn
-    (reach a b)
-    (and
-      (dl-reach-row-has? reach b a)
-      (dl-reach-row-has? reach a b))))
-
-(define
-  dl-reach-row-has?
-  (fn
-    (reach from to)
-    (let ((row (get reach from)))
-      (and (not (nil? row)) (has-key? row to)))))
-
-;; Compute stratum per relation. Iteratively propagate from EDB roots.
-;; Uses the per-relation max-stratum-of-deps formula. Stops when stable.
-(define
-  dl-compute-strata
-  (fn
-    (db)
-    (let
-      ((graph (dl-build-dep-graph db))
-        (nodes (dl-all-relations db))
-        (strata {}))
-      (do
-        (for-each (fn (n) (dict-set! strata n 0)) nodes)
-        (let ((changed true))
-          (do
-            (define
-              dl-cs-loop
-              (fn
-                ()
-                (when
-                  changed
-                  (do
-                    (set! changed false)
-                    (for-each
-                      (fn
-                        (head)
-                        (when
-                          (has-key? graph head)
-                          (for-each
-                            (fn
-                              (edge)
-                              (let
-                                ((tgt (get edge :rel))
-                                  (n (get edge :neg)))
-                                (let
-                                  ((tgt-strat
-                                     (if (has-key? strata tgt)
-                                       (get strata tgt) 0))
-                                    (cur (get strata head)))
-                                  (let
-                                    ((needed
-                                       (if n (+ tgt-strat 1) tgt-strat)))
-                                    (when
-                                      (> needed cur)
-                                      (do
-                                        (dict-set! strata head needed)
-                                        (set! changed true)))))))
-                            (get graph head))))
-                      nodes)
-                    (dl-cs-loop)))))
-            (dl-cs-loop)))
-        strata))))
-
-;; Group rules by their head's stratum. Returns dict {stratum-int -> rules}.
-(define
-  dl-group-rules-by-stratum
-  (fn
-    (db strata)
-    (let ((groups {}) (max-s 0))
-      (do
-        (for-each
-          (fn
-            (rule)
-            (let
-              ((head-rel (dl-rel-name (get rule :head))))
-              (let
-                ((s (if (has-key? strata head-rel)
-                       (get strata head-rel) 0)))
-                (do
-                  (when (> s max-s) (set! max-s s))
-                  (let
-                    ((sk (str s)))
-                    (do
-                      (when
-                        (not (has-key? groups sk))
-                        (dict-set! groups sk (list)))
-                      (append! (get groups sk) rule)))))))
-          (dl-rules db))
-        {:groups groups :max max-s}))))

lib/datalog/tests/aggregates.sx

@@ -1,357 +0,0 @@
-;; lib/datalog/tests/aggregates.sx — count / sum / min / max.
-
-(define dl-at-pass 0)
-(define dl-at-fail 0)
-(define dl-at-failures (list))
-
-(define
-  dl-at-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-at-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-at-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-at-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-at-deep=? (nth a i) (nth b i))) false)
-      (else (dl-at-deq-l? a b (+ i 1))))))
-
-(define
-  dl-at-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-at-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-at-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-at-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-at-subset? a b)
-      (dl-at-subset? b a))))
-
-(define
-  dl-at-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-at-contains? ys (first xs))) false)
-      (else (dl-at-subset? (rest xs) ys)))))
-
-(define
-  dl-at-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-at-deep=? (first xs) target) true)
-      (else (dl-at-contains? (rest xs) target)))))
-
-(define
-  dl-at-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-at-deep=? got expected)
-      (set! dl-at-pass (+ dl-at-pass 1))
-      (do
-        (set! dl-at-fail (+ dl-at-fail 1))
-        (append!
-          dl-at-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-at-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-at-set=? got expected)
-      (set! dl-at-pass (+ dl-at-pass 1))
-      (do
-        (set! dl-at-fail (+ dl-at-fail 1))
-        (append!
-          dl-at-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-at-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do
-        (guard
-          (e (#t (set! threw true)))
-          (thunk))
-        threw))))
-
-(define
-  dl-at-run-all!
-  (fn
-    ()
-    (do
-      ;; count
-      (dl-at-test-set! "count siblings"
-        (dl-query
-          (dl-program
-            "parent(p, bob). parent(p, alice). parent(p, charlie).
-             sibling(X, Y) :- parent(P, X), parent(P, Y), !=(X, Y).
-             sib_count(N) :- count(N, S, sibling(bob, S)).")
-          (list (quote sib_count) (quote N)))
-        (list {:N 2}))
-
-      ;; sum
-      (dl-at-test-set! "sum prices"
-        (dl-query
-          (dl-program
-            "price(apple, 5). price(pear, 7). price(plum, 3).
-             total(T) :- sum(T, X, price(F, X)).")
-          (list (quote total) (quote T)))
-        (list {:T 15}))
-
-      ;; min
-      (dl-at-test-set! "min score"
-        (dl-query
-          (dl-program
-            "score(alice, 80). score(bob, 65). score(carol, 92).
-             lo(M) :- min(M, S, score(P, S)).")
-          (list (quote lo) (quote M)))
-        (list {:M 65}))
-
-      ;; max
-      (dl-at-test-set! "max score"
-        (dl-query
-          (dl-program
-            "score(alice, 80). score(bob, 65). score(carol, 92).
-             hi(M) :- max(M, S, score(P, S)).")
-          (list (quote hi) (quote M)))
-        (list {:M 92}))
-
-      ;; count over derived relation (stratification needed).
-      (dl-at-test-set! "count over derived"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).
-             ancestor(X, Y) :- parent(X, Y).
-             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
-             num_ancestors(N) :- count(N, X, ancestor(a, X)).")
-          (list (quote num_ancestors) (quote N)))
-        (list {:N 4}))
-
-      ;; count with no matches → 0.
-      (dl-at-test-set! "count empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             zero(N) :- count(N, X, q(X)).")
-          (list (quote zero) (quote N)))
-        (list {:N 0}))
-
-      ;; sum with no matches → 0.
-      (dl-at-test-set! "sum empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             total(T) :- sum(T, X, q(X)).")
-          (list (quote total) (quote T)))
-        (list {:T 0}))
-
-      ;; min with no matches → rule does not fire.
-      (dl-at-test-set! "min empty"
-        (dl-query
-          (dl-program
-            "p(1). p(2).
-             lo(M) :- min(M, X, q(X)).")
-          (list (quote lo) (quote M)))
-        (list))
-
-      ;; Aggregate with comparison filter on result.
-      (dl-at-test-set! "popularity threshold"
-        (dl-query
-          (dl-program
-            "post(p1). post(p2).
-             liked(u1, p1). liked(u2, p1). liked(u3, p1).
-             liked(u1, p2). liked(u2, p2).
-             popular(P) :- post(P), count(N, U, liked(U, P)), >=(N, 3).")
-          (list (quote popular) (quote P)))
-        (list {:P (quote p1)}))
-
-      ;; findall: collect distinct values into a list.
-      (dl-at-test-set! "findall over EDB"
-        (dl-query
-          (dl-program
-            "p(a). p(b). p(c).
-             all_p(L) :- findall(L, X, p(X)).")
-          (list (quote all_p) (quote L)))
-        (list {:L (list (quote a) (quote b) (quote c))}))
-
-      (dl-at-test-set! "findall over derived"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(b, c). parent(c, d).
-             ancestor(X, Y) :- parent(X, Y).
-             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
-             desc(L) :- findall(L, X, ancestor(a, X)).")
-          (list (quote desc) (quote L)))
-        (list {:L (list (quote b) (quote c) (quote d))}))
-
-      (dl-at-test-set! "findall empty"
-        (dl-query
-          (dl-program
-            "p(1).
-             all_q(L) :- findall(L, X, q(X)).")
-          (list (quote all_q) (quote L)))
-        (list {:L (list)}))
-
-      ;; Aggregate vs single distinct.
-      ;; Group-by via aggregate-in-rule-body. Per-user friend count
-      ;; over a friends relation. The U var is bound by the prior
-      ;; positive lit u(U) so the aggregate counts only U-rooted
-      ;; friends per group.
-      (dl-at-test-set! "group-by per-user friend count"
-        (dl-query
-          (dl-program
-            "u(alice). u(bob). u(carol).
-             f(alice, x). f(alice, y). f(bob, x).
-             counts(U, N) :- u(U), count(N, X, f(U, X)).")
-          (list (quote counts) (quote U) (quote N)))
-        (list
-          {:U (quote alice) :N 2}
-          {:U (quote bob) :N 1}
-          {:U (quote carol) :N 0}))
-
-      ;; Stratification: recursion through aggregation is rejected.
-      ;; Aggregate validates that second arg is a variable.
-      (dl-at-test! "agg second arg must be var"
-        (dl-at-throws?
-          (fn () (dl-eval "p(1). q(N) :- count(N, 5, p(X))." "?- q(N).")))
-        true)
-
-      ;; Aggregate validates that third arg is a positive literal.
-      (dl-at-test! "agg third arg must be a literal"
-        (dl-at-throws?
-          (fn () (dl-eval "p(1). q(N) :- count(N, X, 42)." "?- q(N).")))
-        true)
-
-      ;; Aggregate validates that the agg-var (2nd arg) appears in the
-      ;; goal. Without it every match contributes the same unbound
-      ;; symbol — count silently returns 1, sum raises a confusing
-      ;; "expected number" error, etc. Catch the mistake at safety
-      ;; check time instead.
-      (dl-at-test! "agg-var must appear in goal"
-        (dl-at-throws?
-          (fn ()
-            (dl-eval
-              "p(1). p(2). c(N) :- count(N, Y, p(X))."
-              "?- c(N).")))
-        true)
-
-      ;; Indirect recursion through aggregation also rejected.
-      ;; q -> r (via positive lit), r -> q (via aggregate body).
-      ;; The aggregate edge counts as negation for stratification.
-      (dl-at-test! "indirect agg cycle rejected"
-        (dl-at-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule! db
-                  {:head (list (quote q) (quote N))
-                   :body (list (list (quote r) (quote N)))})
-                (dl-add-rule! db
-                  {:head (list (quote r) (quote N))
-                   :body (list (list (quote count) (quote N) (quote X)
-                                     (list (quote q) (quote X))))})
-                (dl-saturate! db)))))
-        true)
-
-      (dl-at-test! "agg recursion rejected"
-        (dl-at-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule! db
-                  {:head (list (quote q) (quote N))
-                   :body (list (list (quote count) (quote N) (quote X)
-                                     (list (quote q) (quote X))))})
-                (dl-saturate! db)))))
-        true)
-
-      ;; Negation + aggregation in the same body — different strata.
-      (dl-at-test-set! "neg + agg coexist"
-        (dl-query
-          (dl-program
-            "u(a). u(b). u(c). banned(b).
-             active(X) :- u(X), not(banned(X)).
-             cnt(N) :- count(N, X, active(X)).")
-          (list (quote cnt) (quote N)))
-        (list {:N 2}))
-
-      ;; Min over a derived empty relation: no result.
-      (dl-at-test-set! "min over empty derived"
-        (dl-query
-          (dl-program
-            "s(50). s(60).
-             score(N) :- s(N), >(N, 100).
-             low(M) :- min(M, X, score(X)).")
-          (list (quote low) (quote M)))
-        (list))
-
-      ;; Aggregates as the top-level query goal (regression for
-      ;; dl-match-lit aggregate dispatch and projection cleanup).
-      (dl-at-test-set! "count as query goal"
-        (dl-query
-          (dl-program "p(1). p(2). p(3). p(4).")
-          (list (quote count) (quote N) (quote X) (list (quote p) (quote X))))
-        (list {:N 4}))
-
-      (dl-at-test-set! "findall as query goal"
-        (dl-query
-          (dl-program "p(1). p(2). p(3).")
-          (list (quote findall) (quote L) (quote X)
-                (list (quote p) (quote X))))
-        (list {:L (list 1 2 3)}))
-
-      (dl-at-test-set! "distinct counted once"
-        (dl-query
-          (dl-program
-            "rated(alice, x). rated(alice, y). rated(bob, x).
-             rater_count(N) :- count(N, U, rated(U, F)).")
-          (list (quote rater_count) (quote N)))
-        (list {:N 2})))))
-
-(define
-  dl-aggregates-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-at-pass 0)
-      (set! dl-at-fail 0)
-      (set! dl-at-failures (list))
-      (dl-at-run-all!)
-      {:passed dl-at-pass
-       :failed dl-at-fail
-       :total (+ dl-at-pass dl-at-fail)
-       :failures dl-at-failures})))

lib/datalog/tests/api.sx

@@ -1,350 +0,0 @@
-;; lib/datalog/tests/api.sx — SX-data embedding API.
-
-(define dl-api-pass 0)
-(define dl-api-fail 0)
-(define dl-api-failures (list))
-
-(define
-  dl-api-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-api-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-api-deep=? (nth a i) (nth b i))) false)
-      (else (dl-api-deq-l? a b (+ i 1))))))
-
-(define
-  dl-api-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-api-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-api-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-api-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-api-subset? a b)
-      (dl-api-subset? b a))))
-
-(define
-  dl-api-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-api-contains? ys (first xs))) false)
-      (else (dl-api-subset? (rest xs) ys)))))
-
-(define
-  dl-api-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-api-deep=? (first xs) target) true)
-      (else (dl-api-contains? (rest xs) target)))))
-
-(define
-  dl-api-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-api-deep=? got expected)
-      (set! dl-api-pass (+ dl-api-pass 1))
-      (do
-        (set! dl-api-fail (+ dl-api-fail 1))
-        (append!
-          dl-api-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-api-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-api-set=? got expected)
-      (set! dl-api-pass (+ dl-api-pass 1))
-      (do
-        (set! dl-api-fail (+ dl-api-fail 1))
-        (append!
-          dl-api-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-api-run-all!
-  (fn
-    ()
-    (do
-      ;; dl-program-data with arrow form.
-      (dl-api-test-set! "data API ancestor closure"
-        (dl-query
-          (dl-program-data
-            (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
-            (quote
-              ((ancestor X Y <- (parent X Y))
-               (ancestor X Z <- (parent X Y) (ancestor Y Z)))))
-          (quote (ancestor tom X)))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-
-      ;; dl-program-data with dict rules.
-      (dl-api-test-set! "data API with dict rules"
-        (dl-query
-          (dl-program-data
-            (quote ((p a) (p b) (p c)))
-            (list
-              {:head (quote (q X)) :body (quote ((p X)))}))
-          (quote (q X)))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; dl-rule helper.
-      (dl-api-test-set! "dl-rule constructor"
-        (dl-query
-          (dl-program-data
-            (quote ((p 1) (p 2)))
-            (list (dl-rule (quote (q X)) (quote ((p X))))))
-          (quote (q X)))
-        (list {:X 1} {:X 2}))
-
-      ;; dl-assert! adds and re-derives.
-      (dl-api-test-set! "dl-assert! incremental"
-        (let
-          ((db (dl-program-data
-                 (quote ((parent tom bob) (parent bob ann)))
-                 (quote
-                   ((ancestor X Y <- (parent X Y))
-                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
-          (do
-            (dl-saturate! db)
-            (dl-assert! db (quote (parent ann pat)))
-            (dl-query db (quote (ancestor tom X)))))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-
-      ;; dl-retract! removes a fact and recomputes IDB.
-      (dl-api-test-set! "dl-retract! removes derived"
-        (let
-          ((db (dl-program-data
-                 (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
-                 (quote
-                   ((ancestor X Y <- (parent X Y))
-                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
-          (do
-            (dl-saturate! db)
-            (dl-retract! db (quote (parent bob ann)))
-            (dl-query db (quote (ancestor tom X)))))
-        (list {:X (quote bob)}))
-
-      ;; dl-retract! on a relation with BOTH explicit facts AND a rule
-      ;; (a "mixed" relation) used to wipe the EDB portion when the IDB
-      ;; was re-derived, even when the retract didn't match anything.
-      ;; :edb-keys provenance now preserves user-asserted facts.
-      (dl-api-test-set! "dl-retract! preserves EDB in mixed relation"
-        (let
-          ((db (dl-program-data
-                 (quote ((p a) (p b) (q c)))
-                 (quote ((p X <- (q X)))))))
-          (do
-            (dl-saturate! db)
-            ;; Retract a non-existent tuple — should be a no-op.
-            (dl-retract! db (quote (p z)))
-            (dl-query db (quote (p X)))))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; And retracting an actual EDB fact in a mixed relation drops
-      ;; only that fact; the derived portion stays.
-      (dl-api-test-set! "dl-retract! mixed: drop EDB, keep IDB"
-        (let
-          ((db (dl-program-data
-                 (quote ((p a) (p b) (q c)))
-                 (quote ((p X <- (q X)))))))
-          (do
-            (dl-saturate! db)
-            (dl-retract! db (quote (p a)))
-            (dl-query db (quote (p X)))))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; dl-program-data + dl-query with constants in head.
-      (dl-api-test-set! "constant-in-head data"
-        (dl-query
-          (dl-program-data
-            (quote ((edge a b) (edge b c) (edge c a)))
-            (quote
-              ((reach X Y <- (edge X Y))
-               (reach X Z <- (edge X Y) (reach Y Z)))))
-          (quote (reach a X)))
-        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
-
-      ;; Assert into empty db.
-      (dl-api-test-set! "assert into empty"
-        (let
-          ((db (dl-program-data (list) (list))))
-          (do
-            (dl-assert! db (quote (p 1)))
-            (dl-assert! db (quote (p 2)))
-            (dl-query db (quote (p X)))))
-        (list {:X 1} {:X 2}))
-
-      ;; Multi-goal query: pass list of literals.
-      (dl-api-test-set! "multi-goal query"
-        (dl-query
-          (dl-program-data
-            (quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
-            (list))
-          (list (quote (p X)) (quote (q X))))
-        (list {:X 2} {:X 3}))
-
-      ;; Multi-goal with comparison.
-      (dl-api-test-set! "multi-goal with comparison"
-        (dl-query
-          (dl-program-data
-            (quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
-            (list))
-          (list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
-        (list {:X 3} {:X 4} {:X 5}))
-
-      ;; dl-eval: single-call source + query.
-      (dl-api-test-set! "dl-eval ancestor"
-        (dl-eval
-          "parent(a, b). parent(b, c).
-           ancestor(X, Y) :- parent(X, Y).
-           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
-          "?- ancestor(a, X).")
-        (list {:X (quote b)} {:X (quote c)}))
-
-      (dl-api-test-set! "dl-eval multi-goal"
-        (dl-eval
-          "p(1). p(2). p(3). q(2). q(3)."
-          "?- p(X), q(X).")
-        (list {:X 2} {:X 3}))
-
-      ;; dl-rules-of: rules with head matching a relation name.
-      (dl-api-test! "dl-rules-of count"
-        (let
-          ((db (dl-program
-                 "p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
-          (len (dl-rules-of db "q")))
-        1)
-
-      (dl-api-test! "dl-rules-of empty"
-        (let
-          ((db (dl-program "p(1). p(2).")))
-          (len (dl-rules-of db "q")))
-        0)
-
-      ;; dl-clear-idb!: wipe rule-headed relations.
-      (dl-api-test! "dl-clear-idb! wipes IDB"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-saturate! db)
-            (dl-clear-idb! db)
-            (len (dl-relation db "ancestor"))))
-        0)
-
-      (dl-api-test! "dl-clear-idb! preserves EDB"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).")))
-          (do
-            (dl-saturate! db)
-            (dl-clear-idb! db)
-            (len (dl-relation db "parent"))))
-        2)
-
-      ;; dl-eval-magic — routes single-goal queries through
-      ;; magic-sets evaluation.
-      (dl-api-test-set! "dl-eval-magic ancestor"
-        (dl-eval-magic
-          "parent(a, b). parent(b, c).
-           ancestor(X, Y) :- parent(X, Y).
-           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
-          "?- ancestor(a, X).")
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; Equivalence: dl-eval and dl-eval-magic produce the same
-      ;; answers for any well-formed query (magic-sets is a perf
-      ;; alternative, not a semantic change).
-      (dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
-        (let
-          ((source "parent(a, b). parent(b, c). parent(c, d).
-                    ancestor(X, Y) :- parent(X, Y).
-                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
-          (let
-            ((semi (dl-eval source "?- ancestor(a, X)."))
-              (magic (dl-eval-magic source "?- ancestor(a, X).")))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Comprehensive integration: recursion + stratified negation
-      ;; + aggregation + comparison composed in a single program.
-      ;; (Uses _Anything as a regular var instead of `_` so the
-      ;;  outer rule binds via the reach lit.)
-      (dl-api-test-set! "integration"
-        (dl-eval
-          (str
-            "edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
-            "banned(c). "
-            "reach(X, Y) :- edge(X, Y). "
-            "reach(X, Z) :- edge(X, Y), reach(Y, Z). "
-            "safe(X, Y) :- reach(X, Y), not(banned(Y)). "
-            "reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
-            "popular(X) :- reach_count(X, N), >=(N, 2).")
-          "?- popular(X).")
-        (list {:X (quote a)}))
-
-      ;; dl-rule-from-list with no arrow → fact-style.
-      (dl-api-test-set! "no arrow → fact-like rule"
-        (let
-          ((rule (dl-rule-from-list (quote (foo X Y)))))
-          (list rule))
-        (list {:head (quote (foo X Y)) :body (list)}))
-
-      ;; dl-coerce-rule on dict passes through.
-      (dl-api-test-set! "coerce dict rule"
-        (let
-          ((d {:head (quote (h X)) :body (quote ((b X)))}))
-          (list (dl-coerce-rule d)))
-        (list {:head (quote (h X)) :body (quote ((b X)))})))))
-
-(define
-  dl-api-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-api-pass 0)
-      (set! dl-api-fail 0)
-      (set! dl-api-failures (list))
-      (dl-api-run-all!)
-      {:passed dl-api-pass
-       :failed dl-api-fail
-       :total (+ dl-api-pass dl-api-fail)
-       :failures dl-api-failures})))

lib/datalog/tests/builtins.sx

@@ -1,285 +0,0 @@
-;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
-
-(define dl-bt-pass 0)
-(define dl-bt-fail 0)
-(define dl-bt-failures (list))
-
-(define
-  dl-bt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-bt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-bt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-bt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-bt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-bt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-bt-set=?
-  (fn
-    (a b)
-    (and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
-
-(define
-  dl-bt-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-bt-contains? ys (first xs))) false)
-      (else (dl-bt-subset? (rest xs) ys)))))
-
-(define
-  dl-bt-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-bt-deep=? (first xs) target) true)
-      (else (dl-bt-contains? (rest xs) target)))))
-
-(define
-  dl-bt-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-bt-set=? got expected)
-      (set! dl-bt-pass (+ dl-bt-pass 1))
-      (do
-        (set! dl-bt-fail (+ dl-bt-fail 1))
-        (append!
-          dl-bt-failures
-          (str
-            name
-            "\n    expected (set): "
-            expected
-            "\n    got:            "
-            got))))))
-
-(define
-  dl-bt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-bt-deep=? got expected)
-      (set! dl-bt-pass (+ dl-bt-pass 1))
-      (do
-        (set! dl-bt-fail (+ dl-bt-fail 1))
-        (append!
-          dl-bt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-bt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-bt-run-all!
-  (fn
-    ()
-    (do
-      (dl-bt-test-set!
-        "less than filter"
-        (dl-query
-          (dl-program
-            "age(alice, 30). age(bob, 17). age(carol, 22).\n             adult(X) :- age(X, A), >=(A, 18).")
-          (list (quote adult) (quote X)))
-        (list {:X (quote alice)} {:X (quote carol)}))
-      (dl-bt-test-set!
-        "less-equal filter"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <=(X, 3).")
-          (list (quote small) (quote X)))
-        (list {:X 1} {:X 2} {:X 3}))
-      (dl-bt-test-set!
-        "not-equal filter"
-        (dl-query
-          (dl-program
-            "p(1, 2). p(2, 2). p(3, 4).\n             diff(X, Y) :- p(X, Y), !=(X, Y).")
-          (list (quote diff) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "is plus"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             succ(X, Y) :- n(X), is(Y, +(X, 1)).")
-          (list (quote succ) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "is multiply"
-        (dl-query
-          (dl-program
-            "n(2). n(3). n(4).\n             square(X, Y) :- n(X), is(Y, *(X, X)).")
-          (list (quote square) (quote X) (quote Y)))
-        (list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
-      (dl-bt-test-set!
-        "is nested expr"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
-          (list (quote f) (quote X) (quote Y)))
-        (list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
-      (dl-bt-test-set!
-        "is bound LHS — equality"
-        (dl-query
-          (dl-program
-            "n(1, 2). n(2, 5). n(3, 4).\n             succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
-          (list (quote succ) (quote X) (quote Y)))
-        (list {:X 1 :Y 2} {:X 3 :Y 4}))
-      (dl-bt-test-set!
-        "triple via is"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3).\n             triple(X, Y) :- n(X), is(Y, *(X, 3)).")
-          (list (quote triple) (quote X) (quote Y)))
-        (list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
-      (dl-bt-test-set!
-        "= unifies var with constant"
-        (dl-query
-          (dl-program "p(a). p(b).\n             qual(X) :- p(X), =(X, a).")
-          (list (quote qual) (quote X)))
-        (list {:X (quote a)}))
-      (dl-bt-test-set!
-        "= unifies two vars (one bound)"
-        (dl-query
-          (dl-program "p(a). p(b).\n             twin(X, Y) :- p(X), =(Y, X).")
-          (list (quote twin) (quote X) (quote Y)))
-        (list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
-      (dl-bt-test!
-        "big count"
-        (let
-          ((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n                  big(X) :- n(X), >=(X, 5).")))
-          (do (dl-saturate! db) (len (dl-relation db "big"))))
-        5)
-      ;; Built-in / arithmetic literals work as standalone query goals
-      ;; (without needing a wrapper rule).
-      (dl-bt-test-set! "comparison-only goal true"
-        (dl-eval "" "?- <(1, 2).")
-        (list {}))
-
-      (dl-bt-test-set! "comparison-only goal false"
-        (dl-eval "" "?- <(2, 1).")
-        (list))
-
-      (dl-bt-test-set! "is goal binds"
-        (dl-eval "" "?- is(N, +(2, 3)).")
-        (list {:N 5}))
-
-      ;; Bounded successor: a recursive rule with a comparison
-      ;; guard terminates because the Herbrand base is effectively
-      ;; bounded.
-      (dl-bt-test-set! "bounded successor"
-        (dl-query
-          (dl-program
-            "nat(0).
-             nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
-          (list (quote nat) (quote X)))
-        (list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))
-
-      (dl-bt-test!
-        "unsafe — comparison without binder"
-        (dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
-        true)
-      (dl-bt-test!
-        "unsafe — comparison both unbound"
-        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
-        true)
-      (dl-bt-test!
-        "unsafe — is uses unbound RHS var"
-        (dl-bt-throws?
-          (fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
-        true)
-      (dl-bt-test!
-        "unsafe — is on its own"
-        (dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
-        true)
-      (dl-bt-test!
-        "unsafe — = between two unbound"
-        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
-        true)
-      (dl-bt-test!
-        "safe — is binds head var"
-        (dl-bt-throws?
-          (fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
-        false)
-      (dl-bt-test!
-        "safe — comparison after binder"
-        (dl-bt-throws?
-          (fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
-        false)
-      (dl-bt-test!
-        "safe — = binds head var"
-        (dl-bt-throws?
-          (fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
-        false)
-
-      ;; Division by zero raises with a clear error. Without this guard
-      ;; SX's `/` returned IEEE infinity, which then silently flowed
-      ;; through comparisons and aggregations.
-      (dl-bt-test!
-        "is — division by zero raises"
-        (dl-bt-throws?
-          (fn ()
-            (dl-eval "p(10). q(R) :- p(X), is(R, /(X, 0))." "?- q(R).")))
-        true)
-
-      ;; Comparison ops `<`, `<=`, `>`, `>=` require both operands to
-      ;; have the same primitive type. Cross-type comparisons used to
-      ;; silently return false (for some pairs) or raise a confusing
-      ;; host-level error (for others) — now they all raise with a
-      ;; message that names the offending values.
-      (dl-bt-test!
-        "comparison — string vs number raises"
-        (dl-bt-throws?
-          (fn ()
-            (dl-eval "p(\"hello\"). q(X) :- p(X), <(X, 5)." "?- q(X).")))
-        true)
-
-      ;; `!=` is the exception — it's a polymorphic inequality test
-      ;; (uses dl-tuple-equal? underneath) so cross-type pairs are
-      ;; legitimate (and trivially unequal).
-      (dl-bt-test-set! "!= works across types"
-        (dl-query
-          (dl-program
-            "p(1). p(\"1\"). q(X) :- p(X), !=(X, 1).")
-          (quote (q X)))
-        (list {:X "1"})))))
-
-(define
-  dl-builtins-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-bt-pass 0)
-      (set! dl-bt-fail 0)
-      (set! dl-bt-failures (list))
-      (dl-bt-run-all!)
-      {:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))

lib/datalog/tests/demo.sx

@@ -1,321 +0,0 @@
-;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
-
-(define dl-demo-pass 0)
-(define dl-demo-fail 0)
-(define dl-demo-failures (list))
-
-(define
-  dl-demo-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-demo-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-demo-deep=? (nth a i) (nth b i))) false)
-      (else (dl-demo-deq-l? a b (+ i 1))))))
-
-(define
-  dl-demo-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-demo-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-demo-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-demo-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-demo-subset? a b)
-      (dl-demo-subset? b a))))
-
-(define
-  dl-demo-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-demo-contains? ys (first xs))) false)
-      (else (dl-demo-subset? (rest xs) ys)))))
-
-(define
-  dl-demo-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-demo-deep=? (first xs) target) true)
-      (else (dl-demo-contains? (rest xs) target)))))
-
-(define
-  dl-demo-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-demo-set=? got expected)
-      (set! dl-demo-pass (+ dl-demo-pass 1))
-      (do
-        (set! dl-demo-fail (+ dl-demo-fail 1))
-        (append!
-          dl-demo-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-demo-run-all!
-  (fn
-    ()
-    (do
-      ;; ── Federation ──────────────────────────────────────────
-      (dl-demo-test-set! "mutuals"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob alice)
-                    (follows bob carol) (follows carol dave)))
-            dl-demo-federation-rules)
-          (quote (mutual alice X)))
-        (list {:X (quote bob)}))
-
-      (dl-demo-test-set! "reachable transitive"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob carol) (follows carol dave)))
-            dl-demo-federation-rules)
-          (quote (reachable alice X)))
-        (list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
-
-      (dl-demo-test-set! "foaf"
-        (dl-query
-          (dl-demo-make
-            (quote ((follows alice bob) (follows bob carol) (follows alice dave)))
-            dl-demo-federation-rules)
-          (quote (foaf alice X)))
-        (list {:X (quote carol)}))
-
-      ;; ── Content ─────────────────────────────────────────────
-      (dl-demo-test-set! "popular posts"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((authored alice p1) (authored bob p2) (authored carol p3)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)
-               (liked u1 p2)))
-            dl-demo-content-rules)
-          (quote (popular P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "interesting feed"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me alice) (follows me bob)
-               (authored alice p1) (authored bob p2)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)
-               (liked u4 p2)))
-            dl-demo-content-rules)
-          (quote (interesting me P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "post likes count"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((authored alice p1)
-               (liked u1 p1) (liked u2 p1) (liked u3 p1)))
-            dl-demo-content-rules)
-          (quote (post-likes p1 N)))
-        (list {:N 3}))
-
-      ;; ── Permissions ─────────────────────────────────────────
-      (dl-demo-test-set! "direct group access"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member alice editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote alice)}))
-
-      (dl-demo-test-set! "subgroup access"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member bob writers)
-               (subgroup writers editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote bob)}))
-
-      (dl-demo-test-set! "transitive subgroup"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((member carol drafters)
-               (subgroup drafters writers)
-               (subgroup writers editors)
-               (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list {:X (quote carol)}))
-
-      ;; ── Cooking posts (canonical Phase 10 example) ─────────
-      (dl-demo-test-set! "cooking posts by network"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me alice) (follows alice bob) (follows alice carol)
-               (authored alice p1) (authored bob p2)
-               (authored carol p3) (authored carol p4)
-               (tagged p1 travel) (tagged p2 cooking)
-               (tagged p3 cooking) (tagged p4 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list {:P (quote p2)} {:P (quote p3)}))
-
-      (dl-demo-test-set! "cooking — direct follow only"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me bob)
-               (authored bob p1) (authored bob p2)
-               (tagged p1 cooking) (tagged p2 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "cooking — none in network"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((follows me bob)
-               (authored bob p1) (tagged p1 books)))
-            dl-demo-cooking-rules)
-          (quote (cooking-post-by-network me P)))
-        (list))
-
-      ;; ── Tag co-occurrence ──────────────────────────────────
-      (dl-demo-test-set! "cotagged posts"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((tagged p1 cooking) (tagged p1 vegetarian)
-               (tagged p2 cooking) (tagged p2 quick)
-               (tagged p3 vegetarian)))
-            dl-demo-tag-cooccur-rules)
-          (quote (cotagged P cooking vegetarian)))
-        (list {:P (quote p1)}))
-
-      (dl-demo-test-set! "tag pair count"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((tagged p1 cooking) (tagged p1 vegetarian)
-               (tagged p2 cooking) (tagged p2 quick)
-               (tagged p3 cooking) (tagged p3 vegetarian)))
-            dl-demo-tag-cooccur-rules)
-          (quote (tag-pair-count cooking vegetarian N)))
-        (list {:N 2}))
-
-      ;; ── Shortest path on a weighted DAG ──────────────────
-      (dl-demo-test-set! "shortest a→d via DAG"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a d W)))
-        (list {:W 10}))
-
-      (dl-demo-test-set! "shortest a→c picks 2-hop"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a c W)))
-        (list {:W 8}))
-
-      (dl-demo-test-set! "shortest unreachable empty"
-        (dl-query
-          (dl-demo-make
-            (quote ((edge a b 5) (edge b c 3)))
-            dl-demo-shortest-path-rules)
-          (quote (shortest a d W)))
-        (list))
-
-      ;; ── Org chart + headcount ─────────────────────────────
-      (dl-demo-test-set! "ceo subordinate transitive"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (subordinate ceo X)))
-        (list
-          {:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
-          {:X (quote ic2)} {:X (quote ic3)}))
-
-      (dl-demo-test-set! "ceo headcount = 5"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (headcount ceo N)))
-        (list {:N 5}))
-
-      (dl-demo-test-set! "mgr1 headcount = 2"
-        (dl-query
-          (dl-demo-make
-            (quote
-              ((manager ic1 mgr1) (manager ic2 mgr1)
-               (manager mgr1 vp1) (manager ic3 vp1)
-               (manager vp1 ceo)))
-            dl-demo-org-rules)
-          (quote (headcount mgr1 N)))
-        (list {:N 2}))
-
-      (dl-demo-test-set! "no access without grant"
-        (dl-query
-          (dl-demo-make
-            (quote ((member dave outsiders) (allowed editors blog)))
-            dl-demo-perm-rules)
-          (quote (can-access X blog)))
-        (list)))))
-
-(define
-  dl-demo-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-demo-pass 0)
-      (set! dl-demo-fail 0)
-      (set! dl-demo-failures (list))
-      (dl-demo-run-all!)
-      {:passed dl-demo-pass
-       :failed dl-demo-fail
-       :total (+ dl-demo-pass dl-demo-fail)
-       :failures dl-demo-failures})))

lib/datalog/tests/eval.sx

@@ -1,463 +0,0 @@
-;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
-
-(define dl-et-pass 0)
-(define dl-et-fail 0)
-(define dl-et-failures (list))
-
-;; Same deep-equal helper used in other suites.
-(define
-  dl-et-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-et-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-et-deep=? (nth a i) (nth b i))) false)
-      (else (dl-et-deq-l? a b (+ i 1))))))
-
-(define
-  dl-et-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-et-deq-d? a b ka (+ i 1))))))
-
-;; Set-equality on lists (order-independent, uses dl-et-deep=?).
-(define
-  dl-et-set=?
-  (fn
-    (a b)
-    (and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
-
-(define
-  dl-et-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-et-contains? ys (first xs))) false)
-      (else (dl-et-subset? (rest xs) ys)))))
-
-(define
-  dl-et-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-et-deep=? (first xs) target) true)
-      (else (dl-et-contains? (rest xs) target)))))
-
-(define
-  dl-et-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-et-deep=? got expected)
-      (set! dl-et-pass (+ dl-et-pass 1))
-      (do
-        (set! dl-et-fail (+ dl-et-fail 1))
-        (append!
-          dl-et-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-et-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-et-set=? got expected)
-      (set! dl-et-pass (+ dl-et-pass 1))
-      (do
-        (set! dl-et-fail (+ dl-et-fail 1))
-        (append!
-          dl-et-failures
-          (str
-            name
-            "\n    expected (set): "
-            expected
-            "\n    got:            "
-            got))))))
-
-(define
-  dl-et-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-et-run-all!
-  (fn
-    ()
-    (do
-      (dl-et-test-set!
-        "fact lookup any"
-        (dl-query
-          (dl-program "parent(tom, bob). parent(bob, ann).")
-          (list (quote parent) (quote X) (quote Y)))
-        (list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
-      (dl-et-test-set!
-        "fact lookup constant arg"
-        (dl-query
-          (dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
-          (list (quote parent) (quote tom) (quote Y)))
-        (list {:Y (quote bob)} {:Y (quote liz)}))
-      (dl-et-test-set!
-        "no match"
-        (dl-query
-          (dl-program "parent(tom, bob).")
-          (list (quote parent) (quote nobody) (quote X)))
-        (list))
-      (dl-et-test-set!
-        "ancestor closure"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(bob, ann). parent(ann, pat).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
-          (list (quote ancestor) (quote tom) (quote X)))
-        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
-      (dl-et-test-set!
-        "sibling"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n             sibling(X, Y) :- parent(P, X), parent(P, Y).")
-          (list (quote sibling) (quote bob) (quote Y)))
-        (list {:Y (quote bob)} {:Y (quote liz)}))
-      (dl-et-test-set!
-        "same-generation"
-        (dl-query
-          (dl-program
-            "parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n             person(tom). person(bob). person(liz). person(ann). person(joe).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
-          (list (quote sg) (quote ann) (quote X)))
-        (list {:X (quote ann)} {:X (quote joe)}))
-      (dl-et-test!
-        "ancestor count"
-        (let
-          ((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
-        6)
-      (dl-et-test-set!
-        "grandparent"
-        (dl-query
-          (dl-program
-            "parent(a, b). parent(b, c). parent(c, d).\n             grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
-          (list (quote grandparent) (quote X) (quote Y)))
-        (list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
-      (dl-et-test!
-        "no recursion infinite loop"
-        (let
-          ((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n                  reach(X, Y) :- edge(X, Y).\n                  reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
-          (do (dl-saturate! db) (len (dl-relation db "reach"))))
-        9)
-      ;; Rule-shape sanity: empty-list head and non-list body raise
-      ;; clear errors rather than crashing inside the saturator.
-      (dl-et-test! "empty head rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-add-rule! (dl-make-db)
-              {:head (list) :body (list)})))
-        true)
-
-      (dl-et-test! "non-list body rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-add-rule! (dl-make-db)
-              {:head (list (quote p) (quote X)) :body 42})))
-        true)
-
-      ;; Reserved relation names rejected as rule/fact heads.
-      (dl-et-test!
-        "reserved name `not` as head rejected"
-        (dl-et-throws? (fn () (dl-program "not(X) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `count` as head rejected"
-        (dl-et-throws?
-          (fn () (dl-program "count(N, X, p(X)) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `<` as head rejected"
-        (dl-et-throws? (fn () (dl-program "<(X, 5) :- p(X).")))
-        true)
-
-      (dl-et-test!
-        "reserved name `is` as head rejected"
-        (dl-et-throws? (fn () (dl-program "is(N, +(1, 2)) :- p(N).")))
-        true)
-
-      ;; Body literal with a reserved-name positive head is rejected.
-      ;; The parser only treats outer-level `not(P)` as negation; nested
-      ;; `not(not(P))` would otherwise silently parse as a positive call
-      ;; to a relation named `not` and succeed vacuously. The safety
-      ;; checker now flags this so the user gets a clear error.
-      ;; Body literal with a reserved-name positive head is rejected.
-      ;; The parser only treats outer-level `not(P)` as negation; nested
-      ;; `not(not(P))` would otherwise silently parse as a positive call
-      ;; to a relation named `not` and succeed vacuously — so the safety
-      ;; checker now flags this to give the user a clear error.
-      (dl-et-test!
-        "nested not(not(...)) rejected"
-        (dl-et-throws?
-          (fn ()
-            (dl-program
-              "banned(a). u(a). vip(X) :- u(X), not(not(banned(X))).")))
-        true)
-
-      ;; A dict body literal that isn't `{:neg ...}` is almost always a
-      ;; typo — it would otherwise silently fall through to a confusing
-      ;; head-var-unbound safety error. Now caught with a clear message.
-      (dl-et-test!
-        "dict body lit without :neg rejected"
-        (dl-et-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (dl-add-rule! db
-                {:head (list (quote p) (quote X))
-                 :body (list {:weird "stuff"})}))))
-        true)
-
-      ;; Facts may only have simple-term args (number / string / symbol).
-      ;; A compound arg like `+(1, 2)` would otherwise be silently
-      ;; stored as the unreduced expression `(+ 1 2)` because dl-ground?
-      ;; sees no free variables.
-      (dl-et-test!
-        "compound arg in fact rejected"
-        (dl-et-throws? (fn () (dl-program "p(+(1, 2)).")))
-        true)
-
-      ;; Rule heads may only have variable or constant args — no
-      ;; compounds. Compound heads would be saturated as unreduced
-      ;; tuples rather than the arithmetic result the user expected.
-      (dl-et-test!
-        "compound arg in rule head rejected"
-        (dl-et-throws?
-          (fn () (dl-program "n(3). double(*(X, 2)) :- n(X).")))
-        true)
-
-      ;; The anonymous-variable renamer used to start at `_anon1`
-      ;; unconditionally; a rule that wrote `q(_anon1) :- p(_anon1, _)`
-      ;; (the user picking the same name the renamer would generate)
-      ;; would see the `_` renamed to `_anon1` too, collapsing the
-      ;; two positions in `p(_anon1, _)` to a single var. Now the
-      ;; renamer scans the rule for the max `_anon<N>` and starts past
-      ;; it, so user-written names of that form are preserved.
-      (dl-et-test-set! "anonymous-rename avoids user `_anon` collision"
-        (dl-query
-          (dl-program
-            "p(a, b). p(c, d). q(_anon1) :- p(_anon1, _).")
-          (quote (q X)))
-        (list {:X (quote a)} {:X (quote c)}))
-
-      (dl-et-test!
-        "unsafe head var"
-        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
-        true)
-      (dl-et-test!
-        "unsafe — empty body"
-        (dl-et-throws? (fn () (dl-program "p(X) :- .")))
-        true)
-      ;; Underscore in head is unsafe — it's a fresh existential per
-      ;; occurrence after Phase 5d's anonymous-var renaming, and there's
-      ;; nothing in the body to bind it. (Old behavior accepted this by
-      ;; treating '_' as a literal name to skip; the renaming made it an
-      ;; ordinary unbound variable.)
-      (dl-et-test!
-        "underscore in head — unsafe"
-        (dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
-        true)
-      (dl-et-test!
-        "underscore in body only — safe"
-        (dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
-        false)
-      (dl-et-test!
-        "var only in head — unsafe"
-        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
-        true)
-      (dl-et-test!
-        "head var bound by body"
-        (dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
-        false)
-      (dl-et-test!
-        "head subset of body"
-        (dl-et-throws?
-          (fn
-            ()
-            (dl-program
-              "edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
-        false)
-
-      ;; Anonymous variables: each occurrence must be independent.
-      (dl-et-test-set! "anon vars in rule are independent"
-        (dl-query
-          (dl-program
-            "p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
-          (list (quote q) (quote X)))
-        (list {:X (quote a)} {:X (quote c)}))
-
-      (dl-et-test-set! "anon vars in goal are independent"
-        (dl-query
-          (dl-program "p(1, 2, 3). p(4, 5, 6).")
-          (list (quote p) (quote _) (quote X) (quote _)))
-        (list {:X 2} {:X 5}))
-
-      ;; dl-summary: relation -> tuple-count for inspection.
-      (dl-et-test! "dl-summary basic"
-        (dl-summary
-          (let
-            ((db (dl-program "p(1). p(2). q(3).")))
-            (do (dl-saturate! db) db)))
-        {:p 2 :q 1})
-
-      (dl-et-test! "dl-summary empty IDB shown"
-        (dl-summary
-          (let
-            ((db (dl-program "r(X) :- s(X).")))
-            (do (dl-saturate! db) db)))
-        {:r 0})
-
-      (dl-et-test! "dl-summary mixed EDB and IDB"
-        (dl-summary
-          (let
-            ((db (dl-program
-                   "parent(a, b).
-                    ancestor(X, Y) :- parent(X, Y).
-                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-            (do (dl-saturate! db) db)))
-        {:parent 1 :ancestor 1})
-
-      (dl-et-test! "dl-summary empty db"
-        (dl-summary (dl-make-db))
-        {})
-
-      ;; Strategy hook: default semi-naive; :magic accepted but
-      ;; falls back to semi-naive (the transformation itself is
-      ;; deferred — Phase 6 in plan).
-      (dl-et-test! "default strategy"
-        (dl-get-strategy (dl-make-db))
-        :semi-naive)
-
-      (dl-et-test! "set strategy"
-        (let ((db (dl-make-db)))
-          (do (dl-set-strategy! db :magic) (dl-get-strategy db)))
-        :magic)
-
-      ;; Unknown strategy values are rejected so typos don't silently
-      ;; fall back to the default.
-      (dl-et-test!
-        "unknown strategy rejected"
-        (dl-et-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (dl-set-strategy! db :semi_naive))))
-        true)
-
-      ;; dl-saturated?: no-work-left predicate.
-      (dl-et-test! "saturated? after saturation"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (do (dl-saturate! db) (dl-saturated? db)))
-        true)
-
-      (dl-et-test! "saturated? before saturation"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (dl-saturated? db))
-        false)
-
-      ;; Disjunction via multiple rules — Datalog has no `;` in
-      ;; body, so disjunction is expressed as separate rules with
-      ;; the same head. Here plant_based(X) is satisfied by either
-      ;; vegan(X) or vegetarian(X).
-      (dl-et-test-set! "disjunction via multiple rules"
-        (dl-query
-          (dl-program
-            "vegan(alice). vegetarian(bob). meat_eater(carol).
-             plant_based(X) :- vegan(X).
-             plant_based(X) :- vegetarian(X).")
-          (list (quote plant_based) (quote X)))
-        (list {:X (quote alice)} {:X (quote bob)}))
-
-      ;; Bipartite-style join: pair-of-friends who share a hobby.
-      ;; Three-relation join exercising the planner's join order.
-      (dl-et-test-set! "bipartite friends-with-hobby"
-        (dl-query
-          (dl-program
-            "hobby(alice, climb). hobby(bob, paint).
-             hobby(carol, climb).
-             friend(alice, carol). friend(bob, alice).
-             match(A, B, H) :- friend(A, B), hobby(A, H), hobby(B, H).")
-          (list (quote match) (quote A) (quote B) (quote H)))
-        (list {:A (quote alice) :B (quote carol) :H (quote climb)}))
-
-      ;; Repeated variable (diagonal): p(X, X) only matches tuples
-      ;; whose two args are equal. The unifier handles this via the
-      ;; subst chain — first occurrence binds X, second occurrence
-      ;; checks against the binding.
-      (dl-et-test-set! "diagonal query"
-        (dl-query
-          (dl-program "p(1, 1). p(2, 3). p(4, 4). p(5, 5).")
-          (list (quote p) (quote X) (quote X)))
-        (list {:X 1} {:X 4} {:X 5}))
-
-      ;; A relation can be both EDB-seeded and rule-derived;
-      ;; saturate combines facts + derivations.
-      (dl-et-test-set! "mixed EDB + IDB same relation"
-        (dl-query
-          (dl-program
-            "link(a, b). link(c, d). link(e, c).
-             via(a, e).
-             link(X, Y) :- via(X, M), link(M, Y).")
-          (list (quote link) (quote a) (quote X)))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      (dl-et-test! "saturated? after assert"
-        (let ((db (dl-program
-                    "parent(a, b).
-                     ancestor(X, Y) :- parent(X, Y).")))
-          (do
-            (dl-saturate! db)
-            (dl-add-fact! db (list (quote parent) (quote b) (quote c)))
-            (dl-saturated? db)))
-        false)
-
-      (dl-et-test-set! "magic-set still derives correctly"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-set-strategy! db :magic)
-            (dl-query db (list (quote ancestor) (quote a) (quote X)))))
-        (list {:X (quote b)} {:X (quote c)})))))
-
-(define
-  dl-eval-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-et-pass 0)
-      (set! dl-et-fail 0)
-      (set! dl-et-failures (list))
-      (dl-et-run-all!)
-      {:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))

lib/datalog/tests/magic.sx

@@ -1,528 +0,0 @@
-;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
-
-(define dl-mt-pass 0)
-(define dl-mt-fail 0)
-(define dl-mt-failures (list))
-
-(define
-  dl-mt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-mt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-mt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-mt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-mt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-mt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-mt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-mt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-mt-deep=? got expected)
-      (set! dl-mt-pass (+ dl-mt-pass 1))
-      (do
-        (set! dl-mt-fail (+ dl-mt-fail 1))
-        (append!
-          dl-mt-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-mt-run-all!
-  (fn
-    ()
-    (do
-      ;; Goal adornment.
-      (dl-mt-test! "adorn 0-ary"
-        (dl-adorn-goal (list (quote ready)))
-        "")
-      (dl-mt-test! "adorn all bound"
-        (dl-adorn-goal (list (quote p) 1 2 3))
-        "bbb")
-      (dl-mt-test! "adorn all free"
-        (dl-adorn-goal (list (quote p) (quote X) (quote Y)))
-        "ff")
-      (dl-mt-test! "adorn mixed"
-        (dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
-        "bf")
-      (dl-mt-test! "adorn const var const"
-        (dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
-        "bfb")
-
-      ;; dl-adorn-lit with explicit bound set.
-      (dl-mt-test! "adorn lit with bound"
-        (dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
-        "bf")
-
-      ;; Rule SIPS — chain ancestor.
-      (dl-mt-test! "sips chain ancestor bf"
-        (dl-rule-sips
-          {:head (list (quote ancestor) (quote X) (quote Z))
-           :body (list (list (quote parent) (quote X) (quote Y))
-                       (list (quote ancestor) (quote Y) (quote Z)))}
-          "bf")
-        (list
-          {:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
-          {:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
-
-      ;; SIPS — head fully bound.
-      (dl-mt-test! "sips head bb"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X) (quote Y))
-           :body (list (list (quote p) (quote X) (quote Z))
-                       (list (quote r) (quote Z) (quote Y)))}
-          "bb")
-        (list
-          {:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
-          {:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
-
-      ;; SIPS — comparison; vars must be bound by prior body lit.
-      (dl-mt-test! "sips with comparison"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X))
-           :body (list (list (quote p) (quote X))
-                       (list (string->symbol "<") (quote X) 5))}
-          "f")
-        (list
-          {:lit (list (quote p) (quote X)) :adornment "f"}
-          {:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
-
-      ;; SIPS — `is` binds its left arg.
-      (dl-mt-test! "sips with is"
-        (dl-rule-sips
-          {:head (list (quote q) (quote X) (quote Y))
-           :body (list (list (quote p) (quote X))
-                       (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
-          "ff")
-        (list
-          {:lit (list (quote p) (quote X)) :adornment "f"}
-          {:lit (list (quote is) (quote Y)
-                      (list (string->symbol "+") (quote X) 1))
-           :adornment "fb"}))
-
-      ;; Magic predicate naming.
-      (dl-mt-test! "magic-rel-name"
-        (dl-magic-rel-name "ancestor" "bf")
-        "magic_ancestor^bf")
-
-      ;; Bound-args extraction.
-      (dl-mt-test! "bound-args bf"
-        (dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
-        (list (quote tom)))
-
-      (dl-mt-test! "bound-args mixed"
-        (dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
-        (list 1 3))
-
-      (dl-mt-test! "bound-args all-free"
-        (dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
-        (list))
-
-      ;; Magic literal construction.
-      (dl-mt-test! "magic-lit"
-        (dl-magic-lit "ancestor" "bf" (list (quote tom)))
-        (list (string->symbol "magic_ancestor^bf") (quote tom)))
-
-      ;; Magic-sets rewriter: structural sanity.
-      (dl-mt-test! "rewrite ancestor produces seed"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))})))
-          (get
-            (dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
-            :seed))
-        (list (string->symbol "magic_ancestor^bf") (quote a)))
-
-      ;; Equivalence: rewritten program derives same ancestor tuples.
-      ;; In a chain a→b→c→d, magic-rewritten run still derives all
-      ;; ancestor pairs reachable from any node a/b/c/d propagated via
-      ;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
-      ;; saves work only when the EDB has irrelevant nodes outside
-      ;; the seed's transitive cone.
-      (dl-mt-test! "magic-rewritten ancestor count"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))}))
-            (edb (list
-                   (list (quote parent) (quote a) (quote b))
-                   (list (quote parent) (quote b) (quote c))
-                   (list (quote parent) (quote c) (quote d)))))
-          (let
-            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
-              (db (dl-make-db)))
-            (do
-              (for-each (fn (f) (dl-add-fact! db f)) edb)
-              (dl-add-fact! db (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
-              (dl-saturate! db)
-              (len (dl-relation db "ancestor")))))
-        6)
-
-      ;; dl-magic-query: end-to-end driver, doesn't mutate caller's db.
-      ;; Magic over a rule with negated body literal — propagation
-      ;; rules generated only for positive lits; negated lits pass
-      ;; through unchanged.
-      (dl-mt-test! "magic over rule with negation"
-        (let
-          ((db (dl-program
-                 "u(a). u(b). u(c). banned(b).
-                  active(X) :- u(X), not(banned(X)).")))
-          (let
-            ((semi (dl-query db (list (quote active) (quote X))))
-              (magic (dl-magic-query db (list (quote active) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; All-bound query (existence check) generates an "bb"
-      ;; adornment chain. Verifies the rewriter walks multiple
-      ;; (rel, adn) pairs through the worklist.
-      (dl-mt-test! "magic existence check via bb"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c). parent(c, d).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((found (dl-magic-query
-                      db (list (quote ancestor) (quote a) (quote c))))
-              (missing (dl-magic-query
-                         db (list (quote ancestor) (quote a) (quote z)))))
-            (and (= (len found) 1) (= (len missing) 0))))
-        true)
-
-      ;; Magic equivalence on the federation demo.
-      (dl-mt-test! "magic ≡ semi on foaf demo"
-        (let
-          ((db (dl-program-data
-                 (quote ((follows alice bob)
-                         (follows bob carol)
-                         (follows alice dave)))
-                 dl-demo-federation-rules)))
-          (let
-            ((semi (dl-query db (quote (foaf alice X))))
-              (magic (dl-magic-query db (quote (foaf alice X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Shape validation: dl-magic-query rejects non-list / non-
-      ;; dict goal shapes cleanly rather than crashing in `rest`.
-      (dl-mt-test! "magic rejects string goal"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-magic-query (dl-make-db) "foo"))
-            threw))
-        true)
-
-      (dl-mt-test! "magic rejects bare dict goal"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-magic-query (dl-make-db) {:foo "bar"}))
-            threw))
-        true)
-
-      ;; 3-stratum program under magic — distinct rule heads at
-      ;; strata 0/1/2 must all rewrite via the worklist.
-      (dl-mt-test! "magic 3-stratum program"
-        (let
-          ((db (dl-program
-                 "a(1). a(2). a(3). b(2).
-                  c(X) :- a(X), not(b(X)).
-                  d(X) :- c(X), not(banned(X)).
-                  banned(3).")))
-          (let
-            ((semi (dl-query db (list (quote d) (quote X))))
-              (magic (dl-magic-query db (list (quote d) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Aggregate -> derived -> threshold chain via magic.
-      (dl-mt-test! "magic aggregate-derived chain"
-        (let
-          ((db (dl-program
-                 "src(1). src(2). src(3).
-                  cnt(N) :- count(N, X, src(X)).
-                  active(N) :- cnt(N), >=(N, 2).")))
-          (let
-            ((semi (dl-query db (list (quote active) (quote N))))
-              (magic (dl-magic-query db (list (quote active) (quote N)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Multi-relation rewrite chain: query r4 → propagate to r3,
-      ;; r2, r1, a. The worklist must process all of them; an
-      ;; earlier bug stopped after only the head pair.
-      (dl-mt-test! "magic chain through 4 rule levels"
-        (let
-          ((db (dl-program
-                 "a(1). a(2). r1(X) :- a(X). r2(X) :- r1(X).
-                  r3(X) :- r2(X). r4(X) :- r3(X).")))
-          (= 2 (len (dl-magic-query db (list (quote r4) (quote X))))))
-        true)
-
-      ;; Shortest-path demo via magic — exercises the rewriter
-      ;; against rules that mix recursive positive lits with an
-      ;; aggregate body literal.
-      (dl-mt-test! "magic on shortest-path demo"
-        (let
-          ((db (dl-program-data
-                 (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
-                 dl-demo-shortest-path-rules)))
-          (let
-            ((semi (dl-query db (quote (shortest a c W))))
-              (magic (dl-magic-query db (quote (shortest a c W)))))
-            (and (= (len semi) (len magic))
-                 (= (len semi) 1))))
-        true)
-
-      ;; Same relation called with different adornment patterns
-      ;; in different rules. The worklist must enqueue and process
-      ;; each (rel, adornment) pair.
-      (dl-mt-test! "magic with multi-adornment same relation"
-        (let
-          ((db (dl-program
-                 "parent(p1, alice). parent(p2, bob).
-                  parent(g, p1). parent(g, p2).
-                  sibling(P1, P2) :- parent(G, P1), parent(G, P2),
-                                     !=(P1, P2).
-                  cousin(X, Y) :- parent(P1, X), parent(P2, Y),
-                                  sibling(P1, P2).")))
-          (let
-            ((semi (dl-query db (list (quote cousin) (quote alice) (quote Y))))
-              (magic (dl-magic-query db (list (quote cousin) (quote alice) (quote Y)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Magic over a rule whose body contains an aggregate.
-      ;; The rewriter passes aggregate body lits through unchanged
-      ;; (no propagation generated for them), so semi-naive's count
-      ;; logic still fires correctly under the rewritten program.
-      (dl-mt-test! "magic over rule with aggregate body"
-        (let
-          ((db (dl-program
-                 "post(p1). post(p2). post(p3).
-                  liked(u1, p1). liked(u2, p1). liked(u3, p1).
-                  liked(u1, p2).
-                  rich(P) :- post(P), count(N, U, liked(U, P)),
-                             >=(N, 2).")))
-          (let
-            ((semi (dl-query db (list (quote rich) (quote P))))
-              (magic (dl-magic-query db (list (quote rich) (quote P)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; Mixed EDB + IDB: a relation can be both EDB-seeded and
-      ;; rule-derived. dl-magic-query must include the EDB portion
-      ;; even though the relation has rules.
-      (dl-mt-test! "magic mixed EDB+IDB"
-        (len
-          (dl-magic-query
-            (dl-program
-              "link(a, b). link(c, d). link(e, c).
-               via(a, e).
-               link(X, Y) :- via(X, M), link(M, Y).")
-            (list (quote link) (quote a) (quote X))))
-        2)
-
-      ;; dl-magic-query falls back to dl-query for built-in,
-      ;; aggregate, and negation goals (the magic seed would
-      ;; otherwise be non-ground).
-      (dl-mt-test! "magic-query falls back on aggregate"
-        (let
-          ((r (dl-magic-query
-                (dl-program "p(1). p(2). p(3).")
-                (list (quote count) (quote N) (quote X)
-                      (list (quote p) (quote X))))))
-          (and (= (len r) 1) (= (get (first r) "N") 3)))
-        true)
-
-      (dl-mt-test! "magic-query equivalent to dl-query"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c). parent(c, d).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((semi (dl-query db (list (quote ancestor) (quote a) (quote X))))
-              (magic (dl-magic-query
-                       db (list (quote ancestor) (quote a) (quote X)))))
-            (= (len semi) (len magic))))
-        true)
-
-      ;; The magic rewriter passes aggregate body lits through
-      ;; unchanged, so an aggregate over an IDB relation would see an
-      ;; empty inner-goal in the magic db unless the IDB is already
-      ;; materialised. dl-magic-query now pre-saturates the source db
-      ;; to guarantee equivalence with dl-query for every stratified
-      ;; program. Previously this returned `({:N 0})` because `active`
-      ;; (IDB, derived through negation) was never derived in the
-      ;; magic db.
-      (dl-mt-test! "magic over aggregate-of-IDB matches vanilla"
-        (let
-          ((src
-             "u(a). u(b). u(c). u(d). banned(b). banned(d).
-              active(X) :- u(X), not(banned(X)).
-              n(N) :- count(N, X, active(X))."))
-          (let
-            ((vanilla (dl-eval src "?- n(N)."))
-              (magic (dl-eval-magic src "?- n(N).")))
-            (and (= (len vanilla) 1)
-                 (= (len magic) 1)
-                 (= (get (first vanilla) "N")
-                    (get (first magic) "N")))))
-        true)
-
-      ;; magic-query doesn't mutate caller db.
-      (dl-mt-test! "magic-query preserves caller db"
-        (let
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((rules-before (len (dl-rules db))))
-            (do
-              (dl-magic-query db (list (quote ancestor) (quote a) (quote X)))
-              (= rules-before (len (dl-rules db))))))
-        true)
-
-      ;; Magic-sets benefit: query touches only one cluster of a
-      ;; multi-component graph. Semi-naive derives the full closure
-      ;; over both clusters; magic only the seeded one.
-      ;; Magic-vs-semi work shape: chain of 12. Semi-naive
-      ;; derives the full closure (78 = 12·13/2). A magic query
-      ;; rooted at node 0 returns the 12 descendants only —
-      ;; demonstrating that magic limits derivation to the
-      ;; query's transitive cone.
-      (dl-mt-test! "magic vs semi work-shape on chain-12"
-        (let
-          ((source (str
-                     "parent(0, 1). parent(1, 2). parent(2, 3). "
-                     "parent(3, 4). parent(4, 5). parent(5, 6). "
-                     "parent(6, 7). parent(7, 8). parent(8, 9). "
-                     "parent(9, 10). parent(10, 11). parent(11, 12). "
-                     "ancestor(X, Y) :- parent(X, Y). "
-                     "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (let
-            ((db1 (dl-make-db)) (db2 (dl-make-db)))
-            (do
-              (dl-load-program! db1 source)
-              (dl-saturate! db1)
-              (dl-load-program! db2 source)
-              (let
-                ((semi-count (len (dl-relation db1 "ancestor")))
-                  (magic-count
-                    (len (dl-magic-query
-                           db2 (list (quote ancestor) 0 (quote X))))))
-                ;; Magic returns only descendants of 0 (12 of them).
-                (and (= semi-count 78) (= magic-count 12))))))
-        true)
-
-      ;; Magic + arithmetic: rules with `is` clauses pass through
-      ;; the rewriter unchanged (built-ins aren't propagated).
-      (dl-mt-test! "magic preserves arithmetic"
-        (let
-          ((source "n(1). n(2). n(3).
-                    doubled(X, Y) :- n(X), is(Y, *(X, 2))."))
-          (let
-            ((semi (dl-eval source "?- doubled(2, Y)."))
-              (magic (dl-eval-magic source "?- doubled(2, Y).")))
-            (= (len semi) (len magic))))
-        true)
-
-      (dl-mt-test! "magic skips irrelevant clusters"
-        (let
-          ;; Two disjoint chains. Query is rooted in cluster 1.
-          ((db (dl-program
-                 "parent(a, b). parent(b, c).
-                  parent(x, y). parent(y, z).
-                  ancestor(X, Y) :- parent(X, Y).
-                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (do
-            (dl-saturate! db)
-            (let
-              ((semi-count (len (dl-relation db "ancestor")))
-                (magic-results
-                  (dl-magic-query
-                    db (list (quote ancestor) (quote a) (quote X)))))
-              ;; Semi-naive derives 6 (3 in each cluster). Magic
-              ;; gives 3 query results (a's reachable: b, c).
-              (and (= semi-count 6) (= (len magic-results) 2)))))
-        true)
-
-      (dl-mt-test! "magic-rewritten finds same answers"
-        (let
-          ((rules
-             (list
-               {:head (list (quote ancestor) (quote X) (quote Y))
-                :body (list (list (quote parent) (quote X) (quote Y)))}
-               {:head (list (quote ancestor) (quote X) (quote Z))
-                :body
-                (list (list (quote parent) (quote X) (quote Y))
-                      (list (quote ancestor) (quote Y) (quote Z)))}))
-            (edb (list
-                   (list (quote parent) (quote a) (quote b))
-                   (list (quote parent) (quote b) (quote c)))))
-          (let
-            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
-              (db (dl-make-db)))
-            (do
-              (for-each (fn (f) (dl-add-fact! db f)) edb)
-              (dl-add-fact! db (get rewritten :seed))
-              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
-              (dl-saturate! db)
-              (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
-        2))))
-
-(define
-  dl-magic-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-mt-pass 0)
-      (set! dl-mt-fail 0)
-      (set! dl-mt-failures (list))
-      (dl-mt-run-all!)
-      {:passed dl-mt-pass
-       :failed dl-mt-fail
-       :total (+ dl-mt-pass dl-mt-fail)
-       :failures dl-mt-failures})))

lib/datalog/tests/negation.sx

@@ -1,252 +0,0 @@
-;; lib/datalog/tests/negation.sx — stratified negation tests.
-
-(define dl-nt-pass 0)
-(define dl-nt-fail 0)
-(define dl-nt-failures (list))
-
-(define
-  dl-nt-deep=?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-nt-deq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-nt-deq-d? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-nt-deq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-nt-deep=? (nth a i) (nth b i))) false)
-      (else (dl-nt-deq-l? a b (+ i 1))))))
-
-(define
-  dl-nt-deq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i)))
-         (not (dl-nt-deep=? (get a k) (get b k))))
-        false)
-      (else (dl-nt-deq-d? a b ka (+ i 1))))))
-
-(define
-  dl-nt-set=?
-  (fn
-    (a b)
-    (and
-      (= (len a) (len b))
-      (dl-nt-subset? a b)
-      (dl-nt-subset? b a))))
-
-(define
-  dl-nt-subset?
-  (fn
-    (xs ys)
-    (cond
-      ((= (len xs) 0) true)
-      ((not (dl-nt-contains? ys (first xs))) false)
-      (else (dl-nt-subset? (rest xs) ys)))))
-
-(define
-  dl-nt-contains?
-  (fn
-    (xs target)
-    (cond
-      ((= (len xs) 0) false)
-      ((dl-nt-deep=? (first xs) target) true)
-      (else (dl-nt-contains? (rest xs) target)))))
-
-(define
-  dl-nt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-nt-deep=? got expected)
-      (set! dl-nt-pass (+ dl-nt-pass 1))
-      (do
-        (set! dl-nt-fail (+ dl-nt-fail 1))
-        (append!
-          dl-nt-failures
-          (str
-            name
-            "\n    expected: " expected
-            "\n    got:      " got))))))
-
-(define
-  dl-nt-test-set!
-  (fn
-    (name got expected)
-    (if
-      (dl-nt-set=? got expected)
-      (set! dl-nt-pass (+ dl-nt-pass 1))
-      (do
-        (set! dl-nt-fail (+ dl-nt-fail 1))
-        (append!
-          dl-nt-failures
-          (str
-            name
-            "\n    expected (set): " expected
-            "\n    got:            " got))))))
-
-(define
-  dl-nt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do
-        (guard
-          (e (#t (set! threw true)))
-          (thunk))
-        threw))))
-
-(define
-  dl-nt-run-all!
-  (fn
-    ()
-    (do
-      ;; Negation against EDB-only relation.
-      (dl-nt-test-set! "not against EDB"
-        (dl-query
-          (dl-program
-            "p(1). p(2). p(3). r(2).
-             q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Negation against derived relation — needs stratification.
-      (dl-nt-test-set! "not against derived rel"
-        (dl-query
-          (dl-program
-            "p(1). p(2). p(3). s(2).
-             r(X) :- s(X).
-             q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Two-step strata: r derives via s; q derives via not r.
-      (dl-nt-test-set! "two-step strata"
-        (dl-query
-          (dl-program
-            "node(a). node(b). node(c). node(d).
-             edge(a, b). edge(b, c). edge(c, a).
-             reach(X, Y) :- edge(X, Y).
-             reach(X, Z) :- edge(X, Y), reach(Y, Z).
-             unreachable(X) :- node(X), not(reach(a, X)).")
-          (list (quote unreachable) (quote X)))
-        (list {:X (quote d)}))
-
-      ;; Combine negation with arithmetic and comparison.
-      (dl-nt-test-set! "negation with arithmetic"
-        (dl-query
-          (dl-program
-            "n(1). n(2). n(3). n(4). n(5). odd(1). odd(3). odd(5).
-             even(X) :- n(X), not(odd(X)).")
-          (list (quote even) (quote X)))
-        (list {:X 2} {:X 4}))
-
-      ;; Empty negation result.
-      (dl-nt-test-set! "negation always succeeds"
-        (dl-query
-          (dl-program
-            "p(1). p(2). q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list {:X 1} {:X 2}))
-
-      ;; Negation always fails.
-      (dl-nt-test-set! "negation always fails"
-        (dl-query
-          (dl-program
-            "p(1). p(2). r(1). r(2). q(X) :- p(X), not(r(X)).")
-          (list (quote q) (quote X)))
-        (list))
-
-      ;; Anonymous `_` in a negated literal is existentially quantified
-      ;; — it doesn't need to be bound by an earlier body lit. Without
-      ;; this exemption the safety check would reject the common idiom
-      ;; `orphan(X) :- person(X), not(parent(X, _))`.
-      (dl-nt-test-set! "negation with anonymous var — orphan idiom"
-        (dl-query
-          (dl-program
-            "person(a). person(b). person(c). parent(a, b).
-             orphan(X) :- person(X), not(parent(X, _)).")
-          (list (quote orphan) (quote X)))
-        (list {:X (quote b)} {:X (quote c)}))
-
-      ;; Multiple anonymous vars are each independently existential.
-      (dl-nt-test-set! "negation with multiple anonymous vars"
-        (dl-query
-          (dl-program
-            "u(a). u(b). u(c). edge(a, x). edge(b, y).
-             solo(X) :- u(X), not(edge(X, _)).")
-          (list (quote solo) (quote X)))
-        (list {:X (quote c)}))
-
-      ;; Stratifiability checks.
-      (dl-nt-test! "non-stratifiable rejected"
-        (dl-nt-throws?
-          (fn ()
-            (let ((db (dl-make-db)))
-              (do
-                (dl-add-rule!
-                  db
-                  {:head (list (quote p) (quote X))
-                   :body (list (list (quote q) (quote X))
-                               {:neg (list (quote r) (quote X))})})
-                (dl-add-rule!
-                  db
-                  {:head (list (quote r) (quote X))
-                   :body (list (list (quote p) (quote X)))})
-                (dl-add-fact! db (list (quote q) 1))
-                (dl-saturate! db)))))
-        true)
-
-      (dl-nt-test! "stratifiable accepted"
-        (dl-nt-throws?
-          (fn ()
-            (dl-program
-              "p(1). p(2). r(2).
-               q(X) :- p(X), not(r(X)).")))
-        false)
-
-      ;; Multi-stratum chain.
-      (dl-nt-test-set! "three-level strata"
-        (dl-query
-          (dl-program
-            "a(1). a(2). a(3). a(4).
-             b(X) :- a(X), not(c(X)).
-             c(X) :- d(X).
-             d(2).
-             d(4).")
-          (list (quote b) (quote X)))
-        (list {:X 1} {:X 3}))
-
-      ;; Safety violation: negation refers to unbound var.
-      (dl-nt-test! "negation safety violation"
-        (dl-nt-throws?
-          (fn ()
-            (dl-program
-              "p(1). q(X) :- p(X), not(r(Y)).")))
-        true))))
-
-(define
-  dl-negation-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-nt-pass 0)
-      (set! dl-nt-fail 0)
-      (set! dl-nt-failures (list))
-      (dl-nt-run-all!)
-      {:passed dl-nt-pass
-       :failed dl-nt-fail
-       :total (+ dl-nt-pass dl-nt-fail)
-       :failures dl-nt-failures})))

lib/datalog/tests/parse.sx

@@ -1,179 +0,0 @@
-;; lib/datalog/tests/parse.sx — parser unit tests
-;;
-;; Run via: bash lib/datalog/conformance.sh
-;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
-;;          (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
-
-(define dl-pt-pass 0)
-(define dl-pt-fail 0)
-(define dl-pt-failures (list))
-
-;; Order-independent structural equality. Lists compared positionally,
-;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
-(define
-  dl-deep-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and
-            (= (len ka) (len kb))
-            (dl-deep-equal-dict? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-deep-equal-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-deep-equal? (nth a i) (nth b i))) false)
-      (else (dl-deep-equal-list? a b (+ i 1))))))
-
-(define
-  dl-deep-equal-dict?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
-        false)
-      (else (dl-deep-equal-dict? a b ka (+ i 1))))))
-
-(define
-  dl-pt-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-deep-equal? got expected)
-      (set! dl-pt-pass (+ dl-pt-pass 1))
-      (do
-        (set! dl-pt-fail (+ dl-pt-fail 1))
-        (append!
-          dl-pt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-pt-throws?
-  (fn
-    (thunk)
-    (let
-      ((threw false))
-      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
-
-(define
-  dl-pt-run-all!
-  (fn
-    ()
-    (do
-      (dl-pt-test! "empty program" (dl-parse "") (list))
-      (dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
-      (dl-pt-test!
-        "two facts"
-        (dl-parse "parent(tom, bob). parent(bob, ann).")
-        (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
-      (dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
-      (dl-pt-test!
-        "rule one body lit"
-        (dl-parse "ancestor(X, Y) :- parent(X, Y).")
-        (list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
-      (dl-pt-test!
-        "recursive rule"
-        (dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
-        (list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
-      (dl-pt-test!
-        "query single"
-        (dl-parse "?- ancestor(tom, X).")
-        (list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
-      (dl-pt-test!
-        "query multi"
-        (dl-parse "?- p(X), q(X).")
-        (list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
-      (dl-pt-test!
-        "negation"
-        (dl-parse "safe(X) :- person(X), not(parent(X, _)).")
-        (list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
-      (dl-pt-test!
-        "number arg"
-        (dl-parse "age(alice, 30).")
-        (list {:body (list) :head (list (quote age) (quote alice) 30)}))
-      (dl-pt-test!
-        "string arg"
-        (dl-parse "label(x, \"hi\").")
-        (list {:body (list) :head (list (quote label) (quote x) "hi")}))
-      ;; Quoted 'atoms' parse as strings — a uppercase-starting name
-      ;; in quotes used to misclassify as a variable and reject the
-      ;; fact as non-ground.
-      (dl-pt-test!
-        "quoted atom arg parses as string"
-        (dl-parse "p('Hello World').")
-        (list {:body (list) :head (list (quote p) "Hello World")}))
-      (dl-pt-test!
-        "comparison literal"
-        (dl-parse "p(X) :- <(X, 5).")
-        (list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
-      (dl-pt-test!
-        "is with arith"
-        (dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
-        (list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
-      (dl-pt-test!
-        "mixed program"
-        (dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
-        (list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
-      (dl-pt-test!
-        "comments skipped"
-        (dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
-        (list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
-      (dl-pt-test!
-        "underscore var"
-        (dl-parse "p(X) :- q(X, _).")
-        (list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
-      ;; Negative number literals parse as one negative number,
-      ;; while subtraction (`-(X, Y)`) compound is preserved.
-      (dl-pt-test!
-        "negative integer literal"
-        (dl-parse "n(-3).")
-        (list {:head (list (quote n) -3) :body (list)}))
-
-      (dl-pt-test!
-        "subtraction compound preserved"
-        (dl-parse "r(X) :- is(X, -(10, 3)).")
-        (list
-          {:head (list (quote r) (quote X))
-           :body (list (list (quote is) (quote X)
-                             (list (string->symbol "-") 10 3)))}))
-
-      (dl-pt-test!
-        "number as relation name raises"
-        (dl-pt-throws? (fn () (dl-parse "1(X) :- p(X).")))
-        true)
-
-      (dl-pt-test!
-        "var as relation name raises"
-        (dl-pt-throws? (fn () (dl-parse "P(X).")))
-        true)
-
-      (dl-pt-test!
-        "missing dot raises"
-        (dl-pt-throws? (fn () (dl-parse "p(a)")))
-        true)
-      (dl-pt-test!
-        "trailing comma raises"
-        (dl-pt-throws? (fn () (dl-parse "p(a,).")))
-        true))))
-
-(define
-  dl-parse-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-pt-pass 0)
-      (set! dl-pt-fail 0)
-      (set! dl-pt-failures (list))
-      (dl-pt-run-all!)
-      {:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))

lib/datalog/tests/semi_naive.sx

@@ -1,153 +0,0 @@
-;; lib/datalog/tests/semi_naive.sx — semi-naive correctness vs naive.
-;;
-;; Strategy: differential — run both saturators on each program and
-;; compare the resulting per-relation tuple counts. Counting (not
-;; element-wise set equality) keeps the suite fast under the bundled
-;; conformance session; correctness on the inhabitants is covered by
-;; eval.sx and builtins.sx (which use dl-saturate! by default — the
-;; semi-naive saturator).
-
-(define dl-sn-pass 0)
-(define dl-sn-fail 0)
-(define dl-sn-failures (list))
-
-(define
-  dl-sn-test!
-  (fn
-    (name got expected)
-    (if
-      (equal? got expected)
-      (set! dl-sn-pass (+ dl-sn-pass 1))
-      (do
-        (set! dl-sn-fail (+ dl-sn-fail 1))
-        (append!
-          dl-sn-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; Load `source` into both a semi-naive and a naive db and return a
-;; list of (rel-name semi-count naive-count) triples. Both sets must
-;; have the same union of relation names.
-(define
-  dl-sn-counts
-  (fn
-    (source)
-    (let
-      ((db-s (dl-program source)) (db-n (dl-program source)))
-      (do
-        (dl-saturate! db-s)
-        (dl-saturate-naive! db-n)
-        (let
-          ((out (list)))
-          (do
-            (for-each
-              (fn
-                (k)
-                (append!
-                  out
-                  (list
-                    k
-                    (len (dl-relation db-s k))
-                    (len (dl-relation db-n k)))))
-              (keys (get db-s :facts)))
-            out))))))
-
-(define
-  dl-sn-counts-agree?
-  (fn
-    (counts)
-    (cond
-      ((= (len counts) 0) true)
-      (else
-        (let
-          ((row (first counts)))
-          (and
-            (= (nth row 1) (nth row 2))
-            (dl-sn-counts-agree? (rest counts))))))))
-
-(define
-  dl-sn-chain-source
-  (fn
-    (n)
-    (let
-      ((parts (list "")))
-      (do
-        (define
-          dl-sn-loop
-          (fn
-            (i)
-            (when
-              (< i n)
-              (do
-                (append! parts (str "parent(" i ", " (+ i 1) "). "))
-                (dl-sn-loop (+ i 1))))))
-        (dl-sn-loop 0)
-        (str
-          (join "" parts)
-          "ancestor(X, Y) :- parent(X, Y). "
-          "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))))
-
-(define
-  dl-sn-run-all!
-  (fn
-    ()
-    (do
-      (dl-sn-test!
-        "ancestor closure counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "parent(a, b). parent(b, c). parent(c, d).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
-        true)
-      (dl-sn-test!
-        "cyclic reach counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "edge(1, 2). edge(2, 3). edge(3, 1). edge(3, 4).\n             reach(X, Y) :- edge(X, Y).\n             reach(X, Z) :- edge(X, Y), reach(Y, Z)."))
-        true)
-      (dl-sn-test!
-        "same-gen counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).\n             person(a). person(b). person(c). person(d). person(e).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y)."))
-        true)
-      (dl-sn-test!
-        "rules with builtins counts match"
-        (dl-sn-counts-agree?
-          (dl-sn-counts
-            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <(X, 5).\n             succ(X, Y) :- n(X), <(X, 5), is(Y, +(X, 1))."))
-        true)
-      (dl-sn-test!
-        "static rule fires under semi-naive"
-        (dl-sn-counts-agree?
-          (dl-sn-counts "p(a). p(b). q(X) :- p(X), =(X, a)."))
-        true)
-      ;; Chain length 12 — multiple semi-naive iterations against
-      ;; the recursive ancestor rule (differential vs naive).
-      (dl-sn-test!
-        "chain-12 ancestor counts match"
-        (dl-sn-counts-agree? (dl-sn-counts (dl-sn-chain-source 12)))
-        true)
-      ;; Chain length 25 — semi-naive only — first-arg index makes
-      ;; this tractable in conformance budget.
-      (dl-sn-test!
-        "chain-25 ancestor count value (semi only)"
-        (let
-          ((db (dl-program (dl-sn-chain-source 25))))
-          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
-        325)
-      (dl-sn-test!
-        "query through semi saturate"
-        (let
-          ((db (dl-program "parent(a, b). parent(b, c).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
-          (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))
-        2))))
-
-(define
-  dl-semi-naive-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-sn-pass 0)
-      (set! dl-sn-fail 0)
-      (set! dl-sn-failures (list))
-      (dl-sn-run-all!)
-      {:failures dl-sn-failures :total (+ dl-sn-pass dl-sn-fail) :passed dl-sn-pass :failed dl-sn-fail})))

lib/datalog/tests/tokenize.sx

@@ -1,189 +0,0 @@
-;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
-;;
-;; Run via: bash lib/datalog/conformance.sh
-;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
-;;          (dl-tokenize-tests-run!)
-
-(define dl-tk-pass 0)
-(define dl-tk-fail 0)
-(define dl-tk-failures (list))
-
-(define
-  dl-tk-test!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! dl-tk-pass (+ dl-tk-pass 1))
-      (do
-        (set! dl-tk-fail (+ dl-tk-fail 1))
-        (append!
-          dl-tk-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
-(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
-
-(define
-  dl-tk-run-all!
-  (fn
-    ()
-    (do
-      (dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
-      (dl-tk-test!
-        "atom dot"
-        (dl-tk-types (dl-tokenize "foo."))
-        (list "atom" "punct" "eof"))
-      (dl-tk-test!
-        "atom dot value"
-        (dl-tk-values (dl-tokenize "foo."))
-        (list "foo" "." nil))
-      (dl-tk-test!
-        "var"
-        (dl-tk-types (dl-tokenize "X."))
-        (list "var" "punct" "eof"))
-      (dl-tk-test!
-        "underscore var"
-        (dl-tk-types (dl-tokenize "_x."))
-        (list "var" "punct" "eof"))
-      (dl-tk-test!
-        "integer"
-        (dl-tk-values (dl-tokenize "42"))
-        (list 42 nil))
-      (dl-tk-test!
-        "decimal"
-        (dl-tk-values (dl-tokenize "3.14"))
-        (list 3.14 nil))
-      (dl-tk-test!
-        "string"
-        (dl-tk-values (dl-tokenize "\"hello\""))
-        (list "hello" nil))
-      ;; Quoted 'atoms' tokenize as strings — see the type-table
-      ;; comment in lib/datalog/tokenizer.sx for the rationale.
-      (dl-tk-test!
-        "quoted atom as string"
-        (dl-tk-types (dl-tokenize "'two words'"))
-        (list "string" "eof"))
-      (dl-tk-test!
-        "quoted atom value"
-        (dl-tk-values (dl-tokenize "'two words'"))
-        (list "two words" nil))
-      ;; A quoted atom whose name would otherwise be a variable
-      ;; (uppercase / leading underscore) is now safely a string —
-      ;; this was the bug that motivated the type change.
-      (dl-tk-test!
-        "quoted Uppercase as string"
-        (dl-tk-types (dl-tokenize "'Hello'"))
-        (list "string" "eof"))
-      (dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
-      (dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
-      (dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
-      (dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
-      (dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
-      (dl-tk-test!
-        "single op values"
-        (dl-tk-values (dl-tokenize "< > = + - * /"))
-        (list "<" ">" "=" "+" "-" "*" "/" nil))
-      (dl-tk-test!
-        "single op types"
-        (dl-tk-types (dl-tokenize "< > = + - * /"))
-        (list "op" "op" "op" "op" "op" "op" "op" "eof"))
-      (dl-tk-test!
-        "punct"
-        (dl-tk-values (dl-tokenize "( ) , ."))
-        (list "(" ")" "," "." nil))
-      (dl-tk-test!
-        "fact tokens"
-        (dl-tk-types (dl-tokenize "parent(tom, bob)."))
-        (list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
-      (dl-tk-test!
-        "rule shape"
-        (dl-tk-types (dl-tokenize "p(X) :- q(X)."))
-        (list
-          "atom"
-          "punct"
-          "var"
-          "punct"
-          "op"
-          "atom"
-          "punct"
-          "var"
-          "punct"
-          "punct"
-          "eof"))
-      (dl-tk-test!
-        "comparison literal"
-        (dl-tk-values (dl-tokenize "<(X, 5)"))
-        (list "<" "(" "X" "," 5 ")" nil))
-      (dl-tk-test!
-        "is form"
-        (dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
-        (list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
-      (dl-tk-test!
-        "line comment"
-        (dl-tk-types (dl-tokenize "% comment line\nfoo."))
-        (list "atom" "punct" "eof"))
-      (dl-tk-test!
-        "block comment"
-        (dl-tk-types (dl-tokenize "/* a\nb */ x."))
-        (list "atom" "punct" "eof"))
-      ;; Unexpected characters surface at tokenize time rather
-      ;; than being silently consumed (previously `?(X)` parsed as
-      ;; if the leading `?` weren't there).
-      (dl-tk-test!
-        "unexpected char raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "?(X)"))
-            threw))
-        true)
-
-      ;; Unterminated string / quoted-atom must raise.
-      (dl-tk-test!
-        "unterminated string raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "\"unclosed"))
-            threw))
-        true)
-
-      (dl-tk-test!
-        "unterminated quoted atom raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "'unclosed"))
-            threw))
-        true)
-
-      ;; Unterminated block comment must raise — previously it was
-      ;; silently consumed to EOF.
-      (dl-tk-test!
-        "unterminated block comment raises"
-        (let ((threw false))
-          (do
-            (guard (e (#t (set! threw true)))
-              (dl-tokenize "/* unclosed comment"))
-            threw))
-        true)
-      (dl-tk-test!
-        "whitespace"
-        (dl-tk-types (dl-tokenize "  foo  ,\t bar  ."))
-        (list "atom" "punct" "atom" "punct" "eof"))
-      (dl-tk-test!
-        "positions"
-        (map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
-        (list 0 4 7)))))
-
-(define
-  dl-tokenize-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-tk-pass 0)
-      (set! dl-tk-fail 0)
-      (set! dl-tk-failures (list))
-      (dl-tk-run-all!)
-      {:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))

lib/datalog/tests/unify.sx

@@ -1,194 +0,0 @@
-;; lib/datalog/tests/unify.sx — unification + substitution tests.
-
-(define dl-ut-pass 0)
-(define dl-ut-fail 0)
-(define dl-ut-failures (list))
-
-(define
-  dl-ut-deep-equal?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
-      ((and (number? a) (number? b)) (= a b))
-      (else (equal? a b)))))
-
-(define
-  dl-ut-deq-list?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
-      (else (dl-ut-deq-list? a b (+ i 1))))))
-
-(define
-  dl-ut-deq-dict?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
-        false)
-      (else (dl-ut-deq-dict? a b ka (+ i 1))))))
-
-(define
-  dl-ut-test!
-  (fn
-    (name got expected)
-    (if
-      (dl-ut-deep-equal? got expected)
-      (set! dl-ut-pass (+ dl-ut-pass 1))
-      (do
-        (set! dl-ut-fail (+ dl-ut-fail 1))
-        (append!
-          dl-ut-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define
-  dl-ut-run-all!
-  (fn
-    ()
-    (do
-      (dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
-      (dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
-      (dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
-      (dl-ut-test! "var? number" (dl-var? 5) false)
-      (dl-ut-test! "var? string" (dl-var? "hi") false)
-      (dl-ut-test! "var? list" (dl-var? (list 1)) false)
-      (dl-ut-test!
-        "atom-atom match"
-        (dl-unify (quote tom) (quote tom) (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "atom-atom fail"
-        (dl-unify (quote tom) (quote bob) (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "num-num match"
-        (dl-unify 5 5 (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "num-num fail"
-        (dl-unify 5 6 (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "string match"
-        (dl-unify "hi" "hi" (dl-empty-subst))
-        {})
-      (dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
-      (dl-ut-test!
-        "var-atom binds"
-        (dl-unify (quote X) (quote tom) (dl-empty-subst))
-        {:X (quote tom)})
-      (dl-ut-test!
-        "atom-var binds"
-        (dl-unify (quote tom) (quote X) (dl-empty-subst))
-        {:X (quote tom)})
-      (dl-ut-test!
-        "var-var same"
-        (dl-unify (quote X) (quote X) (dl-empty-subst))
-        {})
-      (dl-ut-test!
-        "var-var bind"
-        (let
-          ((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
-          (dl-walk (quote X) s))
-        (quote Y))
-      (dl-ut-test!
-        "tuple match"
-        (dl-unify
-          (list (quote parent) (quote X) (quote bob))
-          (list (quote parent) (quote tom) (quote Y))
-          (dl-empty-subst))
-        {:X (quote tom) :Y (quote bob)})
-      (dl-ut-test!
-        "tuple arity mismatch"
-        (dl-unify
-          (list (quote p) (quote X))
-          (list (quote p) (quote a) (quote b))
-          (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "tuple head mismatch"
-        (dl-unify
-          (list (quote p) (quote X))
-          (list (quote q) (quote X))
-          (dl-empty-subst))
-        nil)
-      (dl-ut-test!
-        "walk chain"
-        (let
-          ((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
-          (let
-            ((s2 (dl-unify (quote Y) (quote tom) s1)))
-            (dl-walk (quote X) s2)))
-        (quote tom))
-
-      ;; Walk with circular substitution must not infinite-loop.
-      ;; Cycles return the current term unchanged.
-      (dl-ut-test!
-        "walk circular subst no hang"
-        (let ((s (dl-bind (quote B) (quote A)
-                   (dl-bind (quote A) (quote B) (dl-empty-subst)))))
-          (dl-walk (quote A) s))
-        (quote A))
-      (dl-ut-test!
-        "apply subst on tuple"
-        (let
-          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
-          (dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
-        (list (quote parent) (quote tom) (quote Y)))
-      (dl-ut-test!
-        "ground? all const"
-        (dl-ground?
-          (list (quote p) (quote tom) 5)
-          (dl-empty-subst))
-        true)
-      (dl-ut-test!
-        "ground? unbound var"
-        (dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
-        false)
-      (dl-ut-test!
-        "ground? bound var"
-        (let
-          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
-          (dl-ground? (list (quote p) (quote X)) s))
-        true)
-      (dl-ut-test!
-        "ground? bare var"
-        (dl-ground? (quote X) (dl-empty-subst))
-        false)
-      (dl-ut-test!
-        "vars-of basic"
-        (dl-vars-of
-          (list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
-        (list "X" "Y"))
-      (dl-ut-test!
-        "vars-of ground"
-        (dl-vars-of (list (quote p) (quote tom) (quote bob)))
-        (list))
-      (dl-ut-test!
-        "vars-of nested compound"
-        (dl-vars-of
-          (list
-            (quote is)
-            (quote Z)
-            (list (string->symbol "+") (quote X) 1)))
-        (list "Z" "X")))))
-
-(define
-  dl-unify-tests-run!
-  (fn
-    ()
-    (do
-      (set! dl-ut-pass 0)
-      (set! dl-ut-fail 0)
-      (set! dl-ut-failures (list))
-      (dl-ut-run-all!)
-      {:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))

lib/datalog/tokenizer.sx

@@ -1,269 +0,0 @@
-;; lib/datalog/tokenizer.sx — Datalog source → token stream
-;;
-;; Tokens: {:type T :value V :pos P}
-;; Types:
-;;   "atom"    — lowercase-start bare identifier
-;;   "var"     — uppercase-start or _-start ident (value is the name)
-;;   "number"  — numeric literal (decoded to number)
-;;   "string"  — "..." string literal OR quoted 'atom' (treated as a
-;;               string value to avoid the var-vs-atom ambiguity that
-;;               would arise from a quoted atom whose name starts with
-;;               an uppercase letter or underscore)
-;;   "punct"   — ( ) , .
-;;   "op"      — :- ?- <= >= != < > = + - * /
-;;   "eof"
-;;
-;; Datalog has no function symbols in arg position; the parser still
-;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
-;; analysis rejects non-arithmetic nesting at rule-load time.
-
-(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
-
-(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
-(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
-(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
-
-(define
-  dl-ident-char?
-  (fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
-
-(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
-
-(define
-  dl-tokenize
-  (fn
-    (src)
-    (let
-      ((tokens (list)) (pos 0) (src-len (len src)))
-      (define
-        dl-peek
-        (fn
-          (offset)
-          (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
-      (define cur (fn () (dl-peek 0)))
-      (define advance! (fn (n) (set! pos (+ pos n))))
-      (define
-        at?
-        (fn
-          (s)
-          (let
-            ((sl (len s)))
-            (and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
-      (define
-        dl-emit!
-        (fn
-          (type value start)
-          (append! tokens (dl-make-token type value start))))
-      (define
-        skip-line-comment!
-        (fn
-          ()
-          (when
-            (and (< pos src-len) (not (= (cur) "\n")))
-            (do (advance! 1) (skip-line-comment!)))))
-      (define
-        skip-block-comment!
-        (fn
-          ()
-          (cond
-            ((>= pos src-len)
-              (error (str "Tokenizer: unterminated block comment "
-                          "(started at position " pos ")")))
-            ((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
-              (advance! 2))
-            (else (do (advance! 1) (skip-block-comment!))))))
-      (define
-        skip-ws!
-        (fn
-          ()
-          (cond
-            ((>= pos src-len) nil)
-            ((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
-            ((= (cur) "%")
-              (do (advance! 1) (skip-line-comment!) (skip-ws!)))
-            ((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
-              (do (advance! 2) (skip-block-comment!) (skip-ws!)))
-            (else nil))))
-      (define
-        read-ident
-        (fn
-          (start)
-          (do
-            (when
-              (and (< pos src-len) (dl-ident-char? (cur)))
-              (do (advance! 1) (read-ident start)))
-            (slice src start pos))))
-      (define
-        read-decimal-digits!
-        (fn
-          ()
-          (when
-            (and (< pos src-len) (dl-digit? (cur)))
-            (do (advance! 1) (read-decimal-digits!)))))
-      (define
-        read-number
-        (fn
-          (start)
-          (do
-            (read-decimal-digits!)
-            (when
-              (and
-                (< pos src-len)
-                (= (cur) ".")
-                (< (+ pos 1) src-len)
-                (dl-digit? (dl-peek 1)))
-              (do (advance! 1) (read-decimal-digits!)))
-            (parse-number (slice src start pos)))))
-      (define
-        read-quoted
-        (fn
-          (quote-char)
-          (let
-            ((chars (list)))
-            (advance! 1)
-            (define
-              loop
-              (fn
-                ()
-                (cond
-                  ((>= pos src-len)
-                    (error
-                      (str "Tokenizer: unterminated "
-                           (if (= quote-char "'") "quoted atom" "string")
-                           " (started near position " pos ")")))
-                  ((= (cur) "\\")
-                    (do
-                      (advance! 1)
-                      (when
-                        (< pos src-len)
-                        (let
-                          ((ch (cur)))
-                          (do
-                            (cond
-                              ((= ch "n") (append! chars "\n"))
-                              ((= ch "t") (append! chars "\t"))
-                              ((= ch "r") (append! chars "\r"))
-                              ((= ch "\\") (append! chars "\\"))
-                              ((= ch "'") (append! chars "'"))
-                              ((= ch "\"") (append! chars "\""))
-                              (else (append! chars ch)))
-                            (advance! 1))))
-                      (loop)))
-                  ((= (cur) quote-char) (advance! 1))
-                  (else
-                    (do (append! chars (cur)) (advance! 1) (loop))))))
-            (loop)
-            (join "" chars))))
-      (define
-        scan!
-        (fn
-          ()
-          (do
-            (skip-ws!)
-            (when
-              (< pos src-len)
-              (let
-                ((ch (cur)) (start pos))
-                (cond
-                  ((at? ":-")
-                    (do
-                      (dl-emit! "op" ":-" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "?-")
-                    (do
-                      (dl-emit! "op" "?-" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "<=")
-                    (do
-                      (dl-emit! "op" "<=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? ">=")
-                    (do
-                      (dl-emit! "op" ">=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((at? "!=")
-                    (do
-                      (dl-emit! "op" "!=" start)
-                      (advance! 2)
-                      (scan!)))
-                  ((dl-digit? ch)
-                    (do
-                      (dl-emit! "number" (read-number start) start)
-                      (scan!)))
-                  ((= ch "'")
-                    ;; Quoted 'atoms' tokenize as strings so a name
-                    ;; like 'Hello World' doesn't get misclassified
-                    ;; as a variable by dl-var? (which inspects the
-                    ;; symbol's first character).
-                    (do (dl-emit! "string" (read-quoted "'") start) (scan!)))
-                  ((= ch "\"")
-                    (do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
-                  ((dl-lower? ch)
-                    (do (dl-emit! "atom" (read-ident start) start) (scan!)))
-                  ((or (dl-upper? ch) (= ch "_"))
-                    (do (dl-emit! "var" (read-ident start) start) (scan!)))
-                  ((= ch "(")
-                    (do
-                      (dl-emit! "punct" "(" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ")")
-                    (do
-                      (dl-emit! "punct" ")" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ",")
-                    (do
-                      (dl-emit! "punct" "," start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ".")
-                    (do
-                      (dl-emit! "punct" "." start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "<")
-                    (do
-                      (dl-emit! "op" "<" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch ">")
-                    (do
-                      (dl-emit! "op" ">" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "=")
-                    (do
-                      (dl-emit! "op" "=" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "+")
-                    (do
-                      (dl-emit! "op" "+" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "-")
-                    (do
-                      (dl-emit! "op" "-" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "*")
-                    (do
-                      (dl-emit! "op" "*" start)
-                      (advance! 1)
-                      (scan!)))
-                  ((= ch "/")
-                    (do
-                      (dl-emit! "op" "/" start)
-                      (advance! 1)
-                      (scan!)))
-                  (else (error
-                          (str "Tokenizer: unexpected character '" ch
-                               "' at position " start)))))))))
-      (scan!)
-      (dl-emit! "eof" nil pos)
-      tokens)))

lib/datalog/unify.sx

@@ -1,171 +0,0 @@
-;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
-;;
-;; Term taxonomy (after parsing):
-;;   variable  — SX symbol whose first char is uppercase A–Z or '_'.
-;;   constant  — SX symbol whose first char is lowercase a–z (atom name).
-;;   number    — numeric literal.
-;;   string    — string literal.
-;;   compound  — SX list (functor arg ... arg). In core Datalog these
-;;               only appear as arithmetic expressions (see Phase 4
-;;               safety analysis); compound-against-compound unification
-;;               is supported anyway for completeness.
-;;
-;; Substitutions are immutable dicts keyed by variable name (string).
-;; A failed unification returns nil; success returns the extended subst.
-
-(define dl-empty-subst (fn () {}))
-
-(define
-  dl-var?
-  (fn
-    (term)
-    (and
-      (symbol? term)
-      (let
-        ((name (symbol->string term)))
-        (and
-          (> (len name) 0)
-          (let
-            ((c (slice name 0 1)))
-            (or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
-
-;; Walk: chase variable bindings until we hit a non-variable or an unbound
-;; variable. The result is either a non-variable term or an unbound var.
-(define
-  dl-walk
-  (fn (term subst) (dl-walk-aux term subst (list))))
-
-;; Internal: walk with a visited-var set so circular substitutions
-;; (from raw dl-bind misuse) don't infinite-loop. Cycles return the
-;; current term unchanged.
-(define
-  dl-walk-aux
-  (fn
-    (term subst visited)
-    (if
-      (dl-var? term)
-      (let
-        ((name (symbol->string term)))
-        (cond
-          ((dl-member? name visited) term)
-          ((and (dict? subst) (has-key? subst name))
-            (let ((seen (list)))
-              (do
-                (for-each (fn (v) (append! seen v)) visited)
-                (append! seen name)
-                (dl-walk-aux (get subst name) subst seen))))
-          (else term)))
-      term)))
-
-;; Bind a variable symbol to a value in subst, returning a new subst.
-(define
-  dl-bind
-  (fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
-
-(define
-  dl-unify
-  (fn
-    (t1 t2 subst)
-    (if
-      (nil? subst)
-      nil
-      (let
-        ((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
-        (cond
-          ((dl-var? u1)
-            (cond
-              ((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
-                subst)
-              (else (dl-bind u1 u2 subst))))
-          ((dl-var? u2) (dl-bind u2 u1 subst))
-          ((and (list? u1) (list? u2))
-            (if
-              (= (len u1) (len u2))
-              (dl-unify-list u1 u2 subst 0)
-              nil))
-          ((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
-          ((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
-          ((and (symbol? u1) (symbol? u2))
-            (if (= (symbol->string u1) (symbol->string u2)) subst nil))
-          (else nil))))))
-
-(define
-  dl-unify-list
-  (fn
-    (a b subst i)
-    (cond
-      ((nil? subst) nil)
-      ((>= i (len a)) subst)
-      (else
-        (dl-unify-list
-          a
-          b
-          (dl-unify (nth a i) (nth b i) subst)
-          (+ i 1))))))
-
-;; Apply substitution: walk the term and recurse into lists.
-(define
-  dl-apply-subst
-  (fn
-    (term subst)
-    (let
-      ((w (dl-walk term subst)))
-      (if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
-
-;; Ground? — true iff no free variables remain after walking.
-(define
-  dl-ground?
-  (fn
-    (term subst)
-    (let
-      ((w (dl-walk term subst)))
-      (cond
-        ((dl-var? w) false)
-        ((list? w) (dl-ground-list? w subst 0))
-        (else true)))))
-
-(define
-  dl-ground-list?
-  (fn
-    (xs subst i)
-    (cond
-      ((>= i (len xs)) true)
-      ((not (dl-ground? (nth xs i) subst)) false)
-      (else (dl-ground-list? xs subst (+ i 1))))))
-
-;; Return the list of variable names appearing in a term (deduped, in
-;; left-to-right order). Useful for safety analysis later.
-(define
-  dl-vars-of
-  (fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
-
-(define
-  dl-vars-of-aux
-  (fn
-    (term acc)
-    (cond
-      ((dl-var? term)
-        (let
-          ((name (symbol->string term)))
-          (when (not (dl-member? name acc)) (append! acc name))))
-      ((list? term) (dl-vars-of-list term acc 0))
-      (else nil))))
-
-(define
-  dl-vars-of-list
-  (fn
-    (xs acc i)
-    (when
-      (< i (len xs))
-      (do
-        (dl-vars-of-aux (nth xs i) acc)
-        (dl-vars-of-list xs acc (+ i 1))))))
-
-(define
-  dl-member?
-  (fn
-    (x xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) x) true)
-      (else (dl-member? x (rest xs))))))

lib/guest/hm.sx

@@ -1,180 +0,0 @@
-;; lib/guest/hm.sx — Hindley-Milner type-inference foundations.
-;;
-;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical
-;; AST shapes). This file ships the ALGEBRA — types, schemes, free
-;; type-vars, generalize / instantiate, substitution composition — so a
-;; full Algorithm W (or J) can be assembled on top either inside this
-;; file or in a host-specific consumer (haskell/infer.sx,
-;; lib/ocaml/types.sx, …).
-;;
-;; Per the brief the second consumer for this step is OCaml-on-SX
-;; Phase 5 (paired sequencing). Until that lands, the algebra is the
-;; deliverable; the host-flavoured assembly (lambda / app / let
-;; inference rules with substitution threading) lives in the host.
-;;
-;; Types
-;; -----
-;; A type is a canonical match.sx term — type variables use mk-var,
-;; type constructors use mk-ctor:
-;;   (hm-tv NAME)              type variable
-;;   (hm-arrow A B)             A -> B
-;;   (hm-con NAME ARGS)         named n-ary constructor
-;;   (hm-int) / (hm-bool) / (hm-string)   primitive constructors
-;;
-;; Schemes
-;; -------
-;;   (hm-scheme VARS TYPE)        ∀ VARS . TYPE
-;;   (hm-monotype TYPE)           empty quantifier
-;;   (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S)
-;;
-;; Free type variables
-;; -------------------
-;;   (hm-ftv TYPE)                names occurring in TYPE
-;;   (hm-ftv-scheme S)            free names (minus quantifiers)
-;;   (hm-ftv-env ENV)             free across an env (name -> scheme)
-;;
-;; Substitution
-;; ------------
-;;   (hm-apply SUBST TYPE)        substitute through a type
-;;   (hm-apply-scheme SUBST S)    leaves bound vars alone
-;;   (hm-apply-env SUBST ENV)
-;;   (hm-compose S2 S1)           apply S1 then S2
-;;
-;; Generalize / Instantiate
-;; ------------------------
-;;   (hm-generalize TYPE ENV)      → scheme over ftv(t) - ftv(env)
-;;   (hm-instantiate SCHEME COUNTER) → fresh-var instance
-;;   (hm-fresh-tv COUNTER)         → (:var "tN"), bumps COUNTER
-;;
-;; Inference (literal only — the rest of Algorithm W lives in the host)
-;; --------------------------------------------------------------------
-;;   (hm-infer-literal EXPR)       → {:subst {} :type T}
-;;
-;; A complete Algorithm W consumes this kit by assembling lambda / app
-;; / let rules in the host language file.
-
-(define hm-tv     (fn (name) (list :var name)))
-(define hm-con    (fn (name args) (list :ctor name args)))
-(define hm-arrow  (fn (a b) (hm-con "->" (list a b))))
-(define hm-int    (fn () (hm-con "Int" (list))))
-(define hm-bool   (fn () (hm-con "Bool" (list))))
-(define hm-string (fn () (hm-con "String" (list))))
-
-(define hm-scheme        (fn (vars t) (list :scheme vars t)))
-(define hm-monotype      (fn (t) (hm-scheme (list) t)))
-(define hm-scheme?       (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme))))
-(define hm-scheme-vars   (fn (s) (nth s 1)))
-(define hm-scheme-type   (fn (s) (nth s 2)))
-
-(define
-  hm-fresh-tv
-  (fn (counter)
-    (let ((n (first counter)))
-      (begin
-        (set-nth! counter 0 (+ n 1))
-        (hm-tv (str "t" (+ n 1)))))))
-
-(define
-  hm-ftv-acc
-  (fn (t acc)
-    (cond
-      ((is-var? t)
-        (if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc)))
-      ((is-ctor? t)
-        (let ((a acc))
-          (begin
-            (for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t))
-            a)))
-      (:else acc))))
-
-(define hm-ftv (fn (t) (hm-ftv-acc t (list))))
-
-(define
-  hm-ftv-scheme
-  (fn (s)
-    (let ((qs (hm-scheme-vars s))
-          (all (hm-ftv (hm-scheme-type s))))
-      (filter (fn (n) (not (some (fn (q) (= q n)) qs))) all))))
-
-(define
-  hm-ftv-env
-  (fn (env)
-    (let ((acc (list)))
-      (begin
-        (for-each
-          (fn (k)
-            (for-each
-              (fn (n)
-                (when (not (some (fn (m) (= m n)) acc))
-                  (set! acc (cons n acc))))
-              (hm-ftv-scheme (get env k))))
-          (keys env))
-        acc))))
-
-(define hm-apply (fn (subst t) (walk* t subst)))
-
-(define
-  hm-apply-scheme
-  (fn (subst s)
-    (let ((qs (hm-scheme-vars s))
-          (d {}))
-      (begin
-        (for-each
-          (fn (k)
-            (when (not (some (fn (q) (= q k)) qs))
-              (dict-set! d k (get subst k))))
-          (keys subst))
-        (hm-scheme qs (walk* (hm-scheme-type s) d))))))
-
-(define
-  hm-apply-env
-  (fn (subst env)
-    (let ((d {}))
-      (begin
-        (for-each
-          (fn (k) (dict-set! d k (hm-apply-scheme subst (get env k))))
-          (keys env))
-        d))))
-
-(define
-  hm-compose
-  (fn (s2 s1)
-    (let ((d {}))
-      (begin
-        (for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1))
-        (for-each
-          (fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k))))
-          (keys s2))
-        d))))
-
-(define
-  hm-generalize
-  (fn (t env)
-    (let ((tvars (hm-ftv t))
-          (evars (hm-ftv-env env)))
-      (let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars)))
-        (hm-scheme qs t)))))
-
-(define
-  hm-instantiate
-  (fn (s counter)
-    (let ((qs (hm-scheme-vars s))
-          (subst {}))
-      (begin
-        (for-each
-          (fn (q) (set! subst (assoc subst q (hm-fresh-tv counter))))
-          qs)
-        (walk* (hm-scheme-type s) subst)))))
-
-;; Literal inference — the only AST kind whose typing rule is closed
-;; in the kit. Lambda / app / let live in host code so the host's own
-;; AST conventions stay untouched.
-(define
-  hm-infer-literal
-  (fn (expr)
-    (let ((v (ast-literal-value expr)))
-      (cond
-        ((number? v)  {:subst {} :type (hm-int)})
-        ((string? v)  {:subst {} :type (hm-string)})
-        ((boolean? v) {:subst {} :type (hm-bool)})
-        (:else (error (str "hm-infer-literal: unknown kind: " v)))))))

lib/guest/layout.sx

@@ -1,145 +0,0 @@
-;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
-;;
-;; Inserts virtual open / close / separator tokens based on indentation.
-;; Configurable enough to encode either the Haskell 98 layout rule (let /
-;; where / do / of opens a virtual brace at the next token's column) or
-;; a Python-ish indent / dedent rule (a colon at the end of a line opens
-;; a block at the next non-blank line's column).
-;;
-;; Token shape (input + output)
-;; ----------------------------
-;; Each token is a dict {:type :value :line :col …}. The kit reads
-;; only :type / :value / :line / :col and passes everything else
-;; through. The input stream MUST be free of newline filler tokens
-;; (preprocess them away with your tokenizer) — line breaks are detected
-;; by comparing :line of consecutive tokens.
-;;
-;; Config
-;; ------
-;;   :open-keywords    list of strings; a token whose :value matches
-;;                     opens a new layout block at the next token's
-;;                     column (Haskell: let/where/do/of).
-;;   :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
-;;                     fires AFTER the token is emitted. Use for
-;;                     Python-style trailing `:`.
-;;   :open-token / :close-token / :sep-token
-;;                     templates {:type :value} merged with :line and
-;;                     :col when virtual tokens are emitted.
-;;   :explicit-open?   (fn (tok) -> bool) — if the next token after a
-;;                     trigger satisfies this, suppress virtual layout
-;;                     for that block (Haskell: `{`).
-;;   :module-prelude?  if true, wrap whole input in an implicit block
-;;                     at the first token's column (Haskell yes,
-;;                     Python no).
-;;
-;; Public entry
-;; ------------
-;;   (layout-pass cfg tokens) -> tokens with virtual layout inserted.
-
-(define
-  layout-mk-virtual
-  (fn (template line col)
-    (assoc (assoc template :line line) :col col)))
-
-(define
-  layout-is-open-kw?
-  (fn (tok open-kws)
-    (and (= (get tok :type) "reserved")
-         (some (fn (k) (= k (get tok :value))) open-kws))))
-
-(define
-  layout-pass
-  (fn (cfg tokens)
-    (let ((open-kws (get cfg :open-keywords))
-          (trailing-fn (get cfg :open-trailing-fn))
-          (open-tmpl (get cfg :open-token))
-          (close-tmpl (get cfg :close-token))
-          (sep-tmpl (get cfg :sep-token))
-          (mod-prelude? (get cfg :module-prelude?))
-          (expl?-fn (get cfg :explicit-open?))
-          (out (list))
-          (stack (list))
-          (n (len tokens))
-          (i 0)
-          (prev-line -1)
-          (pending-open false)
-          (just-opened false))
-      (define
-        emit-closes-while-greater
-        (fn (col line)
-          (when (and (not (empty? stack)) (> (first stack) col))
-            (do
-              (append! out (layout-mk-virtual close-tmpl line col))
-              (set! stack (rest stack))
-              (emit-closes-while-greater col line)))))
-      (define
-        emit-pending-open
-        (fn (line col)
-          (do
-            (append! out (layout-mk-virtual open-tmpl line col))
-            (set! stack (cons col stack))
-            (set! pending-open false)
-            (set! just-opened true))))
-      (define
-        layout-step
-        (fn ()
-          (when (< i n)
-            (let ((tok (nth tokens i)))
-              (let ((line (get tok :line)) (col (get tok :col)))
-                (cond
-                  (pending-open
-                    (cond
-                      ((and (not (= expl?-fn nil)) (expl?-fn tok))
-                        (do
-                          (set! pending-open false)
-                          (append! out tok)
-                          (set! prev-line line)
-                          (set! i (+ i 1))
-                          (layout-step)))
-                      (:else
-                        (do
-                          (emit-pending-open line col)
-                          (layout-step)))))
-                  (:else
-                    (let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
-                      (do
-                        (when on-fresh-line?
-                          (let ((stack-before stack))
-                            (begin
-                              (emit-closes-while-greater col line)
-                              (when (and (not (empty? stack))
-                                         (= (first stack) col)
-                                         (not just-opened)
-                                         ;; suppress separator if a dedent fired
-                                         ;; — the dedent is itself the separator
-                                         (= (len stack) (len stack-before)))
-                                (append! out (layout-mk-virtual sep-tmpl line col))))))
-                        (set! just-opened false)
-                        (append! out tok)
-                        (set! prev-line line)
-                        (set! i (+ i 1))
-                        (cond
-                          ((layout-is-open-kw? tok open-kws)
-                            (set! pending-open true))
-                          ((and (not (= trailing-fn nil)) (trailing-fn tok))
-                            (set! pending-open true)))
-                        (layout-step))))))))))
-      (begin
-        ;; Module prelude: implicit layout block at the first token's column.
-        (when (and mod-prelude? (> n 0))
-          (let ((tok (nth tokens 0)))
-            (do
-              (append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
-              (set! stack (cons (get tok :col) stack))
-              (set! just-opened true))))
-        (layout-step)
-        ;; EOF: close every remaining block.
-        (define close-rest
-          (fn ()
-            (when (not (empty? stack))
-              (do
-                (append! out (layout-mk-virtual close-tmpl 0 0))
-                (set! stack (rest stack))
-                (close-rest)))))
-        (close-rest)
-        out))))

lib/guest/tests/hm.sx

@@ -1,89 +0,0 @@
-;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra.
-
-(define ghm-test-pass 0)
-(define ghm-test-fail 0)
-(define ghm-test-fails (list))
-
-(define
-  ghm-test
-  (fn (name actual expected)
-    (if (= actual expected)
-      (set! ghm-test-pass (+ ghm-test-pass 1))
-      (begin
-        (set! ghm-test-fail (+ ghm-test-fail 1))
-        (append! ghm-test-fails {:name name :expected expected :actual actual})))))
-
-;; ── Type constructors ─────────────────────────────────────────────
-(ghm-test "tv"           (hm-tv "a") (list :var "a"))
-(ghm-test "int"          (hm-int)    (list :ctor "Int" (list)))
-(ghm-test "arrow"        (ctor-head (hm-arrow (hm-int) (hm-bool))) "->")
-(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2)
-
-;; ── Schemes ───────────────────────────────────────────────────────
-(ghm-test "scheme-vars"  (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a"))
-(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list))
-(ghm-test "scheme?-yes"  (hm-scheme? (hm-monotype (hm-int))) true)
-(ghm-test "scheme?-no"   (hm-scheme? (hm-int)) false)
-
-;; ── Fresh tyvars ──────────────────────────────────────────────────
-(ghm-test "fresh-1"
-  (let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1")
-(ghm-test "fresh-bumps"
-  (let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6)
-
-;; ── Free type variables ──────────────────────────────────────────
-(ghm-test "ftv-int"      (hm-ftv (hm-int)) (list))
-(ghm-test "ftv-tv"       (hm-ftv (hm-tv "a")) (list "a"))
-(ghm-test "ftv-arrow"
-  (len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2)
-(ghm-test "ftv-scheme-quantified"
-  (hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b"))
-(ghm-test "ftv-env"
-  (let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y"))))))
-    (len (hm-ftv-env env))) 2)
-
-;; ── Substitution / apply / compose ───────────────────────────────
-(ghm-test "apply-tv"
-  (hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int))
-(ghm-test "apply-arrow"
-  (ctor-head
-    (hm-apply (assoc {} "a" (hm-int))
-              (hm-arrow (hm-tv "a") (hm-tv "b")))) "->")
-(ghm-test "compose-1-then-2"
-  (var-name
-    (hm-apply
-      (hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b")))
-      (hm-tv "a"))) "c")
-
-;; ── Generalize / Instantiate ─────────────────────────────────────
-;;   forall a. a -> a   instantiated twice yields fresh vars each time
-(ghm-test "generalize-id"
-  (len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1)
-
-(ghm-test "generalize-skips-env"
-  ;; ftv(t)={a,b}, ftv(env)={a}, qs={b}
-  (let ((env (assoc {} "x" (hm-monotype (hm-tv "a")))))
-    (len (hm-scheme-vars
-           (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1)
-
-(ghm-test "instantiate-fresh"
-  (let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a"))))
-        (c (list 0)))
-    (let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c)))
-      (not (= (var-name (first (ctor-args t1)))
-              (var-name (first (ctor-args t2)))))))
-  true)
-
-;; ── Inference (literal only) ─────────────────────────────────────
-(ghm-test "infer-int"
-  (ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int")
-(ghm-test "infer-string"
-  (ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String")
-(ghm-test "infer-bool"
-  (ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool")
-
-(define ghm-tests-run!
-  (fn ()
-    {:passed ghm-test-pass
-     :failed ghm-test-fail
-     :total  (+ ghm-test-pass ghm-test-fail)}))

lib/guest/tests/layout.sx

@@ -1,180 +0,0 @@
-;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture.
-;;
-;; Exercises lib/guest/layout.sx with a config different from Haskell's
-;; (no module-prelude, layout opens via trailing `:` not via reserved
-;; keyword) to prove the kit isn't Haskell-shaped.
-
-(define glayout-test-pass 0)
-(define glayout-test-fail 0)
-(define glayout-test-fails (list))
-
-(define
-  glayout-test
-  (fn (name actual expected)
-    (if (= actual expected)
-      (set! glayout-test-pass (+ glayout-test-pass 1))
-      (begin
-        (set! glayout-test-fail (+ glayout-test-fail 1))
-        (append! glayout-test-fails {:name name :expected expected :actual actual})))))
-
-;; Convenience: build a token from {type value line col}.
-(define
-  glayout-tok
-  (fn (ty val line col)
-    {:type ty :value val :line line :col col}))
-
-;; Project a token list to ((type value) ...) for compact comparison.
-(define
-  glayout-shape
-  (fn (toks)
-    (map (fn (t) (list (get t :type) (get t :value))) toks)))
-
-;; ── Haskell-flavour: keyword opens block ─────────────────────────
-(define
-  glayout-haskell-cfg
-  {:open-keywords (list "let" "where" "do" "of")
-   :open-trailing-fn nil
-   :open-token   {:type "vlbrace" :value "{"}
-   :close-token  {:type "vrbrace" :value "}"}
-   :sep-token    {:type "vsemi"   :value ";"}
-   :module-prelude? false
-   :explicit-open? (fn (tok) (= (get tok :type) "lbrace"))})
-
-;;   do
-;;     a
-;;     b
-;;   c       ← outside the do-block
-(glayout-test "haskell-do-block"
-  (glayout-shape
-    (layout-pass
-      glayout-haskell-cfg
-      (list (glayout-tok "reserved" "do" 1 1)
-            (glayout-tok "ident" "a" 2 3)
-            (glayout-tok "ident" "b" 3 3)
-            (glayout-tok "ident" "c" 4 1))))
-  (list (list "reserved" "do")
-        (list "vlbrace" "{")
-        (list "ident" "a")
-        (list "vsemi" ";")
-        (list "ident" "b")
-        (list "vrbrace" "}")
-        (list "ident" "c")))
-
-;; Explicit `{` after `do` suppresses virtual layout.
-(glayout-test "haskell-explicit-brace"
-  (glayout-shape
-    (layout-pass
-      glayout-haskell-cfg
-      (list (glayout-tok "reserved" "do" 1 1)
-            (glayout-tok "lbrace" "{" 1 4)
-            (glayout-tok "ident" "a" 1 6)
-            (glayout-tok "rbrace" "}" 1 8))))
-  (list (list "reserved" "do")
-        (list "lbrace" "{")
-        (list "ident" "a")
-        (list "rbrace" "}")))
-
-;; Single-statement do-block on the same line.
-(glayout-test "haskell-do-inline"
-  (glayout-shape
-    (layout-pass
-      glayout-haskell-cfg
-      (list (glayout-tok "reserved" "do" 1 1)
-            (glayout-tok "ident" "a" 1 4))))
-  (list (list "reserved" "do")
-        (list "vlbrace" "{")
-        (list "ident" "a")
-        (list "vrbrace" "}")))
-
-;; Module-prelude: wrap whole input in implicit layout block at first
-;; tok's column.
-(glayout-test "haskell-module-prelude"
-  (glayout-shape
-    (layout-pass
-      (assoc glayout-haskell-cfg :module-prelude? true)
-      (list (glayout-tok "ident" "x" 1 1)
-            (glayout-tok "ident" "y" 2 1)
-            (glayout-tok "ident" "z" 3 1))))
-  (list (list "vlbrace" "{")
-        (list "ident" "x")
-        (list "vsemi" ";")
-        (list "ident" "y")
-        (list "vsemi" ";")
-        (list "ident" "z")
-        (list "vrbrace" "}")))
-
-;; ── Python-flavour: trailing `:` opens block ─────────────────────
-(define
-  glayout-python-cfg
-  {:open-keywords (list)
-   :open-trailing-fn (fn (tok) (and (= (get tok :type) "punct")
-                                    (= (get tok :value) ":")))
-   :open-token   {:type "indent" :value "INDENT"}
-   :close-token  {:type "dedent" :value "DEDENT"}
-   :sep-token    {:type "newline" :value "NEWLINE"}
-   :module-prelude? false
-   :explicit-open? nil})
-
-;;   if x:
-;;       a
-;;       b
-;;   c
-(glayout-test "python-if-block"
-  (glayout-shape
-    (layout-pass
-      glayout-python-cfg
-      (list (glayout-tok "reserved" "if" 1 1)
-            (glayout-tok "ident" "x" 1 4)
-            (glayout-tok "punct" ":" 1 5)
-            (glayout-tok "ident" "a" 2 5)
-            (glayout-tok "ident" "b" 3 5)
-            (glayout-tok "ident" "c" 4 1))))
-  (list (list "reserved" "if")
-        (list "ident" "x")
-        (list "punct" ":")
-        (list "indent" "INDENT")
-        (list "ident" "a")
-        (list "newline" "NEWLINE")
-        (list "ident" "b")
-        (list "dedent" "DEDENT")
-        (list "ident" "c")))
-
-;; Nested Python-style blocks.
-;;   def f():
-;;       if x:
-;;           a
-;;       b
-(glayout-test "python-nested"
-  (glayout-shape
-    (layout-pass
-      glayout-python-cfg
-      (list (glayout-tok "reserved" "def" 1 1)
-            (glayout-tok "ident" "f" 1 5)
-            (glayout-tok "punct" "(" 1 6)
-            (glayout-tok "punct" ")" 1 7)
-            (glayout-tok "punct" ":" 1 8)
-            (glayout-tok "reserved" "if" 2 5)
-            (glayout-tok "ident" "x" 2 8)
-            (glayout-tok "punct" ":" 2 9)
-            (glayout-tok "ident" "a" 3 9)
-            (glayout-tok "ident" "b" 4 5))))
-  (list (list "reserved" "def")
-        (list "ident" "f")
-        (list "punct" "(")
-        (list "punct" ")")
-        (list "punct" ":")
-        (list "indent" "INDENT")
-        (list "reserved" "if")
-        (list "ident" "x")
-        (list "punct" ":")
-        (list "indent" "INDENT")
-        (list "ident" "a")
-        (list "dedent" "DEDENT")
-        (list "ident" "b")
-        (list "dedent" "DEDENT")))
-
-(define glayout-tests-run!
-  (fn ()
-    {:passed glayout-test-pass
-     :failed glayout-test-fail
-     :total  (+ glayout-test-pass glayout-test-fail)}))

lib/minikanren/clpfd.sx

@@ -0,0 +1,858 @@
+;; lib/minikanren/clpfd.sx — Phase 6: native CLP(FD) on miniKanren.
+;;
+;; The substitution dict carries an extra reserved key "_fd" that holds a
+;; constraint-store record:
+;;
+;;   {:domains    {var-name -> sorted-int-list}
+;;    :constraints (... pending constraint closures ...)}
+;;
+;; Domains are sorted SX lists of ints (no duplicates).
+;; Constraints are functions s -> s-or-nil that propagate / re-check.
+;; They are re-fired after every label binding via fd-fire-store.
+
+(define fd-key "_fd")
+
+;; --- domain primitives ---
+
+(define
+  fd-dom-rev
+  (fn
+    (xs acc)
+    (cond
+      ((empty? xs) acc)
+      (:else (fd-dom-rev (rest xs) (cons (first xs) acc))))))
+
+(define
+  fd-dom-insert
+  (fn
+    (x desc)
+    (cond
+      ((empty? desc) (list x))
+      ((= x (first desc)) desc)
+      ((> x (first desc)) (cons x desc))
+      (:else (cons (first desc) (fd-dom-insert x (rest desc)))))))
+
+(define
+  fd-dom-sort-dedupe
+  (fn
+    (xs acc)
+    (cond
+      ((empty? xs) (fd-dom-rev acc (list)))
+      (:else (fd-dom-sort-dedupe (rest xs) (fd-dom-insert (first xs) acc))))))
+
+(define fd-dom-from-list (fn (xs) (fd-dom-sort-dedupe xs (list))))
+
+(define fd-dom-empty? (fn (d) (empty? d)))
+(define
+  fd-dom-singleton?
+  (fn (d) (and (not (empty? d)) (empty? (rest d)))))
+(define fd-dom-min (fn (d) (first d)))
+
+(define
+  fd-dom-last
+  (fn
+    (d)
+    (cond ((empty? (rest d)) (first d)) (:else (fd-dom-last (rest d))))))
+
+(define fd-dom-max (fn (d) (fd-dom-last d)))
+(define fd-dom-member? (fn (x d) (some (fn (y) (= x y)) d)))
+
+(define
+  fd-dom-intersect
+  (fn
+    (a b)
+    (cond
+      ((empty? a) (list))
+      ((empty? b) (list))
+      ((= (first a) (first b))
+        (cons (first a) (fd-dom-intersect (rest a) (rest b))))
+      ((< (first a) (first b)) (fd-dom-intersect (rest a) b))
+      (:else (fd-dom-intersect a (rest b))))))
+
+(define
+  fd-dom-without
+  (fn
+    (x d)
+    (cond
+      ((empty? d) (list))
+      ((= (first d) x) (rest d))
+      ((> (first d) x) d)
+      (:else (cons (first d) (fd-dom-without x (rest d)))))))
+
+(define
+  fd-dom-range
+  (fn
+    (lo hi)
+    (cond
+      ((> lo hi) (list))
+      (:else (cons lo (fd-dom-range (+ lo 1) hi))))))
+
+;; --- constraint store accessors ---
+
+(define fd-store-empty (fn () {:domains {} :constraints (list)}))
+
+(define
+  fd-store-of
+  (fn
+    (s)
+    (cond ((has-key? s fd-key) (get s fd-key)) (:else (fd-store-empty)))))
+
+(define fd-domains-of (fn (s) (get (fd-store-of s) :domains)))
+(define fd-with-store (fn (s store) (assoc s fd-key store)))
+
+(define
+  fd-domain-of
+  (fn
+    (s var-name)
+    (let
+      ((doms (fd-domains-of s)))
+      (cond ((has-key? doms var-name) (get doms var-name)) (:else nil)))))
+
+(define
+  fd-set-domain
+  (fn
+    (s var-name d)
+    (cond
+      ((fd-dom-empty? d) nil)
+      (:else
+        (let
+          ((store (fd-store-of s)))
+          (let
+            ((doms-prime (assoc (get store :domains) var-name d)))
+            (let
+              ((store-prime (assoc store :domains doms-prime)))
+              (fd-with-store s store-prime))))))))
+
+(define
+  fd-add-constraint
+  (fn
+    (s c)
+    (let
+      ((store (fd-store-of s)))
+      (let
+        ((cs-prime (cons c (get store :constraints))))
+        (let
+          ((store-prime (assoc store :constraints cs-prime)))
+          (fd-with-store s store-prime))))))
+
+(define
+  fd-fire-list
+  (fn
+    (cs s)
+    (cond
+      ((empty? cs) s)
+      (:else
+        (let
+          ((s2 ((first cs) s)))
+          (cond ((= s2 nil) nil) (:else (fd-fire-list (rest cs) s2))))))))
+
+(define
+  fd-store-signature
+  (fn
+    (s)
+    (let
+      ((doms (fd-domains-of s)))
+      (let
+        ((dom-sizes (reduce (fn (acc k) (+ acc (len (get doms k)))) 0 (keys doms))))
+        (+ dom-sizes (len (keys s)))))))
+
+(define
+  fd-fire-store
+  (fn
+    (s)
+    (let
+      ((s2 (fd-fire-list (get (fd-store-of s) :constraints) s)))
+      (cond
+        ((= s2 nil) nil)
+        ((= (fd-store-signature s) (fd-store-signature s2)) s2)
+        (:else (fd-fire-store s2))))))
+
+;; --- user-facing goals ---
+
+(define
+  fd-in
+  (fn
+    (x dom-list)
+    (fn
+      (s)
+      (let
+        ((new-dom (fd-dom-from-list dom-list)))
+        (let
+          ((wx (mk-walk x s)))
+          (cond
+            ((number? wx)
+              (cond ((fd-dom-member? wx new-dom) (unit s)) (:else mzero)))
+            ((is-var? wx)
+              (let
+                ((existing (fd-domain-of s (var-name wx))))
+                (let
+                  ((narrowed (cond ((= existing nil) new-dom) (:else (fd-dom-intersect existing new-dom)))))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) narrowed)))
+                    (cond ((= s2 nil) mzero) (:else (unit s2)))))))
+            (:else mzero)))))))
+
+;; --- fd-neq ---
+
+(define
+  fd-neq-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((= wx wy) nil) (:else s)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((y-dom (fd-domain-of s (var-name wy))))
+            (cond
+              ((= y-dom nil) s)
+              (:else
+                (fd-set-domain s (var-name wy) (fd-dom-without wx y-dom))))))
+        ((and (number? wy) (is-var? wx))
+          (let
+            ((x-dom (fd-domain-of s (var-name wx))))
+            (cond
+              ((= x-dom nil) s)
+              (:else
+                (fd-set-domain s (var-name wx) (fd-dom-without wy x-dom))))))
+        (:else s)))))
+
+(define
+  fd-neq
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (s-prime) (fd-neq-prop x y s-prime))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- fd-lt ---
+
+(define
+  fd-lt-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((< wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((= yd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wy)
+                  (filter (fn (v) (> v wx)) yd))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((= xd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wx)
+                  (filter (fn (v) (< v wy)) xd))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((or (= xd nil) (= yd nil)) s)
+              (:else
+                (let
+                  ((xd-prime (filter (fn (v) (< v (fd-dom-max yd))) xd)))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) xd-prime)))
+                    (cond
+                      ((= s2 nil) nil)
+                      (:else
+                        (let
+                          ((yd-prime (filter (fn (v) (> v (fd-dom-min xd-prime))) yd)))
+                          (fd-set-domain s2 (var-name wy) yd-prime))))))))))
+        (:else s)))))
+
+(define
+  fd-lt
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-lt-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- fd-lte ---
+
+(define
+  fd-lte-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((<= wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((= yd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wy)
+                  (filter (fn (v) (>= v wx)) yd))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((= xd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wx)
+                  (filter (fn (v) (<= v wy)) xd))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((or (= xd nil) (= yd nil)) s)
+              (:else
+                (let
+                  ((xd-prime (filter (fn (v) (<= v (fd-dom-max yd))) xd)))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) xd-prime)))
+                    (cond
+                      ((= s2 nil) nil)
+                      (:else
+                        (let
+                          ((yd-prime (filter (fn (v) (>= v (fd-dom-min xd-prime))) yd)))
+                          (fd-set-domain s2 (var-name wy) yd-prime))))))))))
+        (:else s)))))
+
+(define
+  fd-lte
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-lte-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- fd-eq ---
+
+(define
+  fd-eq-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((= wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((and (not (= yd nil)) (not (fd-dom-member? wx yd))) nil)
+              (:else
+                (let
+                  ((s2 (mk-unify wy wx s)))
+                  (cond ((= s2 nil) nil) (:else s2)))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((and (not (= xd nil)) (not (fd-dom-member? wy xd))) nil)
+              (:else
+                (let
+                  ((s2 (mk-unify wx wy s)))
+                  (cond ((= s2 nil) nil) (:else s2)))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((and (= xd nil) (= yd nil))
+                (let
+                  ((s2 (mk-unify wx wy s)))
+                  (cond ((= s2 nil) nil) (:else s2))))
+              (:else
+                (let
+                  ((shared (cond ((= xd nil) yd) ((= yd nil) xd) (:else (fd-dom-intersect xd yd)))))
+                  (cond
+                    ((fd-dom-empty? shared) nil)
+                    (:else
+                      (let
+                        ((s2 (fd-set-domain s (var-name wx) shared)))
+                        (cond
+                          ((= s2 nil) nil)
+                          (:else
+                            (let
+                              ((s3 (fd-set-domain s2 (var-name wy) shared)))
+                              (cond
+                                ((= s3 nil) nil)
+                                (:else (mk-unify wx wy s3))))))))))))))
+        (:else s)))))
+
+(define
+  fd-eq
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-eq-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- labelling ---
+
+(define
+  fd-try-each-value
+  (fn
+    (x dom s)
+    (cond
+      ((empty? dom) mzero)
+      (:else
+        (let
+          ((s2 (mk-unify x (first dom) s)))
+          (let
+            ((s3 (cond ((= s2 nil) nil) (:else (fd-fire-store s2)))))
+            (let
+              ((this-stream (cond ((= s3 nil) mzero) (:else (unit s3))))
+                (rest-stream (fd-try-each-value x (rest dom) s)))
+              (mk-mplus this-stream rest-stream))))))))
+
+(define
+  fd-label-one
+  (fn
+    (x)
+    (fn
+      (s)
+      (let
+        ((wx (mk-walk x s)))
+        (cond
+          ((number? wx) (unit s))
+          ((is-var? wx)
+            (let
+              ((dom (fd-domain-of s (var-name wx))))
+              (cond
+                ((= dom nil) mzero)
+                (:else (fd-try-each-value wx dom s)))))
+          (:else mzero))))))
+
+(define
+  fd-label
+  (fn
+    (vars)
+    (cond
+      ((empty? vars) succeed)
+      (:else (mk-conj (fd-label-one (first vars)) (fd-label (rest vars)))))))
+
+;; --- fd-distinct (pairwise distinct via fd-neq) ---
+
+(define
+  fd-distinct-from-head
+  (fn
+    (x others)
+    (cond
+      ((empty? others) succeed)
+      (:else
+        (mk-conj
+          (fd-neq x (first others))
+          (fd-distinct-from-head x (rest others)))))))
+
+(define
+  fd-distinct
+  (fn
+    (vars)
+    (cond
+      ((empty? vars) succeed)
+      ((empty? (rest vars)) succeed)
+      (:else
+        (mk-conj
+          (fd-distinct-from-head (first vars) (rest vars))
+          (fd-distinct (rest vars)))))))
+
+;; --- fd-plus (x + y = z, ground-cases propagator) ---
+
+(define
+  fd-bind-or-narrow
+  (fn
+    (w target s)
+    (cond
+      ((number? w) (cond ((= w target) s) (:else nil)))
+      ((is-var? w)
+        (let
+          ((wd (fd-domain-of s (var-name w))))
+          (cond
+            ((and (not (= wd nil)) (not (fd-dom-member? target wd))) nil)
+            (:else
+              (let
+                ((s2 (mk-unify w target s)))
+                (cond ((= s2 nil) nil) (:else s2)))))))
+      (:else nil))))
+
+(define
+  fd-narrow-or-skip
+  (fn
+    (s var-key d lo hi)
+    (cond
+      ((= d nil) s)
+      (:else
+        (fd-set-domain
+          s
+          var-key
+          (filter (fn (v) (and (>= v lo) (<= v hi))) d))))))
+
+(define
+  fd-plus-prop-vvn
+  (fn
+    (wx wy wz s)
+    (let
+      ((xd (fd-domain-of s (var-name wx)))
+        (yd (fd-domain-of s (var-name wy))))
+      (cond
+        ((or (= xd nil) (= yd nil)) s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wx) xd (- wz (fd-dom-max yd)) (- wz (fd-dom-min yd)))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((xd2 (fd-domain-of s1 (var-name wx))))
+                  (fd-narrow-or-skip
+                    s1
+                    (var-name wy)
+                    yd
+                    (- wz (fd-dom-max xd2))
+                    (- wz (fd-dom-min xd2))))))))))))
+
+(define
+  fd-plus-prop-nvv
+  (fn
+    (wx wy wz s)
+    (let
+      ((yd (fd-domain-of s (var-name wy)))
+        (zd (fd-domain-of s (var-name wz))))
+      (cond
+        ((or (= yd nil) (= zd nil)) s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wy) yd (- (fd-dom-min zd) wx) (- (fd-dom-max zd) wx))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((yd2 (fd-domain-of s1 (var-name wy))))
+                  (fd-narrow-or-skip
+                    s1
+                    (var-name wz)
+                    zd
+                    (+ wx (fd-dom-min yd2))
+                    (+ wx (fd-dom-max yd2))))))))))))
+
+(define
+  fd-plus-prop-vnv
+  (fn
+    (wx wy wz s)
+    (let
+      ((xd (fd-domain-of s (var-name wx)))
+        (zd (fd-domain-of s (var-name wz))))
+      (cond
+        ((or (= xd nil) (= zd nil)) s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wx) xd (- (fd-dom-min zd) wy) (- (fd-dom-max zd) wy))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((xd2 (fd-domain-of s1 (var-name wx))))
+                  (fd-narrow-or-skip
+                    s1
+                    (var-name wz)
+                    zd
+                    (+ (fd-dom-min xd2) wy)
+                    (+ (fd-dom-max xd2) wy))))))))))) 
+
+(define
+  fd-plus-prop-vvv
+  (fn
+    (wx wy wz s)
+    (let
+      ((xd (fd-domain-of s (var-name wx)))
+        (yd (fd-domain-of s (var-name wy)))
+        (zd (fd-domain-of s (var-name wz))))
+      (cond
+        ((or (= xd nil) (or (= yd nil) (= zd nil))) s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wx) xd (- (fd-dom-min zd) (fd-dom-max yd)) (- (fd-dom-max zd) (fd-dom-min yd)))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((s2 (fd-narrow-or-skip s1 (var-name wy) yd (- (fd-dom-min zd) (fd-dom-max xd)) (- (fd-dom-max zd) (fd-dom-min xd)))))
+                  (cond
+                    ((= s2 nil) nil)
+                    (:else
+                      (fd-narrow-or-skip
+                        s2
+                        (var-name wz)
+                        zd
+                        (+ (fd-dom-min xd) (fd-dom-min yd))
+                        (+ (fd-dom-max xd) (fd-dom-max yd))))))))))))))
+
+(define
+  fd-plus-prop
+  (fn
+    (x y z s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
+      (cond
+        ((and (number? wx) (number? wy) (number? wz))
+          (cond ((= (+ wx wy) wz) s) (:else nil)))
+        ((and (number? wx) (number? wy))
+          (fd-bind-or-narrow wz (+ wx wy) s))
+        ((and (number? wx) (number? wz))
+          (fd-bind-or-narrow wy (- wz wx) s))
+        ((and (number? wy) (number? wz))
+          (fd-bind-or-narrow wx (- wz wy) s))
+        ((and (is-var? wx) (is-var? wy) (number? wz))
+          (fd-plus-prop-vvn wx wy wz s))
+        ((and (number? wx) (is-var? wy) (is-var? wz))
+          (fd-plus-prop-nvv wx wy wz s))
+        ((and (is-var? wx) (number? wy) (is-var? wz))
+          (fd-plus-prop-vnv wx wy wz s))
+        ((and (is-var? wx) (is-var? wy) (is-var? wz))
+          (fd-plus-prop-vvv wx wy wz s))
+        (:else s)))))
+
+(define
+  fd-plus
+  (fn
+    (x y z)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-plus-prop x y z sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- fd-times (x * y = z, ground-cases propagator) ---
+
+(define
+  fd-int-ceil-div
+  (fn
+    (a b)
+    (cond
+      ((= (mod a b) 0) (/ a b))
+      (:else (+ (fd-int-floor-div a b) 1)))))
+
+(define fd-int-floor-div (fn (a b) (/ (- a (mod a b)) b)))
+
+(define
+  fd-dom-positive?
+  (fn
+    (d)
+    (cond ((empty? d) false) (:else (>= (fd-dom-min d) 1)))))
+
+(define
+  fd-times-prop-vvv
+  (fn
+    (wx wy wz s)
+    (let
+      ((xd (fd-domain-of s (var-name wx)))
+        (yd (fd-domain-of s (var-name wy)))
+        (zd (fd-domain-of s (var-name wz))))
+      (cond
+        ((or (= xd nil) (or (= yd nil) (= zd nil))) s)
+        ((not (and (fd-dom-positive? xd) (and (fd-dom-positive? yd) (fd-dom-positive? zd))))
+          s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wx) xd (fd-int-ceil-div (fd-dom-min zd) (fd-dom-max yd)) (fd-int-floor-div (fd-dom-max zd) (fd-dom-min yd)))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((s2 (fd-narrow-or-skip s1 (var-name wy) yd (fd-int-ceil-div (fd-dom-min zd) (fd-dom-max xd)) (fd-int-floor-div (fd-dom-max zd) (fd-dom-min xd)))))
+                  (cond
+                    ((= s2 nil) nil)
+                    (:else
+                      (fd-narrow-or-skip
+                        s2
+                        (var-name wz)
+                        zd
+                        (* (fd-dom-min xd) (fd-dom-min yd))
+                        (* (fd-dom-max xd) (fd-dom-max yd))))))))))))))
+
+(define
+  fd-times-prop-vvn
+  (fn
+    (wx wy wz s)
+    (let
+      ((xd (fd-domain-of s (var-name wx)))
+        (yd (fd-domain-of s (var-name wy))))
+      (cond
+        ((or (= xd nil) (= yd nil)) s)
+        ((not (and (fd-dom-positive? xd) (fd-dom-positive? yd))) s)
+        ((<= wz 0) s)
+        (:else
+          (let
+            ((s1 (fd-narrow-or-skip s (var-name wx) xd (fd-int-ceil-div wz (fd-dom-max yd)) (fd-int-floor-div wz (fd-dom-min yd)))))
+            (cond
+              ((= s1 nil) nil)
+              (:else
+                (let
+                  ((xd2 (fd-domain-of s1 (var-name wx))))
+                  (fd-narrow-or-skip
+                    s1
+                    (var-name wy)
+                    yd
+                    (fd-int-ceil-div wz (fd-dom-max xd2))
+                    (fd-int-floor-div wz (fd-dom-min xd2))))))))))))
+
+(define
+  fd-times-prop-nvv
+  (fn
+    (wx wy wz s)
+    (cond
+      ((<= wx 0) s)
+      (:else
+        (let
+          ((yd (fd-domain-of s (var-name wy)))
+            (zd (fd-domain-of s (var-name wz))))
+          (cond
+            ((or (= yd nil) (= zd nil)) s)
+            ((not (and (fd-dom-positive? yd) (fd-dom-positive? zd))) s)
+            (:else
+              (let
+                ((s1 (fd-narrow-or-skip s (var-name wy) yd (fd-int-ceil-div (fd-dom-min zd) wx) (fd-int-floor-div (fd-dom-max zd) wx))))
+                (cond
+                  ((= s1 nil) nil)
+                  (:else
+                    (let
+                      ((yd2 (fd-domain-of s1 (var-name wy))))
+                      (fd-narrow-or-skip
+                        s1
+                        (var-name wz)
+                        zd
+                        (* wx (fd-dom-min yd2))
+                        (* wx (fd-dom-max yd2))))))))))))))
+
+(define
+  fd-times-prop-vnv
+  (fn
+    (wx wy wz s)
+    (cond
+      ((<= wy 0) s)
+      (:else
+        (let
+          ((xd (fd-domain-of s (var-name wx)))
+            (zd (fd-domain-of s (var-name wz))))
+          (cond
+            ((or (= xd nil) (= zd nil)) s)
+            ((not (and (fd-dom-positive? xd) (fd-dom-positive? zd))) s)
+            (:else
+              (let
+                ((s1 (fd-narrow-or-skip s (var-name wx) xd (fd-int-ceil-div (fd-dom-min zd) wy) (fd-int-floor-div (fd-dom-max zd) wy))))
+                (cond
+                  ((= s1 nil) nil)
+                  (:else
+                    (let
+                      ((xd2 (fd-domain-of s1 (var-name wx))))
+                      (fd-narrow-or-skip
+                        s1
+                        (var-name wz)
+                        zd
+                        (* (fd-dom-min xd2) wy)
+                        (* (fd-dom-max xd2) wy))))))))))))) 
+
+(define
+  fd-times-prop
+  (fn
+    (x y z s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
+      (cond
+        ((and (number? wx) (number? wy) (number? wz))
+          (cond ((= (* wx wy) wz) s) (:else nil)))
+        ((and (number? wx) (number? wy))
+          (fd-bind-or-narrow wz (* wx wy) s))
+        ((and (number? wx) (number? wz))
+          (cond
+            ((= wx 0) (cond ((= wz 0) s) (:else nil)))
+            ((not (= (mod wz wx) 0)) nil)
+            (:else (fd-bind-or-narrow wy (/ wz wx) s))))
+        ((and (number? wy) (number? wz))
+          (cond
+            ((= wy 0) (cond ((= wz 0) s) (:else nil)))
+            ((not (= (mod wz wy) 0)) nil)
+            (:else (fd-bind-or-narrow wx (/ wz wy) s))))
+        ((and (is-var? wx) (is-var? wy) (number? wz))
+          (fd-times-prop-vvn wx wy wz s))
+        ((and (number? wx) (is-var? wy) (is-var? wz))
+          (fd-times-prop-nvv wx wy wz s))
+        ((and (is-var? wx) (number? wy) (is-var? wz))
+          (fd-times-prop-vnv wx wy wz s))
+        ((and (is-var? wx) (is-var? wy) (is-var? wz))
+          (fd-times-prop-vvv wx wy wz s))
+        (:else s)))))
+
+(define
+  fd-times
+  (fn
+    (x y z)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-times-prop x y z sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))

lib/minikanren/conda.sx

@@ -0,0 +1,42 @@
+;; lib/minikanren/conda.sx — Phase 5 piece A: `conda`, the soft-cut.
+;;
+;;   (conda (g0 g ...) (h0 h ...) ...)
+;;     — first clause whose head g0 produces ANY answer wins; ALL of g0's
+;;       answers are then conj'd with the rest of that clause; later
+;;       clauses are NOT tried.
+;;     — differs from condu only in not wrapping g0 in onceo: condu
+;;       commits to the SINGLE first answer, conda lets the head's full
+;;       answer-set flow into the rest of the clause.
+;;       (Reasoned Schemer chapter 10; Byrd 5.3.)
+
+(define
+  conda-try
+  (fn
+    (clauses s)
+    (cond
+      ((empty? clauses) mzero)
+      (:else
+        (let
+          ((cl (first clauses)))
+          (let
+            ((head-goal (first cl)) (rest-goals (rest cl)))
+            (let
+              ((peek (stream-take 1 (head-goal s))))
+              (if
+                (empty? peek)
+                (conda-try (rest clauses) s)
+                (mk-bind (head-goal s) (mk-conj-list rest-goals))))))))))
+
+(defmacro
+  conda
+  (&rest clauses)
+  (quasiquote
+    (fn
+      (s)
+      (conda-try
+        (list
+          (splice-unquote
+            (map
+              (fn (cl) (quasiquote (list (splice-unquote cl))))
+              clauses)))
+        s))))

lib/minikanren/conde.sx

@@ -0,0 +1,39 @@
+;; lib/minikanren/conde.sx — Phase 2 piece C: `conde`, the canonical
+;; miniKanren and-or form, with implicit Zzz inverse-eta delay so recursive
+;; relations like appendo terminate.
+;;
+;;   (conde (g1a g1b ...) (g2a g2b ...) ...)
+;;     ≡ (mk-disj (Zzz (mk-conj g1a g1b ...))
+;;                (Zzz (mk-conj g2a g2b ...)) ...)
+;;
+;; `Zzz g` wraps a goal expression in (fn (S) (fn () (g S))) so that
+;; `g`'s body isn't constructed until the surrounding fn is applied to a
+;; substitution AND the returned thunk is forced. This is what gives
+;; miniKanren its laziness — recursive goal definitions can be `(conde
+;; ... (... (recur ...)))` without infinite descent at construction time.
+;;
+;; Hygiene: the substitution parameter is gensym'd so that user goal
+;; expressions which themselves bind `s` (e.g. `(appendo l s ls)`) keep
+;; their lexical `s` and don't accidentally reference the wrapper's
+;; substitution. Without gensym, miniKanren relations that follow the
+;; common (l s ls) parameter convention are silently miscompiled.
+
+(defmacro
+  Zzz
+  (g)
+  (let
+    ((s-sym (gensym "zzz-s-")))
+    (quasiquote
+      (fn ((unquote s-sym)) (fn () ((unquote g) (unquote s-sym)))))))
+
+(defmacro
+  conde
+  (&rest clauses)
+  (quasiquote
+    (mk-disj
+      (splice-unquote
+        (map
+          (fn
+            (clause)
+            (quasiquote (Zzz (mk-conj (splice-unquote clause)))))
+          clauses)))))

lib/minikanren/condu.sx

@@ -0,0 +1,58 @@
+;; lib/minikanren/condu.sx — Phase 2 piece D: `condu` and `onceo`.
+;;
+;; Both are commitment forms (no backtracking into discarded options):
+;;
+;;   (onceo g)        — succeeds at most once: takes the first answer
+;;                      stream-take produces from (g s).
+;;
+;;   (condu (g0 g ...) (h0 h ...) ...)
+;;                    — first clause whose head goal succeeds wins; only
+;;                      the first answer of the head is propagated to the
+;;                      rest of that clause; later clauses are not tried.
+;;                      (Reasoned Schemer chapter 10; Byrd 5.4.)
+
+(define
+  onceo
+  (fn
+    (g)
+    (fn
+      (s)
+      (let
+        ((peek (stream-take 1 (g s))))
+        (if (empty? peek) mzero (unit (first peek)))))))
+
+;; condu-try — runtime walker over a list of clauses (each clause a list of
+;; goals). Forces the head with stream-take 1; if head fails, recurse to
+;; the next clause; if head succeeds, commits its single answer through
+;; the rest of the clause.
+(define
+  condu-try
+  (fn
+    (clauses s)
+    (cond
+      ((empty? clauses) mzero)
+      (:else
+        (let
+          ((cl (first clauses)))
+          (let
+            ((head-goal (first cl)) (rest-goals (rest cl)))
+            (let
+              ((peek (stream-take 1 (head-goal s))))
+              (if
+                (empty? peek)
+                (condu-try (rest clauses) s)
+                ((mk-conj-list rest-goals) (first peek))))))))))
+
+(defmacro
+  condu
+  (&rest clauses)
+  (quasiquote
+    (fn
+      (s)
+      (condu-try
+        (list
+          (splice-unquote
+            (map
+              (fn (cl) (quasiquote (list (splice-unquote cl))))
+              clauses)))
+        s))))

lib/minikanren/defrel.sx

@@ -0,0 +1,25 @@
+;; lib/minikanren/defrel.sx — Prolog-style defrel macro.
+;;
+;;   (defrel (NAME ARG1 ARG2 ...)
+;;     (CLAUSE1 ...)
+;;     (CLAUSE2 ...)
+;;     ...)
+;;
+;; expands to
+;;
+;;   (define NAME (fn (ARG1 ARG2 ...) (conde (CLAUSE1 ...) (CLAUSE2 ...))))
+;;
+;; This puts each clause's goals immediately after the head, mirroring
+;; Prolog's `name(Args) :- goals.` shape. Clauses are conde-conjoined
+;; goals — `Zzz`-wrapping is automatic via `conde`, so recursive
+;; relations terminate on partial answers.
+
+(defmacro
+  defrel
+  (head &rest clauses)
+  (let
+    ((name (first head)) (args (rest head)))
+    (list
+      (quote define)
+      name
+      (list (quote fn) args (cons (quote conde) clauses)))))

lib/minikanren/diseq.sx

@@ -0,0 +1,71 @@
+;; lib/minikanren/diseq.sx — Phase 5 polish: =/= disequality with a
+;; constraint store, generalising nafc / fd-neq to logic terms.
+;;
+;; The constraint store lives under the same `_fd` reserved key as the
+;; CLP(FD) propagators (a disequality is just another constraint
+;; closure that the existing fd-fire-store machinery re-runs).
+;;
+;; =/= semantics:
+;;   - If u and v walk to ground non-unifiable terms, succeed (drop).
+;;   - If they walk to terms that COULD become equal under a future
+;;     binding, store the constraint; re-check after each binding.
+;;   - If they're already equal (unify with no new bindings), fail.
+;;
+;; Implementation: each =/= test attempts (mk-unify wu wv s).
+;;   nil      — distinct, keep s, drop the constraint (return s).
+;;   subst eq — equal, fail (return nil).
+;;   subst >  — partially unifiable; keep the constraint, return s.
+;;
+;; "Substitution equal to s" is detected via key-count: mk-unify only
+;; ever extends a substitution, never removes from it, so equal
+;; key-count means no new bindings were needed.
+
+(define
+  =/=-prop
+  (fn
+    (u v s)
+    (let
+      ((s-after (mk-unify u v s)))
+      (cond
+        ((= s-after nil) s)
+        ((= (len (keys s)) (len (keys s-after))) nil)
+        (:else s)))))
+
+(define
+  =/=
+  (fn
+    (u v)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (=/=-prop u v sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s2-or-nil (c s2)))
+            (let
+              ((s3 (cond ((= s2-or-nil nil) nil) (:else (fd-fire-store s2-or-nil)))))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))
+
+;; --- constraint-aware == ---
+;;
+;; Plain `==` doesn't fire the constraint store, so a binding that
+;; should violate a pending =/= goes undetected. `==-cs` is the
+;; drop-in replacement that fires fd-fire-store after each binding.
+;; Use ==-cs in any program that mixes =/= (or fd-* goals that should
+;; re-check after non-FD bindings) with regular unification.
+
+(define
+  ==-cs
+  (fn
+    (u v)
+    (fn
+      (s)
+      (let
+        ((s2 (mk-unify u v s)))
+        (cond
+          ((= s2 nil) mzero)
+          (:else
+            (let
+              ((s3 (fd-fire-store s2)))
+              (cond ((= s3 nil) mzero) (:else (unit s3))))))))))

lib/minikanren/fd.sx

@@ -0,0 +1,25 @@
+;; lib/minikanren/fd.sx — Phase 6 piece A: minimal finite-domain helpers.
+;;
+;; A full CLP(FD) engine (arc consistency, native integer domains, fd-plus
+;; etc.) is Phase 6 proper. For now we expose two small relations layered
+;; on the existing list machinery — they're sufficient for permutation
+;; puzzles, the N-queens-style core of constraint solving:
+;;
+;;   (ino x dom)         — x is a member of dom (alias for membero with the
+;;                         constraint-store-friendly argument order).
+;;   (all-distincto l)   — all elements of l are pairwise distinct.
+;;
+;; all-distincto uses nafc + membero on the tail — it requires the head
+;; element of each recursive step to be ground enough for membero to be
+;; finitary, so order matters: prefer (in x dom) goals BEFORE
+;; (all-distincto (list x ...)) so values get committed first.
+
+(define ino (fn (x dom) (membero x dom)))
+
+(define
+  all-distincto
+  (fn
+    (l)
+    (conde
+      ((nullo l))
+      ((fresh (a d) (conso a d l) (nafc (membero a d)) (all-distincto d))))))

lib/minikanren/fresh.sx

@@ -0,0 +1,23 @@
+;; lib/minikanren/fresh.sx — Phase 2 piece B: `fresh` for introducing
+;; logic variables inside a goal body.
+;;
+;;   (fresh (x y z) goal1 goal2 ...)
+;;     ≡ (let ((x (make-var)) (y (make-var)) (z (make-var)))
+;;         (mk-conj goal1 goal2 ...))
+;;
+;; A macro rather than a function so user-named vars are real lexical
+;; bindings — which is also what miniKanren convention expects.
+;; The empty-vars form (fresh () goal ...) is just a goal grouping.
+
+(defmacro
+  fresh
+  (vars &rest goals)
+  (quasiquote
+    (let
+      (unquote (map (fn (v) (list v (list (quote make-var)))) vars))
+      (mk-conj (splice-unquote goals)))))
+
+;; call-fresh — functional alternative for code that builds goals
+;; programmatically:
+;;   ((call-fresh (fn (x) (== x 7))) empty-s) → ({:_.N 7})
+(define call-fresh (fn (f) (fn (s) ((f (make-var)) s))))

lib/minikanren/goals.sx

@@ -0,0 +1,58 @@
+;; lib/minikanren/goals.sx — Phase 2 piece B: core goals.
+;;
+;; A goal is a function (fn (s) → stream-of-substitutions).
+;; Goals built here:
+;;   succeed         — always returns (unit s)
+;;   fail            — always returns mzero
+;;   ==              — unifies two terms; succeeds with a singleton, else fails
+;;   ==-check        — opt-in occurs-checked equality
+;;   conj2 / mk-conj — sequential conjunction of goals
+;;   disj2 / mk-disj — interleaved disjunction of goals (raw — `conde` adds
+;;                     the implicit-conj-per-clause sugar in a later commit)
+
+(define succeed (fn (s) (unit s)))
+
+(define fail (fn (s) mzero))
+
+(define
+  ==
+  (fn
+    (u v)
+    (fn
+      (s)
+      (let ((s2 (mk-unify u v s))) (if (= s2 nil) mzero (unit s2))))))
+
+(define
+  ==-check
+  (fn
+    (u v)
+    (fn
+      (s)
+      (let ((s2 (mk-unify-check u v s))) (if (= s2 nil) mzero (unit s2))))))
+
+(define conj2 (fn (g1 g2) (fn (s) (mk-bind (g1 s) g2))))
+
+(define disj2 (fn (g1 g2) (fn (s) (mk-mplus (g1 s) (g2 s)))))
+
+;; Fold goals in a list. (mk-conj-list ()) ≡ succeed; (mk-disj-list ()) ≡ fail.
+(define
+  mk-conj-list
+  (fn
+    (gs)
+    (cond
+      ((empty? gs) succeed)
+      ((empty? (rest gs)) (first gs))
+      (:else (conj2 (first gs) (mk-conj-list (rest gs)))))))
+
+(define
+  mk-disj-list
+  (fn
+    (gs)
+    (cond
+      ((empty? gs) fail)
+      ((empty? (rest gs)) (first gs))
+      (:else (disj2 (first gs) (mk-disj-list (rest gs)))))))
+
+(define mk-conj (fn (&rest gs) (mk-conj-list gs)))
+
+(define mk-disj (fn (&rest gs) (mk-disj-list gs)))

lib/minikanren/intarith.sx

@@ -0,0 +1,151 @@
+;; lib/minikanren/intarith.sx — fast integer arithmetic via project.
+;;
+;; These are ground-only escapes into host arithmetic. They run at native
+;; speed (host ints) but require their arguments to walk to actual numbers
+;; — they are not relational the way `pluso` (Peano) is. Use them when
+;; the puzzle size makes Peano impractical.
+;;
+;; Naming: `-i` suffix marks "integer-only" goals.
+
+(define
+  pluso-i
+  (fn
+    (a b c)
+    (project
+      (a b)
+      (if (and (number? a) (number? b)) (== c (+ a b)) fail))))
+
+(define
+  minuso-i
+  (fn
+    (a b c)
+    (project
+      (a b)
+      (if (and (number? a) (number? b)) (== c (- a b)) fail))))
+
+(define
+  *o-i
+  (fn
+    (a b c)
+    (project
+      (a b)
+      (if (and (number? a) (number? b)) (== c (* a b)) fail))))
+
+(define
+  lto-i
+  (fn
+    (a b)
+    (project
+      (a b)
+      (if (and (number? a) (and (number? b) (< a b))) succeed fail))))
+
+(define
+  lteo-i
+  (fn
+    (a b)
+    (project
+      (a b)
+      (if (and (number? a) (and (number? b) (<= a b))) succeed fail))))
+
+(define
+  neqo-i
+  (fn
+    (a b)
+    (project
+      (a b)
+      (if (and (number? a) (and (number? b) (not (= a b)))) succeed fail))))
+
+(define numbero (fn (x) (project (x) (if (number? x) succeed fail))))
+
+(define stringo (fn (x) (project (x) (if (string? x) succeed fail))))
+
+(define symbolo (fn (x) (project (x) (if (symbol? x) succeed fail))))
+
+(define
+  even-i
+  (fn (n) (project (n) (if (and (number? n) (even? n)) succeed fail))))
+
+(define
+  odd-i
+  (fn (n) (project (n) (if (and (number? n) (odd? n)) succeed fail))))
+
+(define
+  sortedo
+  (fn
+    (l)
+    (conde
+      ((nullo l))
+      ((fresh (a) (== l (list a))))
+      ((fresh (a b rest mid) (conso a mid l) (conso b rest mid) (lteo-i a b) (sortedo mid))))))
+
+(define
+  mino
+  (fn
+    (l m)
+    (conde
+      ((fresh (a) (== l (list a)) (== m a)))
+      ((fresh (a d rest-min) (conso a d l) (mino d rest-min) (conde ((lteo-i a rest-min) (== m a)) ((lto-i rest-min a) (== m rest-min))))))))
+
+(define
+  maxo
+  (fn
+    (l m)
+    (conde
+      ((fresh (a) (== l (list a)) (== m a)))
+      ((fresh (a d rest-max) (conso a d l) (maxo d rest-max) (conde ((lteo-i rest-max a) (== m a)) ((lto-i a rest-max) (== m rest-max))))))))
+
+(define
+  sumo
+  (fn
+    (l total)
+    (conde
+      ((nullo l) (== total 0))
+      ((fresh (a d rest-sum) (conso a d l) (sumo d rest-sum) (pluso-i a rest-sum total))))))
+
+(define
+  producto
+  (fn
+    (l total)
+    (conde
+      ((nullo l) (== total 1))
+      ((fresh (a d rest-prod) (conso a d l) (producto d rest-prod) (*o-i a rest-prod total))))))
+
+(define
+  lengtho-i
+  (fn
+    (l n)
+    (conde
+      ((nullo l) (== n 0))
+      ((fresh (a d n-1) (conso a d l) (lengtho-i d n-1) (pluso-i 1 n-1 n))))))
+
+(define
+  enumerate-from-i
+  (fn
+    (start l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d r-rest start-prime) (conso a d l) (conso (list start a) r-rest result) (pluso-i 1 start start-prime) (enumerate-from-i start-prime d r-rest))))))
+
+(define enumerate-i (fn (l result) (enumerate-from-i 0 l result)))
+
+(define
+  counto
+  (fn
+    (x l n)
+    (conde
+      ((nullo l) (== n 0))
+      ((fresh (a d n-rest) (conso a d l) (conde ((== a x) (counto x d n-rest) (pluso-i 1 n-rest n)) ((nafc (== a x)) (counto x d n))))))))
+
+(define
+  mk-arith-prog
+  (fn
+    (start step len)
+    (cond
+      ((= len 0) (list))
+      (:else (cons start (mk-arith-prog (+ start step) step (- len 1)))))))
+
+(define
+  arith-progo
+  (fn
+    (start step len result)
+    (project (start step len) (== result (mk-arith-prog start step len)))))

lib/minikanren/matche.sx

@@ -0,0 +1,76 @@
+;; lib/minikanren/matche.sx — Phase 5 piece D: pattern matching over terms.
+;;
+;;   (matche TARGET
+;;     (PATTERN1 g1 g2 ...)
+;;     (PATTERN2 g1 ...)
+;;     ...)
+;;
+;; Pattern grammar:
+;;   _                 wildcard — fresh anonymous var
+;;   x                 plain symbol — fresh var, bind by name
+;;   ATOM              literal (number, string, boolean) — must equal
+;;   :keyword          keyword literal — emitted bare (keywords self-evaluate
+;;                     to their string name in SX, so quoting them changes
+;;                     their type from string to keyword)
+;;   ()                empty list — must equal
+;;   (p1 p2 ... pn)    list pattern — recurse on each element
+;;
+;; The macro expands to a `conde` whose clauses are
+;;   `((fresh (vars-in-pat) (== target pat-expr) body...))`.
+;;
+;; Repeated symbol names within a pattern produce the same fresh var, so
+;; they unify by `==`. Fixed-length list patterns only — head/tail
+;; destructuring uses `(fresh (a d) (conso a d target) body)` directly.
+;;
+;; Note: the macro builds the expansion via `cons` / `list` rather than a
+;; quasiquote — quasiquote does not recurse into nested lambda bodies in
+;; SX, so `\`(matche-clause (quote ,target) cl)` left literal
+;; `(unquote target)` in the output.
+
+(define matche-symbol-var? (fn (s) (symbol? s)))
+
+(define
+  matche-collect-vars-acc
+  (fn
+    (pat acc)
+    (cond
+      ((matche-symbol-var? pat)
+        (if (some (fn (s) (= s pat)) acc) acc (append acc (list pat))))
+      ((and (list? pat) (not (empty? pat)))
+        (reduce (fn (a p) (matche-collect-vars-acc p a)) acc pat))
+      (:else acc))))
+
+(define
+  matche-collect-vars
+  (fn (pat) (matche-collect-vars-acc pat (list))))
+
+(define
+  matche-pattern->expr
+  (fn
+    (pat)
+    (cond
+      ((matche-symbol-var? pat) pat)
+      ((and (list? pat) (empty? pat)) (list (quote list)))
+      ((list? pat) (cons (quote list) (map matche-pattern->expr pat)))
+      ((keyword? pat) pat)
+      (:else (list (quote quote) pat)))))
+
+(define
+  matche-clause
+  (fn
+    (target cl)
+    (let
+      ((pat (first cl)) (body (rest cl)))
+      (let
+        ((vars (matche-collect-vars pat)))
+        (let
+          ((pat-expr (matche-pattern->expr pat)))
+          (list
+            (cons
+              (quote fresh)
+              (cons vars (cons (list (quote ==) target pat-expr) body)))))))))
+
+(defmacro
+  matche
+  (target &rest clauses)
+  (cons (quote conde) (map (fn (cl) (matche-clause target cl)) clauses)))

lib/minikanren/nafc.sx

@@ -0,0 +1,24 @@
+;; lib/minikanren/nafc.sx — Phase 5 piece C: negation as finite failure.
+;;
+;;   (nafc g)
+;;     succeeds (yields the input substitution) if g has zero answers
+;;     against that substitution; fails (mzero) if g has at least one.
+;;
+;; Caveat: `nafc` is unsound under the open-world assumption. It only
+;; makes sense for goals over fully-ground terms, or with the explicit
+;; understanding that adding more facts could flip the answer. Use
+;; `(project (...) ...)` to ensure the relevant vars are ground first.
+;;
+;; Caveat 2: stream-take forces g for at least one answer; if g is
+;; infinitely-ground (say, a divergent search over an unbound list),
+;; nafc itself will diverge. Standard miniKanren limitation.
+
+(define
+  nafc
+  (fn
+    (g)
+    (fn
+      (s)
+      (let
+        ((peek (stream-take 1 (g s))))
+        (if (empty? peek) (unit s) mzero)))))

lib/minikanren/peano.sx

@@ -0,0 +1,51 @@
+;; lib/minikanren/peano.sx — Peano-encoded natural-number relations.
+;;
+;; Same encoding as `lengtho`: zero is the keyword `:z`; successors are
+;; `(:s n)`. So 3 = `(:s (:s (:s :z)))`. `(:z)` and `(:s ...)` are normal
+;; SX values that unify positionally — no special primitives needed.
+;;
+;; Peano arithmetic is the canonical miniKanren way to test addition /
+;; multiplication / less-than relationally without an FD constraint store.
+;; (CLP(FD) integers come in Phase 6.)
+
+(define zeroo (fn (n) (== n :z)))
+
+(define succ-of (fn (n m) (== m (list :s n))))
+
+(define
+  pluso
+  (fn
+    (a b c)
+    (conde
+      ((== a :z) (== b c))
+      ((fresh (a-1 c-1) (== a (list :s a-1)) (== c (list :s c-1)) (pluso a-1 b c-1))))))
+
+(define minuso (fn (a b c) (pluso b c a)))
+
+(define lteo (fn (a b) (fresh (k) (pluso a k b))))
+
+(define lto (fn (a b) (fresh (sa) (succ-of a sa) (lteo sa b))))
+
+(define
+  eveno
+  (fn
+    (n)
+    (conde
+      ((== n :z))
+      ((fresh (m) (== n (list :s (list :s m))) (eveno m))))))
+
+(define
+  oddo
+  (fn
+    (n)
+    (conde
+      ((== n (list :s :z)))
+      ((fresh (m) (== n (list :s (list :s m))) (oddo m))))))
+
+(define
+  *o
+  (fn
+    (a b c)
+    (conde
+      ((== a :z) (== c :z))
+      ((fresh (a-1 ab-1) (== a (list :s a-1)) (*o a-1 b ab-1) (pluso b ab-1 c))))))

lib/minikanren/project.sx

@@ -0,0 +1,25 @@
+;; lib/minikanren/project.sx — Phase 5 piece B: `project`.
+;;
+;;   (project (x y) g1 g2 ...)
+;;     — rebinds each named var to (mk-walk* var s) within the body's
+;;       lexical scope, then runs the conjunction of the body goals on
+;;       the same substitution. Use to escape into regular SX (arithmetic,
+;;       string ops, host predicates) when you need a ground value.
+;;
+;; If any of the projected vars is still unbound at this point, the body
+;; sees the raw `(:var NAME)` term — that is intentional and lets you
+;; mix project with `(== ground? var)` patterns or with conda guards.
+;;
+;; Hygiene: substitution parameter is gensym'd so it doesn't capture user
+;; vars (`s` is a popular relation parameter name).
+
+(defmacro
+  project
+  (vars &rest goals)
+  (let
+    ((s-sym (gensym "proj-s-")))
+    (quasiquote
+      (fn
+        ((unquote s-sym))
+        ((let (unquote (map (fn (v) (list v (list (quote mk-walk*) v s-sym))) vars)) (mk-conj (splice-unquote goals)))
+          (unquote s-sym))))))

lib/minikanren/queens.sx

@@ -0,0 +1,67 @@
+;; lib/minikanren/queens.sx — N-queens via ino + all-distincto + project.
+;;
+;; Encoding: q = (c1 c2 ... cn) where ci is the column of the queen in
+;; row i. Each ci ∈ {1..n}; all distinct (no two queens share a column);
+;; no two queens on the same diagonal (|ci - cj| ≠ |i - j| for i ≠ j).
+;;
+;; The diagonal check uses `project` to escape into host arithmetic
+;; once both column values are ground.
+
+(define
+  safe-diag
+  (fn
+    (a b dist)
+    (project (a b) (if (= (abs (- a b)) dist) fail succeed))))
+
+(define
+  safe-cell-vs-rest
+  (fn
+    (c c-row others next-row)
+    (cond
+      ((empty? others) succeed)
+      (:else
+        (mk-conj
+          (safe-diag c (first others) (- next-row c-row))
+          (safe-cell-vs-rest c c-row (rest others) (+ next-row 1)))))))
+
+(define
+  all-cells-safe
+  (fn
+    (cols start-row)
+    (cond
+      ((empty? cols) succeed)
+      (:else
+        (mk-conj
+          (safe-cell-vs-rest
+            (first cols)
+            start-row
+            (rest cols)
+            (+ start-row 1))
+          (all-cells-safe (rest cols) (+ start-row 1)))))))
+
+(define
+  range-1-to-n
+  (fn
+    (n)
+    (cond
+      ((= n 0) (list))
+      (:else (append (range-1-to-n (- n 1)) (list n))))))
+
+(define
+  ino-each
+  (fn
+    (cols dom)
+    (cond
+      ((empty? cols) succeed)
+      (:else (mk-conj (ino (first cols) dom) (ino-each (rest cols) dom))))))
+
+(define
+  queens-cols
+  (fn
+    (cols n)
+    (let
+      ((dom (range-1-to-n n)))
+      (mk-conj
+        (ino-each cols dom)
+        (all-distincto cols)
+        (all-cells-safe cols 1)))))

lib/minikanren/relations.sx

@@ -0,0 +1,361 @@
+;; lib/minikanren/relations.sx — Phase 4 standard relations.
+;;
+;; Programs use native SX lists as data. Relations decompose lists via the
+;; tagged cons-cell shape `(:cons h t)` because SX has no improper pairs;
+;; the unifier treats `(:cons h t)` and the native list `(h . t)` as
+;; equivalent, and `mk-walk*` flattens cons cells back to flat lists for
+;; reification.
+
+;; --- pair / list shape relations ---
+
+(define nullo (fn (l) (== l (list))))
+
+(define pairo (fn (p) (fresh (a d) (== p (mk-cons a d)))))
+
+(define caro (fn (p a) (fresh (d) (== p (mk-cons a d)))))
+
+(define cdro (fn (p d) (fresh (a) (== p (mk-cons a d)))))
+
+(define conso (fn (a d p) (== p (mk-cons a d))))
+
+(define firsto caro)
+(define resto cdro)
+
+(define
+  listo
+  (fn (l) (conde ((nullo l)) ((fresh (a d) (conso a d l) (listo d))))))
+
+;; --- appendo: the canary ---
+;;
+;; (appendo l s ls) — `ls` is the concatenation of `l` and `s`.
+;; Runs forwards (l, s known → ls), backwards (ls known → all (l, s) pairs),
+;; and bidirectionally (mix of bound + unbound).
+
+(define
+  appendo
+  (fn
+    (l s ls)
+    (conde
+      ((nullo l) (== s ls))
+      ((fresh (a d res) (conso a d l) (conso a res ls) (appendo d s res))))))
+
+;; --- membero ---
+;; (membero x l) — x appears (at least once) in l.
+
+(define
+  appendo3
+  (fn
+    (l1 l2 l3 result)
+    (fresh (l12) (appendo l1 l2 l12) (appendo l12 l3 result))))
+
+(define
+  partitiono
+  (fn
+    (pred l yes no)
+    (conde
+      ((nullo l) (nullo yes) (nullo no))
+      ((fresh (a d y-rest n-rest) (conso a d l) (conde ((pred a) (conso a y-rest yes) (== no n-rest) (partitiono pred d y-rest n-rest)) ((nafc (pred a)) (== yes y-rest) (conso a n-rest no) (partitiono pred d y-rest n-rest))))))))
+
+(define
+  foldr-o
+  (fn
+    (rel l acc result)
+    (conde
+      ((nullo l) (== result acc))
+      ((fresh (a d r-rest) (conso a d l) (foldr-o rel d acc r-rest) (rel a r-rest result))))))
+
+(define
+  foldl-o
+  (fn
+    (rel l acc result)
+    (conde
+      ((nullo l) (== result acc))
+      ((fresh (a d new-acc) (conso a d l) (rel acc a new-acc) (foldl-o rel d new-acc result))))))
+
+(define
+  flat-mapo
+  (fn
+    (rel l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d a-result rest-result) (conso a d l) (rel a a-result) (flat-mapo rel d rest-result) (appendo a-result rest-result result))))))
+
+(define
+  nub-o
+  (fn
+    (l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d r-rest) (conso a d l) (conde ((membero a d) (nub-o d result)) ((nafc (membero a d)) (conso a r-rest result) (nub-o d r-rest))))))))
+
+
+(define
+  take-while-o
+  (fn
+    (pred l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d r-rest) (conso a d l) (conde ((pred a) (conso a r-rest result) (take-while-o pred d r-rest)) ((nafc (pred a)) (== result (list)))))))))
+
+(define
+  drop-while-o
+  (fn
+    (pred l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d) (conso a d l) (conde ((pred a) (drop-while-o pred d result)) ((nafc (pred a)) (== result l))))))))
+
+(define
+  membero
+  (fn
+    (x l)
+    (conde
+      ((fresh (d) (conso x d l)))
+      ((fresh (a d) (conso a d l) (membero x d))))))
+
+(define
+  not-membero
+  (fn
+    (x l)
+    (conde
+      ((nullo l))
+      ((fresh (a d) (conso a d l) (nafc (== a x)) (not-membero x d))))))
+
+(define
+  subseto
+  (fn
+    (l1 l2)
+    (conde
+      ((nullo l1))
+      ((fresh (a d) (conso a d l1) (membero a l2) (subseto d l2))))))
+
+(define
+  reverseo
+  (fn
+    (l r)
+    (conde
+      ((nullo l) (nullo r))
+      ((fresh (a d res-rev) (conso a d l) (reverseo d res-rev) (appendo res-rev (list a) r))))))
+
+(define
+  rev-acco
+  (fn
+    (l acc result)
+    (conde
+      ((nullo l) (== result acc))
+      ((fresh (a d acc-prime) (conso a d l) (conso a acc acc-prime) (rev-acco d acc-prime result))))))
+
+(define rev-2o (fn (l result) (rev-acco l (list) result)))
+
+(define palindromeo (fn (l) (fresh (rev) (reverseo l rev) (== l rev))))
+
+(define prefixo (fn (p l) (fresh (rest) (appendo p rest l))))
+
+(define suffixo (fn (s l) (fresh (front) (appendo front s l))))
+
+(define
+  subo
+  (fn
+    (s l)
+    (fresh
+      (front-and-s back front)
+      (appendo front-and-s back l)
+      (appendo front s front-and-s))))
+
+(define
+  selecto
+  (fn
+    (x rest l)
+    (conde
+      ((conso x rest l))
+      ((fresh (a d r) (conso a d l) (conso a r rest) (selecto x r d))))))
+
+(define
+  lengtho
+  (fn
+    (l n)
+    (conde
+      ((nullo l) (== n :z))
+      ((fresh (a d n-1) (conso a d l) (== n (list :s n-1)) (lengtho d n-1))))))
+
+(define
+  inserto
+  (fn
+    (a l p)
+    (conde
+      ((conso a l p))
+      ((fresh (h t pt) (conso h t l) (conso h pt p) (inserto a t pt))))))
+
+(define
+  permuteo
+  (fn
+    (l p)
+    (conde
+      ((nullo l) (nullo p))
+      ((fresh (a d perm-d) (conso a d l) (permuteo d perm-d) (inserto a perm-d p))))))
+
+(define
+  flatteno
+  (fn
+    (tree flat)
+    (conde
+      ((nullo tree) (nullo flat))
+      ((pairo tree)
+        (fresh
+          (h t hf tf)
+          (conso h t tree)
+          (flatteno h hf)
+          (flatteno t tf)
+          (appendo hf tf flat)))
+      ((nafc (nullo tree)) (nafc (pairo tree)) (== flat (list tree))))))
+
+(define
+  rembero
+  (fn
+    (x l out)
+    (conde
+      ((nullo l) (nullo out))
+      ((fresh (a d) (conso a d l) (== a x) (== out d)))
+      ((fresh (a d res) (conso a d l) (nafc (== a x)) (conso a res out) (rembero x d res))))))
+
+(define
+  removeo-allo
+  (fn
+    (x l result)
+    (conde
+      ((nullo l) (nullo result))
+      ((fresh (a d) (conso a d l) (== a x) (removeo-allo x d result)))
+      ((fresh (a d r-rest) (conso a d l) (nafc (== a x)) (conso a r-rest result) (removeo-allo x d r-rest))))))
+
+(define
+  assoco
+  (fn
+    (key pairs val)
+    (fresh
+      (rest)
+      (conde
+        ((conso (list key val) rest pairs))
+        ((fresh (other) (conso other rest pairs) (assoco key rest val)))))))
+
+(define
+  nth-o
+  (fn
+    (n l elem)
+    (conde
+      ((== n :z) (fresh (d) (conso elem d l)))
+      ((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (nth-o n-1 d elem))))))
+
+(define
+  samelengtho
+  (fn
+    (l1 l2)
+    (conde
+      ((nullo l1) (nullo l2))
+      ((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (samelengtho d d-prime))))))
+
+(define
+  mapo
+  (fn
+    (rel l1 l2)
+    (conde
+      ((nullo l1) (nullo l2))
+      ((fresh (a d a-prime d-prime) (conso a d l1) (conso a-prime d-prime l2) (rel a a-prime) (mapo rel d d-prime))))))
+
+(define
+  iterate-no
+  (fn
+    (rel n x result)
+    (conde
+      ((== n :z) (== result x))
+      ((fresh (n-1 mid) (== n (list :s n-1)) (rel x mid) (iterate-no rel n-1 mid result))))))
+
+(define
+  pairlisto
+  (fn
+    (l1 l2 pairs)
+    (conde
+      ((nullo l1) (nullo l2) (nullo pairs))
+      ((fresh (a1 d1 a2 d2 d-pairs) (conso a1 d1 l1) (conso a2 d2 l2) (conso (list a1 a2) d-pairs pairs) (pairlisto d1 d2 d-pairs))))))
+
+(define
+  zip-with-o
+  (fn
+    (rel l1 l2 result)
+    (conde
+      ((nullo l1) (nullo l2) (nullo result))
+      ((fresh (a1 d1 a2 d2 a-result d-result) (conso a1 d1 l1) (conso a2 d2 l2) (rel a1 a2 a-result) (conso a-result d-result result) (zip-with-o rel d1 d2 d-result))))))
+
+(define
+  swap-firsto
+  (fn
+    (l result)
+    (fresh
+      (a b rest mid-l mid-r)
+      (conso a mid-l l)
+      (conso b rest mid-l)
+      (conso b mid-r result)
+      (conso a rest mid-r))))
+
+(define
+  everyo
+  (fn
+    (rel l)
+    (conde
+      ((nullo l))
+      ((fresh (a d) (conso a d l) (rel a) (everyo rel d))))))
+
+(define
+  someo
+  (fn
+    (rel l)
+    (conde
+      ((fresh (a d) (conso a d l) (rel a)))
+      ((fresh (a d) (conso a d l) (someo rel d))))))
+
+(define
+  lasto
+  (fn
+    (l x)
+    (conde
+      ((conso x (list) l))
+      ((fresh (a d) (conso a d l) (lasto d x))))))
+
+(define
+  init-o
+  (fn
+    (l init)
+    (conde
+      ((fresh (x) (conso x (list) l) (== init (list))))
+      ((fresh (a d d-init) (conso a d l) (conso a d-init init) (init-o d d-init))))))
+
+(define
+  tako
+  (fn
+    (n l prefix)
+    (conde
+      ((== n :z) (== prefix (list)))
+      ((fresh (n-1 a d p-rest) (== n (list :s n-1)) (conso a d l) (conso a p-rest prefix) (tako n-1 d p-rest))))))
+
+(define
+  dropo
+  (fn
+    (n l suffix)
+    (conde
+      ((== n :z) (== suffix l))
+      ((fresh (n-1 a d) (== n (list :s n-1)) (conso a d l) (dropo n-1 d suffix))))))
+
+(define
+  repeato
+  (fn
+    (x n result)
+    (conde
+      ((== n :z) (== result (list)))
+      ((fresh (n-1 r-rest) (== n (list :s n-1)) (conso x r-rest result) (repeato x n-1 r-rest))))))
+
+(define
+  concato
+  (fn
+    (lists result)
+    (conde
+      ((nullo lists) (nullo result))
+      ((fresh (h t r-rest) (conso h t lists) (appendo h r-rest result) (concato t r-rest))))))

lib/minikanren/run.sx

@@ -0,0 +1,56 @@
+;; lib/minikanren/run.sx — Phase 3: drive a goal + reify the query var.
+;;
+;; reify-name N        — make the canonical "_.N" reified symbol.
+;; reify-s term rs     — walk term in rs, add a mapping from each fresh
+;;                       unbound var to its _.N name (left-to-right order).
+;; reify q s           — walk* q in s, build reify-s, walk* again to
+;;                       substitute reified names in.
+;; run-n n q-name g... — defmacro: bind q-name to a fresh var, conj goals,
+;;                       take ≤ n answers from the stream, reify each
+;;                       through q-name. n = -1 takes all (used by run*).
+;; run*                — defmacro: (run* q g...) ≡ (run-n -1 q g...)
+;; run                 — defmacro: (run n q g...) ≡ (run-n n q g...)
+;;                       The two-segment form is the standard TRS API.
+
+(define reify-name (fn (n) (make-symbol (str "_." n))))
+
+(define
+  reify-s
+  (fn
+    (term rs)
+    (let
+      ((w (mk-walk term rs)))
+      (cond
+        ((is-var? w) (extend (var-name w) (reify-name (len rs)) rs))
+        ((mk-list-pair? w) (reduce (fn (acc a) (reify-s a acc)) rs w))
+        (:else rs)))))
+
+(define
+  reify
+  (fn
+    (term s)
+    (let
+      ((w (mk-walk* term s)))
+      (let ((rs (reify-s w (empty-subst)))) (mk-walk* w rs)))))
+
+(defmacro
+  run-n
+  (n q-name &rest goals)
+  (quasiquote
+    (let
+      (((unquote q-name) (make-var)))
+      (map
+        (fn (s) (reify (unquote q-name) s))
+        (stream-take
+          (unquote n)
+          ((mk-conj (splice-unquote goals)) empty-s))))))
+
+(defmacro
+  run*
+  (q-name &rest goals)
+  (quasiquote (run-n -1 (unquote q-name) (splice-unquote goals))))
+
+(defmacro
+  run
+  (n q-name &rest goals)
+  (quasiquote (run-n (unquote n) (unquote q-name) (splice-unquote goals))))

lib/minikanren/stream.sx

@@ -0,0 +1,66 @@
+;; lib/minikanren/stream.sx — Phase 2 piece A: lazy streams of substitutions.
+;;
+;; SX has no improper pairs (cons requires a list cdr), so we use a
+;; tagged stream-cell shape for mature stream elements:
+;;
+;;   stream  ::= mzero                        empty (the SX empty list)
+;;             | (:s HEAD TAIL)               mature cell, TAIL is a stream
+;;             | thunk                        (fn () ...) → stream when forced
+;;
+;; HEAD is a substitution dict. TAIL is again a stream (possibly a thunk),
+;; which is what gives us laziness — mk-mplus can return a mature head with
+;; a thunk in the tail, deferring the rest of the search.
+
+(define mzero (list))
+
+(define s-cons (fn (h t) (list :s h t)))
+
+(define
+  s-cons?
+  (fn (s) (and (list? s) (not (empty? s)) (= (first s) :s))))
+
+(define s-car (fn (s) (nth s 1)))
+(define s-cdr (fn (s) (nth s 2)))
+
+(define unit (fn (s) (s-cons s mzero)))
+
+(define stream-pause? (fn (s) (and (not (list? s)) (callable? s))))
+
+;; mk-mplus — interleave two streams. If s1 is paused we suspend and
+;; swap (Reasoned Schemer "interleave"); otherwise mature-cons head with
+;; mk-mplus of the rest.
+(define
+  mk-mplus
+  (fn
+    (s1 s2)
+    (cond
+      ((empty? s1) s2)
+      ((stream-pause? s1) (fn () (mk-mplus s2 (s1))))
+      (:else (s-cons (s-car s1) (mk-mplus (s-cdr s1) s2))))))
+
+;; mk-bind — apply goal g to every substitution in stream s, mk-mplus-ing.
+(define
+  mk-bind
+  (fn
+    (s g)
+    (cond
+      ((empty? s) mzero)
+      ((stream-pause? s) (fn () (mk-bind (s) g)))
+      (:else (mk-mplus (g (s-car s)) (mk-bind (s-cdr s) g))))))
+
+;; stream-take — force up to n results out of a (possibly lazy) stream
+;; into a flat SX list of substitutions. n = -1 means take all.
+(define
+  stream-take
+  (fn
+    (n s)
+    (cond
+      ((= n 0) (list))
+      ((empty? s) (list))
+      ((stream-pause? s) (stream-take n (s)))
+      (:else
+        (cons
+          (s-car s)
+          (stream-take
+            (if (= n -1) -1 (- n 1))
+            (s-cdr s)))))))

lib/minikanren/tabling-slg.sx

@@ -0,0 +1,94 @@
+;; lib/minikanren/tabling-slg.sx — Phase 7 piece A: SLG-style tabling.
+;;
+;; Naive memoization (table-1/2/3 in tabling.sx) drains the body's
+;; answer stream eagerly, then caches. Recursive tabled calls with the
+;; SAME ground key see an empty cache (the in-progress entry doesn't
+;; exist), so they recurse and the host overflows on cyclic relations.
+;;
+;; This module ships the in-progress-sentinel piece of SLG resolution:
+;; before evaluating the body, mark the cache entry as :in-progress;
+;; any recursive call to the same key sees the sentinel and returns
+;; mzero (no answers yet). Outer recursion thus terminates on cycles.
+;; Limitation: a single pass — answers found by cycle-dependent
+;; recursive calls are NOT discovered. Full SLG with fixed-point
+;; iteration (re-running until no new answers) is left for follow-up.
+
+(define
+  table-2-slg-iter
+  (fn
+    (rel-fn input output s key prev-vals)
+    (begin
+      (mk-tab-store! key prev-vals)
+      (let
+        ((all-substs (stream-take -1 ((rel-fn input output) s))))
+        (let
+          ((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
+          (cond
+            ((= (len vals) (len prev-vals))
+              (begin
+                (mk-tab-store! key vals)
+                (mk-tab-replay-vals vals output s)))
+            (:else (table-2-slg-iter rel-fn input output s key vals))))))))
+
+(define
+  table-2-slg
+  (fn
+    (name rel-fn)
+    (fn
+      (input output)
+      (fn
+        (s)
+        (let
+          ((winput (mk-walk* input s)))
+          (cond
+            ((mk-tab-ground-term? winput)
+              (let
+                ((key (str name "/slg/" winput)))
+                (let
+                  ((cached (mk-tab-lookup key)))
+                  (cond
+                    ((not (= cached :miss))
+                      (mk-tab-replay-vals cached output s))
+                    (:else
+                      (table-2-slg-iter rel-fn input output s key (list)))))))
+            (:else ((rel-fn input output) s))))))))
+
+(define
+  table-3-slg-iter
+  (fn
+    (rel-fn i1 i2 output s key prev-vals)
+    (begin
+      (mk-tab-store! key prev-vals)
+      (let
+        ((all-substs (stream-take -1 ((rel-fn i1 i2 output) s))))
+        (let
+          ((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
+          (cond
+            ((= (len vals) (len prev-vals))
+              (begin
+                (mk-tab-store! key vals)
+                (mk-tab-replay-vals vals output s)))
+            (:else (table-3-slg-iter rel-fn i1 i2 output s key vals))))))))
+
+(define
+  table-3-slg
+  (fn
+    (name rel-fn)
+    (fn
+      (i1 i2 output)
+      (fn
+        (s)
+        (let
+          ((wi1 (mk-walk* i1 s)) (wi2 (mk-walk* i2 s)))
+          (cond
+            ((and (mk-tab-ground-term? wi1) (mk-tab-ground-term? wi2))
+              (let
+                ((key (str name "/slg3/" wi1 "/" wi2)))
+                (let
+                  ((cached (mk-tab-lookup key)))
+                  (cond
+                    ((not (= cached :miss))
+                      (mk-tab-replay-vals cached output s))
+                    (:else
+                      (table-3-slg-iter rel-fn i1 i2 output s key (list)))))))
+            (:else ((rel-fn i1 i2 output) s))))))))

lib/minikanren/tabling.sx

@@ -0,0 +1,157 @@
+;; lib/minikanren/tabling.sx — Phase 7 piece A: naive memoization.
+;;
+;; A `table-2` wrapper for 2-arg relations (input, output). Caches by
+;; ground input (walked at call time). On hit, replays the cached output
+;; values; on miss, runs the relation, collects all output values from
+;; the answer stream, stores, then replays.
+;;
+;; Limitations of naive memoization (vs proper SLG / producer-consumer
+;; tabling):
+;;   - Each call must terminate before its result enters the cache —
+;;     so cyclic recursive calls with the SAME ground input would still
+;;     diverge (not addressed here).
+;;   - Caching by full ground walk only; partially-ground args fall
+;;     through to the underlying relation.
+;;
+;; Despite the limitations, naive memoization is enough for the
+;; canonical demo: Fibonacci goes from exponential to linear because
+;; each fib(k) result is computed at most once.
+;;
+;; Cache lifetime: a single global mk-tab-cache. Use `(mk-tab-clear!)`
+;; between independent queries.
+
+(define mk-tab-cache {})
+
+(define mk-tab-clear! (fn () (set! mk-tab-cache {})))
+
+(define
+  mk-tab-lookup
+  (fn
+    (key)
+    (cond
+      ((has-key? mk-tab-cache key) (get mk-tab-cache key))
+      (:else :miss))))
+
+(define
+  mk-tab-store!
+  (fn (key vals) (set! mk-tab-cache (assoc mk-tab-cache key vals))))
+
+(define
+  mk-tab-ground-term?
+  (fn
+    (t)
+    (cond
+      ((is-var? t) false)
+      ((mk-cons-cell? t)
+        (and
+          (mk-tab-ground-term? (mk-cons-head t))
+          (mk-tab-ground-term? (mk-cons-tail t))))
+      ((mk-list-pair? t) (every? mk-tab-ground-term? t))
+      (:else true))))
+
+(define
+  mk-tab-replay-vals
+  (fn
+    (vals output s)
+    (cond
+      ((empty? vals) mzero)
+      (:else
+        (let
+          ((sp (mk-unify output (first vals) s)))
+          (let
+            ((this-stream (cond ((= sp nil) mzero) (:else (unit sp)))))
+            (mk-mplus this-stream (mk-tab-replay-vals (rest vals) output s))))))))
+
+(define
+  table-2
+  (fn
+    (name rel-fn)
+    (fn
+      (input output)
+      (fn
+        (s)
+        (let
+          ((winput (mk-walk* input s)))
+          (cond
+            ((mk-tab-ground-term? winput)
+              (let
+                ((key (str name "@" winput)))
+                (let
+                  ((cached (mk-tab-lookup key)))
+                  (cond
+                    ((= cached :miss)
+                      (let
+                        ((all-substs (stream-take -1 ((rel-fn input output) s))))
+                        (let
+                          ((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
+                          (begin
+                            (mk-tab-store! key vals)
+                            (mk-tab-replay-vals vals output s)))))
+                    (:else (mk-tab-replay-vals cached output s))))))
+            (:else ((rel-fn input output) s))))))))
+
+;; --- table-1: 1-arg relation (one input, no output to cache) ---
+;; The relation is a predicate `(p input)` that succeeds or fails.
+;; Cache stores either :ok or :no.
+
+(define
+  table-1
+  (fn
+    (name rel-fn)
+    (fn
+      (input)
+      (fn
+        (s)
+        (let
+          ((winput (mk-walk* input s)))
+          (cond
+            ((mk-tab-ground-term? winput)
+              (let
+                ((key (str name "@1@" winput)))
+                (let
+                  ((cached (mk-tab-lookup key)))
+                  (cond
+                    ((= cached :miss)
+                      (let
+                        ((stream ((rel-fn input) s)))
+                        (let
+                          ((peek (stream-take 1 stream)))
+                          (cond
+                            ((empty? peek)
+                              (begin (mk-tab-store! key :no) mzero))
+                            (:else (begin (mk-tab-store! key :ok) stream))))))
+                    ((= cached :ok) (unit s))
+                    ((= cached :no) mzero)
+                    (:else mzero)))))
+            (:else ((rel-fn input) s))))))))
+
+;; --- table-3: 3-arg relation (input1 input2 output) ---
+;; Cache keyed by (input1, input2). Output values cached as a list.
+
+(define
+  table-3
+  (fn
+    (name rel-fn)
+    (fn
+      (i1 i2 output)
+      (fn
+        (s)
+        (let
+          ((wi1 (mk-walk* i1 s)) (wi2 (mk-walk* i2 s)))
+          (cond
+            ((and (mk-tab-ground-term? wi1) (mk-tab-ground-term? wi2))
+              (let
+                ((key (str name "@3@" wi1 "/" wi2)))
+                (let
+                  ((cached (mk-tab-lookup key)))
+                  (cond
+                    ((= cached :miss)
+                      (let
+                        ((all-substs (stream-take -1 ((rel-fn i1 i2 output) s))))
+                        (let
+                          ((vals (map (fn (s2) (mk-walk* output s2)) all-substs)))
+                          (begin
+                            (mk-tab-store! key vals)
+                            (mk-tab-replay-vals vals output s)))))
+                    (:else (mk-tab-replay-vals cached output s))))))
+            (:else ((rel-fn i1 i2 output) s))))))))

lib/minikanren/tests/appendo3.sx

@@ -0,0 +1,49 @@
+;; lib/minikanren/tests/appendo3.sx — 3-list append.
+
+(mk-test
+  "appendo3-forward"
+  (run*
+    q
+    (appendo3
+      (list 1 2)
+      (list 3 4)
+      (list 5 6)
+      q))
+  (list
+    (list 1 2 3 4 5 6)))
+
+(mk-test
+  "appendo3-empty-everything"
+  (run* q (appendo3 (list) (list) (list) q))
+  (list (list)))
+
+(mk-test
+  "appendo3-recover-middle"
+  (run*
+    q
+    (appendo3
+      (list 1 2)
+      q
+      (list 5 6)
+      (list 1 2 3 4 5 6)))
+  (list (list 3 4)))
+
+(mk-test
+  "appendo3-empty-middle"
+  (run*
+    q
+    (appendo3
+      (list 1 2)
+      (list)
+      (list 3 4)
+      q))
+  (list (list 1 2 3 4)))
+
+(mk-test
+  "appendo3-empty-first-and-last"
+  (run*
+    q
+    (appendo3 (list) (list 1 2 3) (list) q))
+  (list (list 1 2 3)))
+
+(mk-tests-run!)

lib/minikanren/tests/arith-prog.sx

@@ -0,0 +1,33 @@
+;; lib/minikanren/tests/arith-prog.sx — arithmetic progression generation.
+
+(mk-test
+  "arith-progo-zero-len"
+  (run* q (arith-progo 5 1 0 q))
+  (list (list)))
+
+(mk-test
+  "arith-progo-1-to-5"
+  (run* q (arith-progo 1 1 5 q))
+  (list (list 1 2 3 4 5)))
+
+(mk-test
+  "arith-progo-evens-from-0"
+  (run* q (arith-progo 0 2 5 q))
+  (list (list 0 2 4 6 8)))
+
+(mk-test
+  "arith-progo-descending"
+  (run* q (arith-progo 10 -1 4 q))
+  (list (list 10 9 8 7)))
+
+(mk-test
+  "arith-progo-zero-step"
+  (run* q (arith-progo 7 0 3 q))
+  (list (list 7 7 7)))
+
+(mk-test
+  "arith-progo-negative-start"
+  (run* q (arith-progo -3 2 4 q))
+  (list (list -3 -1 1 3)))
+
+(mk-tests-run!)

lib/minikanren/tests/btree-walko.sx

@@ -0,0 +1,54 @@
+;; lib/minikanren/tests/btree-walko.sx — walk a leaves-of-binary-tree relation
+;; using matche dispatch on (:leaf v) and (:node left right) patterns.
+
+(define
+  btree-walko
+  (fn
+    (tree v)
+    (matche
+      tree
+      ((:leaf x) (== v x))
+      ((:node l r) (conde ((btree-walko l v)) ((btree-walko r v)))))))
+
+;; A small test tree: ((1 2) (3 (4 5))).
+(define
+  test-btree
+  (list
+    :node (list :node (list :leaf 1) (list :leaf 2))
+    (list
+      :node (list :leaf 3)
+      (list :node (list :leaf 4) (list :leaf 5)))))
+
+(mk-test
+  "btree-walko-enumerates-all-leaves"
+  (let
+    ((leaves (run* q (btree-walko test-btree q))))
+    (and
+      (= (len leaves) 5)
+      (and
+        (some (fn (l) (= l 1)) leaves)
+        (and
+          (some (fn (l) (= l 2)) leaves)
+          (and
+            (some (fn (l) (= l 3)) leaves)
+            (and
+              (some (fn (l) (= l 4)) leaves)
+              (some (fn (l) (= l 5)) leaves)))))))
+  true)
+
+(mk-test
+  "btree-walko-find-3-membership"
+  (run 1 q (btree-walko test-btree 3))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "btree-walko-find-99-not-present"
+  (run* q (btree-walko test-btree 99))
+  (list))
+
+(mk-test
+  "btree-walko-leaf-only"
+  (run* q (btree-walko (list :leaf 42) q))
+  (list 42))
+
+(mk-tests-run!)

lib/minikanren/tests/classics.sx

@@ -0,0 +1,87 @@
+;; lib/minikanren/tests/classics.sx — small classic-style puzzles that
+;; exercise the full system end to end (relations + conde + matche +
+;; fresh + run*). Each test is a self-contained miniKanren program.
+
+;; -----------------------------------------------------------------------
+;; Pet puzzle (3 friends, 3 pets, 1-each).
+;; -----------------------------------------------------------------------
+
+(mk-test
+  "classics-pet-puzzle"
+  (run*
+    q
+    (fresh
+      (a b c)
+      (== q (list a b c))
+      (permuteo (list :dog :cat :fish) (list a b c))
+      (== b :fish)
+      (conde ((== a :cat)) ((== a :fish)))))
+  (list (list :cat :fish :dog)))
+
+;; -----------------------------------------------------------------------
+;; Family-relations puzzle (uses membero on a fact list).
+;; -----------------------------------------------------------------------
+
+(define
+  parent-facts
+  (list
+    (list "alice" "bob")
+    (list "alice" "carol")
+    (list "bob" "dave")
+    (list "carol" "eve")
+    (list "dave" "frank")))
+
+(define parento (fn (x y) (membero (list x y) parent-facts)))
+
+(define grandparento (fn (x z) (fresh (y) (parento x y) (parento y z))))
+
+(mk-test
+  "classics-grandparents-of-frank"
+  (run* q (grandparento q "frank"))
+  (list "bob"))
+
+(mk-test
+  "classics-grandchildren-of-alice"
+  (run* q (grandparento "alice" q))
+  (list "dave" "eve"))
+
+;; -----------------------------------------------------------------------
+;; Symbolic differentiation, matche-driven.
+;;   Variable :x:                d/dx x  = 1
+;;   Sum (:+ a b):                d/dx (a+b) = (da + db)
+;;   Product (:* a b):            d/dx (a*b) = (da*b + a*db)
+;; -----------------------------------------------------------------------
+
+(define
+  diffo
+  (fn
+    (expr var d)
+    (matche
+      expr
+      (:x (== d 1))
+      ((:+ a b)
+        (fresh
+          (da db)
+          (== d (list :+ da db))
+          (diffo a var da)
+          (diffo b var db)))
+      ((:* a b)
+        (fresh
+          (da db)
+          (== d (list :+ (list :* da b) (list :* a db)))
+          (diffo a var da)
+          (diffo b var db))))))
+
+(mk-test "classics-diff-of-x" (run* q (diffo :x :x q)) (list 1))
+
+(mk-test
+  "classics-diff-of-x-plus-x"
+  (run* q (diffo (list :+ :x :x) :x q))
+  (list (list :+ 1 1)))
+
+(mk-test
+  "classics-diff-of-x-times-x"
+  (run* q (diffo (list :* :x :x) :x q))
+  (list (list :+ (list :* 1 :x) (list :* :x 1))))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-bounds.sx

@@ -0,0 +1,316 @@
+;; lib/minikanren/tests/clpfd-bounds.sx — Phase 6 piece B: bounds-consistency
+;; for fd-plus and fd-times in the partial- and all-domain cases.
+;;
+;; We probe domains directly (peek at the FD store) before any labelling
+;; happens. This isolates the propagator's narrowing behaviour from the
+;; search engine.
+
+(define
+  probe-dom
+  (fn
+    (goal var-key)
+    (let
+      ((s (first (stream-take 1 (goal empty-s)))))
+      (cond ((= s nil) :no-subst) (:else (fd-domain-of s var-key))))))
+
+;; --- fd-plus partial-domain narrowing ---
+
+(mk-test
+  "fd-plus-vvn-narrows-x"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (probe-dom
+      (mk-conj
+        (fd-in
+          x
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10))
+        (fd-in y (list 1 2 3))
+        (fd-plus x y 10))
+      "x"))
+  (list 7 8 9))
+
+(mk-test
+  "fd-plus-vvn-narrows-y"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (probe-dom
+      (mk-conj
+        (fd-in
+          x
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10))
+        (fd-in y (list 1 2 3))
+        (fd-plus x y 10))
+      "y"))
+  (list 1 2 3))
+
+(mk-test
+  "fd-plus-nvv-narrows"
+  (let
+    ((y (mk-var "y")) (z (mk-var "z")))
+    (probe-dom
+      (mk-conj
+        (fd-in y (list 1 2 3))
+        (fd-in
+          z
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10
+            11
+            12
+            13
+            14
+            15
+            16
+            17
+            18
+            19
+            20))
+        (fd-plus 5 y z))
+      "z"))
+  (list 6 7 8))
+
+(mk-test
+  "fd-plus-vvv-narrows-z"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z")))
+    (probe-dom
+      (mk-conj
+        (fd-in x (list 1 2 3))
+        (fd-in y (list 1 2 3))
+        (fd-in
+          z
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10
+            11
+            12
+            13
+            14
+            15
+            16
+            17
+            18
+            19
+            20))
+        (fd-plus x y z))
+      "z"))
+  (list 2 3 4 5 6))
+
+(mk-test
+  "fd-plus-vvv-narrows-x"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z")))
+    (probe-dom
+      (mk-conj
+        (fd-in
+          x
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10))
+        (fd-in y (list 1 2 3))
+        (fd-in z (list 5 6 7))
+        (fd-plus x y z))
+      "x"))
+  (list 2 3 4 5 6))
+
+;; --- fd-times partial-domain narrowing (positive domains) ---
+
+(mk-test
+  "fd-times-vvn-narrows"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (probe-dom
+      (mk-conj
+        (fd-in
+          x
+          (list
+            1
+            2
+            3
+            4
+            5
+            6))
+        (fd-in
+          y
+          (list
+            1
+            2
+            3
+            4
+            5
+            6))
+        (fd-times x y 12))
+      "x"))
+  (list 2 3 4 5 6))
+
+(mk-test
+  "fd-times-nvv-narrows"
+  (let
+    ((y (mk-var "y")) (z (mk-var "z")))
+    (probe-dom
+      (mk-conj
+        (fd-in y (list 1 2 3 4))
+        (fd-in
+          z
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10
+            11
+            12
+            13
+            14
+            15
+            16
+            17
+            18
+            19
+            20))
+        (fd-times 3 y z))
+      "z"))
+  (list
+    3
+    4
+    5
+    6
+    7
+    8
+    9
+    10
+    11
+    12))
+
+(mk-test
+  "fd-times-vvv-narrows"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z")))
+    (probe-dom
+      (mk-conj
+        (fd-in x (list 1 2 3))
+        (fd-in y (list 1 2 3))
+        (fd-in
+          z
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10
+            11
+            12
+            13
+            14
+            15
+            16
+            17
+            18
+            19
+            20))
+        (fd-times x y z))
+      "z"))
+  (list
+    1
+    2
+    3
+    4
+    5
+    6
+    7
+    8
+    9))
+
+;; --- bounds force impossible branches to fail early ---
+
+(mk-test
+  "fd-plus-impossible-via-bounds"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (probe-dom
+      (mk-conj
+        (fd-in
+          x
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10))
+        (fd-in
+          y
+          (list
+            1
+            2
+            3
+            4
+            5
+            6
+            7
+            8
+            9
+            10))
+        (fd-plus x y 100))
+      "x"))
+  :no-subst)
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-distinct.sx

@@ -0,0 +1,52 @@
+;; lib/minikanren/tests/clpfd-distinct.sx — fd-distinct (alldifferent).
+
+(mk-test
+  "fd-distinct-empty"
+  (run* q (fd-distinct (list)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "fd-distinct-singleton"
+  (run* q (fd-distinct (list 5)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "fd-distinct-pair-distinct"
+  (run* q (fd-distinct (list 1 2)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "fd-distinct-pair-equal-fails"
+  (run* q (fd-distinct (list 5 5)))
+  (list))
+
+(mk-test
+  "fd-distinct-3-perms-of-3"
+  (let
+    ((res (run* q (fresh (a b c) (fd-in a (list 1 2 3)) (fd-in b (list 1 2 3)) (fd-in c (list 1 2 3)) (fd-distinct (list a b c)) (fd-label (list a b c)) (== q (list a b c))))))
+    (= (len res) 6))
+  true)
+
+(mk-test
+  "fd-distinct-4-perms-of-4-count"
+  (let
+    ((res (run* q (fresh (a b c d) (fd-in a (list 1 2 3 4)) (fd-in b (list 1 2 3 4)) (fd-in c (list 1 2 3 4)) (fd-in d (list 1 2 3 4)) (fd-distinct (list a b c d)) (fd-label (list a b c d)) (== q (list a b c d))))))
+    (= (len res) 24))
+  true)
+
+(mk-test
+  "fd-distinct-pigeonhole-fails"
+  (run*
+    q
+    (fresh
+      (a b c d)
+      (fd-in a (list 1 2 3))
+      (fd-in b (list 1 2 3))
+      (fd-in c (list 1 2 3))
+      (fd-in d (list 1 2 3))
+      (fd-distinct (list a b c d))
+      (fd-label (list a b c d))
+      (== q (list a b c d))))
+  (list))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-domains.sx

@@ -0,0 +1,133 @@
+;; lib/minikanren/tests/clpfd-domains.sx — Phase 6 piece B: domain primitives.
+
+;; --- domain construction ---
+
+(mk-test
+  "fd-dom-from-list-sorts"
+  (fd-dom-from-list
+    (list 3 1 2 1 5))
+  (list 1 2 3 5))
+
+(mk-test "fd-dom-from-list-empty" (fd-dom-from-list (list)) (list))
+
+(mk-test
+  "fd-dom-from-list-single"
+  (fd-dom-from-list (list 7))
+  (list 7))
+
+(mk-test
+  "fd-dom-range-1-5"
+  (fd-dom-range 1 5)
+  (list 1 2 3 4 5))
+
+(mk-test "fd-dom-range-empty" (fd-dom-range 5 1) (list))
+
+;; --- predicates ---
+
+(mk-test "fd-dom-empty-yes" (fd-dom-empty? (list)) true)
+(mk-test "fd-dom-empty-no" (fd-dom-empty? (list 1)) false)
+(mk-test "fd-dom-singleton-yes" (fd-dom-singleton? (list 5)) true)
+(mk-test
+  "fd-dom-singleton-multi"
+  (fd-dom-singleton? (list 1 2))
+  false)
+(mk-test "fd-dom-singleton-empty" (fd-dom-singleton? (list)) false)
+
+(mk-test
+  "fd-dom-min"
+  (fd-dom-min (list 3 7 9))
+  3)
+(mk-test
+  "fd-dom-max"
+  (fd-dom-max (list 3 7 9))
+  9)
+
+(mk-test
+  "fd-dom-member-yes"
+  (fd-dom-member?
+    3
+    (list 1 2 3 4))
+  true)
+(mk-test
+  "fd-dom-member-no"
+  (fd-dom-member?
+    9
+    (list 1 2 3 4))
+  false)
+
+;; --- intersect / without ---
+
+(mk-test
+  "fd-dom-intersect"
+  (fd-dom-intersect
+    (list 1 2 3 4 5)
+    (list 2 4 6))
+  (list 2 4))
+
+(mk-test
+  "fd-dom-intersect-disjoint"
+  (fd-dom-intersect
+    (list 1 2 3)
+    (list 4 5 6))
+  (list))
+
+(mk-test
+  "fd-dom-intersect-empty"
+  (fd-dom-intersect (list) (list 1 2 3))
+  (list))
+
+(mk-test
+  "fd-dom-intersect-equal"
+  (fd-dom-intersect
+    (list 1 2 3)
+    (list 1 2 3))
+  (list 1 2 3))
+
+(mk-test
+  "fd-dom-without-mid"
+  (fd-dom-without
+    3
+    (list 1 2 3 4 5))
+  (list 1 2 4 5))
+
+(mk-test
+  "fd-dom-without-missing"
+  (fd-dom-without 9 (list 1 2 3))
+  (list 1 2 3))
+
+(mk-test
+  "fd-dom-without-min"
+  (fd-dom-without 1 (list 1 2 3))
+  (list 2 3))
+
+;; --- store accessors ---
+
+(mk-test "fd-domain-of-unset" (fd-domain-of {} "x") nil)
+
+(mk-test
+  "fd-domain-of-set"
+  (let
+    ((s (fd-set-domain {} "x" (list 1 2 3))))
+    (fd-domain-of s "x"))
+  (list 1 2 3))
+
+(mk-test
+  "fd-set-domain-empty-fails"
+  (fd-set-domain {} "x" (list))
+  nil)
+
+(mk-test
+  "fd-set-domain-overrides"
+  (let
+    ((s (fd-set-domain {} "x" (list 1 2 3))))
+    (fd-domain-of (fd-set-domain s "x" (list 5)) "x"))
+  (list 5))
+
+(mk-test
+  "fd-set-domain-multiple-vars"
+  (let
+    ((s (fd-set-domain (fd-set-domain {} "x" (list 1)) "y" (list 2 3))))
+    (list (fd-domain-of s "x") (fd-domain-of s "y")))
+  (list (list 1) (list 2 3)))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-in-label.sx

@@ -0,0 +1,120 @@
+;; lib/minikanren/tests/clpfd-in-label.sx — fd-in (domain narrowing) + fd-label.
+
+;; --- fd-in: domain narrowing ---
+
+(mk-test
+  "fd-in-bare-label"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-label (list x))
+      (== q x)))
+  (list 1 2 3 4 5))
+
+(mk-test
+  "fd-in-intersection"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-in x (list 3 4 5 6 7))
+      (fd-label (list x))
+      (== q x)))
+  (list 3 4 5))
+
+(mk-test
+  "fd-in-disjoint-empty"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3))
+      (fd-in x (list 7 8 9))
+      (fd-label (list x))
+      (== q x)))
+  (list))
+
+(mk-test
+  "fd-in-singleton-domain"
+  (run*
+    q
+    (fresh (x) (fd-in x (list 5)) (fd-label (list x)) (== q x)))
+  (list 5))
+
+;; --- ground value checks the domain ---
+
+(mk-test
+  "fd-in-ground-in-domain"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x 3)
+      (fd-in x (list 1 2 3 4 5))
+      (== q x)))
+  (list 3))
+
+(mk-test
+  "fd-in-ground-not-in-domain"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x 9)
+      (fd-in x (list 1 2 3 4 5))
+      (== q x)))
+  (list))
+
+;; --- fd-label across multiple vars ---
+
+(mk-test
+  "fd-label-multiple-vars"
+  (let
+    ((res (run* q (fresh (a b) (fd-in a (list 1 2 3)) (fd-in b (list 10 20)) (fd-label (list a b)) (== q (list a b))))))
+    (= (len res) 6))
+  true)
+
+(mk-test
+  "fd-label-empty-vars"
+  (run* q (fd-label (list)))
+  (list (make-symbol "_.0")))
+
+;; --- composition with regular goals ---
+
+(mk-test
+  "fd-in-with-membero-style-filtering"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in
+        x
+        (list
+          1
+          2
+          3
+          4
+          5
+          6
+          7
+          8
+          9
+          10))
+      (fd-label (list x))
+      (== q x)))
+  (list
+    1
+    2
+    3
+    4
+    5
+    6
+    7
+    8
+    9
+    10))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-neq.sx

@@ -0,0 +1,82 @@
+;; lib/minikanren/tests/clpfd-neq.sx — fd-neq with constraint propagation.
+
+;; --- ground / domain interaction ---
+
+(mk-test
+  "fd-neq-ground-distinct"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-neq x 5)
+      (fd-in x (list 4 5 6))
+      (fd-label (list x))
+      (== q x)))
+  (list 4 6))
+
+(mk-test
+  "fd-neq-ground-equal-fails"
+  (run* q (fresh (x) (== x 5) (fd-neq x 5) (== q x)))
+  (list))
+
+(mk-test
+  "fd-neq-symmetric"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-neq 7 x)
+      (fd-in x (list 5 6 7 8 9))
+      (fd-label (list x))
+      (== q x)))
+  (list 5 6 8 9))
+
+;; --- two vars with overlapping domains ---
+
+(mk-test
+  "fd-neq-pair-from-3"
+  (let
+    ((res (run* q (fresh (x y) (fd-in x (list 1 2 3)) (fd-in y (list 1 2 3)) (fd-neq x y) (fd-label (list x y)) (== q (list x y))))))
+    (= (len res) 6))
+  true)
+
+(mk-test
+  "fd-all-distinct-3-of-3"
+  (let
+    ((res (run* q (fresh (a b c) (fd-in a (list 1 2 3)) (fd-in b (list 1 2 3)) (fd-in c (list 1 2 3)) (fd-neq a b) (fd-neq a c) (fd-neq b c) (fd-label (list a b c)) (== q (list a b c))))))
+    (= (len res) 6))
+  true)
+
+(mk-test
+  "fd-pigeonhole-fails"
+  (run*
+    q
+    (fresh
+      (a b c)
+      (fd-in a (list 1 2))
+      (fd-in b (list 1 2))
+      (fd-in c (list 1 2))
+      (fd-neq a b)
+      (fd-neq a c)
+      (fd-neq b c)
+      (fd-label (list a b c))
+      (== q (list a b c))))
+  (list))
+
+;; --- propagation when one side becomes ground ---
+
+(mk-test
+  "fd-neq-propagates-after-ground"
+  (run*
+    q
+    (fresh
+      (x y)
+      (fd-in x (list 1 2 3))
+      (fd-in y (list 1 2 3))
+      (fd-neq x y)
+      (== x 2)
+      (fd-label (list y))
+      (== q y)))
+  (list 1 3))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-ord.sx

@@ -0,0 +1,128 @@
+;; lib/minikanren/tests/clpfd-ord.sx — fd-lt / fd-lte / fd-eq.
+
+;; --- fd-lt ---
+
+(mk-test
+  "fd-lt-narrows-x-against-num"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-lt x 3)
+      (fd-label (list x))
+      (== q x)))
+  (list 1 2))
+
+(mk-test
+  "fd-lt-narrows-x-against-num-symmetric"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-lt 3 x)
+      (fd-label (list x))
+      (== q x)))
+  (list 4 5))
+
+(mk-test
+  "fd-lt-pair-ordered"
+  (let
+    ((res (run* q (fresh (x y) (fd-in x (list 1 2 3 4)) (fd-in y (list 1 2 3 4)) (fd-lt x y) (fd-label (list x y)) (== q (list x y))))))
+    (= (len res) 6))
+  true)
+
+(mk-test
+  "fd-lt-impossible-fails"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 5 6 7))
+      (fd-lt x 3)
+      (fd-label (list x))
+      (== q x)))
+  (list))
+
+;; --- fd-lte ---
+
+(mk-test
+  "fd-lte-includes-equal"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-lte x 3)
+      (fd-label (list x))
+      (== q x)))
+  (list 1 2 3))
+
+(mk-test
+  "fd-lte-equal-bound"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-lte 3 x)
+      (fd-label (list x))
+      (== q x)))
+  (list 3 4 5))
+
+;; --- fd-eq ---
+
+(mk-test
+  "fd-eq-bind"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-eq x 3)
+      (== q x)))
+  (list 3))
+
+(mk-test
+  "fd-eq-out-of-domain-fails"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3))
+      (fd-eq x 5)
+      (== q x)))
+  (list))
+
+(mk-test
+  "fd-eq-two-vars-share-domain"
+  (run*
+    q
+    (fresh
+      (x y)
+      (fd-in x (list 1 2 3))
+      (fd-in y (list 2 3 4))
+      (fd-eq x y)
+      (fd-label (list x y))
+      (== q (list x y))))
+  (list (list 2 2) (list 3 3)))
+
+;; --- combine fd-lt + fd-neq for "between" puzzle ---
+
+(mk-test
+  "fd-lt-neq-combined"
+  (run*
+    q
+    (fresh
+      (x y z)
+      (fd-in x (list 1 2 3))
+      (fd-in y (list 1 2 3))
+      (fd-in z (list 1 2 3))
+      (fd-lt x y)
+      (fd-lt y z)
+      (fd-label (list x y z))
+      (== q (list x y z))))
+  (list (list 1 2 3)))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-plus.sx

@@ -0,0 +1,62 @@
+;; lib/minikanren/tests/clpfd-plus.sx — fd-plus (x + y = z).
+
+(mk-test
+  "fd-plus-all-ground"
+  (run* q (fresh (z) (fd-plus 2 3 z) (== q z)))
+  (list 5))
+
+(mk-test
+  "fd-plus-recover-x"
+  (run* q (fresh (x) (fd-plus x 3 5) (== q x)))
+  (list 2))
+
+(mk-test
+  "fd-plus-recover-y"
+  (run* q (fresh (y) (fd-plus 2 y 5) (== q y)))
+  (list 3))
+
+(mk-test
+  "fd-plus-impossible-fails"
+  (run*
+    q
+    (fresh
+      (z)
+      (fd-plus 2 3 z)
+      (== z 99)
+      (== q z)))
+  (list))
+
+(mk-test
+  "fd-plus-domain-check"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 3 4 5))
+      (fd-plus x 3 5)
+      (== q x)))
+  (list))
+
+(mk-test
+  "fd-plus-pairs-summing-to-5"
+  (run*
+    q
+    (fresh
+      (x y)
+      (fd-in x (list 1 2 3 4))
+      (fd-in y (list 1 2 3 4))
+      (fd-plus x y 5)
+      (fd-label (list x y))
+      (== q (list x y))))
+  (list
+    (list 1 4)
+    (list 2 3)
+    (list 3 2)
+    (list 4 1)))
+
+(mk-test
+  "fd-plus-z-derived"
+  (run* q (fresh (z) (fd-plus 7 8 z) (== q z)))
+  (list 15))
+
+(mk-tests-run!)

lib/minikanren/tests/clpfd-times.sx

@@ -0,0 +1,85 @@
+;; lib/minikanren/tests/clpfd-times.sx — fd-times (x * y = z).
+
+(mk-test
+  "fd-times-3-4"
+  (run* q (fresh (z) (fd-times 3 4 z) (== q z)))
+  (list 12))
+
+(mk-test
+  "fd-times-recover-divisor"
+  (run* q (fresh (x) (fd-times x 5 30) (== q x)))
+  (list 6))
+
+(mk-test
+  "fd-times-non-divisible-fails"
+  (run* q (fresh (x) (fd-times x 5 31) (== q x)))
+  (list))
+
+(mk-test
+  "fd-times-by-zero"
+  (run* q (fresh (z) (fd-times 0 99 z) (== q z)))
+  (list 0))
+
+(mk-test
+  "fd-times-zero-by-anything-zero"
+  (run*
+    q
+    (fresh
+      (x)
+      (fd-in x (list 1 2 3))
+      (fd-times x 0 0)
+      (fd-label (list x))
+      (== q x)))
+  (list 1 2 3))
+
+(mk-test
+  "fd-times-12-divisor-pairs"
+  (run*
+    q
+    (fresh
+      (x y)
+      (fd-in
+        x
+        (list
+          1
+          2
+          3
+          4
+          5
+          6))
+      (fd-in
+        y
+        (list
+          1
+          2
+          3
+          4
+          5
+          6))
+      (fd-times x y 12)
+      (fd-label (list x y))
+      (== q (list x y))))
+  (list
+    (list 2 6)
+    (list 3 4)
+    (list 4 3)
+    (list 6 2)))
+
+(mk-test
+  "fd-times-square-of-each"
+  (run*
+    q
+    (fresh
+      (x z)
+      (fd-in x (list 1 2 3 4 5))
+      (fd-times x x z)
+      (fd-label (list x))
+      (== q (list x z))))
+  (list
+    (list 1 1)
+    (list 2 4)
+    (list 3 9)
+    (list 4 16)
+    (list 5 25)))
+
+(mk-tests-run!)

lib/minikanren/tests/conda.sx

@@ -0,0 +1,75 @@
+;; lib/minikanren/tests/conda.sx — Phase 5 piece A tests for `conda`.
+
+;; --- conda commits to first non-failing head, keeps ALL its answers ---
+
+(mk-test
+  "conda-first-clause-keeps-all"
+  (run*
+    q
+    (conda
+      ((mk-disj (== q 1) (== q 2)))
+      ((== q 100))))
+  (list 1 2))
+
+(mk-test
+  "conda-skips-failing-head"
+  (run*
+    q
+    (conda
+      ((== 1 2))
+      ((mk-disj (== q 10) (== q 20)))))
+  (list 10 20))
+
+(mk-test
+  "conda-all-fail"
+  (run*
+    q
+    (conda ((== 1 2)) ((== 3 4))))
+  (list))
+
+(mk-test "conda-no-clauses" (run* q (conda)) (list))
+
+;; --- conda DIFFERS from condu: conda keeps all head answers ---
+
+(mk-test
+  "conda-vs-condu-divergence"
+  (list
+    (run*
+      q
+      (conda
+        ((mk-disj (== q 1) (== q 2)))
+        ((== q 100))))
+    (run*
+      q
+      (condu
+        ((mk-disj (== q 1) (== q 2)))
+        ((== q 100)))))
+  (list (list 1 2) (list 1)))
+
+;; --- conda head's rest-goals run on every head answer ---
+
+(mk-test
+  "conda-rest-goals-run-on-all-answers"
+  (run*
+    q
+    (fresh
+      (x r)
+      (conda
+        ((mk-disj (== x 1) (== x 2))
+          (== r (list :tag x))))
+      (== q r)))
+  (list (list :tag 1) (list :tag 2)))
+
+;; --- if rest-goals fail on a head answer, that head answer is filtered;
+;;     the clause does not fall through to next clauses (per soft-cut). ---
+
+(mk-test
+  "conda-rest-fails-no-fallthrough"
+  (run*
+    q
+    (conda
+      ((mk-disj (== q 1) (== q 2)) (== q 99))
+      ((== q 200))))
+  (list))
+
+(mk-tests-run!)

lib/minikanren/tests/conde.sx

@@ -0,0 +1,89 @@
+;; lib/minikanren/tests/conde.sx — Phase 2 piece C tests for `conde`.
+;;
+;; Note on ordering: conde clauses are wrapped in Zzz (inverse-eta delay),
+;; so applying the conde goal to a substitution returns thunks. mk-mplus
+;; suspends-and-swaps when its left operand is paused, giving fair
+;; interleaving — this is exactly what makes recursive relations work,
+;; but it does mean conde answers can interleave rather than appear in
+;; strict left-to-right clause order.
+
+;; --- single-clause conde ≡ conj of clause body ---
+
+(mk-test
+  "conde-one-clause"
+  (let ((q (mk-var "q"))) (run* q (conde ((== q 7)))))
+  (list 7))
+
+(mk-test
+  "conde-one-clause-multi-goals"
+  (let
+    ((q (mk-var "q")))
+    (run* q (conde ((fresh (x) (== x 5) (== q (list x x)))))))
+  (list (list 5 5)))
+
+;; --- multi-clause: produces one row per clause (interleaved) ---
+
+(mk-test
+  "conde-three-clauses-as-set"
+  (let
+    ((qs (run* q (conde ((== q 1)) ((== q 2)) ((== q 3))))))
+    (and
+      (= (len qs) 3)
+      (and
+        (some (fn (x) (= x 1)) qs)
+        (and
+          (some (fn (x) (= x 2)) qs)
+          (some (fn (x) (= x 3)) qs)))))
+  true)
+
+(mk-test
+  "conde-mixed-success-failure-as-set"
+  (let
+    ((qs (run* q (conde ((== q "a")) ((== 1 2)) ((== q "b"))))))
+    (and
+      (= (len qs) 2)
+      (and (some (fn (x) (= x "a")) qs) (some (fn (x) (= x "b")) qs))))
+  true)
+
+;; --- conde with conjuncts inside clauses ---
+
+(mk-test
+  "conde-clause-conj-as-set"
+  (let
+    ((rows (run* q (fresh (x y) (conde ((== x 1) (== y 10)) ((== x 2) (== y 20))) (== q (list x y))))))
+    (and
+      (= (len rows) 2)
+      (and
+        (some (fn (r) (= r (list 1 10))) rows)
+        (some (fn (r) (= r (list 2 20))) rows))))
+  true)
+
+;; --- nested conde ---
+
+(mk-test
+  "conde-nested-yields-three"
+  (let
+    ((qs (run* q (conde ((conde ((== q 1)) ((== q 2)))) ((== q 3))))))
+    (and
+      (= (len qs) 3)
+      (and
+        (some (fn (x) (= x 1)) qs)
+        (and
+          (some (fn (x) (= x 2)) qs)
+          (some (fn (x) (= x 3)) qs)))))
+  true)
+
+;; --- conde all clauses fail → empty stream ---
+
+(mk-test
+  "conde-all-fail"
+  (run*
+    q
+    (conde ((== 1 2)) ((== 3 4))))
+  (list))
+
+;; --- empty conde: no clauses ⇒ fail ---
+
+(mk-test "conde-no-clauses" (run* q (conde)) (list))
+
+(mk-tests-run!)

lib/minikanren/tests/condu.sx

@@ -0,0 +1,86 @@
+;; lib/minikanren/tests/condu.sx — Phase 2 piece D tests for `onceo` and `condu`.
+
+;; --- onceo: at most one answer ---
+
+(mk-test
+  "onceo-single-success-passes-through"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((onceo (== q 7)) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 7))
+
+(mk-test
+  "onceo-multi-success-trimmed-to-one"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((onceo (mk-disj (== q 1) (== q 2) (== q 3))) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 1))
+
+(mk-test
+  "onceo-failure-stays-failure"
+  ((onceo (== 1 2)) empty-s)
+  (list))
+
+(mk-test
+  "onceo-conde-trimmed"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((onceo (conde ((== q "a")) ((== q "b")))) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list "a"))
+
+;; --- condu: first clause with successful head wins ---
+
+(mk-test
+  "condu-first-clause-wins"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 10 ((condu ((== q 1)) ((== q 2))) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 1))
+
+(mk-test
+  "condu-skips-failing-head"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 10 ((condu ((== 1 2)) ((== q 100)) ((== q 200))) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 100))
+
+(mk-test
+  "condu-all-fail-empty"
+  ((condu ((== 1 2)) ((== 3 4)))
+    empty-s)
+  (list))
+
+(mk-test "condu-empty-clauses-fail" ((condu) empty-s) (list))
+
+;; --- condu commits head's first answer; rest-goals can still backtrack
+;;     within that committed substitution but cannot revisit other heads. ---
+
+(mk-test
+  "condu-head-onceo-rest-runs"
+  (let
+    ((q (mk-var "q")) (r (mk-var "r")))
+    (let
+      ((res (stream-take 10 ((condu ((mk-disj (== q 1) (== q 2)) (== r 99))) empty-s))))
+      (map (fn (s) (list (mk-walk q s) (mk-walk r s))) res)))
+  (list (list 1 99)))
+
+(mk-test
+  "condu-rest-goals-can-fail-the-clause"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 10 ((condu ((== q 1) (== 2 3)) ((== q 99))) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list))
+
+(mk-tests-run!)

lib/minikanren/tests/counto.sx

@@ -0,0 +1,35 @@
+;; lib/minikanren/tests/counto.sx — count occurrences of x in l (intarith).
+
+(mk-test
+  "counto-empty"
+  (run* q (counto 1 (list) q))
+  (list 0))
+(mk-test
+  "counto-not-found"
+  (run* q (counto 99 (list 1 2 3) q))
+  (list 0))
+(mk-test
+  "counto-once"
+  (run* q (counto 2 (list 1 2 3) q))
+  (list 1))
+(mk-test
+  "counto-thrice"
+  (run*
+    q
+    (counto
+      1
+      (list 1 2 1 3 1)
+      q))
+  (list 3))
+(mk-test
+  "counto-all-same"
+  (run*
+    q
+    (counto 7 (list 7 7 7 7) q))
+  (list 4))
+(mk-test
+  "counto-string"
+  (run* q (counto "x" (list "x" "y" "x") q))
+  (list 2))
+
+(mk-tests-run!)

lib/minikanren/tests/cyclic-graph.sx

@@ -0,0 +1,48 @@
+;; lib/minikanren/tests/cyclic-graph.sx — demonstrates the naive-patho
+;; behaviour on a cyclic graph. Without Phase-7 tabling/SLG, the search
+;; produces ever-longer paths revisiting the cycle. `run n` truncates;
+;; `run*` would diverge.
+
+(define cyclic-edges (list (list :a :b) (list :b :a) (list :b :c)))
+
+(define cyclic-edgeo (fn (x y) (membero (list x y) cyclic-edges)))
+
+(define
+  cyclic-patho
+  (fn
+    (x y path)
+    (conde
+      ((cyclic-edgeo x y) (== path (list x y)))
+      ((fresh (z mid) (cyclic-edgeo x z) (cyclic-patho z y mid) (conso x mid path))))))
+
+;; --- direct edge ---
+
+(mk-test
+  "cyclic-direct"
+  (run 1 q (cyclic-patho :a :b q))
+  (list (list :a :b)))
+
+;; --- runs first 5 paths from a to b: bare edge, then increasing
+;;     numbers of cycle traversals (a->b->a->b, etc.) ---
+
+(mk-test
+  "cyclic-enumerates-prefix-via-run-n"
+  (let
+    ((paths (run 5 q (cyclic-patho :a :b q))))
+    (and
+      (= (len paths) 5)
+      (and
+        (every? (fn (p) (= (first p) :a)) paths)
+        (every? (fn (p) (= (last p) :b)) paths))))
+  true)
+
+(mk-test
+  "cyclic-finds-c-via-cycle-or-direct"
+  (let
+    ((paths (run 3 q (cyclic-patho :a :c q))))
+    (and
+      (>= (len paths) 1)
+      (some (fn (p) (= p (list :a :b :c))) paths)))
+  true)
+
+(mk-tests-run!)

lib/minikanren/tests/defrel.sx

@@ -0,0 +1,40 @@
+;; lib/minikanren/tests/defrel.sx — Prolog-style relation definition macro.
+
+(defrel
+  (my-membero x l)
+  ((fresh (d) (conso x d l)))
+  ((fresh (a d) (conso a d l) (my-membero x d))))
+
+(mk-test
+  "defrel-defines-membero"
+  (run* q (my-membero q (list 1 2 3)))
+  (list 1 2 3))
+
+(defrel
+  (my-listo l)
+  ((nullo l))
+  ((fresh (a d) (conso a d l) (my-listo d))))
+
+(mk-test
+  "defrel-listo-bounded"
+  (run 3 q (my-listo q))
+  (list
+    (list)
+    (list (make-symbol "_.0"))
+    (list (make-symbol "_.0") (make-symbol "_.1"))))
+
+;; Multi-arg relation with arithmetic.
+
+(defrel
+  (my-pluso a b c)
+  ((== a :z) (== b c))
+  ((fresh (a-1 c-1) (== a (list :s a-1)) (== c (list :s c-1)) (my-pluso a-1 b c-1))))
+
+(mk-test
+  "defrel-pluso-2-3"
+  (run*
+    q
+    (my-pluso (list :s (list :s :z)) (list :s (list :s (list :s :z))) q))
+  (list (list :s (list :s (list :s (list :s (list :s :z)))))))
+
+(mk-tests-run!)

lib/minikanren/tests/diseq.sx

@@ -0,0 +1,83 @@
+;; lib/minikanren/tests/diseq.sx — Phase 5 polish: =/= disequality.
+
+;; --- ground cases ---
+
+(mk-test
+  "=/=-ground-distinct"
+  (run* q (=/= 1 2))
+  (list (make-symbol "_.0")))
+(mk-test "=/=-ground-equal" (run* q (=/= 1 1)) (list))
+(mk-test
+  "=/=-ground-strings"
+  (run* q (=/= "a" "b"))
+  (list (make-symbol "_.0")))
+(mk-test "=/=-ground-strings-eq" (run* q (=/= "a" "a")) (list))
+
+;; --- structural ---
+
+(mk-test
+  "=/=-pair-distinct"
+  (run* q (=/= (list 1 2) (list 1 3)))
+  (list (make-symbol "_.0")))
+(mk-test
+  "=/=-pair-equal"
+  (run* q (=/= (list 1 2) (list 1 2)))
+  (list))
+(mk-test
+  "=/=-pair-vs-atom"
+  (run* q (=/= (list 1) 1))
+  (list (make-symbol "_.0")))
+
+;; --- partial / late binding ---
+;;
+;; ==-cs is required to wake up the constraint store after a binding;
+;; plain == doesn't fire constraints.
+
+(mk-test
+  "=/=-late-bind-violates"
+  (run* q (fresh (x) (=/= x 5) (==-cs x 5) (== q x)))
+  (list))
+
+(mk-test
+  "=/=-late-bind-ok"
+  (run* q (fresh (x) (=/= x 5) (==-cs x 7) (== q x)))
+  (list 7))
+
+(mk-test
+  "=/=-two-vars-equal-late-fails"
+  (run*
+    q
+    (fresh
+      (x y)
+      (=/= x y)
+      (==-cs x 1)
+      (==-cs y 1)
+      (== q (list x y))))
+  (list))
+
+(mk-test
+  "=/=-two-vars-distinct-late"
+  (run*
+    q
+    (fresh
+      (x y)
+      (=/= x y)
+      (==-cs x 1)
+      (==-cs y 2)
+      (== q (list x y))))
+  (list (list 1 2)))
+
+;; --- compose with conde / fresh ---
+
+(mk-test
+  "=/=-with-membero-filter"
+  (run*
+    q
+    (fresh
+      (x)
+      (membero x (list 1 2 3))
+      (=/= x 2)
+      (== q x)))
+  (list 1 3))
+
+(mk-tests-run!)

lib/minikanren/tests/enumerate.sx

@@ -0,0 +1,31 @@
+;; lib/minikanren/tests/enumerate.sx — index-each-element relation.
+
+(mk-test
+  "enumerate-i-empty"
+  (run* q (enumerate-i (list) q))
+  (list (list)))
+
+(mk-test
+  "enumerate-i-three"
+  (run* q (enumerate-i (list :a :b :c) q))
+  (list
+    (list (list 0 :a) (list 1 :b) (list 2 :c))))
+
+(mk-test
+  "enumerate-i-strings"
+  (run* q (enumerate-i (list "x" "y" "z") q))
+  (list
+    (list (list 0 "x") (list 1 "y") (list 2 "z"))))
+
+(mk-test
+  "enumerate-from-i-100"
+  (run* q (enumerate-from-i 100 (list :x :y :z) q))
+  (list
+    (list (list 100 :x) (list 101 :y) (list 102 :z))))
+
+(mk-test
+  "enumerate-from-i-singleton"
+  (run* q (enumerate-from-i 0 (list :only) q))
+  (list (list (list 0 :only))))
+
+(mk-tests-run!)

lib/minikanren/tests/fd.sx

@@ -0,0 +1,75 @@
+;; lib/minikanren/tests/fd.sx — Phase 6 piece A: ino + all-distincto.
+
+;; --- ino ---
+
+(mk-test
+  "ino-element-in-domain"
+  (run* q (ino q (list 1 2 3)))
+  (list 1 2 3))
+
+(mk-test "ino-empty-domain" (run* q (ino q (list))) (list))
+
+(mk-test
+  "ino-singleton-domain"
+  (run* q (ino q (list 42)))
+  (list 42))
+
+;; --- all-distincto ---
+
+(mk-test
+  "all-distincto-empty"
+  (run* q (all-distincto (list)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "all-distincto-singleton"
+  (run* q (all-distincto (list 1)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "all-distincto-distinct-three"
+  (run* q (all-distincto (list 1 2 3)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "all-distincto-duplicate-fails"
+  (run* q (all-distincto (list 1 2 1)))
+  (list))
+
+(mk-test
+  "all-distincto-adjacent-duplicate-fails"
+  (run* q (all-distincto (list 1 1 2)))
+  (list))
+
+;; --- ino + all-distincto: classic enumerate-all-permutations ---
+
+(mk-test
+  "fd-puzzle-three-distinct-from-domain"
+  (let
+    ((perms (run* q (fresh (a b c) (== q (list a b c)) (ino a (list 1 2 3)) (ino b (list 1 2 3)) (ino c (list 1 2 3)) (all-distincto (list a b c))))))
+    (and
+      (= (len perms) 6)
+      (and
+        (some (fn (p) (= p (list 1 2 3))) perms)
+        (and
+          (some
+            (fn (p) (= p (list 1 3 2)))
+            perms)
+          (and
+            (some
+              (fn (p) (= p (list 2 1 3)))
+              perms)
+            (and
+              (some
+                (fn (p) (= p (list 2 3 1)))
+                perms)
+              (and
+                (some
+                  (fn (p) (= p (list 3 1 2)))
+                  perms)
+                (some
+                  (fn (p) (= p (list 3 2 1)))
+                  perms))))))))
+  true)
+
+(mk-tests-run!)

lib/minikanren/tests/flat-mapo.sx

@@ -0,0 +1,39 @@
+;; lib/minikanren/tests/flat-mapo.sx — concatMap-style relation.
+
+(mk-test
+  "flat-mapo-empty"
+  (run* q (flat-mapo (fn (x r) (== r (list x x))) (list) q))
+  (list (list)))
+
+(mk-test
+  "flat-mapo-duplicate-each"
+  (run*
+    q
+    (flat-mapo
+      (fn (x r) (== r (list x x)))
+      (list 1 2 3)
+      q))
+  (list
+    (list 1 1 2 2 3 3)))
+
+(mk-test
+  "flat-mapo-empty-from-each"
+  (run* q (flat-mapo (fn (x r) (== r (list))) (list :a :b :c) q))
+  (list (list)))
+
+(mk-test
+  "flat-mapo-singleton-from-each-is-identity"
+  (run* q (flat-mapo (fn (x r) (== r (list x))) (list :a :b :c) q))
+  (list (list :a :b :c)))
+
+(mk-test
+  "flat-mapo-tag-each"
+  (run*
+    q
+    (flat-mapo
+      (fn (x r) (== r (list :tag x)))
+      (list 1 2)
+      q))
+  (list (list :tag 1 :tag 2)))
+
+(mk-tests-run!)

lib/minikanren/tests/flatteno.sx

@@ -0,0 +1,42 @@
+(mk-test "flatteno-empty" (run* q (flatteno (list) q)) (list (list)))
+
+(mk-test
+  "flatteno-atom"
+  (run* q (flatteno 5 q))
+  (list (list 5)))
+
+(mk-test
+  "flatteno-flat-list"
+  (run* q (flatteno (list 1 2 3) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "flatteno-singleton"
+  (run* q (flatteno (list 1) q))
+  (list (list 1)))
+
+(mk-test
+  "flatteno-nested-once"
+  (run*
+    q
+    (flatteno (list 1 (list 2 3) 4) q))
+  (list (list 1 2 3 4)))
+
+(mk-test
+  "flatteno-nested-twice"
+  (run*
+    q
+    (flatteno
+      (list
+        1
+        (list 2 (list 3 4))
+        5)
+      q))
+  (list (list 1 2 3 4 5)))
+
+(mk-test
+  "flatteno-keywords"
+  (run* q (flatteno (list :a (list :b :c) :d) q))
+  (list (list :a :b :c :d)))
+
+(mk-tests-run!)

lib/minikanren/tests/foldl-o.sx

@@ -0,0 +1,48 @@
+;; lib/minikanren/tests/foldl-o.sx — relational left fold.
+
+(mk-test
+  "foldl-o-empty"
+  (run* q (foldl-o pluso-i (list) 42 q))
+  (list 42))
+
+(mk-test
+  "foldl-o-sum"
+  (run*
+    q
+    (foldl-o
+      pluso-i
+      (list 1 2 3 4 5)
+      0
+      q))
+  (list 15))
+
+(mk-test
+  "foldl-o-product"
+  (run*
+    q
+    (foldl-o
+      *o-i
+      (list 1 2 3 4)
+      1
+      q))
+  (list 24))
+
+(mk-test
+  "foldl-o-reverse-via-flip-conso"
+  (run*
+    q
+    (foldl-o
+      (fn (acc x r) (conso x acc r))
+      (list 1 2 3 4)
+      (list)
+      q))
+  (list (list 4 3 2 1)))
+
+(mk-test
+  "foldl-o-with-init"
+  (run*
+    q
+    (foldl-o pluso-i (list 1 2 3) 100 q))
+  (list 106))
+
+(mk-tests-run!)

lib/minikanren/tests/foldr-o.sx

@@ -0,0 +1,38 @@
+;; lib/minikanren/tests/foldr-o.sx — relational right fold.
+
+(mk-test
+  "foldr-o-empty"
+  (run* q (foldr-o conso (list) (list 99) q))
+  (list (list 99)))
+
+(mk-test
+  "foldr-o-conso-rebuilds-list"
+  (run* q (foldr-o conso (list 1 2 3) (list) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "foldr-o-appendo-flattens"
+  (run*
+    q
+    (foldr-o
+      appendo
+      (list
+        (list 1 2)
+        (list 3)
+        (list 4 5))
+      (list)
+      q))
+  (list (list 1 2 3 4 5)))
+
+(mk-test
+  "foldr-o-with-acc-init"
+  (run*
+    q
+    (foldr-o
+      conso
+      (list 1 2)
+      (list 9 9)
+      q))
+  (list (list 1 2 9 9)))
+
+(mk-tests-run!)

lib/minikanren/tests/fresh.sx

@@ -0,0 +1,101 @@
+;; lib/minikanren/tests/fresh.sx — Phase 2 piece B tests for `fresh`.
+
+;; --- empty fresh: pure goal grouping ---
+
+(mk-test
+  "fresh-empty-vars-equiv-conj"
+  (stream-take 5 ((fresh () (== 1 1)) empty-s))
+  (list empty-s))
+
+(mk-test
+  "fresh-empty-vars-no-goals-is-succeed"
+  (stream-take 5 ((fresh ()) empty-s))
+  (list empty-s))
+
+;; --- single var ---
+
+(mk-test
+  "fresh-one-var-bound"
+  (let
+    ((s (first (stream-take 5 ((fresh (x) (== x 7)) empty-s)))))
+    (first (vals s)))
+  7)
+
+;; --- multiple vars + multiple goals ---
+
+(mk-test
+  "fresh-two-vars-three-goals"
+  (let
+    ((q (mk-var "q"))
+      (g
+        (fresh
+          (x y)
+          (== x 10)
+          (== y 20)
+          (== q (list x y)))))
+    (mk-walk* q (first (stream-take 5 (g empty-s)))))
+  (list 10 20))
+
+(mk-test
+  "fresh-three-vars"
+  (let
+    ((q (mk-var "q"))
+      (g
+        (fresh
+          (a b c)
+          (== a 1)
+          (== b 2)
+          (== c 3)
+          (== q (list a b c)))))
+    (mk-walk* q (first (stream-take 5 (g empty-s)))))
+  (list 1 2 3))
+
+;; --- fresh interacts with disj ---
+
+(mk-test
+  "fresh-with-disj"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((g (fresh (x) (mk-disj (== x 1) (== x 2)) (== q x))))
+      (let
+        ((res (stream-take 5 (g empty-s))))
+        (map (fn (s) (mk-walk q s)) res))))
+  (list 1 2))
+
+;; --- nested fresh ---
+
+(mk-test
+  "fresh-nested"
+  (let
+    ((q (mk-var "q"))
+      (g
+        (fresh
+          (x)
+          (fresh
+            (y)
+            (== x 1)
+            (== y 2)
+            (== q (list x y))))))
+    (mk-walk* q (first (stream-take 5 (g empty-s)))))
+  (list 1 2))
+
+;; --- call-fresh (functional alternative) ---
+
+(mk-test
+  "call-fresh-binds-and-walks"
+  (let
+    ((s (first (stream-take 5 ((call-fresh (fn (x) (== x 99))) empty-s)))))
+    (first (vals s)))
+  99)
+
+(mk-test
+  "call-fresh-distinct-from-outer-vars"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((g (call-fresh (fn (x) (mk-conj (== x 5) (== q (list x x)))))))
+      (mk-walk* q (first (stream-take 5 (g empty-s))))))
+  (list 5 5))
+
+(mk-tests-run!)

lib/minikanren/tests/goals.sx

@@ -0,0 +1,260 @@
+;; lib/minikanren/tests/goals.sx — Phase 2 tests for stream.sx + goals.sx.
+;;
+;; Streams use a tagged shape internally (`(:s head tail)`) so that mature
+;; cells can have thunk tails — SX has no improper pairs. Test assertions
+;; therefore stream-take into a plain SX list, or check goal effects via
+;; mk-walk on the resulting subst, instead of inspecting raw streams.
+
+;; --- stream-take base cases (input streams use s-cons / mzero) ---
+
+(mk-test
+  "stream-take-zero-from-mature"
+  (stream-take 0 (s-cons (empty-subst) mzero))
+  (list))
+
+(mk-test "stream-take-from-mzero" (stream-take 5 mzero) (list))
+
+(mk-test
+  "stream-take-mature-pair"
+  (stream-take 5 (s-cons :a (s-cons :b mzero)))
+  (list :a :b))
+
+(mk-test
+  "stream-take-fewer-than-available"
+  (stream-take 1 (s-cons :a (s-cons :b mzero)))
+  (list :a))
+
+(mk-test
+  "stream-take-all-with-neg-1"
+  (stream-take -1 (s-cons :a (s-cons :b (s-cons :c mzero))))
+  (list :a :b :c))
+
+;; --- stream-take forces immature thunks ---
+
+(mk-test
+  "stream-take-forces-thunk"
+  (stream-take 5 (fn () (s-cons :x mzero)))
+  (list :x))
+
+(mk-test
+  "stream-take-forces-nested-thunks"
+  (stream-take 5 (fn () (fn () (s-cons :y mzero))))
+  (list :y))
+
+;; --- mk-mplus interleaves ---
+
+(mk-test
+  "mplus-empty-left"
+  (stream-take 5 (mk-mplus mzero (s-cons :r mzero)))
+  (list :r))
+
+(mk-test
+  "mplus-empty-right"
+  (stream-take 5 (mk-mplus (s-cons :l mzero) mzero))
+  (list :l))
+
+(mk-test
+  "mplus-mature-mature"
+  (stream-take
+    5
+    (mk-mplus (s-cons :a (s-cons :b mzero)) (s-cons :c (s-cons :d mzero))))
+  (list :a :b :c :d))
+
+(mk-test
+  "mplus-with-paused-left-swaps"
+  (stream-take
+    5
+    (mk-mplus
+      (fn () (s-cons :a (s-cons :b mzero)))
+      (s-cons :c (s-cons :d mzero))))
+  (list :c :d :a :b))
+
+;; --- mk-bind ---
+
+(mk-test
+  "bind-empty-stream"
+  (stream-take 5 (mk-bind mzero (fn (s) (unit s))))
+  (list))
+
+(mk-test
+  "bind-singleton-identity"
+  (stream-take
+    5
+    (mk-bind (s-cons 5 mzero) (fn (x) (unit x))))
+  (list 5))
+
+(mk-test
+  "bind-flat-multi"
+  (stream-take
+    10
+    (mk-bind
+      (s-cons 1 (s-cons 2 mzero))
+      (fn (x) (s-cons x (s-cons (* x 10) mzero)))))
+  (list 1 10 2 20))
+
+(mk-test
+  "bind-fail-prunes-some"
+  (stream-take
+    10
+    (mk-bind
+      (s-cons 1 (s-cons 2 (s-cons 3 mzero)))
+      (fn (x) (if (= x 2) mzero (unit x)))))
+  (list 1 3))
+
+;; --- core goals: succeed / fail ---
+
+(mk-test
+  "succeed-yields-singleton"
+  (stream-take 5 (succeed empty-s))
+  (list empty-s))
+
+(mk-test "fail-yields-mzero" (stream-take 5 (fail empty-s)) (list))
+
+;; --- == ---
+
+(mk-test
+  "eq-ground-success"
+  (stream-take 5 ((== 1 1) empty-s))
+  (list empty-s))
+
+(mk-test
+  "eq-ground-failure"
+  (stream-take 5 ((== 1 2) empty-s))
+  (list))
+
+(mk-test
+  "eq-binds-var"
+  (let
+    ((x (mk-var "x")))
+    (mk-walk
+      x
+      (first (stream-take 5 ((== x 7) empty-s)))))
+  7)
+
+(mk-test
+  "eq-list-success"
+  (let
+    ((x (mk-var "x")))
+    (mk-walk
+      x
+      (first
+        (stream-take
+          5
+          ((== x (list 1 2)) empty-s)))))
+  (list 1 2))
+
+(mk-test
+  "eq-list-mismatch-fails"
+  (stream-take
+    5
+    ((== (list 1 2) (list 1 3)) empty-s))
+  (list))
+
+;; --- conj2 / mk-conj ---
+
+(mk-test
+  "conj2-both-bind"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (let
+      ((s (first (stream-take 5 ((conj2 (== x 1) (== y 2)) empty-s)))))
+      (list (mk-walk x s) (mk-walk y s))))
+  (list 1 2))
+
+(mk-test
+  "conj2-conflict-empty"
+  (let
+    ((x (mk-var "x")))
+    (stream-take
+      5
+      ((conj2 (== x 1) (== x 2)) empty-s)))
+  (list))
+
+(mk-test
+  "conj-empty-is-succeed"
+  (stream-take 5 ((mk-conj) empty-s))
+  (list empty-s))
+
+(mk-test
+  "conj-single-is-goal"
+  (let
+    ((x (mk-var "x")))
+    (mk-walk
+      x
+      (first
+        (stream-take 5 ((mk-conj (== x 99)) empty-s)))))
+  99)
+
+(mk-test
+  "conj-three-bindings"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z")))
+    (let
+      ((s (first (stream-take 5 ((mk-conj (== x 1) (== y 2) (== z 3)) empty-s)))))
+      (list (mk-walk x s) (mk-walk y s) (mk-walk z s))))
+  (list 1 2 3))
+
+;; --- disj2 / mk-disj ---
+
+(mk-test
+  "disj2-both-succeed"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((disj2 (== q 1) (== q 2)) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 1 2))
+
+(mk-test
+  "disj2-fail-or-succeed"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((disj2 fail (== q 5)) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list 5))
+
+(mk-test
+  "disj-empty-is-fail"
+  (stream-take 5 ((mk-disj) empty-s))
+  (list))
+
+(mk-test
+  "disj-three-clauses"
+  (let
+    ((q (mk-var "q")))
+    (let
+      ((res (stream-take 5 ((mk-disj (== q "a") (== q "b") (== q "c")) empty-s))))
+      (map (fn (s) (mk-walk q s)) res)))
+  (list "a" "b" "c"))
+
+;; --- conj/disj nesting ---
+
+(mk-test
+  "disj-of-conj"
+  (let
+    ((x (mk-var "x")) (y (mk-var "y")))
+    (let
+      ((res (stream-take 5 ((mk-disj (mk-conj (== x 1) (== y 2)) (mk-conj (== x 3) (== y 4))) empty-s))))
+      (map (fn (s) (list (mk-walk x s) (mk-walk y s))) res)))
+  (list (list 1 2) (list 3 4)))
+
+;; --- ==-check ---
+
+(mk-test
+  "eq-check-no-occurs-fails"
+  (let
+    ((x (mk-var "x")))
+    (stream-take 5 ((==-check x (list 1 x)) empty-s)))
+  (list))
+
+(mk-test
+  "eq-check-no-occurs-non-occurring-succeeds"
+  (let
+    ((x (mk-var "x")))
+    (mk-walk
+      x
+      (first (stream-take 5 ((==-check x 5) empty-s)))))
+  5)
+
+(mk-tests-run!)

lib/minikanren/tests/graph.sx

@@ -0,0 +1,70 @@
+;; lib/minikanren/tests/graph.sx — directed-graph reachability via patho.
+
+(define
+  test-edges
+  (list (list :a :b) (list :b :c) (list :c :d) (list :a :c) (list :d :e)))
+
+(define edgeo (fn (from to) (membero (list from to) test-edges)))
+
+(define
+  patho
+  (fn
+    (x y path)
+    (conde
+      ((edgeo x y) (== path (list x y)))
+      ((fresh (z mid-path) (edgeo x z) (patho z y mid-path) (conso x mid-path path))))))
+
+;; --- direct edges ---
+
+(mk-test "patho-direct" (run* q (patho :a :b q)) (list (list :a :b)))
+
+(mk-test "patho-no-direct-edge" (run* q (patho :e :a q)) (list))
+
+;; --- indirect ---
+
+(mk-test
+  "patho-multi-hop"
+  (let
+    ((paths (run* q (patho :a :d q))))
+    (and
+      (= (len paths) 2)
+      (and
+        (some (fn (p) (= p (list :a :b :c :d))) paths)
+        (some (fn (p) (= p (list :a :c :d))) paths))))
+  true)
+
+(mk-test
+  "patho-to-leaf"
+  (let
+    ((paths (run* q (patho :a :e q))))
+    (and
+      (= (len paths) 2)
+      (and
+        (some (fn (p) (= p (list :a :b :c :d :e))) paths)
+        (some (fn (p) (= p (list :a :c :d :e))) paths))))
+  true)
+
+;; --- enumeration with multiplicity ---
+;; Each path contributes one tuple, so reachable nodes can repeat. Here
+;; targets are: b (1 path), c (2 paths), d (2 paths), e (2 paths) = 7.
+
+(mk-test
+  "patho-enumerate-from-a-with-multiplicity"
+  (let
+    ((targets (run* q (fresh (path) (patho :a q path)))))
+    (and
+      (= (len targets) 7)
+      (and
+        (some (fn (t) (= t :b)) targets)
+        (and
+          (some (fn (t) (= t :c)) targets)
+          (and
+            (some (fn (t) (= t :d)) targets)
+            (some (fn (t) (= t :e)) targets))))))
+  true)
+
+;; --- unreachable target ---
+
+(mk-test "patho-unreachable" (run* q (patho :a :z q)) (list))
+
+(mk-tests-run!)

lib/minikanren/tests/intarith.sx

@@ -0,0 +1,103 @@
+;; lib/minikanren/tests/intarith.sx — ground-only integer arithmetic
+;; goals that escape into host operations via project.
+
+;; --- pluso-i ---
+
+(mk-test
+  "pluso-i-forward"
+  (run* q (pluso-i 7 8 q))
+  (list 15))
+(mk-test
+  "pluso-i-zero"
+  (run* q (pluso-i 0 0 q))
+  (list 0))
+(mk-test
+  "pluso-i-negatives"
+  (run* q (pluso-i -5 3 q))
+  (list -2))
+(mk-test
+  "pluso-i-non-ground-fails"
+  (run* q (fresh (a) (pluso-i a 3 5)))
+  (list))
+
+;; --- minuso-i ---
+
+(mk-test
+  "minuso-i-forward"
+  (run* q (minuso-i 10 4 q))
+  (list 6))
+(mk-test
+  "minuso-i-zero"
+  (run* q (minuso-i 5 5 q))
+  (list 0))
+
+;; --- *o-i ---
+
+(mk-test
+  "times-i-forward"
+  (run* q (*o-i 6 7 q))
+  (list 42))
+(mk-test
+  "times-i-by-zero"
+  (run* q (*o-i 0 99 q))
+  (list 0))
+(mk-test
+  "times-i-by-one"
+  (run* q (*o-i 1 17 q))
+  (list 17))
+
+;; --- comparisons ---
+
+(mk-test
+  "lto-i-true"
+  (run 1 q (lto-i 2 5))
+  (list (make-symbol "_.0")))
+(mk-test "lto-i-false" (run* q (lto-i 5 2)) (list))
+(mk-test "lto-i-equal-false" (run* q (lto-i 3 3)) (list))
+
+(mk-test
+  "lteo-i-equal"
+  (run 1 q (lteo-i 4 4))
+  (list (make-symbol "_.0")))
+(mk-test
+  "lteo-i-less"
+  (run 1 q (lteo-i 1 4))
+  (list (make-symbol "_.0")))
+(mk-test "lteo-i-more" (run* q (lteo-i 9 4)) (list))
+
+(mk-test
+  "neqo-i-different"
+  (run 1 q (neqo-i 3 5))
+  (list (make-symbol "_.0")))
+(mk-test "neqo-i-same" (run* q (neqo-i 3 3)) (list))
+
+;; --- composition with relational vars ---
+
+(mk-test
+  "intarith-with-membero"
+  (run*
+    q
+    (fresh
+      (x)
+      (membero
+        x
+        (list 1 2 3 4 5))
+      (lto-i x 3)
+      (== q x)))
+  (list 1 2))
+
+(mk-test "even-i-pos" (run* q (even-i 4)) (list (make-symbol "_.0")))
+
+(mk-test "even-i-neg" (run* q (even-i 5)) (list))
+
+(mk-test "odd-i-pos" (run* q (odd-i 7)) (list (make-symbol "_.0")))
+
+(mk-test "odd-i-neg" (run* q (odd-i 4)) (list))
+
+(mk-test
+  "even-i-filter"
+  (run* q (fresh (x) (membero x (list 1 2 3 4 5 6)) (even-i x) (== q x)))
+  (list 2 4 6))
+
+(mk-tests-run!)
+

lib/minikanren/tests/iterate-no.sx

@@ -0,0 +1,38 @@
+;; lib/minikanren/tests/iterate-no.sx — iterated relation application.
+
+(define
+  mk-nat
+  (fn (n) (if (= n 0) :z (list :s (mk-nat (- n 1))))))
+
+(mk-test
+  "iterate-no-zero"
+  (run*
+    q
+    (iterate-no
+      (fn (a b) (== b (list :wrap a)))
+      (mk-nat 0)
+      :seed q))
+  (list :seed))
+
+(mk-test
+  "iterate-no-three-wraps"
+  (run*
+    q
+    (iterate-no (fn (a b) (== b (list :wrap a))) (mk-nat 3) :x q))
+  (list (list :wrap (list :wrap (list :wrap :x)))))
+
+(mk-test
+  "iterate-no-succ-three-times"
+  (run*
+    q
+    (iterate-no (fn (a b) (== b (list :s a))) (mk-nat 3) :z q))
+  (list (mk-nat 3)))
+
+(mk-test
+  "iterate-no-with-list-cons"
+  (run*
+    q
+    (iterate-no (fn (a b) (conso :a a b)) (mk-nat 4) (list) q))
+  (list (list :a :a :a :a)))
+
+(mk-tests-run!)

lib/minikanren/tests/lasto.sx

@@ -0,0 +1,38 @@
+;; lib/minikanren/tests/lasto.sx — last-element + init-without-last.
+
+(mk-test
+  "lasto-singleton"
+  (run* q (lasto (list 5) q))
+  (list 5))
+(mk-test
+  "lasto-multi"
+  (run* q (lasto (list 1 2 3 4) q))
+  (list 4))
+(mk-test "lasto-empty" (run* q (lasto (list) q)) (list))
+
+(mk-test "lasto-strings" (run* q (lasto (list "a" "b" "c") q)) (list "c"))
+
+(mk-test
+  "init-o-multi"
+  (run* q (init-o (list 1 2 3 4) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "init-o-singleton"
+  (run* q (init-o (list 7) q))
+  (list (list)))
+
+(mk-test "init-o-empty" (run* q (init-o (list) q)) (list))
+
+(mk-test
+  "lasto-init-o-roundtrip"
+  (run*
+    q
+    (fresh
+      (init last)
+      (lasto (list 1 2 3 4) last)
+      (init-o (list 1 2 3 4) init)
+      (appendo init (list last) q)))
+  (list (list 1 2 3 4)))
+
+(mk-tests-run!)

lib/minikanren/tests/latin.sx

@@ -0,0 +1,61 @@
+;; lib/minikanren/tests/latin.sx — 2x2 Latin square via ino + all-distincto.
+;;
+;; A 2x2 Latin square has 2 distinct fillings:
+;;   ((1 2) (2 1))  and  ((2 1) (1 2)).
+;; The 3x3 version has 12 fillings but takes minutes under naive search;
+;; full CLP(FD) (Phase 6 proper) would handle it in milliseconds.
+
+(define
+  latin-2x2
+  (fn
+    (cells)
+    (let
+      ((c11 (nth cells 0))
+        (c12 (nth cells 1))
+        (c21 (nth cells 2))
+        (c22 (nth cells 3))
+        (dom (list 1 2)))
+      (mk-conj
+        (ino c11 dom)
+        (ino c12 dom)
+        (ino c21 dom)
+        (ino c22 dom)
+        (all-distincto (list c11 c12))
+        (all-distincto (list c21 c22))
+        (all-distincto (list c11 c21))
+        (all-distincto (list c12 c22))))))   ;; col 2
+
+(mk-test
+  "latin-2x2-count"
+  (let
+    ((squares (run* q (fresh (a b c d) (== q (list a b c d)) (latin-2x2 (list a b c d))))))
+    (len squares))
+  2)
+
+(mk-test
+  "latin-2x2-as-set"
+  (let
+    ((squares (run* q (fresh (a b c d) (== q (list a b c d)) (latin-2x2 (list a b c d))))))
+    (and
+      (= (len squares) 2)
+      (and
+        (some
+          (fn (s) (= s (list 1 2 2 1)))
+          squares)
+        (some
+          (fn (s) (= s (list 2 1 1 2)))
+          squares))))
+  true)
+
+(mk-test
+  "latin-2x2-with-clue"
+  (run*
+    q
+    (fresh
+      (a b c d)
+      (== a 1)
+      (== q (list a b c d))
+      (latin-2x2 (list a b c d))))
+  (list (list 1 2 2 1)))
+
+(mk-tests-run!)

lib/minikanren/tests/laziness.sx

@@ -0,0 +1,77 @@
+;; lib/minikanren/tests/laziness.sx — verify Zzz wrapping (in conde)
+;; lets infinitely-recursive relations produce finite prefixes via run-n.
+
+;; --- a relation that has no base case but conde-protects via Zzz ---
+
+(define
+  listo-aux
+  (fn
+    (l)
+    (conde ((nullo l)) ((fresh (a d) (conso a d l) (listo-aux d))))))
+
+(mk-test
+  "infinite-relation-truncates-via-run-n"
+  (run 4 q (listo-aux q))
+  (list
+    (list)
+    (list (make-symbol "_.0"))
+    (list (make-symbol "_.0") (make-symbol "_.1"))
+    (list (make-symbol "_.0") (make-symbol "_.1") (make-symbol "_.2"))))
+
+;; --- two infinite generators interleaved via mk-disj must both produce
+;;     answers (no starvation) — the fairness test ---
+
+(define
+  ones-gen
+  (fn
+    (l)
+    (conde
+      ((== l (list)))
+      ((fresh (d) (conso 1 d l) (ones-gen d))))))
+
+(define
+  twos-gen
+  (fn
+    (l)
+    (conde
+      ((== l (list)))
+      ((fresh (d) (conso 2 d l) (twos-gen d))))))
+
+(mk-test
+  "interleaving-keeps-both-streams-alive"
+  (let
+    ((res (run 4 q (mk-disj (ones-gen q) (twos-gen q)))))
+    (and
+      (= (len res) 4)
+      (and
+        (some
+          (fn
+            (x)
+            (and
+              (list? x)
+              (and (not (empty? x)) (= (first x) 1))))
+          res)
+        (some
+          (fn
+            (x)
+            (and
+              (list? x)
+              (and (not (empty? x)) (= (first x) 2))))
+          res))))
+  true)
+
+;; --- run* terminates on a relation whose conde has finite base case
+;;     reached from any starting point ---
+
+(mk-test
+  "run-star-terminates-on-bounded-relation"
+  (run*
+    q
+    (fresh
+      (l)
+      (== l (list 1 2 3))
+      (listo l)
+      (== q :ok)))
+  (list :ok))
+
+(mk-tests-run!)

lib/minikanren/tests/lengtho-i.sx

@@ -0,0 +1,28 @@
+;; lib/minikanren/tests/lengtho-i.sx — integer-indexed length (fast).
+
+(mk-test "lengtho-i-empty" (run* q (lengtho-i (list) q)) (list 0))
+(mk-test
+  "lengtho-i-singleton"
+  (run* q (lengtho-i (list :a) q))
+  (list 1))
+(mk-test
+  "lengtho-i-three"
+  (run* q (lengtho-i (list 1 2 3) q))
+  (list 3))
+(mk-test
+  "lengtho-i-five"
+  (run*
+    q
+    (lengtho-i
+      (list 1 2 3 4 5)
+      q))
+  (list 5))
+
+(mk-test
+  "lengtho-i-mixed-types"
+  (run*
+    q
+    (lengtho-i (list 1 "two" :three (list 4 5)) q))
+  (list 4))
+
+(mk-tests-run!)

lib/minikanren/tests/list-relations.sx

@@ -0,0 +1,126 @@
+;; lib/minikanren/tests/list-relations.sx — rembero, assoco, nth-o, samelengtho.
+
+;; --- rembero (remove first occurrence) ---
+
+(mk-test
+  "rembero-element-present"
+  (run*
+    q
+    (rembero 2 (list 1 2 3 2) q))
+  (list (list 1 3 2)))
+
+(mk-test
+  "rembero-element-not-present"
+  (run* q (rembero 99 (list 1 2 3) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "rembero-empty"
+  (run* q (rembero 1 (list) q))
+  (list (list)))
+
+(mk-test
+  "rembero-only-element"
+  (run* q (rembero 5 (list 5) q))
+  (list (list)))
+
+(mk-test
+  "rembero-first-of-many"
+  (run*
+    q
+    (rembero 1 (list 1 2 3 4) q))
+  (list (list 2 3 4)))
+
+;; --- assoco (alist lookup) ---
+
+(define
+  test-pairs
+  (list
+    (list "alice" 30)
+    (list "bob" 25)
+    (list "carol" 35)))
+
+(mk-test
+  "assoco-found"
+  (run* q (assoco "bob" test-pairs q))
+  (list 25))
+
+(mk-test
+  "assoco-first"
+  (run* q (assoco "alice" test-pairs q))
+  (list 30))
+
+(mk-test "assoco-missing" (run* q (assoco "dave" test-pairs q)) (list))
+
+(mk-test
+  "assoco-find-keys-with-value"
+  (run* q (assoco q test-pairs 25))
+  (list "bob"))
+
+;; --- nth-o (Peano-indexed access) ---
+
+(mk-test
+  "nth-o-zero"
+  (run* q (nth-o :z (list 10 20 30) q))
+  (list 10))
+
+(mk-test
+  "nth-o-one"
+  (run* q (nth-o (list :s :z) (list 10 20 30) q))
+  (list 20))
+
+(mk-test
+  "nth-o-two"
+  (run*
+    q
+    (nth-o (list :s (list :s :z)) (list 10 20 30) q))
+  (list 30))
+
+(mk-test
+  "nth-o-out-of-range"
+  (run*
+    q
+    (nth-o
+      (list :s (list :s (list :s :z)))
+      (list 10 20 30)
+      q))
+  (list))
+
+;; --- samelengtho ---
+
+(mk-test
+  "samelengtho-equal"
+  (run*
+    q
+    (samelengtho (list 1 2 3) (list :a :b :c)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "samelengtho-different-fails"
+  (run* q (samelengtho (list 1 2) (list :a :b :c)))
+  (list))
+
+(mk-test
+  "samelengtho-empty-equal"
+  (run* q (samelengtho (list) (list)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "samelengtho-builds-vars"
+  (run 1 q (samelengtho (list 1 2 3) q))
+  (list (list (make-symbol "_.0") (make-symbol "_.1") (make-symbol "_.2"))))
+
+(mk-test
+  "samelengtho-enumerates-pairs"
+  (run
+    3
+    q
+    (fresh (l1 l2) (samelengtho l1 l2) (== q (list l1 l2))))
+  (list
+    (list (list) (list))
+    (list (list (make-symbol "_.0")) (list (make-symbol "_.1")))
+    (list
+      (list (make-symbol "_.0") (make-symbol "_.1"))
+      (list (make-symbol "_.2") (make-symbol "_.3")))))
+
+(mk-tests-run!)

lib/minikanren/tests/mapo.sx

@@ -0,0 +1,62 @@
+;; lib/minikanren/tests/mapo.sx — relational map.
+
+(mk-test
+  "mapo-identity"
+  (run*
+    q
+    (mapo (fn (a b) (== a b)) (list 1 2 3) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "mapo-tag-each"
+  (run*
+    q
+    (mapo
+      (fn (a b) (== b (list :tag a)))
+      (list 1 2 3)
+      q))
+  (list
+    (list
+      (list :tag 1)
+      (list :tag 2)
+      (list :tag 3))))
+
+(mk-test
+  "mapo-backward"
+  (run*
+    q
+    (mapo (fn (a b) (== a b)) q (list 1 2 3)))
+  (list (list 1 2 3)))
+
+(mk-test
+  "mapo-empty"
+  (run* q (mapo (fn (a b) (== a b)) (list) q))
+  (list (list)))
+
+(mk-test
+  "mapo-duplicate"
+  (run* q (mapo (fn (a b) (== b (list a a))) (list :x :y) q))
+  (list (list (list :x :x) (list :y :y))))
+
+(mk-test
+  "mapo-different-length-fails"
+  (run*
+    q
+    (mapo
+      (fn (a b) (== a b))
+      (list 1 2)
+      (list 1 2 3)))
+  (list))
+
+;; mapo + arithmetic via intarith
+(mk-test
+  "mapo-square-each"
+  (run*
+    q
+    (mapo
+      (fn (a b) (*o-i a a b))
+      (list 1 2 3 4)
+      q))
+  (list (list 1 4 9 16)))
+
+(mk-tests-run!)

lib/minikanren/tests/matche.sx

@@ -0,0 +1,138 @@
+;; lib/minikanren/tests/matche.sx — Phase 5 piece D tests for `matche`.
+
+;; --- literal patterns ---
+
+(mk-test
+  "matche-literal-number"
+  (run* q (matche q (1 (== q 1))))
+  (list 1))
+
+(mk-test
+  "matche-literal-string"
+  (run* q (matche q ("hello" (== q "hello"))))
+  (list "hello"))
+
+(mk-test
+  "matche-literal-no-clause-matches"
+  (run*
+    q
+    (matche 7 (1 (== q :a)) (2 (== q :b))))
+  (list))
+
+;; --- variable patterns ---
+
+(mk-test
+  "matche-symbol-pattern"
+  (run* q (fresh (x) (== x 99) (matche x (a (== q a)))))
+  (list 99))
+
+(mk-test
+  "matche-wildcard"
+  (run* q (fresh (x) (== x 7) (matche x (_ (== q :any)))))
+  (list :any))
+
+;; --- list patterns ---
+
+(mk-test
+  "matche-empty-list"
+  (run* q (matche (list) (() (== q :ok))))
+  (list :ok))
+
+(mk-test
+  "matche-pair-binds"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 1 2))
+      (matche x ((a b) (== q (list b a))))))
+  (list (list 2 1)))
+
+(mk-test
+  "matche-triple-binds"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 1 2 3))
+      (matche x ((a b c) (== q (list :sum a b c))))))
+  (list (list :sum 1 2 3)))
+
+(mk-test
+  "matche-mixed-literal-and-var"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 1 99 3))
+      (matche x ((1 m 3) (== q m)))))
+  (list 99))
+
+;; --- multi-clause dispatch ---
+
+(mk-test
+  "matche-multi-clause-shape"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 5 6))
+      (matche
+        x
+        (() (== q :empty))
+        ((a) (== q (list :one a)))
+        ((a b) (== q (list :two a b))))))
+  (list (list :two 5 6)))
+
+(mk-test
+  "matche-three-shapes-via-fresh"
+  (run*
+    q
+    (fresh
+      (x)
+      (matche
+        x
+        (() (== q :empty))
+        ((a) (== q (list :one a)))
+        ((a b) (== q (list :two a b))))))
+  (list
+    :empty (list :one (make-symbol "_.0"))
+    (list :two (make-symbol "_.0") (make-symbol "_.1"))))
+
+;; --- nested patterns ---
+
+(mk-test
+  "matche-nested"
+  (run*
+    q
+    (fresh
+      (x)
+      (==
+        x
+        (list (list 1 2) (list 3 4)))
+      (matche x (((a b) (c d)) (== q (list a b c d))))))
+  (list (list 1 2 3 4)))
+
+;; --- repeated var names create the same fresh var → must unify ---
+
+(mk-test
+  "matche-repeated-var-implies-equality"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 7 7))
+      (matche x ((a a) (== q a)))))
+  (list 7))
+
+(mk-test
+  "matche-repeated-var-mismatch-fails"
+  (run*
+    q
+    (fresh
+      (x)
+      (== x (list 7 8))
+      (matche x ((a a) (== q a)))))
+  (list))
+
+(mk-tests-run!)

lib/minikanren/tests/minmax.sx

@@ -0,0 +1,49 @@
+;; lib/minikanren/tests/minmax.sx — mino + maxo via intarith.
+
+(mk-test
+  "mino-singleton"
+  (run* q (mino (list 7) q))
+  (list 7))
+(mk-test
+  "mino-of-3"
+  (run* q (mino (list 5 1 3) q))
+  (list 1))
+(mk-test
+  "mino-of-5"
+  (run*
+    q
+    (mino (list 5 1 3 2 4) q))
+  (list 1))
+(mk-test
+  "mino-with-dups"
+  (run* q (mino (list 3 3 3) q))
+  (list 3))
+(mk-test "mino-empty-fails" (run* q (mino (list) q)) (list))
+
+(mk-test
+  "maxo-singleton"
+  (run* q (maxo (list 7) q))
+  (list 7))
+(mk-test
+  "maxo-of-5"
+  (run*
+    q
+    (maxo (list 5 1 3 2 4) q))
+  (list 5))
+(mk-test
+  "maxo-of-negs"
+  (run* q (maxo (list -5 -1 -3) q))
+  (list -1))
+
+(mk-test
+  "min-and-max-of-list"
+  (run*
+    q
+    (fresh
+      (mn mx)
+      (mino (list 5 1 3 2 4) mn)
+      (maxo (list 5 1 3 2 4) mx)
+      (== q (list mn mx))))
+  (list (list 1 5)))
+
+(mk-tests-run!)

lib/minikanren/tests/nafc.sx

@@ -0,0 +1,50 @@
+;; lib/minikanren/tests/nafc.sx — Phase 5 piece C tests for `nafc`.
+
+(mk-test
+  "nafc-failed-goal-succeeds"
+  (run* q (nafc (== 1 2)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "nafc-successful-goal-fails"
+  (run* q (nafc (== 1 1)))
+  (list))
+
+(mk-test
+  "nafc-double-negation"
+  (run* q (nafc (nafc (== 1 1))))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "nafc-with-conde-no-clauses-succeed"
+  (run*
+    q
+    (nafc
+      (conde ((== 1 2)) ((== 3 4)))))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "nafc-with-conde-some-clause-succeeds-fails"
+  (run*
+    q
+    (nafc
+      (conde ((== 1 1)) ((== 3 4)))))
+  (list))
+
+;; --- composing nafc with == as a guard ---
+
+(mk-test
+  "nafc-as-guard"
+  (run*
+    q
+    (fresh (x) (== x 5) (nafc (== x 99)) (== q x)))
+  (list 5))
+
+(mk-test
+  "nafc-guard-blocking"
+  (run*
+    q
+    (fresh (x) (== x 5) (nafc (== x 5)) (== q x)))
+  (list))
+
+(mk-tests-run!)

lib/minikanren/tests/not-membero.sx

@@ -0,0 +1,29 @@
+;; lib/minikanren/tests/not-membero.sx — relational "not in list".
+
+(mk-test
+  "not-membero-absent"
+  (run* q (not-membero 99 (list 1 2 3)))
+  (list (make-symbol "_.0")))
+(mk-test
+  "not-membero-present"
+  (run* q (not-membero 2 (list 1 2 3)))
+  (list))
+(mk-test
+  "not-membero-empty"
+  (run* q (not-membero 1 (list)))
+  (list (make-symbol "_.0")))
+
+(mk-test
+  "not-membero-as-filter"
+  (run*
+    q
+    (fresh
+      (x)
+      (membero
+        x
+        (list 1 2 3 4 5))
+      (not-membero x (list 2 4))
+      (== q x)))
+  (list 1 3 5))
+
+(mk-tests-run!)

lib/minikanren/tests/nub-o.sx

@@ -0,0 +1,31 @@
+;; lib/minikanren/tests/nub-o.sx — relational dedupe (keep last occurrence).
+
+(mk-test "nub-o-empty" (run* q (nub-o (list) q)) (list (list)))
+
+(mk-test
+  "nub-o-no-duplicates"
+  (run* q (nub-o (list 1 2 3) q))
+  (list (list 1 2 3)))
+
+(mk-test
+  "nub-o-with-duplicates"
+  (run*
+    q
+    (nub-o
+      (list 1 2 1 3 2 4)
+      q))
+  (list (list 1 3 2 4)))
+
+(mk-test
+  "nub-o-all-same"
+  (let
+    ((res (run* q (nub-o (list 1 1 1) q))))
+    (every? (fn (r) (= r (list 1))) res))
+  true)
+
+(mk-test
+  "nub-o-keeps-last"
+  (run* q (nub-o (list 1 2 1) q))
+  (list (list 2 1)))
+
+(mk-tests-run!)