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

deshuffle

Browse Source
main
Matthew Butterick 6 years ago
parent fe94d1ff60
commit fc42059e3b
3 changed files with 94 additions and 86 deletions
Show Stats Download Patch File Download Diff File

35
csp/hacs-test-workbench.rkt
Unescape Escape View File

@ -4,25 +4,28 @@
(current-inference forward-check)
(current-select-variable mrv)
(current-order-values shuffle)
(current-shuffle #true)
(current-random #true)
;; queens problem
;; place queens on chessboard so they do not intersect
(define queens (make-csp))
(define qs (for/list ([q 8]) (string->symbol (format "q~a" q))))
(define rows (range (length qs)))
(add-vars! queens qs rows)
(define (q-col q) (string->number (string-trim (symbol->string q) "q")))
(for* ([qs (in-combinations qs 2)])
(match-define (list qa qb) qs)
(match-define (list qa-col qb-col) (map q-col qs))
(add-constraint! queens
(λ (qa-row qb-row)
(nor
(= (abs (- qa-row qb-row)) (abs (- qa-col qb-col))) ; same diagonal?
(= qa-row qb-row))) ; same row?
(list qa qb)))
#;(time-named (solve queens))
(define board-size 8)
(define queens (make-csp))
(define qs (for/list ([q board-size]) (string->symbol (format "q~a" q))))
(define rows (range (length qs)))
(add-vars! queens qs rows)
(define (q-col q) (string->number (string-trim (symbol->string q) "q")))
(for* ([qs (in-combinations qs 2)])
(match-define (list qa qb) qs)
(match-define (list qa-col qb-col) (map q-col qs))
(add-constraint! queens
(λ (qa-row qb-row)
(nor
(= (abs (- qa-row qb-row)) (abs (- qa-col qb-col))) ; same diagonal?
(= qa-row qb-row))) ; same row?
(list qa qb)))
(time-avg 10 (solve queens))
(parameterize ([current-solver min-conflicts])
(time-named (solve queens)))

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

@ -4,7 +4,7 @@
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-order-values shuffle)
(current-shuffle #true)
(current-random #true)
(check-equal? (first-unassigned-variable ($csp (list ($var 'a (range 3)) ($var 'b (range 3))) null))
($var 'a (range 3)))
@ -278,7 +278,7 @@
(apply map list (slice-at x 5)))
(check-equal? (parameterize ([current-select-variable mrv]
[current-shuffle #f])
[current-random #f])
(finish (time-named (solve zebra))))
'(((nationality-0 . norwegian) (color-0 . yellow) (drink-0 . water) (smoke-0 . kools) (pet-0 . foxes))
((nationality-1 . ukrainian) (color-1 . blue) (drink-1 . tea) (smoke-1 . chesterfields) (pet-1 . horses))

141
csp/hacs.rkt
Unescape Escape View File

@ -16,7 +16,7 @@
(if (null? argss)
(yield (reverse acc))
(for ([arg (in-list (car argss))])
(loop (cdr argss) (cons arg acc))))))))
(loop (cdr argss) (cons arg acc))))))))
(struct $csp (vars
constraints
@ -37,7 +37,7 @@
(raise-argument-error '$constraint-proc "$csp" csp))
;; apply proc in many-to-many style
(for/and ([args (in-cartesian (map (λ (cname) ($csp-vals csp cname)) ($constraint-names constraint)))])
(apply ($constraint-proc constraint) args))))
(apply ($constraint-proc constraint) args))))
(define (make-constraint [names null] [proc values])
($constraint names proc))
@ -92,11 +92,11 @@
((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?)
(set-$csp-constraints! csp (append (constraints csp)
(for/list ([names (in-list namess)])
(for ([name (in-list names)])
(check-name-in-csp! 'add-constraints! csp name))
(make-constraint names (if proc-name
(procedure-rename proc proc-name)
proc))))))
(for ([name (in-list names)])
(check-name-in-csp! 'add-constraints! csp name))
(make-constraint names (if proc-name
(procedure-rename proc proc-name)
proc))))))
(define/contract (add-pairwise-constraint! csp proc var-names [proc-name #false])
((csp? procedure? (listof name?)) (name?) . ->* . void?)
@ -117,7 +117,7 @@
(define current-order-values (make-parameter #f))
(define current-inference (make-parameter #f))
(define current-solver (make-parameter #f))
(define current-shuffle (make-parameter #t))
(define current-random (make-parameter #t))
(define/contract (check-name-in-csp! caller csp name)
(symbol? csp? name? . -> . void?)
@ -130,7 +130,7 @@
(check-name-in-csp! 'csp-var csp name)
(for/first ([var (in-vars csp)]
#:when (eq? name (var-name var)))
var))
var))
(define/contract ($csp-vals csp name)
(csp? name? . -> . (listof any/c))
@ -143,7 +143,7 @@
(csp? name? . -> . any/c)
(for/or ([var (in-vars csp)]
#:when (assigned-var? var))
(eq? name (var-name var))))
(eq? name (var-name var))))
(define (reduce-function-arity proc pattern)
(unless (match (procedure-arity proc)
@ -174,19 +174,19 @@
(ormap assigned-name? ($constraint-names constraint)))
(make-csp (vars csp)
(for/list ([constraint (in-constraints csp)])
(cond
[(and (if minimum-arity (<= minimum-arity (constraint-arity constraint)) #true)
(partially-assigned? constraint))
(match-define ($constraint cnames proc) constraint)
($constraint (filter-not assigned-name? cnames)
;; pattern is mix of values and boxed symbols (indicating variables to persist)
;; use boxes here as cheap way to distinguish id symbols from value symbols
(let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
(if (assigned-name? cname)
(first ($csp-vals csp cname))
(box cname)))])
(reduce-function-arity proc reduce-arity-pattern)))]
[else constraint])))))
(cond
[(and (if minimum-arity (<= minimum-arity (constraint-arity constraint)) #true)
(partially-assigned? constraint))
(match-define ($constraint cnames proc) constraint)
($constraint (filter-not assigned-name? cnames)
;; pattern is mix of values and boxed symbols (indicating variables to persist)
;; use boxes here as cheap way to distinguish id symbols from value symbols
(let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
(if (assigned-name? cname)
(first ($csp-vals csp cname))
(box cname)))])
(reduce-function-arity proc reduce-arity-pattern)))]
[else constraint])))))
(define nassns 0)
(define (reset-assns!) (set! nassns 0))
@ -195,9 +195,9 @@
(when-debug (set! nassns (add1 nassns)))
(make-csp
(for/list ([var (vars csp)])
(if (eq? name (var-name var))
($avar name (list val))
var))
(if (eq? name (var-name var))
($avar name (list val))
var))
(constraints csp)))
(define/contract (unassigned-vars csp)
@ -214,7 +214,7 @@
(csp? . -> . (or/c #false (and/c $var? (not/c assigned-var?))))
(match (unassigned-vars csp)
[(? empty?) #false]
[xs (argmin (λ (var) (length ($var-domain var))) (shuffle xs))]))
[xs (argmin (λ (var) (length ($var-domain var))) xs)]))
(define mrv minimum-remaining-values)
@ -222,7 +222,7 @@
(csp? $var? . -> . exact-nonnegative-integer?)
(for/sum ([constraint (in-constraints csp)]
#:when (memq (var-name var) ($constraint-names constraint)))
1))
1))
(define/contract (blended-variable-selector csp)
(csp? . -> . (or/c #false (and/c $var? (not/c assigned-var?))))
@ -252,7 +252,7 @@
;; use degree as tiebreaker for mrv
(define max-degree-arg (argmax (λ (var) (var-degree csp var)) mrv-uvars))
;; use random tiebreaker for degree
(first (shuffle (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars)))])]))
(random-pick (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars))])]))
(define first-domain-value values)
@ -264,8 +264,8 @@
[cnames (in-value ($constraint-names constraint))]
#:when (and (= (length names) (length cnames))
(for/and ([name (in-list names)])
(memq name cnames))))
constraint))
(memq name cnames))))
constraint))
(define (binary-constraint? constraint)
(= 2 (constraint-arity constraint)))
@ -291,11 +291,11 @@
(define new-vals
(for/list ([val (in-list vals)]
#:when (for/and ([constraint (in-list constraints)])
(let ([proc ($constraint-proc constraint)])
(if (eq? name (first ($constraint-names constraint)))
(proc val aval)
(proc aval val)))))
val))
(let ([proc ($constraint-proc constraint)])
(if (eq? name (first ($constraint-names constraint)))
(proc val aval)
(proc aval val)))))
val))
($cvar name new-vals (cons aname (if ($cvar? var)
($cvar-past var)
null)))])]))
@ -305,7 +305,7 @@
(define conflict-set (for*/list ([var (in-list checked-vars)]
#:when (empty? ($var-domain var))
[name (in-list ($cvar-past var))])
name))
name))
;; for conflict-directed backjumping it's essential to forward-check ALL vars
;; (even after an empty domain is generated) and combine their conflicts
;; so we can discover the *most recent past var* that could be the culprit.
@ -322,13 +322,13 @@
(constraint-relates? constraint aname)
(let ([other-name (first (remq aname ($constraint-names constraint)))])
(singleton-var? (csp-var csp other-name)))))
constraint))
constraint))
(make-csp checked-vars nonsingleton-constraints))
(define/contract (constraint-checkable? c names)
($constraint? (listof name?) . -> . any/c)
(for/and ([cname (in-list ($constraint-names c))])
(memq cname names)))
(memq cname names)))
(define/contract (constraint-arity constraint)
($constraint? . -> . exact-nonnegative-integer?)
@ -346,24 +346,24 @@
;; we also want to use "singleton" vars (that is, vars that have been reduced to a single domain value by forward checking)
(define singleton-varnames (for/list ([var (in-vars csp)]
#:when (singleton-var? var))
(var-name var)))
(var-name var)))
(define-values (checkable-constraints other-constraints)
(partition (λ (c) (and (constraint-checkable? c singleton-varnames)
(if mandatory-names
(for/and ([name (in-list mandatory-names)])
(constraint-relates? c name))
(constraint-relates? c name))
#true))) (constraints csp)))
(cond
[conflict-count? (define conflict-count
(for/sum ([constraint (in-list checkable-constraints)]
#:unless (constraint csp))
1))
1))
(when-debug (set! nchecks (+ conflict-count nchecks)))
conflict-count]
[else (for ([(constraint idx) (in-indexed (sort checkable-constraints < #:key constraint-arity))]
#:unless (constraint csp))
(when-debug (set! nchecks (+ (add1 idx) nchecks)))
(backtrack!))
(when-debug (set! nchecks (+ (add1 idx) nchecks)))
(backtrack!))
;; discard checked constraints, since they have no further reason to live
(make-csp (vars csp) other-constraints)]))
@ -372,15 +372,15 @@
;; todo: why does this function slow down searches?
(make-csp
(for/list ([var (in-vars csp)])
(match-define ($var name vals) var)
(define procs (for*/list ([constraint (in-constraints csp)]
[cnames (in-value ($constraint-names constraint))]
#:when (and (= 1 (length cnames)) (eq? name (car cnames))))
($constraint-proc constraint)))
($var name
(for*/fold ([vals vals])
([proc (in-list procs)])
(filter proc vals))))
(match-define ($var name vals) var)
(define procs (for*/list ([constraint (in-constraints csp)]
[cnames (in-value ($constraint-names constraint))]
#:when (and (= 1 (length cnames)) (eq? name (car cnames))))
($constraint-proc constraint)))
($var name
(for*/fold ([vals vals])
([proc (in-list procs)])
(filter proc vals))))
(constraints csp)))
(define/contract (backtracking-solver
@ -412,8 +412,10 @@
(loop csp)))
conflicts)]))))
(define (random-pick xs)
(list-ref xs (random (length xs))))
(define/contract (min-conflicts csp [max-steps 64])
(define/contract (min-conflicts csp [max-steps 100])
(($csp?) (integer?) . ->* . generator?)
;; Solve a CSP by stochastic hillclimbing on the number of conflicts.
(generator ()
@ -421,31 +423,34 @@
;; Generate a complete assignment for all variables (probably with conflicts)
(define starting-assignment
(for/fold ([csp csp0])
([var (in-vars csp0)])
(define name (var-name var))
(assign-val csp name (first (shuffle ($csp-vals csp0 name))))))
([var (in-vars csp0)])
(define name (var-name var))
(assign-val csp name (random-pick ($csp-vals csp0 name)))))
;; Now repeatedly choose a random conflicted variable and change it
(for/fold ([csp starting-assignment])
([i (in-range max-steps)])
(match (conflicted-var-names csp)
[(? empty?) (when (check-constraints csp) (yield csp)) (loop csp0)]
[cvar-names
(define cvar-name (first ((if (current-shuffle) shuffle values) cvar-names)))
(define val (min-conflicts-value csp cvar-name ($csp-vals csp0 cvar-name)))
(assign-val csp cvar-name val)]))
(loop csp0))))
[(? empty?) (yield csp) (loop csp0)]
[names
(define name (random-pick names))
(define val (min-conflicts-value csp name ($csp-vals csp0 name)))
(assign-val csp name val)])))))
(define/contract (conflicted-var-names csp)
($csp? . -> . (listof name?))
;; Return a list of variables in current assignment that are conflicted
(for/list ([name (in-var-names csp)]
#:when (positive? (nconflicts csp name)))
name))
name))
(define/contract (min-conflicts-value csp name vals)
($csp? name? (listof any/c) . -> . any/c)
;; Return the value that will give var the least number of conflicts
(argmin (λ (val) (nconflicts csp name val)) (shuffle vals)))
(define vals-by-conflict (sort vals < #:key (λ (val) (nconflicts csp name val))
#:cache-keys? #true))
(for/first ([val (in-list vals-by-conflict)]
#:unless (equal? val (first ($csp-vals csp name))))
val))
(define no-value-sig (gensym))
@ -459,8 +464,8 @@
(define/contract (csp->assocs csp)
(csp? . -> . (listof (cons/c name? any/c)))
(for/list ([var (in-vars csp)])
(match var
[($var name domain) (cons name (first domain))])))
(match var
[($var name domain) (cons name (first domain))])))
(define/contract (solve* csp
#:finish-proc [finish-proc csp->assocs]
@ -473,7 +478,7 @@
(reset-nchecks!))
(for/list ([solution (in-producer (solver csp) (void))]
[idx (in-range max-solutions)])
(finish-proc solution)))
(finish-proc solution)))
(define/contract (solve csp
#:finish-proc [finish-proc csp->assocs]

Write Preview
Loading…
Cancel
Save