diff --git a/csp/aima-smm.rkt b/csp/aima-smm.rkt new file mode 100644 index 00000000..949f30f7 --- /dev/null +++ b/csp/aima-smm.rkt @@ -0,0 +1,30 @@ +#lang br +(require "aima.rkt") + +; SEND +;+ MORE +;------ +; MONEY +(define (word-value . xs) + (for/sum ([(x idx) (in-indexed (reverse xs))]) + (* x (expt 10 idx)))) + +(define vs '(s e n d m o r y)) +(define ds (for/hash ([k vs]) + (values k (range 10)))) +(define ns (for*/hash ([v (in-list vs)]) + (values v (remove v vs)))) + +(define (smm-constraint A a B b) + (and + (not (eq? a b)) + (when (eq? A 's) (= 1 a)))) + +(define csp (make-csp vs ds ns smm-constraint)) +(parameterize ([current-select-variable mrv] + [current-order-values lcv] + [current-inference mac] + [current-reset #f]) + (solve csp)) +(nassigns csp) +(nchecks csp) \ No newline at end of file diff --git a/csp/aima-sum.rkt b/csp/aima-sum.rkt new file mode 100644 index 00000000..68617087 --- /dev/null +++ b/csp/aima-sum.rkt @@ -0,0 +1,12 @@ +#lang br +(require "aima.rkt") +(define vs '(a b c)) + +(define ds (for/hash ([k vs]) + (values k (range 10)))) +(define ns (for*/hash ([v (in-list vs)]) + (values v (remove v vs)))) +(define csp (make-csp vs ds ns (λ (A a B b) (not (eq? a b))))) +(solve csp) +(nassigns csp) +(nchecks csp) \ No newline at end of file diff --git a/csp/aima.rkt b/csp/aima.rkt index 8e515cf2..65983000 100644 --- a/csp/aima.rkt +++ b/csp/aima.rkt @@ -1,14 +1,15 @@ #lang debug racket -(require racket/generator sugar/debug) +(require racket/generator sugar) +(provide (all-defined-out)) -(struct $csp (variables domains neighbors constraints initial curr_domains nassigns) #:transparent #:mutable) +(struct $csp (variables domains neighbors constraints initial curr_domains nassigns nchecks) #:transparent #:mutable) (define assignment? hash?) (define variable? symbol?) (define removal? (cons/c variable? any/c)) (define/contract (make-csp variables domains neighbors constraints) ((listof variable?) hash? hash? procedure? . -> . $csp?) - ($csp variables domains neighbors constraints null #f 0)) + ($csp variables domains neighbors constraints null #f 0 0)) (define/contract (curr_domain csp var) ($csp? variable? . -> . (listof any/c)) @@ -22,9 +23,19 @@ (assignment? variable? . -> . boolean?) (hash-has-key? assignment var)) -(define/contract (reset-nassigns! csp) +(define nassigns $csp-nassigns) +(define nchecks $csp-nchecks) + +(define/contract (check-constraint csp A a B b) + ($csp? variable? any/c variable? any/c . -> . any/c) + (begin0 + (($csp-constraints csp) A a B b) + (set-$csp-nchecks! csp (add1 ($csp-nchecks csp))))) + +(define/contract (reset-counters! csp) ($csp? . -> . void?) - (set-$csp-nassigns! csp 0)) + (set-$csp-nassigns! csp 0) + (set-$csp-nchecks! csp 0)) (define/contract (assign csp var val assignment) ($csp? variable? any/c assignment? . -> . void?) @@ -45,7 +56,9 @@ ;; Subclasses may implement this more efficiently (for/sum ([v (in-list (neighbors csp var))] #:when (assignment . assigns? . v)) - (if (($csp-constraints csp) var val v (hash-ref assignment v)) 0 1))) + (if (check-constraint csp var val v (hash-ref assignment v)) + 0 + 1))) (define (display csp assignment) (displayln csp)) @@ -117,7 +130,44 @@ [(cons B b) (hash-update! ($csp-curr_domains csp) B (λ (vals) (append vals (list b))))]))) +;; ______________________________________________________________________________ +;; Constraint Propagation with AC-3 +(struct $arc (start end) #:transparent) +(define/contract (AC3 csp [queue #f][removals #f]) + (($csp?) ((or/c #f (listof any/c)) (box/c (listof removal?))) . ->* . boolean?) + (support_pruning csp) + (with-handlers ([boolean? values]) + (for/fold ([queue (or queue + (for*/list ([Xi (in-list ($csp-variables csp))] + [Xk (in-list (neighbors csp Xi))]) + ($arc Xi Xk)))] + #:result #true) + ([i (in-naturals)] + #:break (empty? queue)) + (match-define (cons ($arc Xi Xj) other-arcs) queue) + (cond + [(revise csp Xi Xj removals) + (when (empty? (curr_domain csp Xi)) + (raise #false)) + (append other-arcs + (for/list ([Xk (in-list (neighbors csp Xi))] + #:unless (eq? Xk Xj)) + ($arc Xk Xi)))] + [else other-arcs])))) + +(define/contract (revise csp Xi Xj removals) + ($csp? variable? variable? (box/c (listof removal?)) . -> . boolean?) + ;; Return true if we remove a value. + (for/fold ([revised #false]) + ([x (in-list (curr_domain csp Xi))]) + ;; If Xi=x conflicts with Xj=y for every possible y, eliminate Xi=x + (cond + [(for/and ([y (in-list (curr_domain csp Xj))]) + (not (check-constraint csp Xi x Xj y))) + (prune csp Xi x removals) + #true] + [else revised]))) ;; ______________________________________________________________________________ ;; CSP Backtracking Search @@ -139,7 +189,6 @@ (define (num_legal_values var) (if ($csp-curr_domains csp) (length (curr_domain csp var)) - ;; todo: is this the same as python `count`? (for/sum ([val (in-list (hash-ref ($csp-domains csp) var))] #:when (zero? (nconflicts csp var val assignment))) 1))) @@ -177,18 +226,25 @@ (for/and ([B (in-list (neighbors csp var))] #:unless (assignment . assigns? . B)) (for ([b (in-list (curr_domain csp B))] - #:unless (($csp-constraints csp) var value B b)) + #:unless (check-constraint csp var value B b)) (prune csp B b removals)) (not (empty? (curr_domain csp B))))) -(define current-select-variable (make-parameter first_unassigned_variable)) -(define current-order-values (make-parameter unordered_domain_values)) -(define current-inference (make-parameter no_inference)) +(define/contract (mac csp var value assignment removals) + ($csp? variable? any/c assignment? (box/c (listof removal?)) . -> . boolean?) + ;; Maintain arc consistency. + (AC3 csp (for/list ([X (in-list (neighbors csp var))]) + ($arc X var)) removals)) + + +(define current-select-variable (make-parameter #f)) +(define current-order-values (make-parameter #f)) +(define current-inference (make-parameter #f)) (define/contract (backtracking_search csp - [select_unassigned_variable (current-select-variable)] - [order_domain_values (current-order-values)] - [inference (current-inference)]) + [select_unassigned_variable (or (current-select-variable) first_unassigned_variable)] + [order_domain_values (or (current-order-values) unordered_domain_values)] + [inference (or (current-inference) no_inference)]) (($csp?) (procedure? procedure? procedure?) . ->* . generator?) (generator () (let backtrack ([assignment (make-hasheq)]) @@ -216,7 +272,7 @@ (match (for/list ([solution (in-producer (solver csp) (void))] [idx (in-range solution-limit)]) (finish-proc solution)) - [(? pair? solutions) solutions] + [(list solutions ...) solutions] [else #false]) (when (current-reset) (set-$csp-curr_domains! csp #f)))) @@ -240,7 +296,7 @@ (sa wa nt q nsw v) (t)))]) (values i ns))) -(define csp (make-csp vs ds ns (λ (A a B b) (not (equal? a b))))) +(define csp (make-csp vs ds ns (λ (A a B b) (not (eq? a b))))) (check-true ($csp? csp)) (define a (make-hasheq)) (assign csp 'key 42 a) @@ -275,7 +331,7 @@ (set-$csp-curr_domains! csp #f) ; reset current domains (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) -(check-equal? (begin0 ($csp-nassigns csp) (reset-nassigns! csp)) 40) +(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(40 321)) (check-equal? (length (solve* csp)) 18) (check-equal? (suppose csp 'nsw 'red) '#&((nsw . green) (nsw . blue))) @@ -283,22 +339,23 @@ (make-hasheq '((nsw . red) (nt . red) (q . green) (sa . blue) (t . blue) (v . green) (wa . green)))) (check-equal? ($csp-nassigns csp) 368) +(reset-counters! csp) (check-equal? (suppose csp 'nsw 'red) '#&((nsw . green) (nsw . blue))) (check-equal? (length (solve* csp)) 6) -(check-equal? (begin0 ($csp-nassigns csp) (reset-nassigns! csp)) 479) +(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(111 1035)) (parameterize ([current-select-variable mrv] [current-shuffle #f]) (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) - (check-equal? (begin0 ($csp-nassigns csp) (reset-nassigns! csp)) 39)) + (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(39 321))) (parameterize ([current-order-values lcv]) (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) - (check-equal? (begin0 ($csp-nassigns csp) (reset-nassigns! csp)) 39)) + (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(39 1040))) (parameterize ([current-inference forward_checking]) (forward_checking csp 'sa 'blue (make-hasheq) (box null)) @@ -306,10 +363,23 @@ (make-hasheq '((nsw . (red green)) (nt . (red green)) (q . (red green)) (sa . (red green blue)) (t . (red green blue)) (v . (red green)) (wa . (red green)))))) (set-$csp-curr_domains! csp #f) -(parameterize ([current-inference forward_checking] - [current-reset #f]) +(parameterize ([current-inference forward_checking]) (check-equal? (solve csp) (make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red)))) - (check-equal? (begin0 ($csp-nassigns csp) (reset-nassigns! csp)) 25)) + (check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(25 123))) +(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))) + +(parameterize ([current-select-variable mrv] + [current-order-values lcv] + [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)) '(7 45)))