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-inference forward-check)
(current-select-variable mrv) (current-select-variable mrv)
(current-order-values shuffle) (current-order-values shuffle)
(current-shuffle #true) (current-random #true)
;; queens problem ;; queens problem
;; place queens on chessboard so they do not intersect ;; 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]) (parameterize ([current-solver min-conflicts])
(time-named (solve queens))) (time-named (solve queens)))

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

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

Write Preview
Loading…
Cancel
Save