From eb0c99b9ba1ab7d880a882c292e8073e92a3127a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 15 Oct 2018 13:37:51 -0700 Subject: [PATCH] fc --- csp/aima.rkt | 133 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 97 insertions(+), 36 deletions(-) diff --git a/csp/aima.rkt b/csp/aima.rkt index 13d2f8da..8dde7680 100644 --- a/csp/aima.rkt +++ b/csp/aima.rkt @@ -113,6 +113,28 @@ #:unless (hash-has-key? assignment var)) var)) +(define current-shuffle (make-parameter #t)) + +(define/contract (mrv assignment csp) + (assignment? $csp? . -> . any/c) + ;; Minimum-remaining-values heuristic. + ;; with random tiebreaker. + (define (num_legal_values var) + (if ($csp-curr_domains csp) + (length (hash-ref ($csp-curr_domains 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))) + (struct $mrv-rec (var num) #:transparent) + (define recs (sort + (for/list ([var (in-list ($csp-variables csp))] + #:unless (hash-has-key? assignment var)) + ($mrv-rec var (num_legal_values var))) + < #:key $mrv-rec-num)) + (first ((if (current-shuffle) shuffle values) (map $mrv-rec-var (takef recs (λ (rec) (= ($mrv-rec-num (first recs)) + ($mrv-rec-num rec)))))))) + ;; Value ordering (define/contract (unordered_domain_values var assignment csp) @@ -120,55 +142,71 @@ ;; The default value order. (choices csp var)) +(define/contract (lcv var assignment csp) + (variable? assignment? $csp? . -> . (listof any/c)) + ;; Least-constraining-values heuristic. + (sort (choices csp var) < #:key (λ (val) (nconflicts csp var val assignment)))) + ;; Inference (define/contract (no_inference csp var value assignment removals) ($csp? variable? any/c assignment? (listof removal?) . -> . boolean?) #true) +(define/contract (forward_checking csp var value assignment removals) + ($csp? variable? any/c assignment? (listof removal?) . -> . boolean?) + ;; Prune neighbor values inconsistent with var=value. + (support_pruning csp) ;; necessary to set up curr_domains + (for/and ([B (in-list (hash-ref ($csp-neighbors csp) var))] + #:unless (hash-has-key? assignment B)) + (for/fold ([removals removals]) + ([b (in-list (hash-ref ($csp-curr_domains csp) B))] + #:unless (($csp-constraints csp) var value B b)) + (prune csp B b removals)) + (not (empty? (hash-ref ($csp-curr_domains 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 (backtracking_search csp - [select_unassigned_variable first_unassigned_variable] - [order_domain_values unordered_domain_values] - [inference no_inference]) - (($csp?) (procedure? procedure? procedure?) . ->* . (or/c #f assignment?)) - (define (backtrack [assignment (make-hasheq)]) - ;; todo: convert to generator with `yield` - (let/ec return - (when (all-variables-assigned? csp assignment) - (return assignment)) - (define var (select_unassigned_variable assignment csp)) - (for ([val (in-list (order_domain_values var assignment csp))] - #:when (zero? (nconflicts csp var val assignment))) - (assign csp var val assignment) - (define removals (suppose csp var val)) - (when (inference csp var val assignment removals) - (define result (backtrack assignment)) - (when result - (return result)) - (restore csp removals))) - (unassign csp var assignment) - (return #false))) - - (define result (backtrack)) - (unless (or (false? result) (goal_test csp result)) - (error 'whut)) - result) - -;; todo: make multiple results work + [select_unassigned_variable (current-select-variable)] + [order_domain_values (current-order-values)] + [inference (current-inference)]) + (($csp?) (procedure? procedure? procedure?) . ->* . generator?) + (generator () + (let backtrack ([assignment (make-hasheq)]) + (cond + [(all-variables-assigned? csp assignment) + (unless (goal_test csp assignment) (error 'whut)) + (yield (hash-copy assignment))] + [else + (define var (select_unassigned_variable assignment csp)) + (for ([val (in-list (order_domain_values var assignment csp))] + #:when (zero? (nconflicts csp var val assignment))) + (assign csp var val assignment) + (define removals (suppose csp var val)) + (when (inference csp var val assignment removals) + (backtrack assignment)) + (restore csp removals)) + (unassign csp var assignment)])))) + (define/contract (solve* csp [solver backtracking_search] [finish-proc values] #:count [solution-limit +inf.0]) (($csp?) (procedure? procedure? #:count integer?) . ->* . (or/c #f (non-empty-listof any/c))) - (match (for/list ([solution (in-value (solver csp))] ; needs generator here - [idx (in-range solution-limit)]) - (finish-proc solution)) - [(? pair? solutions) solutions] - [else #f])) + (begin0 + (match (for/list ([solution (in-producer (solver csp) (void))] + [idx (in-range solution-limit)]) + (finish-proc solution)) + [(? pair? solutions) solutions] + [else #false]) + (set-$csp-curr_domains! csp #f))) (define/contract (solve csp [solver backtracking_search] [finish-proc values]) (($csp?) (procedure? procedure?) . ->* . any/c) (match (solve* csp solver finish-proc #:count 1) [(list solution) solution] - [else #f])) + [else #false])) (require rackunit) (define vs '(wa nsw t q nt v sa)) @@ -217,11 +255,34 @@ (check-equal? (unordered_domain_values 'wa (hash) csp) '(red green)) (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? (length (solve* csp)) 18) -(set-$csp-curr_domains! csp #f) (check-equal? (suppose csp 'nsw 'red) '((nsw . green) (nsw . blue))) (check-equal? (solve csp) (make-hasheq '((nsw . red) (nt . red) (q . green) (sa . blue) (t . blue) (v . green) (wa . green)))) + +(check-equal? (suppose csp 'nsw 'red) '((nsw . green) (nsw . blue))) +(check-equal? (length (solve* csp)) 6) + +(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))))) + +(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))))) + +(parameterize ([current-inference forward_checking]) + (forward_checking csp 'sa 'blue (make-hasheq) null) + (check-equal? ($csp-curr_domains csp) + (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)))))) + +(parameterize ([current-inference forward_checking]) + (support_pruning csp) + (solve csp)) +