mk: phase 4A — appendo canary green, both directions
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
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.
This commit is contained in:
@@ -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)))))
|
||||
|
||||
@@ -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
|
||||
|
||||
51
lib/minikanren/relations.sx
Normal file
51
lib/minikanren/relations.sx
Normal file
@@ -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))))))
|
||||
@@ -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)))))))
|
||||
|
||||
@@ -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!)
|
||||
|
||||
@@ -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!)
|
||||
|
||||
@@ -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!)
|
||||
|
||||
175
lib/minikanren/tests/relations.sx
Normal file
175
lib/minikanren/tests/relations.sx
Normal file
@@ -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!)
|
||||
@@ -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)))))
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user