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