coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mk: phase 6E — fd-lt + fd-lte + fd-eq with propagation
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 55s
Details

Browse Source 
Three more constraint goals built on the same propagator-store
machinery as fd-neq:

fd-lt: x < y. Ground/ground compares; var/num filters domain;
var/var narrows x's domain to (< y-max) and y's to (> x-min).

fd-lte: ≤ variant.

fd-eq: x = y. Ground/ground checks. Var/num: requires num to be in
var's domain (or var unconstrained) before binding. Var/var: intersect
domains, narrow both, then unify the vars.

10 new tests: narrowing against ground, ordered-pair generation,
chained x<y<z determinism, domain-sharing, out-of-domain rejection.
603/603 cumulative (100/100 across the four CLP(FD) test files).
This commit is contained in:
giles
2026-05-08 14:34:10 +00:00
parent 27637aa0f9
commit c01ddc2b23
2 changed files with 327 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

200
lib/minikanren/clpfd.sx
View File

@@ -177,7 +177,7 @@
(cond ((= s2 nil) mzero) (:else (unit s2)))))))
(:else mzero)))))))
;; --- fd-neq with propagation ---
;; --- fd-neq ---
(define
fd-neq-prop
@@ -218,6 +218,204 @@
((s3 (c s2)))
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
;; --- fd-lt ---
(define
fd-lt-prop
(fn
(x y s)
(let
((wx (mk-walk x s)) (wy (mk-walk y s)))
(cond
((and (number? wx) (number? wy))
(cond ((< wx wy) s) (:else nil)))
((and (number? wx) (is-var? wy))
(let
((yd (fd-domain-of s (var-name wy))))
(cond
((= yd nil) s)
(:else
(fd-set-domain
s
(var-name wy)
(filter (fn (v) (> v wx)) yd))))))
((and (is-var? wx) (number? wy))
(let
((xd (fd-domain-of s (var-name wx))))
(cond
((= xd nil) s)
(:else
(fd-set-domain
s
(var-name wx)
(filter (fn (v) (< v wy)) xd))))))
((and (is-var? wx) (is-var? wy))
(let
((xd (fd-domain-of s (var-name wx)))
(yd (fd-domain-of s (var-name wy))))
(cond
((or (= xd nil) (= yd nil)) s)
(:else
(let
((xd-prime (filter (fn (v) (< v (fd-dom-max yd))) xd)))
(let
((s2 (fd-set-domain s (var-name wx) xd-prime)))
(cond
((= s2 nil) nil)
(:else
(let
((yd-prime (filter (fn (v) (> v (fd-dom-min xd-prime))) yd)))
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
(:else s)))))
(define
fd-lt
(fn
(x y)
(fn
(s)
(let
((c (fn (sp) (fd-lt-prop x y sp))))
(let
((s2 (fd-add-constraint s c)))
(let
((s3 (c s2)))
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
;; --- fd-lte ---
(define
fd-lte-prop
(fn
(x y s)
(let
((wx (mk-walk x s)) (wy (mk-walk y s)))
(cond
((and (number? wx) (number? wy))
(cond ((<= wx wy) s) (:else nil)))
((and (number? wx) (is-var? wy))
(let
((yd (fd-domain-of s (var-name wy))))
(cond
((= yd nil) s)
(:else
(fd-set-domain
s
(var-name wy)
(filter (fn (v) (>= v wx)) yd))))))
((and (is-var? wx) (number? wy))
(let
((xd (fd-domain-of s (var-name wx))))
(cond
((= xd nil) s)
(:else
(fd-set-domain
s
(var-name wx)
(filter (fn (v) (<= v wy)) xd))))))
((and (is-var? wx) (is-var? wy))
(let
((xd (fd-domain-of s (var-name wx)))
(yd (fd-domain-of s (var-name wy))))
(cond
((or (= xd nil) (= yd nil)) s)
(:else
(let
((xd-prime (filter (fn (v) (<= v (fd-dom-max yd))) xd)))
(let
((s2 (fd-set-domain s (var-name wx) xd-prime)))
(cond
((= s2 nil) nil)
(:else
(let
((yd-prime (filter (fn (v) (>= v (fd-dom-min xd-prime))) yd)))
(fd-set-domain s2 (var-name wy) yd-prime))))))))))
(:else s)))))
(define
fd-lte
(fn
(x y)
(fn
(s)
(let
((c (fn (sp) (fd-lte-prop x y sp))))
(let
((s2 (fd-add-constraint s c)))
(let
((s3 (c s2)))
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
;; --- fd-eq ---
(define
fd-eq-prop
(fn
(x y s)
(let
((wx (mk-walk x s)) (wy (mk-walk y s)))
(cond
((and (number? wx) (number? wy))
(cond ((= wx wy) s) (:else nil)))
((and (number? wx) (is-var? wy))
(let
((yd (fd-domain-of s (var-name wy))))
(cond
((and (not (= yd nil)) (not (fd-dom-member? wx yd))) nil)
(:else
(let
((s2 (mk-unify wy wx s)))
(cond ((= s2 nil) nil) (:else s2)))))))
((and (is-var? wx) (number? wy))
(let
((xd (fd-domain-of s (var-name wx))))
(cond
((and (not (= xd nil)) (not (fd-dom-member? wy xd))) nil)
(:else
(let
((s2 (mk-unify wx wy s)))
(cond ((= s2 nil) nil) (:else s2)))))))
((and (is-var? wx) (is-var? wy))
(let
((xd (fd-domain-of s (var-name wx)))
(yd (fd-domain-of s (var-name wy))))
(cond
((and (= xd nil) (= yd nil))
(let
((s2 (mk-unify wx wy s)))
(cond ((= s2 nil) nil) (:else s2))))
(:else
(let
((shared (cond ((= xd nil) yd) ((= yd nil) xd) (:else (fd-dom-intersect xd yd)))))
(cond
((fd-dom-empty? shared) nil)
(:else
(let
((s2 (fd-set-domain s (var-name wx) shared)))
(cond
((= s2 nil) nil)
(:else
(let
((s3 (fd-set-domain s2 (var-name wy) shared)))
(cond
((= s3 nil) nil)
(:else (mk-unify wx wy s3))))))))))))))
(:else s)))))
(define
fd-eq
(fn
(x y)
(fn
(s)
(let
((c (fn (sp) (fd-eq-prop x y sp))))
(let
((s2 (fd-add-constraint s c)))
(let
((s3 (c s2)))
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
;; --- labelling ---
(define