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

more

Browse Source
main
Matthew Butterick 6 years ago
parent 2eca36e674
commit ff193429e5
3 changed files with 51 additions and 50 deletions
Show Stats Download Patch File Download Diff File

4
csp/hacs-map.rkt
Unescape Escape View File

@ -5,7 +5,7 @@
(define (map-coloring-csp colors neighbors)
(define variables (remove-duplicates (flatten neighbors) eq?))
(define vds (for/list ([var (in-list variables)])
($var var colors null)))
($var var colors)))
(define cs (for*/list ([neighbor neighbors]
[target (cdr neighbor)])
($constraint (list (car neighbor) target) neq?)))
@ -23,6 +23,8 @@
(current-inference forward-check)
(current-select-variable minimum-remaining-values)
(current-order-values shuffle)
(define aus (map-coloring-csp (parse-colors "RGB")
(parse-neighbors "SA: WA NT Q NSW V; NT: WA Q; NSW: Q V; T: ")))

49
csp/hacs-test.rkt
Unescape Escape View File

@ -1,62 +1,61 @@
#lang debug racket
(require "hacs.rkt" rackunit)
(check-equal? (first-unassigned-variable ($csp (list (+var 'a (range 3)) (+var 'b (range 3))) null))
(+var 'a (range 3)))
(check-equal? (first-unassigned-variable ($csp (list (+avar 'a (range 3)) (+var 'b (range 3))) null))
(+var 'b (range 3)))
(check-false (first-unassigned-variable ($csp (list (+avar 'a (range 3)) (+avar 'b (range 3))) null)))
(check-equal? (first-unassigned-variable ($csp (list ($var 'a (range 3)) ($var 'b (range 3))) null))
($var 'a (range 3)))
(check-equal? (first-unassigned-variable ($csp (list ($avar 'a (range 3)) ($var 'b (range 3))) null))
($var 'b (range 3)))
(check-false (first-unassigned-variable ($csp (list ($avar 'a (range 3)) ($avar 'b (range 3))) null)))
(check-equal?
;; no forward checking when no constraints
($csp-vars (forward-check ($csp (list (+avar 'a '(1)) (+var 'b (range 2))) null) 'a))
(list (+avar 'a '(1)) (+var 'b '(0 1))))
($csp-vars (forward-check ($csp (list ($avar 'a '(1)) ($var 'b (range 2))) null) 'a))
(list ($avar 'a '(1)) ($var 'b '(0 1))))
(check-equal?
($csp-vars (forward-check (forward-check ($csp (list (+avar 'a '(1)) (+avar 'b '(0)) (+var 'c '(0 1 2)))
($csp-vars (forward-check (forward-check ($csp (list ($avar 'a '(1)) ($avar 'b '(0)) ($var 'c '(0 1 2)))
(list ($constraint '(a c) (negate =))
($constraint '(b c) (negate =)))) 'a) 'b))
(list (+avar 'a '(1)) (+avar 'b '(0) '()) (+var 'c '(2) '(b a))))
(list ($avar 'a '(1)) ($avar 'b '(0)) ($cvar 'c '(2) '(b a))))
(check-equal?
;; no inconsistency: b≠c not checked when fc is relative to a
($csp-vars (forward-check ($csp (list (+avar 'a '(1)) (+var 'b (range 2)) (+var 'c '(0)))
($csp-vars (forward-check ($csp (list ($avar 'a '(1)) ($var 'b (range 2)) ($var 'c '(0)))
(list ($constraint '(a b) (negate =))
($constraint '(b c) (negate =)))) 'a))
(list (+avar 'a '(1)) (+var 'b '(0) '(a)) (+var 'c '(0))))
(list ($avar 'a '(1)) ($cvar 'b '(0) '(a)) ($var 'c '(0))))
(check-equal?
;; no inconsistency: a≠b not checked when fc ignores a, which is already assigned
($csp-vars (forward-check ($csp (list (+avar 'a '(1)) (+avar 'b '(1)) (+var 'c (range 2)))
($csp-vars (forward-check ($csp (list ($avar 'a '(1)) ($avar 'b '(1)) ($var 'c (range 2)))
(list ($constraint '(a b) (negate =))
($constraint '(b c) (negate =)))) 'b))
(list (+avar 'a '(1)) (+avar 'b '(1)) (+var 'c '(0) '(b))))
(list ($avar 'a '(1)) ($avar 'b '(1)) ($cvar 'c '(0) '(b))))
(check-exn $backtrack?
(λ () ($csp-vars (forward-check ($csp (list (+avar 'a '(1))
(+var 'b '(1)))
(λ () ($csp-vars (forward-check ($csp (list ($avar 'a '(1))
($var 'b '(1)))
(list ($constraint '(a b) (negate =)))) 'a))))
(check-equal? ($csp-vars (forward-check ($csp (list (+avar 'a (range 3))
(+var 'b (range 3)))
(list ($constraint '(a b) <)
($constraint '(a b) <)
($constraint '(a b) <))) 'a))
(list (+avar 'a '(0 1 2)) (+var 'b '(1 2) '(a))))
(check-equal? ($csp-vars (forward-check ($csp (list ($var 'a '(0))
($var 'b (range 3)))
(list ($constraint '(a b) <))) 'a))
(list ($var 'a '(0)) ($cvar 'b '(1 2) '(a))))
(check-equal?
(parameterize ([current-inference forward-check])
(length (solve* ($csp (list (+var 'x (range 3))
(+var 'y (range 3))
(+var 'z (range 3)))
(length (solve* ($csp (list ($var 'x (range 3))
($var 'y (range 3))
($var 'z (range 3)))
(list ($constraint '(x y) <>)
($constraint '(x z) <>)
($constraint '(y z) <>)))))) 6)
(parameterize ([current-inference forward-check])
(define vds (for/list ([k '(wa nt nsw q t v sa)])
(+var k '(red green blue))))
($var k '(red green blue))))
(define cs (list
($constraint '(wa nt) neq?)
($constraint '(wa sa) neq?)

48
csp/hacs.rkt
Unescape Escape View File

@ -5,14 +5,13 @@
(struct $csp ([vars #:mutable]
[constraints #:mutable]) #:transparent)
(struct $constraint (names proc) #:transparent)
(struct $var (name domain past) #:transparent)
(define (+var name vals [past null])
($var name vals past))
(struct $var (name domain) #:transparent)
(define $var-name? symbol?)
(struct $cvar $var (past) #:transparent)
(struct $avar $var () #:transparent)
(define (+avar name vals [past null])
($avar name vals past))
(struct inconsistency-signal (csp) #:transparent)
(struct $backtrack (names) #:transparent)
@ -42,25 +41,16 @@
($var-domain ($csp-var csp name)))
(define order-domain-values values)
(define/contract (assign-val csp name val)
($csp? $var-name? any/c . -> . $csp?)
($csp
(for/list ([var ($csp-vars csp)])
(if (eq? name ($var-name var))
(+avar name (list val) ($var-past var))
($avar name (list val))
var))
($csp-constraints csp)))
(define/contract (update-conflicts csp name conflicts)
($csp? $var-name? (listof $var-name?) . -> . $csp?)
($csp
(for/list ([var ($csp-vars csp)])
(match var
[($var (? (λ (x) (eq? x name))) vals past)
(+avar name vals past conflicts)]
[else var]))
($csp-constraints csp)))
(define (unassigned-vars csp)
(for/list ([var (in-list ($csp-vars csp))]
#:unless ($avar? var))
@ -102,8 +92,10 @@
(define aval (first ($csp-vals csp aname)))
(define (check-var var)
(match var
[(? $avar?) var]
[($var name vals past)
;; don't check against assigned vars, or the reference var
;; (which is probably assigned but maybe not)
[(? (λ (x) (or ($avar? x) (eq? ($var-name x) aname)))) var]
[($var name vals)
(match (($csp-constraints csp) . relating . (list aname name))
[(? empty?) var]
[constraints
@ -115,12 +107,14 @@
(proc val aval)
(proc aval val)))))
val))
(+var name new-vals (cons aname past))])]))
($cvar name new-vals (cons aname (if ($cvar? var)
($cvar-past var)
null)))])]))
(define checked-vars (map check-var ($csp-vars csp)))
;; conflict-set will be empty if there are no empty domains
(define conflict-set (for*/list ([var (in-list checked-vars)]
#:when (empty? ($var-domain var))
[name (in-list ($var-past var))])
[name (in-list ($cvar-past var))])
name))
;; for conflict-directed backjumping it's essential to forward-check ALL vars
;; (even after an empty domain is generated) and combine their conflicts
@ -142,7 +136,7 @@
(let loop ([csp csp])
(match (select-unassigned-variable csp)
[#false (yield csp)]
[($var name domain _)
[($var name domain)
(define (wants-backtrack? exn)
(and ($backtrack? exn) (memq name ($backtrack-names exn))))
(for/fold ([conflicts null]
@ -162,8 +156,14 @@
#:when (eq? name ($var-name var)))
(first ($var-domain var))))))
(define/contract ($csp-assocs csp)
($csp? . -> . (listof (cons/c $var-name? any/c)))
(for/list ([var (in-list ($csp-vars csp))])
(match var
[($var name domain) (cons name (first domain))])))
(define/contract (solve* csp
#:finish-proc [finish-proc $csp-vars]
#:finish-proc [finish-proc $csp-assocs]
#:solver [solver (or (current-solver) backtracking-solver)]
#:count [max-solutions +inf.0])
(($csp?) (#:finish-proc procedure? #:solver procedure? #:count integer?) . ->* . (listof any/c))
@ -174,7 +174,7 @@
(finish-proc solution)))
(define/contract (solve csp
#:finish-proc [finish-proc $csp-vars]
#:finish-proc [finish-proc $csp-assocs]
#:solver [solver (or (current-solver) backtracking-solver)])
(($csp?) (#:finish-proc procedure? #:solver procedure?) . ->* . (or/c #false any/c))
(match (solve* csp #:finish-proc finish-proc #:solver solver #:count 1)

Write Preview
Loading…
Cancel
Save