diff --git a/csp/aima.rkt b/csp/aima.rkt index cca13ca7..51ef805d 100644 --- a/csp/aima.rkt +++ b/csp/aima.rkt @@ -1,5 +1,5 @@ #lang debug racket -(require racket/generator sugar) +(require racket/generator sugar graph) (provide (all-defined-out)) (struct $csp (variables domains neighbors constraints initial curr_domains nassigns nchecks current) #:transparent #:mutable) @@ -10,9 +10,19 @@ (struct $constraint (names proc) #:transparent) -(define/contract (make-csp variables domains neighbors constraints newconstraints) - ((listof variable?) hash? hash? procedure? (listof $constraint?) . -> . $csp?) - ($csp variables domains neighbors constraints null #f 0 0 #f)) +(define (constraint-graph variables constraints) + (for*/fold ([g (unweighted-graph/undirected variables)]) + ([constraint (in-list constraints)] + [edge (in-combinations ($constraint-names constraint) 2)]) + (apply add-edge! g edge) + g)) + +(define/contract (make-csp variables domains constraints) + ((listof variable?) hash? (listof $constraint?) . -> . $csp?) + (define g (constraint-graph variables constraints)) + (define ns (for/hasheq ([v (in-list variables)]) + (values v (get-neighbors g v)))) + ($csp variables domains ns constraints null #f 0 0 #f)) (define/contract (domain csp var) ($csp? variable? . -> . (listof any/c)) @@ -35,8 +45,13 @@ (define/contract (check-constraint csp A a B b) ($csp? variable? any/c variable? any/c . -> . any/c) + (define AB-constraints (for/list ([constraint (in-list ($csp-constraints csp))] + #:when (for/and ([name (in-list (list A B))]) + (memq name ($constraint-names constraint)))) + constraint)) (begin0 - (($csp-constraints csp) A a B b) + (for/and ([constraint (in-list AB-constraints)]) + (($constraint-proc constraint) a b)) (set-$csp-nchecks! csp (add1 ($csp-nchecks csp))))) (define/contract (reset-counters! csp) @@ -367,17 +382,7 @@ (define vs '(wa nsw t q nt v sa)) (define ds (for/hash ([k vs]) (values k '(red green blue)))) -(define ns (for*/hash ([(i ns) (in-dict - '((wa nt sa) - (nt wa sa q) - (q nt sa nsw) - (nsw q sa v) - (v sa nsw) - (sa wa nt q nsw v) - (t)))]) - (values i ns))) (define (neq? a b) (not (eq? a b))) -(define c (λ (A a B b) (neq? a b))) (define ncs (list ($constraint '(wa nt) neq?) ($constraint '(wa sa) neq?) @@ -388,7 +393,7 @@ ($constraint '(nsw sa) neq?) ($constraint '(nsw v) neq?) ($constraint '(v sa) neq?))) -(define csp (make-csp vs ds ns c ncs)) +(define csp (make-csp vs ds ncs)) (check-true ($csp? csp)) (define a (make-hasheq)) (assign csp 'key 42 a) @@ -459,14 +464,14 @@ (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) - (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(25 123))) + (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(25 121))) (set-$csp-curr_domains! csp #f) (parameterize ([current-inference mac] [current-reset #f]) (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) - (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(17 159))) + (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(17 175))) (parameterize ([current-select-variable mrv] [current-order-values lcv]