|
|
|
@ -348,11 +348,12 @@
|
|
|
|
;; csp is arc-consistent if every pair of variables (x y)
|
|
|
|
;; csp is arc-consistent if every pair of variables (x y)
|
|
|
|
;; has values in their domain that satisfy every binary constraint
|
|
|
|
;; 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 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)]
|
|
|
|
(define starting-arcs
|
|
|
|
#:when (and (two-arity? const)
|
|
|
|
(two-arity-constraints->arcs (for/list ([const (in-constraints prob)]
|
|
|
|
(for/and ([cname (in-list (constraint-names const))])
|
|
|
|
#:when (and (two-arity? const)
|
|
|
|
(memq cname checkable-names))))
|
|
|
|
(for/and ([cname (in-list (constraint-names const))])
|
|
|
|
const)))
|
|
|
|
(memq cname checkable-names))))
|
|
|
|
|
|
|
|
const)))
|
|
|
|
(for/fold ([prob prob]
|
|
|
|
(for/fold ([prob prob]
|
|
|
|
[arcs (sort starting-arcs < #:key (λ (a) (length (find-domain prob (arc-name a)))) #:cache-keys? #true)]
|
|
|
|
[arcs (sort starting-arcs < #:key (λ (a) (length (find-domain prob (arc-name a)))) #:cache-keys? #true)]
|
|
|
|
#:result (prune-singleton-constraints prob))
|
|
|
|
#:result (prune-singleton-constraints prob))
|
|
|
|
@ -360,22 +361,21 @@
|
|
|
|
#:break (empty? arcs))
|
|
|
|
#:break (empty? arcs))
|
|
|
|
(match-define (cons (arc name proc) other-arcs) arcs)
|
|
|
|
(match-define (cons (arc name proc) other-arcs) arcs)
|
|
|
|
(define reduced-csp (reduce-domain prob (arc name proc)))
|
|
|
|
(define reduced-csp (reduce-domain prob (arc name proc)))
|
|
|
|
(values reduced-csp (if (= (length (find-domain prob name)) (length (find-domain reduced-csp name)))
|
|
|
|
(define (domain-reduced? name)
|
|
|
|
;; revision did not reduce the domain, so keep going
|
|
|
|
(= (length (find-domain prob name)) (length (find-domain reduced-csp name))))
|
|
|
|
other-arcs
|
|
|
|
(values reduced-csp (if (domain-reduced? name)
|
|
|
|
;; revision reduced the domain, so supplement the list of arcs
|
|
|
|
(remove-duplicates (append (starting-arcs . terminating-at? . name) other-arcs))
|
|
|
|
(remove-duplicates (append (starting-arcs . terminating-at? . name) other-arcs))))))
|
|
|
|
other-arcs))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define/contract (forward-check-var prob ref-name vr)
|
|
|
|
(define/contract (forward-check-var prob ref-name vr)
|
|
|
|
(csp? name? var? . -> . var?)
|
|
|
|
(csp? name? var? . -> . var?)
|
|
|
|
(cond
|
|
|
|
(match vr
|
|
|
|
;; don't check against assigned vars, or the reference var
|
|
|
|
;; don't check against assigned vars, or the reference var
|
|
|
|
;; (which is probably assigned but maybe not)
|
|
|
|
;; (which is probably assigned but maybe not)
|
|
|
|
[(assigned-var? vr) vr]
|
|
|
|
[(? assigned-var? vr) vr]
|
|
|
|
[(eq? (var-name vr) ref-name) vr]
|
|
|
|
[(var (== ref-name eq?) _) vr]
|
|
|
|
[else
|
|
|
|
[(var name vals)
|
|
|
|
(match-define (var name vals) vr)
|
|
|
|
|
|
|
|
(match ((constraints prob) . relating-only . (list ref-name name))
|
|
|
|
(match ((constraints prob) . relating-only . (list ref-name name))
|
|
|
|
[(? empty?) vr]
|
|
|
|
[(? empty?) vr]
|
|
|
|
[constraints
|
|
|
|
[constraints
|
|
|
|
@ -383,14 +383,13 @@
|
|
|
|
(define new-vals
|
|
|
|
(define new-vals
|
|
|
|
(for/list ([val (in-list vals)]
|
|
|
|
(for/list ([val (in-list vals)]
|
|
|
|
#:when (for/and ([const (in-list constraints)])
|
|
|
|
#:when (for/and ([const (in-list constraints)])
|
|
|
|
(let ([proc (constraint-proc const)])
|
|
|
|
(match const
|
|
|
|
(if (eq? name (first (constraint-names const)))
|
|
|
|
[(constraint (list (== name eq?) _) proc) (proc val ref-val)]
|
|
|
|
(proc val ref-val)
|
|
|
|
[(constraint _ proc) (proc ref-val val)])))
|
|
|
|
(proc ref-val val)))))
|
|
|
|
|
|
|
|
val))
|
|
|
|
val))
|
|
|
|
(checked-variable name new-vals (cons (cons ref-name ref-val) (match vr
|
|
|
|
(checked-variable name new-vals (cons (cons ref-name ref-val) (match vr
|
|
|
|
[(checked-variable _ _ history) history]
|
|
|
|
[(checked-variable _ _ history) history]
|
|
|
|
[else null])))])]))
|
|
|
|
[_ null])))])]))
|
|
|
|
|
|
|
|
|
|
|
|
(define/contract (prune-singleton-constraints prob [ref-name #false])
|
|
|
|
(define/contract (prune-singleton-constraints prob [ref-name #false])
|
|
|
|
((csp?) ((or/c #false name?)) . ->* . csp?)
|
|
|
|
((csp?) ((or/c #false name?)) . ->* . csp?)
|
|
|
|
@ -419,7 +418,7 @@
|
|
|
|
;; so we can discover the *most recent past var* that could be the culprit.
|
|
|
|
;; so we can discover the *most recent past var* that could be the culprit.
|
|
|
|
;; If we just bail out at the first conflict, we may backjump too far based on its history
|
|
|
|
;; If we just bail out at the first conflict, we may backjump too far based on its history
|
|
|
|
;; (and thereby miss parts of the search tree)
|
|
|
|
;; (and thereby miss parts of the search tree)
|
|
|
|
(when (pair? conflict-set)
|
|
|
|
(unless (empty? conflict-set)
|
|
|
|
(backtrack! conflict-set))
|
|
|
|
(backtrack! conflict-set))
|
|
|
|
;; Discard constraints that have produced singleton domains
|
|
|
|
;; Discard constraints that have produced singleton domains
|
|
|
|
;; (they have no further use)
|
|
|
|
;; (they have no further use)
|
|
|
|
@ -514,8 +513,8 @@
|
|
|
|
(λ (bt)
|
|
|
|
(λ (bt)
|
|
|
|
(define bths (backtrack-histories bt))
|
|
|
|
(define bths (backtrack-histories bt))
|
|
|
|
(append conflicts (remq name (remove-duplicates
|
|
|
|
(append conflicts (remq name (remove-duplicates
|
|
|
|
(for*/list ([bth bths]
|
|
|
|
(for*/list ([bth (in-list bths)]
|
|
|
|
[rec bth])
|
|
|
|
[rec (in-list bth)])
|
|
|
|
(car rec)) eq?))))])
|
|
|
|
(car rec)) eq?))))])
|
|
|
|
(let* ([prob (assign-val prob name val)]
|
|
|
|
(let* ([prob (assign-val prob name val)]
|
|
|
|
;; reduce constraints before inference,
|
|
|
|
;; reduce constraints before inference,
|
|
|
|
|
