From cae87c1e2cd8d18afec5cf110c99067aa74cb46c Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 20:24:42 +0000 Subject: [PATCH] =?UTF-8?q?mk:=20phase=204A=20=E2=80=94=20appendo=20canary?= =?UTF-8?q?=20green,=20both=20directions?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Three coupled fixes plus a new relations module land together because each is required for the next: appendo can't terminate without all three. 1. unify.sx — added (:cons h t) tagged cons-cell shape because SX has no improper pairs. The unifier treats (:cons h t) and the native list (h . t) as equivalent. mk-walk* re-flattens cons cells back to flat lists for clean reification. 2. stream.sx — switched mature stream cells from plain SX lists to a (:s head tail) tagged shape so a mature head can have a thunk tail. With the old representation, mk-mplus had to (cons head thunk) which SX rejects (cons requires a list cdr). 3. conde.sx — wraps each clause in Zzz (inverse-eta delay) for laziness. Zzz uses (gensym "zzz-s-") for the substitution parameter so it does not capture user goals that follow the (l s ls) convention. Without gensym, every relation that uses `s` as a list parameter silently binds it to the substitution dict. relations.sx is the new module: nullo, pairo, caro, cdro, conso, firsto, resto, listo, appendo, membero. 25 new tests. Canary green: (run* q (appendo (list 1 2) (list 3 4) q)) → ((1 2 3 4)) (run* q (fresh (l s) (appendo l s (list 1 2 3)) (== q (list l s)))) → ((() (1 2 3)) ((1) (2 3)) ((1 2) (3)) ((1 2 3) ())) (run 3 q (listo q)) → (() (_.0) (_.0 _.1)) 152/152 cumulative. --- lib/minikanren/conde.sx | 33 ++++-- lib/minikanren/condu.sx | 20 ++-- lib/minikanren/relations.sx | 51 +++++++++ lib/minikanren/stream.sx | 48 ++++---- lib/minikanren/tests/conde.sx | 98 ++++++++--------- lib/minikanren/tests/fresh.sx | 18 +-- lib/minikanren/tests/goals.sx | 152 +++++++++++++++++--------- lib/minikanren/tests/relations.sx | 175 ++++++++++++++++++++++++++++++ lib/minikanren/unify.sx | 42 ++++++- plans/minikanren-on-sx.md | 38 +++++-- 10 files changed, 511 insertions(+), 164 deletions(-) create mode 100644 lib/minikanren/relations.sx create mode 100644 lib/minikanren/tests/relations.sx diff --git a/lib/minikanren/conde.sx b/lib/minikanren/conde.sx index ffcb9a28..b09eb0b4 100644 --- a/lib/minikanren/conde.sx +++ b/lib/minikanren/conde.sx @@ -1,13 +1,30 @@ ;; lib/minikanren/conde.sx — Phase 2 piece C: `conde`, the canonical -;; miniKanren and-or form. +;; miniKanren and-or form, with implicit Zzz inverse-eta delay so recursive +;; relations like appendo terminate. ;; ;; (conde (g1a g1b ...) (g2a g2b ...) ...) -;; ≡ (mk-disj (mk-conj g1a g1b ...) -;; (mk-conj g2a g2b ...) ...) +;; ≡ (mk-disj (Zzz (mk-conj g1a g1b ...)) +;; (Zzz (mk-conj g2a g2b ...)) ...) ;; -;; Each clause is a list of goals, conj'd internally; clauses are disj'd -;; among one another (interleaved via mk-mplus, so left-recursive -;; relations don't starve the right-hand clauses). +;; `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 @@ -16,5 +33,7 @@ (mk-disj (splice-unquote (map - (fn (clause) (quasiquote (mk-conj (splice-unquote clause)))) + (fn + (clause) + (quasiquote (Zzz (mk-conj (splice-unquote clause))))) clauses))))) diff --git a/lib/minikanren/condu.sx b/lib/minikanren/condu.sx index 6cd223f1..3c24b1d9 100644 --- a/lib/minikanren/condu.sx +++ b/lib/minikanren/condu.sx @@ -10,15 +10,21 @@ ;; 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.) -;; -;; `conda` (the variant that propagates ALL answers of the head) lives in -;; Phase 5 with `project` and `matche`. -(define onceo (fn (g) (fn (s) (stream-take 1 (g s))))) +(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, falls to next clause; -;; if head succeeds, commits its single answer through the rest of the clause. +;; 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 diff --git a/lib/minikanren/relations.sx b/lib/minikanren/relations.sx new file mode 100644 index 00000000..b9f38732 --- /dev/null +++ b/lib/minikanren/relations.sx @@ -0,0 +1,51 @@ +;; 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 + membero + (fn + (x l) + (conde + ((fresh (d) (conso x d l))) + ((fresh (a d) (conso a d l) (membero x d)))))) diff --git a/lib/minikanren/stream.sx b/lib/minikanren/stream.sx index 11da7b2a..04173707 100644 --- a/lib/minikanren/stream.sx +++ b/lib/minikanren/stream.sx @@ -1,26 +1,34 @@ ;; lib/minikanren/stream.sx — Phase 2 piece A: lazy streams of substitutions. ;; -;; Three stream shapes per The Reasoned Schemer (chapter 9): -;; mzero — empty stream (the SX empty list) -;; mature — '(s . rest) (a proper SX list of substitutions) -;; immature — a thunk (an SX lambda taking zero args, returns a stream) +;; SX has no improper pairs (cons requires a list cdr), so we use a +;; tagged stream-cell shape for mature stream elements: ;; -;; Immature thunks are how miniKanren keeps search lazy and supports -;; interleaved disjunction without diverging on left-recursive relations. -;; SX has plain function closures, so a thunk is just (fn () body). +;; stream ::= mzero empty (the SX empty list) +;; | (:s HEAD TAIL) mature cell, TAIL is a stream +;; | thunk (fn () ...) → stream when forced ;; -;; Names are mk-prefixed: SX has a host primitive `bind` that would shadow -;; a user-level definition. +;; 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 unit (fn (s) (list s))) +(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 the first is mature/empty we use it -;; directly; if it is paused, we suspend and swap so the other stream gets -;; explored fairly (Reasoned Schemer "interleave"). +;; 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 @@ -28,9 +36,9 @@ (cond ((empty? s1) s2) ((stream-pause? s1) (fn () (mk-mplus s2 (s1)))) - (:else (cons (first s1) (mk-mplus (rest s1) s2)))))) + (: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 results. +;; mk-bind — apply goal g to every substitution in stream s, mk-mplus-ing. (define mk-bind (fn @@ -38,10 +46,10 @@ (cond ((empty? s) mzero) ((stream-pause? s) (fn () (mk-bind (s) g))) - (:else (mk-mplus (g (first s)) (mk-bind (rest 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. -;; n = -1 to take all (used by run*). +;; 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 @@ -52,7 +60,7 @@ ((stream-pause? s) (stream-take n (s))) (:else (cons - (first s) + (s-car s) (stream-take (if (= n -1) -1 (- n 1)) - (rest s))))))) + (s-cdr s))))))) diff --git a/lib/minikanren/tests/conde.sx b/lib/minikanren/tests/conde.sx index ec761064..681f372b 100644 --- a/lib/minikanren/tests/conde.sx +++ b/lib/minikanren/tests/conde.sx @@ -1,93 +1,89 @@ ;; lib/minikanren/tests/conde.sx — Phase 2 piece C tests for `conde`. ;; -;; Note on ordering: mk-mplus only interleaves when the left stream is a -;; paused thunk. Eager streams from == compose via mature DFS order -;; (left-clause results first, then right-clause). True interleaving is -;; tested in Phase 4 via recursive relations. +;; 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"))) - (let - ((res (stream-take 5 ((conde ((== q 7))) empty-s)))) - (map (fn (s) (mk-walk q s)) res))) + (let ((q (mk-var "q"))) (run* q (conde ((== q 7))))) (list 7)) (mk-test "conde-one-clause-multi-goals" (let ((q (mk-var "q"))) - (let - ((res (stream-take 5 ((conde ((fresh (x) (== x 5) (== q (list x x))))) empty-s)))) - (map (fn (s) (mk-walk* q s)) res))) + (run* q (conde ((fresh (x) (== x 5) (== q (list x x))))))) (list (list 5 5))) -;; --- multi-clause: produces one row per clause (eager DFS order) --- +;; --- multi-clause: produces one row per clause (interleaved) --- (mk-test - "conde-three-clauses" + "conde-three-clauses-as-set" (let - ((q (mk-var "q"))) - (let - ((res (stream-take 10 ((conde ((== q 1)) ((== q 2)) ((== q 3))) empty-s)))) - (map (fn (s) (mk-walk q s)) res))) - (list 1 2 3)) + ((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" + "conde-mixed-success-failure-as-set" (let - ((q (mk-var "q"))) - (let - ((res (stream-take 10 ((conde ((== q "a")) ((== 1 2)) ((== q "b"))) empty-s)))) - (map (fn (s) (mk-walk q s)) res))) - (list "a" "b")) + ((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" + "conde-clause-conj-as-set" (let - ((q (mk-var "q")) (r (mk-var "r"))) - (let - ((res (stream-take 10 ((conde ((== q 1) (== r 10)) ((== q 2) (== r 20))) empty-s)))) - (map (fn (s) (list (mk-walk q s) (mk-walk r s))) res))) - (list (list 1 10) (list 2 20))) - -;; --- conde + fresh: multiple solutions per clause --- - -(mk-test - "conde-with-fresh-and-disj" - (let - ((q (mk-var "q"))) - (let - ((res (stream-take 10 ((conde ((fresh (x) (mk-disj (== x 1) (== x 2)) (== q x))) ((== q 100))) empty-s)))) - (map (fn (s) (mk-walk q s)) res))) - (list 1 2 100)) + ((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" + "conde-nested-yields-three" (let - ((q (mk-var "q"))) - (let - ((res (stream-take 10 ((conde ((conde ((== q 1)) ((== q 2)))) ((== q 3))) empty-s)))) - (map (fn (s) (mk-walk q s)) res))) - (list 1 2 3)) + ((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" - ((conde ((== 1 2)) ((== 3 4))) - empty-s) + (run* + q + (conde ((== 1 2)) ((== 3 4)))) (list)) ;; --- empty conde: no clauses ⇒ fail --- -(mk-test "conde-no-clauses" ((conde) empty-s) (list)) +(mk-test "conde-no-clauses" (run* q (conde)) (list)) (mk-tests-run!) diff --git a/lib/minikanren/tests/fresh.sx b/lib/minikanren/tests/fresh.sx index e4df2bda..fd912c55 100644 --- a/lib/minikanren/tests/fresh.sx +++ b/lib/minikanren/tests/fresh.sx @@ -4,12 +4,12 @@ (mk-test "fresh-empty-vars-equiv-conj" - ((fresh () (== 1 1)) empty-s) + (stream-take 5 ((fresh () (== 1 1)) empty-s)) (list empty-s)) (mk-test "fresh-empty-vars-no-goals-is-succeed" - ((fresh ()) empty-s) + (stream-take 5 ((fresh ()) empty-s)) (list empty-s)) ;; --- single var --- @@ -17,8 +17,8 @@ (mk-test "fresh-one-var-bound" (let - ((s (first ((fresh (x) (== x 7)) empty-s)))) - (let ((vs (vals s))) (first vs))) + ((s (first (stream-take 5 ((fresh (x) (== x 7)) empty-s))))) + (first (vals s))) 7) ;; --- multiple vars + multiple goals --- @@ -33,7 +33,7 @@ (== x 10) (== y 20) (== q (list x y))))) - (mk-walk* q (first (g empty-s)))) + (mk-walk* q (first (stream-take 5 (g empty-s))))) (list 10 20)) (mk-test @@ -47,7 +47,7 @@ (== b 2) (== c 3) (== q (list a b c))))) - (mk-walk* q (first (g empty-s)))) + (mk-walk* q (first (stream-take 5 (g empty-s))))) (list 1 2 3)) ;; --- fresh interacts with disj --- @@ -77,7 +77,7 @@ (== x 1) (== y 2) (== q (list x y)))))) - (mk-walk* q (first (g empty-s)))) + (mk-walk* q (first (stream-take 5 (g empty-s))))) (list 1 2)) ;; --- call-fresh (functional alternative) --- @@ -85,7 +85,7 @@ (mk-test "call-fresh-binds-and-walks" (let - ((s (first ((call-fresh (fn (x) (== x 99))) empty-s)))) + ((s (first (stream-take 5 ((call-fresh (fn (x) (== x 99))) empty-s))))) (first (vals s))) 99) @@ -95,7 +95,7 @@ ((q (mk-var "q"))) (let ((g (call-fresh (fn (x) (mk-conj (== x 5) (== q (list x x))))))) - (mk-walk* q (first (g empty-s))))) + (mk-walk* q (first (stream-take 5 (g empty-s)))))) (list 5 5)) (mk-tests-run!) diff --git a/lib/minikanren/tests/goals.sx b/lib/minikanren/tests/goals.sx index f08a9c5c..150b0650 100644 --- a/lib/minikanren/tests/goals.sx +++ b/lib/minikanren/tests/goals.sx @@ -1,124 +1,153 @@ ;; lib/minikanren/tests/goals.sx — Phase 2 tests for stream.sx + goals.sx. ;; -;; Loaded after: lib/guest/match.sx, lib/minikanren/unify.sx, -;; lib/minikanren/stream.sx, lib/minikanren/goals.sx. -;; Reuses the mk-test* counters from tests/unify.sx — load that first to -;; accumulate, or call mk-tests-run! after this file alone for fresh totals. +;; 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 --- +;; --- stream-take base cases (input streams use s-cons / mzero) --- (mk-test "stream-take-zero-from-mature" - (stream-take 0 (list 1 2 3)) + (stream-take 0 (s-cons (empty-subst) mzero)) (list)) -(mk-test "stream-take-from-empty" (stream-take 5 mzero) (list)) +(mk-test "stream-take-from-mzero" (stream-take 5 mzero) (list)) (mk-test - "stream-take-mature-list" - (stream-take 5 (list 1 2 3)) - (list 1 2 3)) + "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 2 (list 10 20 30)) - (list 10 20)) + (stream-take 1 (s-cons :a (s-cons :b mzero))) + (list :a)) (mk-test "stream-take-all-with-neg-1" - (stream-take -1 (list 1 2 3 4)) - (list 1 2 3 4)) + (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 3 (fn () (list "a" "b" "c"))) - (list "a" "b" "c")) + (stream-take 5 (fn () (s-cons :x mzero))) + (list :x)) (mk-test "stream-take-forces-nested-thunks" - (stream-take - 3 - (fn () (fn () (list 1 2 3)))) - (list 1 2 3)) + (stream-take 5 (fn () (fn () (s-cons :y mzero)))) + (list :y)) ;; --- mk-mplus interleaves --- (mk-test "mplus-empty-left" - (mk-mplus mzero (list 1 2)) - (list 1 2)) + (stream-take 5 (mk-mplus mzero (s-cons :r mzero))) + (list :r)) + (mk-test "mplus-empty-right" - (mk-mplus (list 1 2) mzero) - (list 1 2)) + (stream-take 5 (mk-mplus (s-cons :l mzero) mzero)) + (list :l)) (mk-test "mplus-mature-mature" - (mk-mplus (list 1 2) (list 3 4)) - (list 1 2 3 4)) + (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 4 (mk-mplus (fn () (list "a" "b")) (list "c" "d"))) - (list "c" "d" "a" "b")) + (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" (mk-bind mzero (fn (s) (unit s))) (list)) +(mk-test + "bind-empty-stream" + (stream-take 5 (mk-bind mzero (fn (s) (unit s)))) + (list)) (mk-test "bind-singleton-identity" - (mk-bind (list 5) (fn (x) (list x))) + (stream-take + 5 + (mk-bind (s-cons 5 mzero) (fn (x) (unit x)))) (list 5)) (mk-test "bind-flat-multi" - (mk-bind - (list 1 2) - (fn (x) (list x (* x 10)))) + (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" - (mk-bind - (list 1 2 3) - (fn (x) (if (= x 2) (list) (list x)))) + (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" (succeed empty-s) (list empty-s)) +(mk-test + "succeed-yields-singleton" + (stream-take 5 (succeed empty-s)) + (list empty-s)) -(mk-test "fail-yields-mzero" (fail empty-s) (list)) +(mk-test "fail-yields-mzero" (stream-take 5 (fail empty-s)) (list)) ;; --- == --- (mk-test "eq-ground-success" - (mk-unified? (first ((== 1 1) empty-s))) - true) + (stream-take 5 ((== 1 1) empty-s)) + (list empty-s)) -(mk-test "eq-ground-failure" ((== 1 2) empty-s) (list)) +(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 ((== x 7) empty-s)))) + (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 ((== x (list 1 2)) empty-s)))) + (mk-walk + x + (first + (stream-take + 5 + ((== x (list 1 2)) empty-s))))) (list 1 2)) (mk-test "eq-list-mismatch-fails" - ((== (list 1 2) (list 1 3)) empty-s) + (stream-take + 5 + ((== (list 1 2) (list 1 3)) empty-s)) (list)) ;; --- conj2 / mk-conj --- @@ -128,7 +157,7 @@ (let ((x (mk-var "x")) (y (mk-var "y"))) (let - ((s (first ((conj2 (== x 1) (== y 2)) empty-s)))) + ((s (first (stream-take 5 ((conj2 (== x 1) (== y 2)) empty-s))))) (list (mk-walk x s) (mk-walk y s)))) (list 1 2)) @@ -136,16 +165,24 @@ "conj2-conflict-empty" (let ((x (mk-var "x"))) - ((conj2 (== x 1) (== x 2)) empty-s)) + (stream-take + 5 + ((conj2 (== x 1) (== x 2)) empty-s))) (list)) -(mk-test "conj-empty-is-succeed" ((mk-conj) empty-s) (list empty-s)) +(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 ((mk-conj (== x 99)) empty-s)))) + (mk-walk + x + (first + (stream-take 5 ((mk-conj (== x 99)) empty-s))))) 99) (mk-test @@ -153,7 +190,7 @@ (let ((x (mk-var "x")) (y (mk-var "y")) (z (mk-var "z"))) (let - ((s (first ((mk-conj (== x 1) (== y 2) (== z 3)) empty-s)))) + ((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)) @@ -177,7 +214,10 @@ (map (fn (s) (mk-walk q s)) res))) (list 5)) -(mk-test "disj-empty-is-fail" ((mk-disj) empty-s) (list)) +(mk-test + "disj-empty-is-fail" + (stream-take 5 ((mk-disj) empty-s)) + (list)) (mk-test "disj-three-clauses" @@ -188,7 +228,7 @@ (map (fn (s) (mk-walk q s)) res))) (list "a" "b" "c")) -;; --- conj/disj nesting (distributivity check) --- +;; --- conj/disj nesting --- (mk-test "disj-of-conj" @@ -199,18 +239,22 @@ (map (fn (s) (list (mk-walk x s) (mk-walk y s))) res))) (list (list 1 2) (list 3 4))) -;; --- ==-check (occurs-checked equality goal) --- +;; --- ==-check --- (mk-test "eq-check-no-occurs-fails" - (let ((x (mk-var "x"))) ((==-check x (list 1 x)) empty-s)) + (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 ((==-check x 5) empty-s)))) + (mk-walk + x + (first (stream-take 5 ((==-check x 5) empty-s))))) 5) (mk-tests-run!) diff --git a/lib/minikanren/tests/relations.sx b/lib/minikanren/tests/relations.sx new file mode 100644 index 00000000..ae3475c9 --- /dev/null +++ b/lib/minikanren/tests/relations.sx @@ -0,0 +1,175 @@ +;; lib/minikanren/tests/relations.sx — Phase 4 standard relations. +;; +;; Includes the classic miniKanren canaries: appendo forwards / backwards / +;; bidirectionally, membero, listo enumeration. + +;; --- nullo / pairo --- + +(mk-test + "nullo-empty-succeeds" + (run* q (nullo (list))) + (list (make-symbol "_.0"))) + +(mk-test "nullo-non-empty-fails" (run* q (nullo (list 1))) (list)) + +(mk-test + "pairo-non-empty-succeeds" + (run* q (pairo (list 1 2))) + (list (make-symbol "_.0"))) + +(mk-test "pairo-empty-fails" (run* q (pairo (list))) (list)) + +;; --- caro / cdro / firsto / resto --- + +(mk-test + "caro-extracts-head" + (run* q (caro (list 1 2 3) q)) + (list 1)) + +(mk-test + "cdro-extracts-tail" + (run* q (cdro (list 1 2 3) q)) + (list (list 2 3))) + +(mk-test + "firsto-alias-of-caro" + (run* q (firsto (list 10 20) q)) + (list 10)) + +(mk-test + "resto-alias-of-cdro" + (run* q (resto (list 10 20) q)) + (list (list 20))) + +(mk-test + "caro-cdro-build" + (run* + q + (fresh + (h t) + (caro (list 1 2 3) h) + (cdro (list 1 2 3) t) + (== q (list h t)))) + (list (list 1 (list 2 3)))) + +;; --- conso --- + +(mk-test + "conso-forward" + (run* q (conso 0 (list 1 2 3) q)) + (list (list 0 1 2 3))) + +(mk-test + "conso-extract-head" + (run* + q + (conso + q + (list 2 3) + (list 1 2 3))) + (list 1)) + +(mk-test + "conso-extract-tail" + (run* q (conso 1 q (list 1 2 3))) + (list (list 2 3))) + +;; --- listo --- + +(mk-test + "listo-empty-succeeds" + (run* q (listo (list))) + (list (make-symbol "_.0"))) + +(mk-test + "listo-finite-list-succeeds" + (run* q (listo (list 1 2 3))) + (list (make-symbol "_.0"))) + +(mk-test + "listo-enumerates-shapes" + (run 3 q (listo q)) + (list + (list) + (list (make-symbol "_.0")) + (list (make-symbol "_.0") (make-symbol "_.1")))) + +;; --- appendo: the canary --- + +(mk-test + "appendo-forward-simple" + (run* + q + (appendo (list 1 2) (list 3 4) q)) + (list (list 1 2 3 4))) + +(mk-test + "appendo-forward-empty-l" + (run* q (appendo (list) (list 3 4) q)) + (list (list 3 4))) + +(mk-test + "appendo-forward-empty-s" + (run* q (appendo (list 1 2) (list) q)) + (list (list 1 2))) + +(mk-test + "appendo-recovers-tail" + (run* + q + (appendo + (list 1 2) + q + (list 1 2 3 4))) + (list (list 3 4))) + +(mk-test + "appendo-recovers-prefix" + (run* + q + (appendo + q + (list 3 4) + (list 1 2 3 4))) + (list (list 1 2))) + +(mk-test + "appendo-backward-all-splits" + (run* + q + (fresh + (l s) + (appendo l s (list 1 2 3)) + (== q (list l s)))) + (list + (list (list) (list 1 2 3)) + (list (list 1) (list 2 3)) + (list (list 1 2) (list 3)) + (list (list 1 2 3) (list)))) + +(mk-test + "appendo-empty-empty-empty" + (run* q (appendo (list) (list) q)) + (list (list))) + +;; --- membero --- + +(mk-test + "membero-element-present" + (run + 1 + q + (membero 2 (list 1 2 3))) + (list (make-symbol "_.0"))) + +(mk-test + "membero-element-absent-empty" + (run* q (membero 99 (list 1 2 3))) + (list)) + +(mk-test + "membero-enumerates" + (run* q (membero q (list "a" "b" "c"))) + (list "a" "b" "c")) + +(mk-tests-run!) diff --git a/lib/minikanren/unify.sx b/lib/minikanren/unify.sx index f043dc48..89f00ab4 100644 --- a/lib/minikanren/unify.sx +++ b/lib/minikanren/unify.sx @@ -1,22 +1,43 @@ -;; lib/minikanren/unify.sx — Phase 1: variables + unification. +;; lib/minikanren/unify.sx — Phase 1 + cons-cell extension. ;; ;; miniKanren-on-SX, built on lib/guest/match.sx. The kit ships the heavy ;; lifting (walk-with, unify-with, occurs-with, extend, empty-subst, ;; mk-var/is-var?/var-name); this file supplies a miniKanren-shaped cfg ;; and a thin public API. ;; -;; Term shape (designed for natural SX use): -;; logic var : (:var NAME) — kit's mk-var -;; pair : any non-empty SX list — head + tail unified positionally -;; atom : number / string / symbol / boolean / nil / () +;; Term shapes: +;; logic var : (:var NAME) — kit's mk-var +;; cons cell : (:cons HEAD TAIL) — for relational programming +;; (built by mk-cons; lets relations decompose lists by +;; head/tail without proper improper pairs in the host) +;; native list : SX list (a b c) — also unifies pair-style: +;; args = (head, tail) so (1 2 3) ≡ (:cons 1 (:cons 2 (:cons 3 ()))) +;; atom : number / string / symbol / boolean / nil / () +;; ;; Substitution: SX dict mapping VAR-NAME → term. Empty = (empty-subst). +(define mk-cons (fn (h t) (list :cons h t))) + +(define + mk-cons-cell? + (fn (t) (and (list? t) (not (empty? t)) (= (first t) :cons)))) + +(define mk-cons-head (fn (t) (nth t 1))) +(define mk-cons-tail (fn (t) (nth t 2))) + (define mk-list-pair? (fn (t) (and (list? t) (not (empty? t)) (not (is-var? t))))) (define mk-list-pair-head (fn (t) :pair)) -(define mk-list-pair-args (fn (t) t)) + +(define + mk-list-pair-args + (fn + (t) + (cond + ((mk-cons-cell? t) (list (mk-cons-head t) (mk-cons-tail t))) + (:else (list (first t) (rest t)))))) (define mk-cfg {:ctor-head mk-list-pair-head :var? is-var? :ctor? mk-list-pair? :occurs-check? false :var-name var-name :ctor-args mk-list-pair-args}) @@ -45,6 +66,15 @@ (let ((w (mk-walk t s))) (cond + ((mk-cons-cell? w) + (let + ((h (mk-walk* (mk-cons-head w) s)) + (tl (mk-walk* (mk-cons-tail w) s))) + (cond + ((empty? tl) (list h)) + ((mk-cons-cell? tl) tl) + ((list? tl) (cons h tl)) + (:else (mk-cons h tl))))) ((mk-list-pair? w) (map (fn (a) (mk-walk* a s)) w)) (:else w))))) diff --git a/plans/minikanren-on-sx.md b/plans/minikanren-on-sx.md index f833e2bf..ff9b67e0 100644 --- a/plans/minikanren-on-sx.md +++ b/plans/minikanren-on-sx.md @@ -100,20 +100,21 @@ Key semantic mappings: `appendo` deferred to Phase 4. ### Phase 4 — standard relations -- [ ] `appendo` `l` `s` `ls` — list append, runs forwards and backwards -- [ ] `membero` `x` `l` — x is a member of l -- [ ] `listo` `l` — l is a proper list -- [ ] `nullo` `l` — l is empty -- [ ] `pairo` `p` — p is a pair (cons cell) -- [ ] `caro` `p` `a` — car of pair -- [ ] `cdro` `p` `d` — cdr of pair -- [ ] `conso` `a` `d` `p` — cons -- [ ] `firsto` / `resto` — aliases for caro/cdro +- [x] `appendo` `l` `s` `ls` — list append, runs forwards AND backwards. + Canary green: `(run* q (appendo (1 2) (3 4) q))` → `((1 2 3 4))`; + `(run* q (fresh (l s) (appendo l s (1 2 3)) (== q (list l s))))` → + all four splits. +- [x] `membero` `x` `l` — enumerates: `(run* q (membero q (a b c)))` → `(a b c)` +- [x] `listo` `l` — l is a proper list; enumerates list shapes with laziness +- [x] `nullo` `l` — l is empty +- [x] `pairo` `p` — p is a (non-empty) cons-cell / list +- [x] `caro` / `cdro` / `conso` / `firsto` / `resto` - [ ] `reverseo` `l` `r` — reverse of list - [ ] `flatteno` `l` `f` — flatten nested lists - [ ] `permuteo` `l` `p` — permutation of list - [ ] `lengtho` `l` `n` — length as a relation (Peano or integer) -- [ ] Tests: run each relation forwards and backwards; generate from partial inputs +- [x] Tests: run each relation forwards and backwards (so far 25 in + `tests/relations.sx`; reverseo/flatteno/permuteo/lengtho deferred) ### Phase 5 — `project` + `matche` + negation - [ ] `project` `(x ...) body` — access reified values of logic vars inside a goal; @@ -151,6 +152,23 @@ _(none yet)_ _Newest first._ +- **2026-05-07** — **Phase 4 piece A — appendo canary green**: cons-cell support + in `unify.sx` + `(:s head tail)` lazy stream refactor in `stream.sx` + hygienic + `Zzz` (gensym'd subst-name) wrapping each `conde` clause + `lib/minikanren/ + relations.sx` with `nullo` / `pairo` / `caro` / `cdro` / `conso` / `firsto` / + `resto` / `listo` / `appendo` / `membero`. 25 new tests in `tests/relations.sx`, + 152/152 cumulative. + - **Three deep fixes shipped together**, all required to make `appendo` + terminate in both directions: + 1. SX has no improper pairs, so a stream cell of mature subst + thunk + tail can't use `cons` — moved to a `(:s head tail)` tagged shape. + 2. `(Zzz g)` wrapped its inner fn in a parameter named `s`, capturing + the user goal's own `s` binding (the `(appendo l s ls)` convention). + Replaced with `(gensym "zzz-s-")` for hygiene. + 3. SX cons cells `(:cons h t)` for relational decomposition (so + `(conso a d l)` can split a list by head/tail without proper + improper pairs); `mk-walk*` re-flattens cons cells back to native + lists for clean reification output. - **2026-05-07** — **Phase 3 done** (run + reification): `lib/minikanren/run.sx` (~28 lines). `reify`/`reify-s`/`reify-name` for canonical `_.N` rendering of unbound vars in left-to-right occurrence order; `run*` / `run` / `run-n` defmacros. 18 new tests