giles
c71da0e1cf
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 58s
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.
126 lines
3.0 KiB
Plaintext
126 lines
3.0 KiB
Plaintext
;; 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))))))))
|