From 9ce8bc01eadceab48e322037ea4cdb1451b25341 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 14 Oct 2018 23:29:29 -0700 Subject: [PATCH] generations --- csp/aima.rkt | 172 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 108 insertions(+), 64 deletions(-) diff --git a/csp/aima.rkt b/csp/aima.rkt index ced9d838..1b59c2a0 100644 --- a/csp/aima.rkt +++ b/csp/aima.rkt @@ -1,59 +1,65 @@ #lang debug racket +(require racket/generator sugar/debug) (struct $csp (variables domains neighbors constraints initial curr_domains nassigns) #:transparent #:mutable) +(define assignment? hash?) +(define variable? symbol?) +(define removal? (cons/c variable? any/c)) (define/contract (make-csp variables domains neighbors constraints) - ((listof symbol?) hash? hash? procedure? . -> . $csp?) - ($csp - variables - domains - neighbors - constraints - null - #f - 0)) + ((listof variable?) hash? hash? procedure? . -> . $csp?) + ($csp variables domains neighbors constraints null #f 0)) (define/contract (assign csp var val assignment) - ($csp? symbol? any/c hash? . -> . void?) + ($csp? variable? any/c assignment? . -> . void?) ;; Add {var: val} to assignment; Discard the old value if any. (hash-set! assignment var val) (set-$csp-nassigns! csp (add1 ($csp-nassigns csp)))) (define/contract (unassign csp var assignment) - ($csp? symbol? hash? . -> . void?) + ($csp? variable? assignment? . -> . void?) ;; Remove {var: val} from assignment. ;; DO NOT call this if you are changing a variable to a new value; ;; just call assign for that. (hash-remove! assignment var)) (define/contract (nconflicts csp var val assignment) - ($csp? symbol? any/c hash? . -> . number?) + ($csp? variable? any/c assignment? . -> . number?) ;; Return the number of conflicts var=val has with other variables.""" ;; Subclasses may implement this more efficiently - (define (conflict var2) - (and (hash-has-key? assignment var2) - (not (($csp-constraints csp) var val var2 (hash-ref assignment var2))))) - (for/sum ([v (hash-ref ($csp-neighbors csp) var)] - #:when (conflict v)) - 1)) + (for/sum ([v (in-list (hash-ref ($csp-neighbors csp) var))] + #:when (hash-has-key? assignment v)) + (if (($csp-constraints csp) var val v (hash-ref assignment v)) 0 1))) (define (display csp assignment) - (displayln "todo")) + (displayln csp)) + +(define/contract (all-variables-assigned? csp assignment) + ($csp? assignment? . -> . boolean?) + (= (length (hash-keys assignment)) (length ($csp-variables csp)))) + +(define/contract (goal_test csp state) + ($csp? assignment? . -> . boolean?) + ;; The goal is to assign all variables, with all constraints satisfied. + (define assignment state) + (and (all-variables-assigned? csp assignment) + (for/and ([variable ($csp-variables csp)]) + (zero? (nconflicts csp variable (hash-ref assignment variable) assignment))))) + +;; These are for constraint propagation (define/contract (support_pruning csp) ($csp? . -> . void?) ;; Make sure we can prune values from domains. (We want to pay ;; for this only if we use it.) - (when (false? ($csp-curr_domains csp)) - (set-$csp-curr_domains! - csp - (let ([h (make-hash)]) - (for ([v ($csp-variables csp)]) - (hash-set! h v (hash-ref ($csp-domains csp) v))) - h)))) + (unless ($csp-curr_domains csp) + (define h (make-hasheq)) + (for ([v ($csp-variables csp)]) + (hash-set! h v (hash-ref ($csp-domains csp) v))) + (set-$csp-curr_domains! csp h))) (define/contract (suppose csp var value) - ($csp? symbol? any/c . -> . (listof (cons/c symbol? any/c))) + ($csp? variable? any/c . -> . (listof removal?)) ;; Start accumulating inferences from assuming var=value (support_pruning csp) (define removals @@ -63,37 +69,36 @@ (hash-set! ($csp-curr_domains csp) var (list value)) removals) - +;; todo: update uses of `prune` to be functional on removals (define/contract (prune csp var value removals) - ($csp? symbol? any/c (or/c #f (listof (cons/c symbol? any/c))) . -> . (listof (cons/c symbol? any/c))) + ($csp? variable? any/c (or/c #f (listof removal?)) . -> . (listof removal?)) ;; Rule out var=value - (hash-update! ($csp-curr_domains csp) var - (λ (vals) (remove value vals))) - (and removals - (append removals (list (cons var value))))) + (hash-update! ($csp-curr_domains csp) var (λ (vals) (remove value vals))) + (and removals (append removals (list (cons var value))))) (define/contract (choices csp var) - ($csp? symbol? . -> . (listof any/c)) + ($csp? variable? . -> . (listof any/c)) ;; Return all values for var that aren't currently ruled out. (hash-ref (or ($csp-curr_domains csp) ($csp-domains csp)) var)) (define/contract (infer_assignment csp) - ($csp? . -> . hash?) + ($csp? . -> . assignment?) ;; Return the partial assignment implied by the current inferences. (support_pruning csp) - (let ([a (make-hash)]) - (for ([v ($csp-variables csp)] - #:when (= 1 (length (hash-ref ($csp-curr_domains csp) v)))) - (hash-set! a v (first (hash-ref ($csp-curr_domains csp) v)))) - a)) + (define assignment (make-hasheq)) + (for ([v (in-list ($csp-variables csp))]) + (match (hash-ref ($csp-curr_domains csp) v) + [(list one-value) (hash-set! assignment v one-value)] + [else #f])) + assignment) (define/contract (restore csp removals) - ($csp? (listof (cons/c symbol? any/c)) . -> . void?) + ($csp? (listof removal?) . -> . void?) ;; Undo a supposition and all inferences from it. - (for ([removal removals]) - (match-define (cons B b) removal) - (hash-update! ($csp-curr_domains csp) B - (λ (vals) (append vals (list b)))))) + (for ([removal (in-list removals)]) + (match removal + [(cons B b) (hash-update! ($csp-curr_domains csp) B + (λ (vals) (append vals (list b))))]))) ;; ______________________________________________________________________________ @@ -102,42 +107,73 @@ ;; Variable ordering (define/contract (first_unassigned_variable assignment csp) - (hash? $csp? . -> . symbol?) + (assignment? $csp? . -> . (or/c #false variable?)) ;; The default variable order. - (for/first ([var ($csp-variables csp)] - #:when (not (hash-has-key? assignment var))) + (for/first ([var (in-list ($csp-variables csp))] + #:unless (hash-has-key? assignment var)) var)) ;; Value ordering (define/contract (unordered_domain_values var assignment csp) - (symbol? hash? $csp? . -> . (listof any/c)) + (variable? assignment? $csp? . -> . (listof any/c)) ;; The default value order. (choices csp var)) ;; Inference (define/contract (no_inference csp var value assignment removals) - ($csp? symbol? any/c hash? (listof (cons/c symbol? any/c)) . -> . boolean?) + ($csp? variable? any/c assignment? (listof removal?) . -> . boolean?) #true) (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 hash?)) - #f) + (($csp?) (procedure? procedure? procedure?) . ->* . generator?) + (generator () + (let backtrack ([assignment (make-hasheq)]) + (match (select_unassigned_variable assignment csp) + [#false (and (goal_test csp assignment) assignment)] + [var + (cond + [(for/or ([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)) + (cond + [(and (inference csp var val assignment removals) (backtrack assignment))] + [else (restore csp removals) #false]))] + [else (unassign csp var assignment) #false])])))) + +(define/contract (solve* csp [solver backtracking_search] [finish-proc values][solution-limit +inf.0]) + (($csp?) (procedure? procedure? integer?) . ->* . (non-empty-listof any/c)) + (match (for/list ([solution (in-producer (solver csp) (void))] + [idx (in-range solution-limit)]) + (finish-proc solution)) + [(? pair? solutions) solutions] + [else #f])) + +(define/contract (solve csp [solver backtracking_search] [finish-proc values]) + (($csp?) (procedure? procedure?) . ->* . any/c) + (first (solve* csp solver finish-proc 1))) (require rackunit) (define vs '(wa nsw t q nt v sa)) (define ds (for/hash ([k vs]) (values k '(red green blue)))) -(define ns (for*/hash ([k vs] - [k2 (cdr vs)]) - (values k (list k2)))) -(define csp (make-csp vs ds ns void)) +(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 csp (make-csp vs ds ns (λ (A a B b) (not (equal? a b))))) (check-true ($csp? csp)) -(define a (make-hash)) +(define a (make-hasheq)) (assign csp 'key 42 a) (check-equal? (hash-ref a 'key) 42) (unassign csp 'key a) @@ -146,9 +182,7 @@ (support_pruning csp) (check-true (hash? ($csp-curr_domains csp))) -(check-equal? - (suppose csp 'wa 'red) - '((wa . green) (wa . blue))) +(check-equal? (suppose csp 'wa 'red) '((wa . green) (wa . blue))) (check-equal? (hash-ref ($csp-curr_domains csp) 'wa) '(red)) @@ -157,15 +191,25 @@ (check-equal? (choices csp 'v) '(green blue)) (check-equal? (choices csp 'wa) '(red)) (check-equal? (infer_assignment csp) - (make-hash '((wa . red)))) + (make-hasheq '((wa . red)))) (check-equal? (suppose csp 'v 'blue) '((v . green))) (check-equal? (infer_assignment csp) - (make-hash '((v . blue) (wa . red)))) + (make-hasheq '((v . blue) (wa . red)))) (restore csp '((wa . green))) (check-equal? (infer_assignment csp) - (make-hash '((v . blue)))) + (make-hasheq '((v . blue)))) +(restore csp '((v . blue))) +(check-equal? (infer_assignment csp) (make-hasheq)) (check-equal? (first_unassigned_variable (hash) csp) 'wa) (check-equal? (unordered_domain_values 'wa (hash) csp) '(red green)) -(backtracking_search csp) \ No newline at end of file +(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)))) + +(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))))