mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

generations

Browse Source
main
Matthew Butterick 6 years ago
parent a82a8c1a1d
commit 9ce8bc01ea
1 changed files with 108 additions and 64 deletions
Show Stats Download Patch File Download Diff File

172
csp/aima.rkt
Unescape Escape View File

@ -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)
(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))))

Write Preview
Loading…
Cancel
Save