main
Matthew Butterick 6 years ago
parent c6c13bc486
commit 59ae964544

@ -18,12 +18,9 @@
(time-avg 10 (solve* triples)) (time-avg 10 (solve* triples))
(define (f) (for*/list ([a (in-range 10 50)]
(for*/list ([a (in-range 10 50)] [b (in-range 10 50)]
[b (in-range 10 50)] #:when (<= a b)
#:when (<= a b) [c (in-range 10 50)]
[c (in-range 10 50)] #:when (and (coprime? a b c) (valid-triple? a b c)))
#:when (and (coprime? a b c) (valid-triple? a b c))) (map cons '(a b c) (list a b c)))
`((a . ,a) (b . ,b) (c . ,c))))
(time-avg 10 (f))

@ -1,28 +1,28 @@
#lang debug br #lang debug br
(require sugar/debug "hacs.rkt") (require sugar/debug "hacs.rkt")
(define names (for/list ([i (in-range 81)]) (define cells (for/list ([i (in-range 81)])
(string->symbol (format "c~a" i)))) (string->symbol (format "c~a" i))))
(define (make-sudoku) (define (make-sudoku)
(define sudoku (make-csp)) (define sudoku (make-csp))
(add-vars! sudoku names (range 1 10)) (add-vars! sudoku cells (range 1 10))
(define (not= . xs) (= (length xs) (length (remove-duplicates xs =)))) (define (not= . xs) (not (check-duplicates xs =)))
(for ([i (in-range 9)]) (for ([i (in-range 9)])
(define row-cells (for/list ([(name idx) (in-indexed names)] (define row-cells (for/list ([(name idx) (in-indexed cells)]
#:when (= (quotient idx 9) i)) #:when (= (quotient idx 9) i))
name)) name))
(add-pairwise-constraint! sudoku not= row-cells) (add-pairwise-constraint! sudoku not= row-cells)
(define col-cells (for/list ([(name idx) (in-indexed names)] (define col-cells (for/list ([(name idx) (in-indexed cells)]
#:when (= (remainder idx 9) i)) #:when (= (remainder idx 9) i))
name)) name))
(add-pairwise-constraint! sudoku not= col-cells)) (add-pairwise-constraint! sudoku not= col-cells))
(for ([i '(0 3 6 27 30 33 54 57 60)]) (for ([i '(0 3 6 27 30 33 54 57 60)])
(define box-cells (for/list ([j '(0 1 2 9 10 11 18 19 20)]) (define box-cells (for/list ([offset '(0 1 2 9 10 11 18 19 20)])
(string->symbol (format "c~a" (+ i j))))) (string->symbol (format "c~a" (+ i offset)))))
(add-pairwise-constraint! sudoku not= box-cells)) (add-pairwise-constraint! sudoku not= box-cells))
sudoku) sudoku)
@ -35,11 +35,11 @@
(define (board . strs) (define (board . strs)
(define sudoku (make-sudoku)) (define sudoku (make-sudoku))
(define vals (define vals
(for*/list ([str strs] (for*/list ([str (in-list strs)]
[c (in-port read-char (open-input-string str))] [c (in-string str)]
#:unless (memv c '(#\- #\|))) #:unless (memv c '(#\- #\|)))
(string->number (string c)))) (string->number (string c))))
(for ([name names] (for ([name cells]
[val vals] [val vals]
#:when val) #:when val)
(add-constraint! sudoku (curry = val) (list name) (string->symbol (format "is-~a" val)))) (add-constraint! sudoku (curry = val) (list name) (string->symbol (format "is-~a" val))))

@ -20,7 +20,7 @@
(if (null? argss) (if (null? argss)
(yield (reverse acc)) (yield (reverse acc))
(for ([arg (car argss)]) (for ([arg (car argss)])
(loop (cdr argss) (cons arg acc)))))))) (loop (cdr argss) (cons arg acc))))))))
(struct csp (vars constraints) #:mutable #:transparent) (struct csp (vars constraints) #:mutable #:transparent)
(define constraints csp-constraints) (define constraints csp-constraints)
@ -36,7 +36,7 @@
(raise-argument-error 'constraint "csp" prob)) (raise-argument-error 'constraint "csp" prob))
;; apply proc in many-to-many style ;; apply proc in many-to-many style
(for/and ([args (in-cartesian (map (λ (name) (find-domain prob name)) (constraint-names const)))]) (for/and ([args (in-cartesian (map (λ (name) (find-domain prob name)) (constraint-names const)))])
(apply (constraint-proc const) args)))) (apply (constraint-proc const) args))))
(define name? symbol?) (define name? symbol?)
@ -57,7 +57,7 @@
(apply add-edge! gr edge) (apply add-edge! gr edge)
gr)) gr))
(struct var (name domain) #:transparent #:mutable) (struct var (name domain) #:transparent)
(define domain var-domain) (define domain var-domain)
(struct checked-variable var (history) #:transparent) (struct checked-variable var (history) #:transparent)
@ -77,19 +77,17 @@
((name?) ((listof any/c)) . ->* . var?) ((name?) ((listof any/c)) . ->* . var?)
(var name vals)) (var name vals))
(define/contract (add-vars! prob names-or-procedure [vals-or-procedure empty]) (define/contract (add-vars! prob names [vals-or-procedure empty])
((csp? (or/c (listof name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?) ((csp? (listof name?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
(for/fold ([vrs (vars prob)] (for/fold ([vrs (vars prob)]
#:result (set-csp-vars! prob (reverse vrs))) #:result (set-csp-vars! prob vrs))
([name (in-list (match names-or-procedure ([name (in-list names)])
[(? procedure? proc) (proc)]
[names names]))])
(when (memq name (map var-name vrs)) (when (memq name (map var-name vrs))
(raise-argument-error 'add-vars! "var that doesn't already exist" name)) (raise-argument-error 'add-vars! "var that doesn't already exist" name))
(cons (make-var name (append vrs (list (make-var name
(match vals-or-procedure (match vals-or-procedure
[(? procedure? proc) (proc)] [(? procedure? proc) (proc)]
[vals vals])) vrs))) [vals vals]))))))
(define/contract (add-var! prob name [vals-or-procedure empty]) (define/contract (add-var! prob name [vals-or-procedure empty])
((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?) ((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
@ -99,11 +97,11 @@
((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?) ((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?)
(set-csp-constraints! prob (append (constraints prob) (set-csp-constraints! prob (append (constraints prob)
(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! prob name)) (check-name-in-csp! 'add-constraints! prob 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! prob proc names [proc-name #false]) (define/contract (add-pairwise-constraint! prob proc names [proc-name #false])
((csp? procedure? (listof name?)) (name?) . ->* . void?) ((csp? procedure? (listof name?)) (name?) . ->* . void?)
@ -142,7 +140,7 @@
(check-name-in-csp! 'find-var prob name) (check-name-in-csp! 'find-var prob name)
(for/first ([vr (in-vars prob)] (for/first ([vr (in-vars prob)]
#:when (eq? name (var-name vr))) #:when (eq? name (var-name vr)))
vr)) vr))
(define/contract (find-domain prob name) (define/contract (find-domain prob name)
(csp? name? . -> . (listof any/c)) (csp? name? . -> . (listof any/c))
@ -185,20 +183,20 @@
(ormap assigned? (constraint-names constraint))) (ormap assigned? (constraint-names constraint)))
(make-csp (vars prob) (make-csp (vars prob)
(for/list ([const (in-constraints prob)]) (for/list ([const (in-constraints prob)])
(cond (cond
;; no point reducing 2-arity functions because they will be consumed by forward checking ;; no point reducing 2-arity functions because they will be consumed by forward checking
[(and (or (not minimum-arity) (<= minimum-arity (constraint-arity const))) [(and (or (not minimum-arity) (<= minimum-arity (constraint-arity const)))
(partially-assigned? const)) (partially-assigned? const))
(match-define (constraint cnames proc) const) (match-define (constraint cnames proc) const)
;; 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
(define arity-reduction-pattern (for/list ([cname (in-list cnames)]) (define arity-reduction-pattern (for/list ([cname (in-list cnames)])
(if (assigned? cname) (if (assigned? cname)
(first (find-domain prob cname)) (first (find-domain prob cname))
(box cname)))) (box cname))))
(constraint (filter-not assigned? cnames) (constraint (filter-not assigned? cnames)
(reduce-function-arity proc arity-reduction-pattern))] (reduce-function-arity proc arity-reduction-pattern))]
[else const])))) [else const]))))
(define nassns 0) (define nassns 0)
(define nfchecks 0) (define nfchecks 0)
@ -213,9 +211,9 @@
(begin0 (begin0
(make-csp (make-csp
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(if (eq? name (var-name vr)) (if (eq? name (var-name vr))
(assigned-var name (list val)) (assigned-var name (list val))
vr)) vr))
(constraints prob)) (constraints prob))
(when-debug (set! nassns (add1 nassns))))) (when-debug (set! nassns (add1 nassns)))))
@ -245,7 +243,7 @@
(for/list ([x (in-list xs)] (for/list ([x (in-list xs)]
[val (in-list vals)] [val (in-list vals)]
#:when (= val target-val)) #:when (= val target-val))
x)])) x)]))
(define/contract (argmax* proc xs) (define/contract (argmax* proc xs)
(procedure? (listof any/c) . -> . (listof any/c)) (procedure? (listof any/c) . -> . (listof any/c))
@ -270,7 +268,7 @@
(csp? var? . -> . natural?) (csp? var? . -> . natural?)
(for/sum ([const (in-constraints prob)] (for/sum ([const (in-constraints prob)]
#:when (memq (var-name var) (constraint-names const))) #:when (memq (var-name var) (constraint-names const)))
1)) 1))
(define/contract (domain-length var) (define/contract (domain-length var)
(var? . -> . natural?) (var? . -> . natural?)
@ -279,7 +277,7 @@
(define/contract (state-count csp) (define/contract (state-count csp)
(csp? . -> . natural?) (csp? . -> . natural?)
(for/product ([vr (in-vars csp)]) (for/product ([vr (in-vars csp)])
(domain-length vr))) (domain-length vr)))
(define/contract (mrv-degree-hybrid prob) (define/contract (mrv-degree-hybrid prob)
(csp? . -> . (or/c #f var?)) (csp? . -> . (or/c #f var?))
@ -298,8 +296,8 @@
[cnames (in-value (constraint-names const))] [cnames (in-value (constraint-names const))]
#: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))))
const)) const))
(define (one-arity? const) (= 1 (constraint-arity const))) (define (one-arity? const) (= 1 (constraint-arity const)))
(define (two-arity? const) (= 2 (constraint-arity const))) (define (two-arity? const) (= 2 (constraint-arity const)))
@ -313,7 +311,7 @@
((listof (and/c constraint? two-arity?)) . -> . (listof arc?)) ((listof (and/c constraint? two-arity?)) . -> . (listof arc?))
(for*/list ([const (in-list constraints)] (for*/list ([const (in-list constraints)]
[name (in-list (constraint-names const))]) [name (in-list (constraint-names const))])
(arc name const))) (arc name const)))
(require sugar/debug) (require sugar/debug)
(define/contract (reduce-domain prob ark) (define/contract (reduce-domain prob ark)
@ -325,16 +323,16 @@
(λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order (λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order
(define (satisfies-arc? val) (define (satisfies-arc? val)
(for/or ([other-val (in-list (find-domain prob other-name))]) (for/or ([other-val (in-list (find-domain prob other-name))])
(proc val other-val))) (proc val other-val)))
(make-csp (make-csp
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(cond (cond
[(assigned-var? vr) vr] [(assigned-var? vr) vr]
[(eq? name (var-name vr)) [(eq? name (var-name vr))
(make-var name (match (filter satisfies-arc? (domain vr)) (make-var name (match (filter satisfies-arc? (domain vr))
[(? empty?) (backtrack!)] [(? empty?) (backtrack!)]
[vals vals]))] [vals vals]))]
[else vr])) [else vr]))
(constraints prob))) (constraints prob)))
(define/contract (terminating-at? arcs name) (define/contract (terminating-at? arcs name)
@ -343,7 +341,7 @@
#:when (and #:when (and
(memq name (constraint-names (arc-const arc))) (memq name (constraint-names (arc-const arc)))
(not (eq? name (arc-name arc))))) (not (eq? name (arc-name arc)))))
arc)) arc))
(define/contract (ac-3 prob ref-name) (define/contract (ac-3 prob ref-name)
(csp? name? . -> . csp?) (csp? name? . -> . csp?)
@ -353,8 +351,8 @@
(define starting-arcs (two-arity-constraints->arcs (for/list ([const (in-constraints prob)] (define starting-arcs (two-arity-constraints->arcs (for/list ([const (in-constraints prob)]
#:when (and (two-arity? const) #:when (and (two-arity? const)
(for/and ([cname (in-list (constraint-names const))]) (for/and ([cname (in-list (constraint-names const))])
(memq cname checkable-names)))) (memq cname checkable-names))))
const))) const)))
(for/fold ([prob prob] (for/fold ([prob prob]
[arcs (sort starting-arcs < #:key (λ (a) (length (find-domain prob (arc-name a)))) #:cache-keys? #true)] [arcs (sort starting-arcs < #:key (λ (a) (length (find-domain prob (arc-name a)))) #:cache-keys? #true)]
#:result (prune-singleton-constraints prob)) #:result (prune-singleton-constraints prob))
@ -385,11 +383,11 @@
(define new-vals (define new-vals
(for/list ([val (in-list vals)] (for/list ([val (in-list vals)]
#:when (for/and ([const (in-list constraints)]) #:when (for/and ([const (in-list constraints)])
(let ([proc (constraint-proc const)]) (let ([proc (constraint-proc const)])
(if (eq? name (first (constraint-names const))) (if (eq? name (first (constraint-names const)))
(proc val ref-val) (proc val ref-val)
(proc ref-val val))))) (proc ref-val val)))))
val)) val))
(checked-variable name new-vals (cons (cons ref-name ref-val) (match vr (checked-variable name new-vals (cons (cons ref-name ref-val) (match vr
[(checked-variable _ _ history) history] [(checked-variable _ _ history) history]
[else null])))])])) [else null])))])]))
@ -398,15 +396,15 @@
((csp?) ((or/c #false name?)) . ->* . csp?) ((csp?) ((or/c #false name?)) . ->* . csp?)
(define singleton-var-names (for/list ([vr (in-vars prob)] (define singleton-var-names (for/list ([vr (in-vars prob)]
#:when (singleton-var? vr)) #:when (singleton-var? vr))
(var-name vr))) (var-name vr)))
(make-csp (make-csp
(vars prob) (vars prob)
(for/list ([const (in-constraints prob)] (for/list ([const (in-constraints prob)]
#:unless (and (two-arity? const) #:unless (and (two-arity? const)
(or (not ref-name) (constraint-relates? const ref-name)) (or (not ref-name) (constraint-relates? const ref-name))
(for/and ([cname (in-list (constraint-names const))]) (for/and ([cname (in-list (constraint-names const))])
(memq cname singleton-var-names)))) (memq cname singleton-var-names))))
const))) const)))
(define/contract (forward-check prob ref-name) (define/contract (forward-check prob ref-name)
(csp? name? . -> . csp?) (csp? name? . -> . csp?)
@ -415,7 +413,7 @@
;; conflict-set will be empty if there are no empty domains (as we would hope) ;; conflict-set will be empty if there are no empty domains (as we would hope)
(define conflict-set (for/list ([cvr (in-list checked-vars)] (define conflict-set (for/list ([cvr (in-list checked-vars)]
#:when (empty? (domain cvr))) #:when (empty? (domain cvr)))
(history cvr))) (history cvr)))
;; 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.
@ -432,7 +430,7 @@
;; constraint is checkable if all constraint names ;; constraint is checkable if all constraint names
;; are in target list of names. ;; are in target list of names.
(for/and ([cname (in-list (constraint-names const))]) (for/and ([cname (in-list (constraint-names const))])
(memq cname names))) (memq cname names)))
(define/contract (constraint-arity const) (define/contract (constraint-arity const)
(constraint? . -> . natural?) (constraint? . -> . natural?)
@ -449,21 +447,21 @@
(partition (λ (const) (and (constraint-checkable? const assigned-varnames) (partition (λ (const) (and (constraint-checkable? const assigned-varnames)
(or (not mandatory-names) (or (not mandatory-names)
(for/and ([name (in-list mandatory-names)]) (for/and ([name (in-list mandatory-names)])
(constraint-relates? const name))))) (constraint-relates? const name)))))
(constraints prob))) (constraints prob)))
(cond (cond
[conflict-count? [conflict-count?
(define conflict-count (define conflict-count
(for/sum ([constraint (in-list checkable-consts)] (for/sum ([constraint (in-list checkable-consts)]
#:unless (constraint prob)) #:unless (constraint prob))
1)) 1))
(when-debug (set! nchecks (+ conflict-count nchecks))) (when-debug (set! nchecks (+ conflict-count nchecks)))
conflict-count] conflict-count]
[else [else
(for ([(constraint idx) (in-indexed checkable-consts)] (for ([(constraint idx) (in-indexed checkable-consts)]
#:unless (constraint prob)) #:unless (constraint prob))
(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 prob) other-consts)])) (make-csp (vars prob) other-consts)]))
@ -475,26 +473,26 @@
prob prob
(make-csp (make-csp
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(match-define (var name vals) vr) (match-define (var name vals) vr)
(define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints)) (define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints))
(make-var name (for/list ([val (in-list vals)] (make-var name (for/list ([val (in-list vals)]
#:when (for/and ([const (in-list name-constraints)]) #:when (for/and ([const (in-list name-constraints)])
((constraint-proc const) val))) ((constraint-proc const) val)))
val))) val)))
other-constraints))) other-constraints)))
(define ((make-hist-proc assocs) . xs) (define ((make-hist-proc assocs) . xs)
(not (not
(for/and ([x (in-list xs)] (for/and ([x (in-list xs)]
[val (in-list (map cdr assocs))]) [val (in-list (map cdr assocs))])
(equal? x val)))) (equal? x val))))
(define/contract (backtracking-solver (define/contract (backtracking-solver
prob prob
#:select-variable [select-unassigned-variable #:select-variable [select-unassigned-variable
(or (current-select-variable) first-unassigned-variable)] (or (current-select-variable) first-unassigned-variable)]
#:order-values [order-domain-values (or (current-order-values) first-domain-value)] #:order-values [order-domain-values (or (current-order-values) first-domain-value)]
#:inference [inference (or (current-inference) no-inference)]) #:inference [inference (or (current-inference) forward-check)])
((csp?) (#:select-variable procedure? #:order-values procedure? #:inference procedure?) . ->* . generator?) ((csp?) (#:select-variable procedure? #:order-values procedure? #:inference procedure?) . ->* . generator?)
(generator () (generator ()
(define starting-state-count (state-count prob)) (define starting-state-count (state-count prob))
@ -508,7 +506,7 @@
(and (backtrack? exn) (or (let ([bths (backtrack-histories exn)]) (and (backtrack? exn) (or (let ([bths (backtrack-histories exn)])
(or (empty? bths) (for*/or ([bth bths] (or (empty? bths) (for*/or ([bth bths]
[rec bth]) [rec bth])
(eq? name (car rec)))))))) (eq? name (car rec))))))))
(for/fold ([conflicts null] (for/fold ([conflicts null]
#:result (void)) #:result (void))
([val (in-list (order-domain-values domain))]) ([val (in-list (order-domain-values domain))])
@ -518,7 +516,7 @@
(append conflicts (remq name (remove-duplicates (append conflicts (remq name (remove-duplicates
(for*/list ([bth bths] (for*/list ([bth bths]
[rec bth]) [rec bth])
(car rec)) eq?))))]) (car rec)) eq?))))])
(let* ([prob (assign-val prob name val)] (let* ([prob (assign-val prob name val)]
;; reduce constraints before inference, ;; reduce constraints before inference,
;; to create more forward-checkable (binary) constraints ;; to create more forward-checkable (binary) constraints
@ -558,9 +556,9 @@
((csp?) (integer?) . ->* . generator?) ((csp?) (integer?) . ->* . generator?)
(generator () (generator ()
(for ([thread-count (or (current-thread-count) 1)]) ; todo: what is ideal thread count? (for ([thread-count (or (current-thread-count) 1)]) ; todo: what is ideal thread count?
(make-min-conflcts-thread prob thread-count max-steps)) (make-min-conflcts-thread prob thread-count max-steps))
(for ([i (in-naturals)]) (for ([i (in-naturals)])
(yield (thread-receive))))) (yield (thread-receive)))))
(define/contract (optimal-stop-min proc xs) (define/contract (optimal-stop-min proc xs)
(procedure? (listof any/c) . -> . any/c) (procedure? (listof any/c) . -> . any/c)
@ -568,7 +566,7 @@
(define threshold (argmin proc sample)) (define threshold (argmin proc sample))
(or (for/first ([candidate (in-list candidates)] (or (for/first ([candidate (in-list candidates)]
#:when (<= (proc candidate) threshold)) #:when (<= (proc candidate) threshold))
candidate) candidate)
(last candidates))) (last candidates)))
(define/contract (conflicted-variable-names prob) (define/contract (conflicted-variable-names prob)
@ -576,7 +574,7 @@
;; 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 prob)] (for/list ([name (in-var-names prob)]
#:when (positive? (nconflicts prob name))) #:when (positive? (nconflicts prob name)))
name)) name))
(define/contract (min-conflicts-value prob name vals) (define/contract (min-conflicts-value prob name vals)
(csp? name? (listof any/c) . -> . any/c) (csp? name? (listof any/c) . -> . any/c)
@ -585,7 +583,7 @@
#:cache-keys? #true)) #:cache-keys? #true))
(for/first ([val (in-list vals-by-conflict)] (for/first ([val (in-list vals-by-conflict)]
#:unless (equal? val (first (find-domain prob name)))) ;; but change the value #:unless (equal? val (first (find-domain prob name)))) ;; but change the value
val)) val))
(define no-value-sig (gensym)) (define no-value-sig (gensym))
@ -600,11 +598,11 @@
((csp?) ((listof name?)) . ->* . (listof (cons/c name? any/c))) ((csp?) ((listof name?)) . ->* . (listof (cons/c name? any/c)))
(define assocs (define assocs
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(match vr (match vr
[(var name (list val)) (cons name val)]))) [(var name (list val)) (cons name val)])))
(if keys (if keys
(for/list ([key (in-list keys)]) (for/list ([key (in-list keys)])
(assq key assocs)) (assq key assocs))
assocs)) assocs))
(define/contract (combine-csps probs) (define/contract (combine-csps probs)
@ -619,42 +617,42 @@
(make-csp (make-csp
(for/list ([vr (in-vars prob)] (for/list ([vr (in-vars prob)]
#:when (memq (var-name vr) names)) #:when (memq (var-name vr) names))
vr) vr)
(for/list ([const (in-constraints prob)] (for/list ([const (in-constraints prob)]
#:when (for/and ([cname (in-list (constraint-names const))]) #:when (for/and ([cname (in-list (constraint-names const))])
(memq cname names))) (memq cname names)))
const))) const)))
(define/contract (solve* prob (define/contract (solve* prob
#:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))] #:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))]
#:solver [solver (or (current-solver) backtracking-solver)] #:solver [solver (or (current-solver) backtracking-solver)]
#:limit [max-solutions +inf.0]) #:count [max-solutions +inf.0])
((csp?) (#:finish-proc procedure? #:solver procedure? #:limit natural?) ((csp?) (#:finish-proc procedure? #:solver procedure? #:count natural?)
. ->* . (listof any/c)) . ->* . (listof any/c))
(when-debug (reset-nassns!) (reset-nfchecks!) (reset-nchecks!)) (when-debug (reset-nassns!) (reset-nfchecks!) (reset-nchecks!))
(define subcsps ; decompose into independent csps. `cc` determines "connected components" (define subcsps ; decompose into independent csps. `cc` determines "connected components"
(if (current-decompose) (if (current-decompose)
(for/list ([nodeset (in-list (cc (csp->graph prob)))]) (for/list ([nodeset (in-list (cc (csp->graph prob)))])
(extract-subcsp prob nodeset)) (extract-subcsp prob nodeset))
(list prob))) (list prob)))
(define solgens (map solver subcsps)) (define solgens (map solver subcsps))
(define solstreams (for/list ([solgen (in-list solgens)]) (define solstreams (for/list ([solgen (in-list solgens)])
(for/stream ([sol (in-producer solgen (void))]) (for/stream ([sol (in-producer solgen (void))])
sol))) sol)))
(for/list ([solution-pieces (in-cartesian solstreams)] (for/list ([solution-pieces (in-cartesian solstreams)]
[idx (in-range max-solutions)]) [idx (in-range max-solutions)])
(finish-proc (combine-csps solution-pieces)))) (finish-proc (combine-csps solution-pieces))))
(define/contract (solve prob (define/contract (solve prob
#:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))] #:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))]
#:solver [solver (or (current-solver) backtracking-solver)] #:solver [solver (or (current-solver) backtracking-solver)]
#:limit [max-solutions 1]) #:count [max-solutions 1])
((csp?) (#:finish-proc procedure? #:solver procedure? #:limit natural?) ((csp?) (#:finish-proc procedure? #:solver procedure? #:count natural?)
. ->* . (or/c #false any/c)) . ->* . (or/c #false any/c))
(match (solve* prob #:finish-proc finish-proc #:solver solver #:limit max-solutions) (match (solve* prob #:finish-proc finish-proc #:solver solver #:count max-solutions)
[(list solution) solution] [(list solution) solution]
[(list) #false] [(list) #false]
[(list solutions ...) solutions])) [(list solutions ...) solutions]))

@ -1,10 +1,13 @@
#lang scribble/manual #lang scribble/manual
@(require scribble/eval (for-label racket csp (except-in math/number-theory permutations))) @(require (except-in scribble/eval examples) scribble/example (for-label racket csp graph (except-in math/number-theory permutations)))
@(define my-eval (make-base-eval)) @(define my-eval (make-base-eval))
@(my-eval `(require csp racket/list)) @(my-eval `(require csp racket/list))
@(define-syntax-rule (my-examples ARG ...)
(examples #:label #f #:eval my-eval ARG ...))
@title{Constraint-satisfaction problems} @title{Constraint-satisfaction problems}
@author[(author+email "Matthew Butterick" "mb@mbtype.com")] @author[(author+email "Matthew Butterick" "mb@mbtype.com")]
@ -28,72 +31,72 @@ Import into your program like so:
@section{Introduction} @section{Introduction}
A @deftech{constraint-satisfaction problem} (often shortened to @deftech{CSP}) has two ingredients. The first is a set of @deftech{variables}, each associated with a set of possible values (called a @deftech{domain}). The other is a set of @deftech{constraints} that define relationships between the variables. A @deftech{constraint-satisfaction problem} (often shortened to @deftech{CSP}) has two ingredients. The first is a set of @deftech{variables}, each associated with a set of possible values (called its @deftech{domain}). The other is a set of @deftech{constraints} — a fancy word for @italic{rules} — that describe relationships among the variables.
Solving a CSP means finding a value for each variable from its domain that @deftech{satisfies} (that is, doesn't violate) any constraints. This selection of values is also known as an @deftech{assignment}. A CSP may have any number of assignments that solve the problem (including zero). When we select a value for each variable, we have what's known as an @deftech{assignment} or a @deftech{state}. Solving a CSP means finding an assignment that @deftech{satisfies} all the constraints. A CSP may have any number of solution states (including zero).
Even if the name is new, the idea of a CSP is probably familiar. For instance, many brain teasers — like Sudoku or crosswords or logic puzzles — are really just constraint-satisfaction problems. (Indeed, you can use this package to ruin all of them.) Even if the name is new, the idea of a CSP is probably familiar. For instance, many brain teasers — like Sudoku or crosswords or logic puzzles — are really just constraint-satisfaction problems. (Indeed, you can use this package to ruin all of them.)
When the computer solves a CSP, it's using an analogous process of deductive reasoning to eliminate impossible assignments, eventually converging on a solution (or determining that no solution exists). When the computer solves a CSP, it's using an analogous process of deductive reasoning to eliminate impossible assignments, eventually converging on a solution (or determining that no solution exists).
@section{Example} @section{First example}
Suppose we wanted to find @link["http://www.friesian.com/pythag.htm"]{Pythagorean triples} with sides between 10 and 49, inclusive. Suppose we wanted to find @link["http://www.friesian.com/pythag.htm"]{Pythagorean triples} with sides between 10 and 49, inclusive.
First we create a new CSP called @racket[triples], using @racket[make-csp]: First we create a new CSP called @racket[triples], using @racket[make-csp]:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(define triples (make-csp)) (define triples (make-csp))
] ]
Then we need variables to represent the values in the triple. For that, we use @racket[add-var!], where each variable has a @tech{symbol} for its name and a list of values for its domain: We use CSP variables to represent the values in the triple. We insert each one with @racket[add-var!], where each variable has a @tech{symbol} for its name and a list of values for its domain:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(add-var! triples 'a (range 10 50)) (add-var! triples 'a (range 10 50))
(add-var! triples 'b (range 10 50)) (add-var! triples 'b (range 10 50))
(add-var! triples 'c (range 10 50)) (add-var! triples 'c (range 10 50))
] ]
Then we need our constraint. We make a function called @racket[valid-triple?] that tests three values to see if they qualify as a Pythagorean triple. Then we insert this function as a constraint using @racket[add-constraint!], where we pass in the function we want to use for the constraint, and a list of variable names that the constraint applies to. Then we need our constraint. We make a function called @racket[valid-triple?] that tests three values to see if they qualify as a Pythagorean triple. Then we insert this function as a constraint using @racket[add-constraint!], passing as arguments 1) the function we want to use for the constraint, and 2) a list of variable names that the constraint applies to.
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(define (valid-triple? x y z) (define (valid-triple? x y z)
(= (expt z 2) (+ (expt x 2) (expt y 2)))) (= (expt z 2) (+ (expt x 2) (expt y 2))))
(add-constraint! triples valid-triple? '(a b c)) (add-constraint! triples valid-triple? '(a b c))
] ]
The argument names used within the constraint function have nothing to do with the CSP variable names that are passed to the function. This makes sense — we might want constraints that apply the same function to different groups of CSP variables. What's important is that the @tech{arity} of the constraint matches the number of variable names. Notice that the argument names used within the constraint function (@racket[x] @racket[y] @racket[z]) have nothing to do with the CSP variable names that are passed to the function @racket['(a b c)]. This makes sense — we might want constraints that apply the same function to different groups of CSP variables. What's important is that the @tech{arity} of the constraint function matches the number of variable names, and that the variable names are ordered correctly (the first variable will become the first argument to the constraint function, and so on).
Finally we call @racket[solve], which finds a solution (if it exists): Finally we call @racket[solve], which finds a solution (if it exists):
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(solve triples) (solve triples)
] ]
``But that's just the 5--12--13 triple, doubled.'' True. If we wanted to ensure that the values in our solution have no common factors, we can add a new @racket[coprime?] constraint: ``But that's just the 5--12--13 triple, doubled.'' True. Suppose we want to ensure that the values in our solution have no common factors. We add a new @racket[coprime?] constraint:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(require math/number-theory) (require math/number-theory)
(add-constraint! triples coprime? '(a b c)) (add-constraint! triples coprime? '(a b c))
] ]
And we can @racket[solve] again to see the new result: We @racket[solve] again to see the new result:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(solve triples) (solve triples)
] ]
Maybe we become curious to see how many of these triples exist. We can use @racket[solve*] to find all four solutions: Perhaps we're curious to see how many of these triples exist. We use @racket[solve*] to find all four solutions:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(solve* triples) (solve* triples)
] ]
``But really there's only two solutions — the values for @racket[a] and @racket[b] are swapped in the other two.'' Fair enough. We might say that this problem is @deftech{symmetric} relative to variables @racket[a] and @racket[b], because they have the same domains and are constrained the same way. We can break the symmetry by adding a constraint that forces @racket[a] to be less than or equal to @racket[b]: ``But really there's only two solutions — the values for @racket[a] and @racket[b] are swapped in the other two.'' Fair enough. We might say that this problem is @deftech{symmetric} relative to variables @racket[a] and @racket[b], because they have the same domains and are constrained the same way. We can break the symmetry by adding a constraint that forces @racket[a] to be less than or equal to @racket[b]:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(add-constraint! triples <= '(a b)) (add-constraint! triples <= '(a b))
(solve* triples) (solve* triples)
@ -103,32 +106,32 @@ Now our list of solutions doesn't have any symmetric duplicates.
By the way, what if we had accidentally included @racket[c] in the last constraint? By the way, what if we had accidentally included @racket[c] in the last constraint?
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(add-constraint! triples <= '(a b c)) (add-constraint! triples <= '(a b c))
(solve* triples) (solve* triples)
] ]
Nothing changes. Why? Because @racket[c] is necessarily going to be larger because of the existing @racket[valid-triple?] constraint, so it always meets this constraint too. Still, it's good practice to minimize constraints — no need for the ``belt and suspenders'' approach. Nothing changes. Why not? Because of the existing @racket[valid-triple?] constraint, @racket[c] is necessarily going to be larger than @racket[a] and @racket[b]. So it always meets this constraint too. But generally, it's good practice to minimize constraints — no need for the ``belt and suspenders'' approach.
We should use @racket[solve*] with care. It can't finish until the CSP solver examines every possible assignment of values in the problem, which can be a big number. Specifically, it's the product of the domain sizes of each variable, which in this case is 40 × 40 × 40 = 64,000. This realm of possible assignments is also known as the CSP's @deftech{state space}. We can also get this number from @racket[state-count]: We should use @racket[solve*] with care. It can't finish until the CSP solver examines every possible assignment of values in the problem, which can be a big number. Specifically, it's the product of the domain sizes of each variable, which in this case is 40 × 40 × 40 = 64,000. This realm of possible assignments is also known as the CSP's @deftech{state space}. We can also get this number from @racket[state-count]:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(state-count triples) (state-count triples)
] ]
It's easy for a CSP to have a state count in the zillions. For this reason we can supply @racket[solve*] with an optional @racket[#:limit] argument that will only generate a certain number of solutions: It's easy for a CSP to have a state count in the zillions. For this reason we can supply @racket[solve*] with an optional @racket[#:count] argument that will only generate a certain number of solutions:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(time (solve* triples)) (time (solve* triples))
(time (solve* triples #:limit 2)) (time (solve* triples #:count 2))
] ]
Here, the answers are the same. But the second call to @racket[solve*] finishes sooner, because it quits as soon as it's found two solutions. Here, the answers are the same. But the second call to @racket[solve*] finishes sooner, because it quits as soon as it's found two solutions.
Of course, when we use ordinary @racket[solve], we don't know how many assignments it will have to try before it finds a solution. If the problem is impossible, even @racket[solve] will have to examine every possible assignment before it knows for sure. For instance, let's see what happens if we add a constraint that's impossible to meet: Of course, even when we use ordinary @racket[solve], we don't know how many assignments it will have to try before it finds a solution. If the problem is impossible, even @racket[solve] will have to visit the entire state space before it knows for sure. For instance, let's see what happens if we add a constraint that's impossible to meet:
@examples[#:eval my-eval @examples[#:label #f #:eval my-eval
(add-constraint! triples = '(a b c)) (add-constraint! triples = '(a b c))
(solve triples) (solve triples)
@ -136,17 +139,227 @@ Of course, when we use ordinary @racket[solve], we don't know how many assignmen
Disappointing but accurate. Disappointing but accurate.
The whole example in one block:
@racketblock[
(require csp)
(define triples (make-csp))
(add-var! triples 'a (range 10 50))
(add-var! triples 'b (range 10 50))
(add-var! triples 'c (range 10 50))
(define (valid-triple? x y z)
(= (expt z 2) (+ (expt x 2) (expt y 2))))
(add-constraint! triples valid-triple? '(a b c))
(require math/number-theory)
(add-constraint! triples coprime? '(a b c))
(add-constraint! triples <= '(a b))
(solve* triples #:count 2)
]
@section{Interlude}
``Dude, are you kidding me? I can write a much shorter loop to do the same thing—"
@my-examples[
(for*/list ([a (in-range 10 50)]
[b (in-range 10 50)]
#:when (<= a b)
[c (in-range 10 50)]
#:when (and (coprime? a b c) (valid-triple? a b c)))
(map cons '(a b c) (list a b c)))
]
Yes, I agree that in this toy example, the CSP approach is overkill. The variables are few enough, the domains small enough, and the constraints simple enough, that a loop is more concise. Also, with only 64,000 possibilities in the state space, this sort of brute-force approach is cheap & cheerful.
@section{Second example}
But what about a more complicated problem — like a Sudoku? A Sudoku has 81 squares, each of which can hold the digits 1 through 9. The goal in Sudoku is to fill the grid so that no row, no column, and no ``box'' (a 3 × 3 subgroup of cells) has a duplicate digit. About 25 of the squares are filled in at the start, so the size of the state space is therefore:
@my-examples[
(expt 9 (- 81 25))
]
Well over a zillion, certainly. Let's optimistically suppose that the 3.7GHz processor in your computer takes one cycle to check an assignment. There are 31,557,600 seconds in a year, so the brute-force method will only take this many years:
@my-examples[
(define states (expt 9 (- 81 25)))
(define states-per-second (* 3.7 1e9))
(define seconds-per-year 31557600)
(/ states states-per-second seconds-per-year)
]
@section{Another interlude}
``Dude, are you serious? The JMAXX Sudoku Solver runs three to four times faster—''
@racketblock[
;; TK
]
Yes, I agree that an algorithm custom-tailored to the problem will likely beat the CSP solver, which is necessarily general-purpose.
But let's consider the labor involved. To write something like the JMAXX Sudoku Solver, we'd need a PhD in computer science, and the time to explain not just the rules of Sudoku to the computer, but the process for solving a Sudoku.
By contrast, when we use a CSP, @italic{all we need are the rules}. The CSP solver does the rest. In this way, a CSP gives us an alternative, simpler way to explain Sudoku to the computer, just like regular expressions are an alternate way of expressing string patterns. And if the CSP solver is half a second slower, that seems like a reasonable tradeoff.
@margin-note{Daring minds might even consider a CSP solver to be a kind of domain-specific language.}
@section{Making & solving CSPs} @section{Making & solving CSPs}
@defstruct[csp ([vars (listof var?)]
[constraints (listof constraint?)])
#:transparent]{
TK
}
@defstruct[var ([name name?]
[domain (listof any/c)])
#:transparent]{
TK
}
@defstruct[constraint ([names (listof name?)]
[proc procedure?])
#:transparent]{
TK
}
@defproc[(make-csp [vars (listof var?) null]
[constraints (listof constraint?) empty])
csp?]{
TK
}
@deftogether[(
@defproc[(add-var!
[prob csp?]
[name name?]
[domain (or/c (listof any/c) procedure?) empty])
void?]
@defproc[(add-vars!
[prob csp?]
[names (listof name?)]
[domain (or/c (listof any/c) procedure?) empty])
void?]
)]{
TK
}
@deftogether[(
@defproc[(add-constraint!
[prob csp?]
[func procedure?]
[names (listof name?)]
[func-name (or/c #false name?) #f])
void?]
@defproc[(add-constraints!
[prob csp?]
[func procedure?]
[namess (listof (listof name?))]
[func-name (or/c #false name?) #f])
void?]
)]{
TK
}
@defproc[(add-pairwise-constraint!
[prob csp?]
[func procedure?]
[names (listof name?)]
[func-name (or/c #false name?) #f])
void?]{
TK
}
@defproc[(solve
[prob csp?]
[#:count count natural? 1])
(or/c #false any/c (listof any/c))]{
TK
}
@defproc[(solve*
[prob csp?]
[#:count count natural? +inf.0])
(listof any/c)]{
TK
}
@section{Sideshows} @section{Sideshows}
@defproc[(state-count
[prob csp?])
natural?]{
TK
}
@defproc[(csp->graph
[prob csp?])
graph?]{
TK
}
@defproc[(csp->graphviz
[prob csp?])
string?]{
TK
}
@section{Parameters} @section{Parameters}
@defparam[current-select-variable val (or/c #false procedure?) #:value #f]{
TK
}
@defparam[current-order-values val (or/c #false procedure?) #:value #f]{
TK
}
@defparam[current-inference val (or/c #false procedure?) #:value #f]{
TK
}
@defparam[current-solver val (or/c #false procedure?) #:value #f]{
TK
}
@defparam[current-random val (or/c #false procedure?) #:value #t]{
TK
}
@defparam[current-decompose val (or/c #false procedure?) #:value #t]{
TK
}
@defparam[current-thread-count val (or/c #false natural?) #:value 4]{
TK
}
@defparam[current-node-consistency val (or/c #false procedure?) #:value #f]{
TK
}
@defparam[current-arity-reduction val (or/c #false procedure?) #:value #t]{
TK
}
@defparam[current-learning val (or/c #false procedure?) #:value #f]{
TK
}
@section{License & source code} @section{License & source code}

Loading…
Cancel
Save