diff --git a/csp/hacs.rkt b/csp/hacs.rkt index 99e8aab3..95648900 100644 --- a/csp/hacs.rkt +++ b/csp/hacs.rkt @@ -49,6 +49,16 @@ var)) ($csp-constraints csp))) +(define/contract (update-conflicts csp name conflicts) + ($csp? $var-name? (listof $var-name?) . -> . $csp?) + ($csp + (for/list ([var ($csp-vars csp)]) + (match var + [($var (? (λ (x) (eq? x name))) vals past _) + (+$avar name vals past conflicts)] + [else var])) + ($csp-constraints csp))) + (define/contract (first-unassigned-variable csp) ($csp? . -> . (or/c #false (and/c $var? (not/c $avar?)))) (for/first ([var (in-list ($csp-vars csp))] @@ -75,9 +85,10 @@ (define/contract (forward-check csp aname) ($csp? $var-name? . -> . $csp?) + #R csp (define aval (first ($csp-vals csp aname))) (define (filter-vals var) - (match-define ($var name vals _ _) var) + (match-define ($var name vals past conflicts) var) (match (($csp-constraints csp) . relating . (list aname name)) [(? empty?) var] [constraints @@ -90,8 +101,8 @@ (proc aval val))))) val)) (unless (pair? new-vals) - (raise (inconsistency-signal csp))) - (+$var name new-vals (cons aname ($var-past var)) ($var-conflicts var))])) + (raise (inconsistency-signal past))) + (+$var name new-vals (cons aname past) conflicts)])) ($csp (for/list ([var (in-list ($csp-vars csp))]) @@ -101,9 +112,16 @@ ($csp-constraints csp))) (check-equal? + ;; no forward checking when no constraints ($csp-vars (forward-check ($csp (list (+$avar 'a '(1)) (+$var 'b (range 2))) null) 'a)) (list (+$avar 'a '(1)) (+$var 'b '(0 1)))) +(check-equal? + ($csp-vars (forward-check (forward-check ($csp (list (+$avar 'a '(1)) (+$avar 'b '(0)) (+$var 'c '(0 1 2))) + (list ($constraint '(a c) (negate =)) + ($constraint '(b c) (negate =)))) 'a) 'b)) + (list (+$avar 'a '(1)) (+$avar 'b '(0) '()) (+$var 'c '(2) '(b a)))) + (check-equal? ;; no inconsistency: b≠c not checked when fc is relative to a ($csp-vars (forward-check ($csp (list (+$avar 'a '(1)) (+$var 'b (range 2)) (+$var 'c '(0))) @@ -143,11 +161,19 @@ (match (select-unassigned-variable csp) [#false (yield csp)] [($var name vals _ _) - (for ([val (in-list (order-domain-values vals))]) - (with-handlers ([inconsistency-signal? void]) + (for/fold ([conflicts null] + #:result (void)) + ([val (in-list (order-domain-values vals))]) + #R conflicts + (with-handlers ([inconsistency-signal? + (λ (sig) + (match sig + [(inconsistency-signal new-conflicts) + (append new-conflicts conflicts)]))]) (let* ([csp (assign-val csp name val)] [csp (inference csp name)]) - (backtrack csp))))])))) + (backtrack csp)) + conflicts))])))) (define/contract (solve* csp #:finish-proc [finish-proc $csp-vars] @@ -169,10 +195,10 @@ (define (<> a b) (not (= a b))) (define (neq? a b) (not (eq? a b))) -#;(parameterize ([current-inference forward-check]) - (time (solve* ($csp (list (+$var 'a (range 3)) - (+$var 'b (range 3)) - (+$var 'c (range 3))) +(parameterize ([current-inference forward-check]) + (time (solve* ($csp (list (+$var 'a '(1)) + (+$var 'b '(1)) + (+$var 'c '(1))) (list ($constraint '(a b) <>) ($constraint '(a c) <>) ($constraint '(b c) <>))))))