From c71da0e1cf0f58cdaf4d79d6cc4df4fba7289911 Mon Sep 17 00:00:00 2001
From: giles <giles.bradshaw@rose-ash.com>
Date: Fri, 8 May 2026 14:06:19 +0000
Subject: [PATCH] =?UTF-8?q?mk:=20phase=206B=20=E2=80=94=20clpfd.sx=20domai?=
 =?UTF-8?q?n=20primitives?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Foundation for native CLP(FD). The substitution dict carries a reserved
"_fd" key holding a constraint store:
  {:domains {var-name -> sorted-int-list}
   :constraints (... pending constraints ...)}

This commit ships only the domain machinery + accessors:
  fd-dom-from-list / fd-dom-range / fd-dom-empty? / fd-dom-singleton?
  fd-dom-min / fd-dom-max / fd-dom-member? / fd-dom-intersect /
  fd-dom-without

  fd-store-of / fd-domain-of / fd-set-domain / fd-with-store

fd-set-domain returns nil when the domain becomes empty (failure),
which is the wire signal subsequent constraint goals will consume.
The constraints field is reserved for the next iteration.

26 new tests, 577/577 cumulative.
---
 lib/minikanren/clpfd.sx               | 125 ++++++++++++++++++++++++
 lib/minikanren/tests/clpfd-domains.sx | 133 ++++++++++++++++++++++++++
 2 files changed, 258 insertions(+)
 create mode 100644 lib/minikanren/clpfd.sx
 create mode 100644 lib/minikanren/tests/clpfd-domains.sx

diff --git a/lib/minikanren/clpfd.sx b/lib/minikanren/clpfd.sx
new file mode 100644
index 00000000..0b9134ee
--- /dev/null
+++ b/lib/minikanren/clpfd.sx
@@ -0,0 +1,125 @@
+;; lib/minikanren/clpfd.sx — Phase 6 piece B: CLP(FD) foundation.
+;;
+;; A finite-domain layer on top of the existing miniKanren machinery. The
+;; substitution dict carries an extra reserved key "_fd" that holds a
+;; constraint-store record:
+;;
+;;   {:domains    {var-name -> sorted-int-list}
+;;    :constraints (... pending constraints ...)}
+;;
+;; Domains are sorted SX lists of ints (no duplicates). The constraints
+;; field is reserved for later iterations; this commit ships only the
+;; domain machinery + accessors.
+;;
+;; Naming: fd-* (domain primitives, kernel-style).
+
+(define fd-key "_fd")
+
+(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))))))
+
+(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))))))))
diff --git a/lib/minikanren/tests/clpfd-domains.sx b/lib/minikanren/tests/clpfd-domains.sx
new file mode 100644
index 00000000..a43a7270
--- /dev/null
+++ b/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!)