rose-ash/lib/minikanren/clpfd.sx

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

(define
  fd-in
  (fn
    (x dom-list)
    (fn
      (s)
      (let
        ((new-dom (fd-dom-from-list dom-list)))
        (let
          ((wx (mk-walk x s)))
          (cond
            ((number? wx)
              (cond ((fd-dom-member? wx new-dom) (unit s)) (:else mzero)))
            ((is-var? wx)
              (let
                ((existing (fd-domain-of s (var-name wx))))
                (let
                  ((narrowed (cond ((= existing nil) new-dom) (:else (fd-dom-intersect existing new-dom)))))
                  (let
                    ((s2 (fd-set-domain s (var-name wx) narrowed)))
                    (cond ((= s2 nil) mzero) (:else (unit s2)))))))
            (:else mzero)))))))

(define
  fd-try-each-value
  (fn
    (x dom s)
    (cond
      ((empty? dom) mzero)
      (:else
        (let
          ((s2 (mk-unify x (first dom) s)))
          (let
            ((this-stream (cond ((= s2 nil) mzero) (:else (unit s2))))
              (rest-stream (fd-try-each-value x (rest dom) s)))
            (mk-mplus this-stream rest-stream)))))))

(define
  fd-label-one
  (fn
    (x)
    (fn
      (s)
      (let
        ((wx (mk-walk x s)))
        (cond
          ((number? wx) (unit s))
          ((is-var? wx)
            (let
              ((dom (fd-domain-of s (var-name wx))))
              (cond
                ((= dom nil) mzero)
                (:else (fd-try-each-value wx dom s)))))
          (:else mzero))))))

(define
  fd-label
  (fn
    (vars)
    (cond
      ((empty? vars) succeed)
      (:else (mk-conj (fd-label-one (first vars)) (fd-label (rest vars)))))))