|
|
|
@ -2,7 +2,7 @@
|
|
|
|
|
(require racket/generator sugar graph)
|
|
|
|
|
(provide (all-defined-out))
|
|
|
|
|
|
|
|
|
|
(struct $csp (variables domains neighbors constraints initial curr_domains nassigns nchecks current) #:transparent #:mutable)
|
|
|
|
|
(struct $csp (variables domains neighbors constraints initial curr_domains nassigns nchecks current graph) #:transparent #:mutable)
|
|
|
|
|
;; `current` = current assignment
|
|
|
|
|
(define assignment? hash?)
|
|
|
|
|
(define variable? symbol?)
|
|
|
|
@ -18,16 +18,16 @@
|
|
|
|
|
(apply add-edge! g edge)
|
|
|
|
|
g))
|
|
|
|
|
|
|
|
|
|
(define/contract (make-csp variables vds constraints)
|
|
|
|
|
((listof variable?) (listof $vd?) (listof $constraint?) . -> . $csp?)
|
|
|
|
|
(define g (constraint-graph variables constraints))
|
|
|
|
|
(define ns (for/hasheq ([v (in-list variables)])
|
|
|
|
|
(values v (get-neighbors g v))))
|
|
|
|
|
(define/contract (make-csp vds constraints)
|
|
|
|
|
((listof $vd?) (listof $constraint?) . -> . $csp?)
|
|
|
|
|
(define variables (map $vd-name vds))
|
|
|
|
|
(define domains (for/hasheq ([vd (in-list vds)])
|
|
|
|
|
(match vd
|
|
|
|
|
[($vd name vals) (values name vals)])))
|
|
|
|
|
|
|
|
|
|
($csp variables domains ns constraints null #f 0 0 #f))
|
|
|
|
|
(define g (constraint-graph variables constraints))
|
|
|
|
|
(define neighbors (for/hasheq ([v (in-list variables)])
|
|
|
|
|
(values v (get-neighbors g v))))
|
|
|
|
|
($csp variables domains neighbors constraints null #f 0 0 #f g))
|
|
|
|
|
|
|
|
|
|
(define/contract (domain csp var)
|
|
|
|
|
($csp? variable? . -> . (listof any/c))
|
|
|
|
@ -384,21 +384,22 @@
|
|
|
|
|
[else #false]))
|
|
|
|
|
|
|
|
|
|
(require rackunit)
|
|
|
|
|
|
|
|
|
|
(define vs '(wa nsw t q nt v sa))
|
|
|
|
|
(define ds (for/list ([k vs])
|
|
|
|
|
($vd k '(red green blue))))
|
|
|
|
|
(define vds (for/list ([k vs])
|
|
|
|
|
($vd k '(red green blue))))
|
|
|
|
|
(define (neq? a b) (not (eq? a b)))
|
|
|
|
|
(define cs (list
|
|
|
|
|
($constraint '(wa nt) neq?)
|
|
|
|
|
($constraint '(wa sa) neq?)
|
|
|
|
|
($constraint '(nt sa) neq?)
|
|
|
|
|
($constraint '(nt q) neq?)
|
|
|
|
|
($constraint '(q sa) neq?)
|
|
|
|
|
($constraint '(q nsw) neq?)
|
|
|
|
|
($constraint '(nsw sa) neq?)
|
|
|
|
|
($constraint '(nsw v) neq?)
|
|
|
|
|
($constraint '(v sa) neq?)))
|
|
|
|
|
(define csp (make-csp vs ds cs))
|
|
|
|
|
($constraint '(wa nt) neq?)
|
|
|
|
|
($constraint '(wa sa) neq?)
|
|
|
|
|
($constraint '(nt sa) neq?)
|
|
|
|
|
($constraint '(nt q) neq?)
|
|
|
|
|
($constraint '(q sa) neq?)
|
|
|
|
|
($constraint '(q nsw) neq?)
|
|
|
|
|
($constraint '(nsw sa) neq?)
|
|
|
|
|
($constraint '(nsw v) neq?)
|
|
|
|
|
($constraint '(v sa) neq?)))
|
|
|
|
|
(define csp (make-csp vds cs))
|
|
|
|
|
(check-true ($csp? csp))
|
|
|
|
|
(define a (make-hasheq))
|
|
|
|
|
(assign csp 'key 42 a)
|
|
|
|
|