fix ac-3 (closes #3)

main
Matthew Butterick 3 years ago
parent b7608d35aa
commit 7a700bc564

@ -344,14 +344,14 @@
constraint-proc ; so val stays on left
(λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order
(define (satisfies-arc? val)
(for/or ([other-val (in-list (find-domain prob other-name))])
(for/or ([other-val (in-set (find-domain prob other-name))])
(proc val other-val)))
(make-csp
(for/list ([vr (in-vars prob)])
(cond
[(assigned-var? vr) vr]
[(eq? name (var-name vr))
(make-var name (match (filter satisfies-arc? (domain vr))
(make-var name (match (filter satisfies-arc? (set->list (domain vr)))
[(? empty?) (backtrack!)]
[vals vals]))]
[else vr]))
@ -371,24 +371,27 @@
;; has values in their domain that satisfy every binary constraint
(define checkable-names (cons ref-name (filter-not (λ (vn) (assigned-name? prob vn)) (map var-name (vars prob)))))
(define starting-arcs
(two-arity-constraints->arcs (for/list ([const (in-constraints prob)]
#:when (and (two-arity? const)
(for/and ([cname (in-list (constraint-names const))])
(memq cname checkable-names))))
const)))
(two-arity-constraints->arcs
(for/list ([const (in-constraints prob)]
#:when (and (two-arity? const)
(for/and ([cname (in-list (constraint-names const))])
(memq cname checkable-names))))
const)))
(for/fold ([prob prob]
[arcs (sort starting-arcs < #:key (λ (a) (domain-length (find-domain prob (arc-name a)))) #:cache-keys? #true)]
[arcs (sort starting-arcs < #:key (λ (a) (domain-length (find-var prob (arc-name a)))) #:cache-keys? #true)]
#:result (prune-singleton-constraints prob))
([i (in-naturals)]
#:break (empty? arcs))
(match-define (cons (arc name proc) other-arcs) arcs)
(define reduced-csp (reduce-domain prob (arc name proc)))
(define (domain-reduced? name)
(= (domain-length (find-domain prob name)) (domain-length (find-domain reduced-csp name))))
(values reduced-csp (if (domain-reduced? name)
(remove-duplicates (append (starting-arcs . terminating-at? . name) other-arcs))
other-arcs))))
(match-define (cons (and first-arc (arc name _)) other-arcs) arcs)
(define reduced-csp (reduce-domain prob first-arc))
(define domain-reduced?
(< (domain-length (find-var reduced-csp name)) (domain-length (find-var prob name))))
(values reduced-csp
(if domain-reduced?
;; revision reduced the domain, so supplement the list of arcs
(remove-duplicates (append (starting-arcs . terminating-at? . name) other-arcs))
;; revision did not reduce the domain, so keep going
other-arcs))))
(define/contract (forward-check-var prob ref-name vr)
(csp? name? var? . -> . var?)

@ -479,14 +479,16 @@ Pass these functions to @racket[current-inference].
[prob csp?]
[name var-name?])
csp?]{
Used for inference when @racket[current-inference] is not otherwise set. Tests whether the newest variable assignment necessarily causes any other variable domains to collapse, and thereby discovers a failure faster than backtracking alone.
Used for inference when @racket[current-inference] is not otherwise set. Tests whether the newest variable assignment necessarily causes any other variable domains to become empty. and thereby discovers a failure faster than backtracking alone.
}
@defproc[(ac-3
[prob csp?]
[name var-name?])
csp?]{
Applies the AC-3 arc-consistency algorithm. Similar to forward checking, but checks pairs of variables rather than single variables. Thus, it is a more thorough form of inference, but for that reason it will usually take longer (and may not add much value).
Applies the AC-3 arc-consistency algorithm. Similar to forward checking, but checks pairs of variables rather than single variables. Thus, it is a more thorough form of inference, but for that reason it will usually take longer.
Specifically: following a new variable assignment, AC-3 examines the remaining constraints that link exactly two variables. It checks that each variable has at least one value in its domain that can be paired with the other to satisfy the constraint. If no such pair exists, then the constraint can never be satisfied, so the new variable assignment must fail.
}

Loading…
Cancel
Save