mk: phase 4A — appendo canary green, both directions
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:
2026-05-07 20:24:42 +00:00
parent 52070e07fc
commit cae87c1e2c
10 changed files with 511 additions and 164 deletions

View File

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