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 (map-coloring-csp colors neighbors)
(define variables (remove-duplicates (flatten neighbors) eq?)) (define variables (remove-duplicates (flatten neighbors) eq?))
(define vds (for/list ([var (in-list variables)]) (define vds (for/list ([var (in-list variables)])
($var var colors null))) ($var var colors)))
(define cs (for*/list ([neighbor neighbors] (define cs (for*/list ([neighbor neighbors]
[target (cdr neighbor)]) [target (cdr neighbor)])
($constraint (list (car neighbor) target) neq?))) ($constraint (list (car neighbor) target) neq?)))
@ -23,6 +23,8 @@
(current-inference forward-check) (current-inference forward-check)
(current-select-variable minimum-remaining-values) (current-select-variable minimum-remaining-values)
(current-order-values shuffle)
(define aus (map-coloring-csp (parse-colors "RGB") (define aus (map-coloring-csp (parse-colors "RGB")
(parse-neighbors "SA: WA NT Q NSW V; NT: WA Q; NSW: Q V; T: "))) (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 #lang debug racket
(require "hacs.rkt" rackunit) (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 ($var 'a (range 3)) ($var 'b (range 3))) null))
(check-equal? (first-unassigned-variable ($csp (list (+avar 'a (range 3)) (+var 'b (range 3))) null)) ($var 'a (range 3)))
(+var 'b (range 3))) (check-equal? (first-unassigned-variable ($csp (list ($avar 'a (range 3)) ($var 'b (range 3))) null))
(check-false (first-unassigned-variable ($csp (list (+avar 'a (range 3)) (+avar '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? (check-equal?
;; no forward checking when no constraints ;; no forward checking when no constraints
($csp-vars (forward-check ($csp (list (+avar 'a '(1)) (+var 'b (range 2))) null) 'a)) ($csp-vars (forward-check ($csp (list ($avar 'a '(1)) ($var 'b (range 2))) null) 'a))
(list (+avar 'a '(1)) (+var 'b '(0 1)))) (list ($avar 'a '(1)) ($var 'b '(0 1))))
(check-equal? (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 =)) (list ($constraint '(a c) (negate =))
($constraint '(b c) (negate =)))) 'a) 'b)) ($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? (check-equal?
;; no inconsistency: b≠c not checked when fc is relative to a ;; 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 =)) (list ($constraint '(a b) (negate =))
($constraint '(b c) (negate =)))) 'a)) ($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? (check-equal?
;; no inconsistency: a≠b not checked when fc ignores a, which is already assigned ;; 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 =)) (list ($constraint '(a b) (negate =))
($constraint '(b c) (negate =)))) 'b)) ($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? (check-exn $backtrack?
(λ () ($csp-vars (forward-check ($csp (list (+avar 'a '(1)) (λ () ($csp-vars (forward-check ($csp (list ($avar 'a '(1))
(+var 'b '(1))) ($var 'b '(1)))
(list ($constraint '(a b) (negate =)))) 'a)))) (list ($constraint '(a b) (negate =)))) 'a))))
(check-equal? ($csp-vars (forward-check ($csp (list (+avar 'a (range 3)) (check-equal? ($csp-vars (forward-check ($csp (list ($var 'a '(0))
(+var 'b (range 3))) ($var 'b (range 3)))
(list ($constraint '(a b) <) (list ($constraint '(a b) <))) 'a))
($constraint '(a b) <) (list ($var 'a '(0)) ($cvar 'b '(1 2) '(a))))
($constraint '(a b) <))) 'a))
(list (+avar 'a '(0 1 2)) (+var 'b '(1 2) '(a))))
(check-equal? (check-equal?
(parameterize ([current-inference forward-check]) (parameterize ([current-inference forward-check])
(length (solve* ($csp (list (+var 'x (range 3)) (length (solve* ($csp (list ($var 'x (range 3))
(+var 'y (range 3)) ($var 'y (range 3))
(+var 'z (range 3))) ($var 'z (range 3)))
(list ($constraint '(x y) <>) (list ($constraint '(x y) <>)
($constraint '(x z) <>) ($constraint '(x z) <>)
($constraint '(y z) <>)))))) 6) ($constraint '(y z) <>)))))) 6)
(parameterize ([current-inference forward-check]) (parameterize ([current-inference forward-check])
(define vds (for/list ([k '(wa nt nsw q t v sa)]) (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 (define cs (list
($constraint '(wa nt) neq?) ($constraint '(wa nt) neq?)
($constraint '(wa sa) neq?) ($constraint '(wa sa) neq?)

48
csp/hacs.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save