mk: phase 6H — fd-times (x * y = z)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
Ground-cases propagator parallel to fd-plus. Division back-direction checks (mod z x) = 0 before recovering a divisor. Edge cases: multiplying by zero binds the product to zero; with z=0 and one factor zero, the other factor is unconstrained. 7 tests including divisor enumeration, square-of-each, divisibility rejection. 624/624 cumulative.
This commit is contained in:
@@ -534,3 +534,42 @@
|
|||||||
(let
|
(let
|
||||||
((s3 (c s2)))
|
((s3 (c s2)))
|
||||||
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||||
|
|
||||||
|
;; --- fd-times (x * y = z, ground-cases propagator) ---
|
||||||
|
|
||||||
|
(define
|
||||||
|
fd-times-prop
|
||||||
|
(fn
|
||||||
|
(x y z s)
|
||||||
|
(let
|
||||||
|
((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
|
||||||
|
(cond
|
||||||
|
((and (number? wx) (number? wy) (number? wz))
|
||||||
|
(cond ((= (* wx wy) wz) s) (:else nil)))
|
||||||
|
((and (number? wx) (number? wy))
|
||||||
|
(fd-bind-or-narrow wz (* wx wy) s))
|
||||||
|
((and (number? wx) (number? wz))
|
||||||
|
(cond
|
||||||
|
((= wx 0) (cond ((= wz 0) s) (:else nil)))
|
||||||
|
((not (= (mod wz wx) 0)) nil)
|
||||||
|
(:else (fd-bind-or-narrow wy (/ wz wx) s))))
|
||||||
|
((and (number? wy) (number? wz))
|
||||||
|
(cond
|
||||||
|
((= wy 0) (cond ((= wz 0) s) (:else nil)))
|
||||||
|
((not (= (mod wz wy) 0)) nil)
|
||||||
|
(:else (fd-bind-or-narrow wx (/ wz wy) s))))
|
||||||
|
(:else s)))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
fd-times
|
||||||
|
(fn
|
||||||
|
(x y z)
|
||||||
|
(fn
|
||||||
|
(s)
|
||||||
|
(let
|
||||||
|
((c (fn (sp) (fd-times-prop x y z sp))))
|
||||||
|
(let
|
||||||
|
((s2 (fd-add-constraint s c)))
|
||||||
|
(let
|
||||||
|
((s3 (c s2)))
|
||||||
|
(cond ((= s3 nil) mzero) (:else (unit s3)))))))))
|
||||||
|
|||||||
85
lib/minikanren/tests/clpfd-times.sx
Normal file
85
lib/minikanren/tests/clpfd-times.sx
Normal file
@@ -0,0 +1,85 @@
|
|||||||
|
;; lib/minikanren/tests/clpfd-times.sx — fd-times (x * y = z).
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-3-4"
|
||||||
|
(run* q (fresh (z) (fd-times 3 4 z) (== q z)))
|
||||||
|
(list 12))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-recover-divisor"
|
||||||
|
(run* q (fresh (x) (fd-times x 5 30) (== q x)))
|
||||||
|
(list 6))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-non-divisible-fails"
|
||||||
|
(run* q (fresh (x) (fd-times x 5 31) (== q x)))
|
||||||
|
(list))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-by-zero"
|
||||||
|
(run* q (fresh (z) (fd-times 0 99 z) (== q z)))
|
||||||
|
(list 0))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-zero-by-anything-zero"
|
||||||
|
(run*
|
||||||
|
q
|
||||||
|
(fresh
|
||||||
|
(x)
|
||||||
|
(fd-in x (list 1 2 3))
|
||||||
|
(fd-times x 0 0)
|
||||||
|
(fd-label (list x))
|
||||||
|
(== q x)))
|
||||||
|
(list 1 2 3))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-12-divisor-pairs"
|
||||||
|
(run*
|
||||||
|
q
|
||||||
|
(fresh
|
||||||
|
(x y)
|
||||||
|
(fd-in
|
||||||
|
x
|
||||||
|
(list
|
||||||
|
1
|
||||||
|
2
|
||||||
|
3
|
||||||
|
4
|
||||||
|
5
|
||||||
|
6))
|
||||||
|
(fd-in
|
||||||
|
y
|
||||||
|
(list
|
||||||
|
1
|
||||||
|
2
|
||||||
|
3
|
||||||
|
4
|
||||||
|
5
|
||||||
|
6))
|
||||||
|
(fd-times x y 12)
|
||||||
|
(fd-label (list x y))
|
||||||
|
(== q (list x y))))
|
||||||
|
(list
|
||||||
|
(list 2 6)
|
||||||
|
(list 3 4)
|
||||||
|
(list 4 3)
|
||||||
|
(list 6 2)))
|
||||||
|
|
||||||
|
(mk-test
|
||||||
|
"fd-times-square-of-each"
|
||||||
|
(run*
|
||||||
|
q
|
||||||
|
(fresh
|
||||||
|
(x z)
|
||||||
|
(fd-in x (list 1 2 3 4 5))
|
||||||
|
(fd-times x x z)
|
||||||
|
(fd-label (list x))
|
||||||
|
(== q (list x z))))
|
||||||
|
(list
|
||||||
|
(list 1 1)
|
||||||
|
(list 2 4)
|
||||||
|
(list 3 9)
|
||||||
|
(list 4 16)
|
||||||
|
(list 5 25)))
|
||||||
|
|
||||||
|
(mk-tests-run!)
|
||||||
Reference in New Issue
Block a user