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

Merge remote-tracking branch 'csp/master'

Browse Source
main
Matthew Butterick 3 years ago
parent 6f7a8bbc42 993005dc20
commit 93a682a158
28 changed files with 4263 additions and 0 deletions
Show Stats Download Patch File Download Diff File

20
csp/.gitignore vendored
Unescape Escape View File

@ -0,0 +1,20 @@
*.pyc
# for Racket
compiled/
# for Mac OS X
.DS_Store
.AppleDouble
.LSOverride
Icon
# Thumbnails
._*
# Files that might appear on external disk
.Spotlight-V100
.Trashes
csp/scribblings/*.html
csp/scribblings/*.css
csp/scribblings/*.js

9
csp/LICENSE.md
Unescape Escape View File

@ -0,0 +1,9 @@
MIT License for CSP
© 2014-2019 Matthew Butterick
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

33
csp/NOTICES
Unescape Escape View File

@ -0,0 +1,33 @@
This software includes open-source software components that require the following legal notices.
===============================================================================
python-constraint http://labix.org/python-constraint
===============================================================================
Copyright (c) 2005-2014 - Gustavo Niemeyer <gustavo@niemeyer.net>
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
===============================================================================

13
csp/README.md
Unescape Escape View File

@ -0,0 +1,13 @@
## csp
`raco pkg install csp`
## Docs
https://docs.racket-lang.org/csp/
## Project status
Unclear. The code works well, but I built this library thinking it would be useful for a certain project and then it turned out I didn’t need it. I haven’t abandoned it. But I also haven’t gotten it to a 1.0 release. And I don’t want to, unless I’m developing it in service of a larger project, because that tends to be the best way to reveal bugs and misbegotten thinking.

25
csp/csp/aima-queens.rkt
Unescape Escape View File

@ -0,0 +1,25 @@
#lang br
(require "aima.rkt" sugar/debug)
;; queens problem
;; place queens on chessboard so they do not intersect
(define qs (for/list ([q 8]) (string->symbol (format "q~a" q))))
(define rows (range (length qs)))
(define vds (for/list ([q qs])
($vd q (range (length qs)))))
(define (q-col q) (string->number (string-trim (symbol->string q) "q")))
(define cs (for*/list ([qs (in-combinations qs 2)])
(match-define (list qa qb) qs)
(match-define (list qa-col qb-col) (map q-col qs))
($constraint
(list qa qb)
(λ (qa-row qb-row)
(and
(not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal?
(not (= qa-row qb-row)))))))
(define queens (make-csp vds cs))
(current-solver min-conflicts)
(time-named (solve queens))

45
csp/csp/aima-smm.rkt
Unescape Escape View File

@ -0,0 +1,45 @@
#lang br
(require "aima.rkt")
; SEND
;+ MORE
;------
; MONEY
(define (word-value . xs)
(for/sum ([(x idx) (in-indexed (reverse xs))])
(* x (expt 10 idx))))
(define vs '(s e n d m o r y))
(define vds (for/list ([k vs])
($vd k (range 10))))
(define (not= x y) (not (= x y)))
(define alldiffs
(for/list ([pr (in-combinations vs 2)])
($constraint pr not=)))
(define smm (make-csp vds (append
alldiffs
(list
($constraint '(s) positive?)
($constraint '(m) positive?)
($constraint '(d e y) (λ (d e y) (= (modulo (+ d e) 10) y)))
($constraint '(n d r e y) (λ (n d r e y)
(= (modulo (+ (word-value n d) (word-value r e)) 100)
(word-value e y))))
($constraint '(e n d o r y) (λ (e n d o r y)
(= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))))
($constraint '(s e n d m o r y) (λ (s e n d m o r y)
(= (+ (word-value s e n d) (word-value m o r e))
(word-value m o n e y))))))))
(parameterize ([current-select-variable mrv]
[current-order-values lcv]
[current-inference mac])
(time (solve smm)))
(nassigns smm)
(nchecks smm)
(reset! smm)

12
csp/csp/aima-sum.rkt
Unescape Escape View File

@ -0,0 +1,12 @@
#lang br
(require "aima.rkt")
(define vs '(a b c))
(define ds (for/hash ([k vs])
(values k (range 10))))
(define ns (for*/hash ([v (in-list vs)])
(values v (remove v vs))))
(define csp (make-csp vs ds ns (λ (A a B b) (not (eq? a b)))))
(solve csp)
(nassigns csp)
(nchecks csp)

571
csp/csp/aima.rkt
Unescape Escape View File

@ -0,0 +1,571 @@
#lang debug racket
(require racket/generator sugar graph)
(provide (all-defined-out))
(struct $csp (variables domains neighbors constraints initial curr_domains nassigns nchecks current graph) #:transparent #:mutable)
;; `current` = current assignment
(define assignment? hash?)
(define variable? symbol?)
(define removal? (cons/c variable? any/c))
(define (update-assignment assignment var val)
(define h (hash-copy assignment))
(hash-set! h var val)
h)
(struct $constraint (names proc) #:transparent)
(struct $vd (name vals) #:transparent)
(define (constraint-graph variables constraints)
(for*/fold ([g (unweighted-graph/undirected variables)])
([constraint (in-list constraints)]
[edge (in-combinations ($constraint-names constraint) 2)])
(apply add-edge! g edge)
g))
(define/contract (make-csp vds [constraints null])
(((listof $vd?)) ((listof $constraint?)) . ->* . $csp?)
(define variables (map $vd-name vds))
(define domains (for/hasheq ([vd (in-list vds)])
(match vd
[($vd name vals) (values name vals)])))
(define g (constraint-graph variables constraints))
(define neighbors (for/hasheq ([v (in-list variables)])
(values v (get-neighbors g v))))
($csp variables domains neighbors constraints null #f 0 0 #f g))
(define/contract (domain csp var)
($csp? variable? . -> . (listof any/c))
(hash-ref ($csp-domains csp) var))
(define/contract (curr_domain csp var)
($csp? variable? . -> . (listof any/c))
(hash-ref ($csp-curr_domains csp) var))
(define/contract (neighbors csp var)
($csp? variable? . -> . (listof variable?))
(hash-ref ($csp-neighbors csp) var))
(define/contract (assigns? assignment var)
(assignment? variable? . -> . boolean?)
(hash-has-key? assignment var))
(define/contract (assignment-ref assignment name-or-names)
(assignment? (or/c (listof variable?) variable?) . -> . (or/c any/c (listof any/c)))
(let loop ([name-or-names name-or-names])
(match name-or-names
[(? variable? name) (hash-ref assignment name)]
[(list names ...) (map loop names)])))
(define nassigns $csp-nassigns)
(define nchecks $csp-nchecks)
(define/contract (reset! csp)
($csp? . -> . void?)
(set-$csp-curr_domains! csp #f)
(reset-counters! csp))
(define/contract (check-constraints csp varval-hash [limits null] #:conflicts [count-conflicts? #f])
(($csp? hash?) ((listof variable?) #:conflicts boolean?) . ->* . any/c)
(define relevant-constraints
(for/list ([constraint (in-list ($csp-constraints csp))]
#:when (let ([cnames ($constraint-names constraint)])
(and
(for/and ([limit (in-list limits)])
(memq limit cnames))
(for/and ([cname (in-list cnames)])
(memq cname (hash-keys varval-hash))))))
constraint))
(begin
;; ordinary: behave like for/and, stop if #false result.
;; count-conflicts mode: behave like for/sum, don't stop till end.
(define-values (result check-count)
(for/fold ([result (if count-conflicts? 0 #true)]
[check-count 0])
([constraint (in-list relevant-constraints)]
#:break (false? result)) ; only breaks early in ordinary mode, when #f is result value
(define vals (assignment-ref varval-hash ($constraint-names constraint)))
(define res (apply ($constraint-proc constraint) vals))
(values (if count-conflicts? (+ (if res 0 1) result) res) (add1 check-count))))
(set-$csp-nchecks! csp (+ check-count ($csp-nchecks csp)))
result))
(define/contract (reset-counters! csp)
($csp? . -> . void?)
(set-$csp-nassigns! csp 0)
(set-$csp-nchecks! csp 0))
(define/contract (assign csp var val assignment)
($csp? variable? any/c assignment? . -> . void?)
;; Add {var: val} to assignment; Discard the old value if any.
(hash-set! assignment var val)
(set-$csp-nassigns! csp (add1 ($csp-nassigns csp))))
(define/contract (unassign csp var assignment)
($csp? variable? assignment? . -> . void?)
;; Remove {var: val} from assignment.
;; DO NOT call this if you are changing a variable to a new value;
;; just call assign for that.
(hash-remove! assignment var))
(define/contract (all-variables-assigned? csp assignment)
($csp? assignment? . -> . boolean?)
(= (length (hash-keys assignment)) (length ($csp-variables csp))))
(define asses (make-parameter #f))
(define ncon (make-parameter #f))
(define/contract (nconflicts csp var val assignment)
($csp? variable? any/c assignment? . -> . number?)
;; Return the number of conflicts var=val has with other variables."""
;; Subclasses may implement this more efficiently
(define ass (update-assignment assignment var val))
(check-constraints csp ass (list var) #:conflicts #t))
(define (display csp assignment)
(displayln csp))
;; These methods are for the tree and graph-search interface:
(struct $action (var val) #:transparent #:mutable)
(define/contract (state->assignment state)
((listof $action?) . -> . assignment?)
(for/hasheq ([action (in-list state)])
(match action
[($action var val) (values var val)])))
;; todo: test that this works
(define/contract (actions csp state)
($csp? (listof $action?) . -> . any/c)
;; Return a list of applicable actions: nonconflicting
;; assignments to an unassigned variable.
(cond
[(all-variables-assigned? csp state) empty]
[else
(define assignment (state->assignment state))
(define var (for/first ([var (in-list ($csp-variables csp))]
#:unless (assignment . assigns? . var))
var))
(for/list ([val (in-list (domain csp var))]
#:when (zero? (nconflicts csp var val assignment)))
($action var val))]))
;; todo: test that this works
(define/contract (result csp state action)
($csp? (listof $action?) $action? . -> . assignment?)
;; Perform an action and return the new state.
(match-define ($action var val) action)
(append state (list action)))
;; todo: test that this works
(define/contract (goal_test csp state)
($csp? (or/c assignment? (listof $action?)) . -> . boolean?)
;; The goal is to assign all variables, with all constraints satisfied.
(define assignment (if (assignment? state) state (state->assignment state)))
(and (all-variables-assigned? csp assignment)
(for/and ([variable ($csp-variables csp)])
(zero? (nconflicts csp variable (hash-ref assignment variable) assignment)))))
;; These are for constraint propagation
(define/contract (support_pruning csp)
($csp? . -> . void?)
;; Make sure we can prune values from domains. (We want to pay
;; for this only if we use it.)
(unless ($csp-curr_domains csp)
(define h (make-hasheq))
(for ([v ($csp-variables csp)])
(hash-set! h v (hash-ref ($csp-domains csp) v)))
(set-$csp-curr_domains! csp h)))
(define/contract (suppose csp var value)
($csp? variable? any/c . -> . (box/c (listof removal?)))
;; Start accumulating inferences from assuming var=value
(support_pruning csp)
(begin0
(box (for/list ([val (in-list (curr_domain csp var))]
#:when (not (equal? val value)))
(cons var val)))
(hash-set! ($csp-curr_domains csp) var (list value))))
(define/contract (prune csp var value removals)
($csp? variable? any/c (or/c #f (box/c (listof removal?))) . -> . (box/c (listof removal?)))
;; Rule out var=value
(hash-update! ($csp-curr_domains csp) var (λ (vals) (remove value vals)))
(when removals
(set-box! removals (append (unbox removals) (list (cons var value)))))
removals)
(define/contract (choices csp var)
($csp? variable? . -> . (listof any/c))
;; Return all values for var that aren't currently ruled out.
(hash-ref (or ($csp-curr_domains csp) ($csp-domains csp)) var))
(define/contract (infer_assignment csp)
($csp? . -> . assignment?)
;; Return the partial assignment implied by the current inferences.
(support_pruning csp)
(define assignment (make-hasheq))
(for ([v (in-list ($csp-variables csp))])
(match (curr_domain csp v)
[(list one-value) (hash-set! assignment v one-value)]
[else #f]))
assignment)
(define/contract (restore csp removals)
($csp? (box/c (listof removal?)) . -> . void?)
;; Undo a supposition and all inferences from it.
(for ([removal (in-list (unbox removals))])
(match removal
[(cons B b) (hash-update! ($csp-curr_domains csp) B
(λ (vals) (append vals (list b))))])))
;; This is for min_conflicts search
(define/contract (conflicted_vars csp current)
($csp? hash? . -> . (listof variable?))
;; Return a list of variables in current assignment that are in conflict
(for/list ([var (in-list ($csp-variables csp))]
#:when (positive? (nconflicts csp var (hash-ref current var) current)))
var))
;; ______________________________________________________________________________
;; Constraint Propagation with AC-3
(struct $arc (start end) #:transparent)
(define/contract (AC3 csp [queue #f][removals #f])
(($csp?) ((or/c #f (listof any/c)) (box/c (listof removal?))) . ->* . boolean?)
(support_pruning csp)
(with-handlers ([boolean? values])
(for/fold ([queue (or queue
(for*/list ([Xi (in-list ($csp-variables csp))]
[Xk (in-list (neighbors csp Xi))])
($arc Xi Xk)))]
#:result #true)
([i (in-naturals)]
#:break (empty? queue))
(match-define (cons ($arc Xi Xj) other-arcs) queue)
(cond
[(revise csp Xi Xj removals)
(when (empty? (curr_domain csp Xi))
(raise #false))
(append other-arcs
(for/list ([Xk (in-list (neighbors csp Xi))]
#:unless (eq? Xk Xj))
($arc Xk Xi)))]
[else other-arcs]))))
(define/contract (revise csp Xi Xj removals)
($csp? variable? variable? (box/c (listof removal?)) . -> . boolean?)
;; Return true if we remove a value.
(for/fold ([revised #false])
([x (in-list (curr_domain csp Xi))])
;; If Xi=x is consistent with Xj=y for any y, keep Xi=x, otherwise prune
(cond
[(not
(for/or ([y (in-list (curr_domain csp Xj))])
(check-constraints csp (hasheq Xi x Xj y) (list Xi))))
(prune csp Xi x removals)
#true]
[else revised])))
;; ______________________________________________________________________________
;; CSP Backtracking Search
;; Variable ordering
(define/contract (first_unassigned_variable assignment csp)
(assignment? $csp? . -> . (or/c #false variable?))
;; The default variable order.
(for/first ([var (in-list ($csp-variables csp))]
#:unless (assignment . assigns? . var))
var))
(define current-shuffle (make-parameter #t))
(define/contract (argmin_random_tie proc xs)
(procedure? (listof any/c) . -> . any/c)
(define ordered-xs (sort xs < #:key proc))
(first ((if (current-shuffle) shuffle values)
(takef ordered-xs (λ (x) (= (proc (car ordered-xs)) (proc x)))))))
(define/contract (mrv assignment csp)
(assignment? $csp? . -> . any/c)
;; Minimum-remaining-values heuristic.
;; with random tiebreaker.
(define (num_legal_values var)
(if ($csp-curr_domains csp)
(length (curr_domain csp var))
(for/sum ([val (in-list (domain csp var))]
#:when (zero? (nconflicts csp var val assignment)))
1)))
(struct $mrv-rec (var num) #:transparent)
(argmin_random_tie
(λ (var) (num_legal_values var))
(for/list ([var (in-list ($csp-variables csp))]
#:unless (assignment . assigns? . var))
var)))
;; Value ordering
(define/contract (unordered_domain_values var assignment csp)
(variable? assignment? $csp? . -> . (listof any/c))
;; The default value order.
(choices csp var))
(define/contract (lcv var assignment csp)
(variable? assignment? $csp? . -> . (listof any/c))
;; Least-constraining-values heuristic.
(sort (choices csp var) < #:key (λ (val) (nconflicts csp var val assignment))))
;; Inference
(define/contract (no_inference csp var value assignment removals)
($csp? variable? any/c assignment? (box/c (listof removal?)) . -> . boolean?)
#true)
(define/contract (forward_checking csp var value assignment removals)
($csp? variable? any/c assignment? (box/c (listof removal?)) . -> . boolean?)
;; Prune neighbor values inconsistent with var=value.
(support_pruning csp) ;; necessary to set up curr_domains
(define ass (update-assignment assignment var value))
(for/and ([B (in-list (neighbors csp var))]
#:unless (assignment . assigns? . B))
(for ([b (in-list (curr_domain csp B))]
#:unless (check-constraints csp (update-assignment ass B b) (list var B)))
(prune csp B b removals))
(not (empty? (curr_domain csp B)))))
(define/contract (mac csp var value assignment removals)
($csp? variable? any/c assignment? (box/c (listof removal?)) . -> . boolean?)
;; Maintain arc consistency.
(AC3 csp (for/list ([neighbor (in-list (neighbors csp var))])
($arc neighbor var)) removals))
(define current-select-variable (make-parameter #f))
(define current-order-values (make-parameter #f))
(define current-inference (make-parameter #f))
(define/contract (backtracking_search
csp
[select_unassigned_variable (or (current-select-variable) first_unassigned_variable)]
[order_domain_values (or (current-order-values) unordered_domain_values)]
[inference (or (current-inference) no_inference)])
(($csp?) (procedure? procedure? procedure?) . ->* . generator?)
(generator ()
(let backtrack ([assignment (make-hasheq)])
(cond
[(all-variables-assigned? csp assignment)
(unless (goal_test csp assignment) (error 'whut))
(yield (hash-copy assignment))]
[else
(define var (select_unassigned_variable assignment csp))
(for ([val (in-list (order_domain_values var assignment csp))]
#:when (zero? (nconflicts csp var val assignment)))
(assign csp var val assignment)
(define removals (suppose csp var val))
(when (inference csp var val assignment removals)
(backtrack assignment))
(restore csp removals))
(unassign csp var assignment)]))))
;; ______________________________________________________________________________
;; Min-conflicts hillclimbing search for CSPs
(require sugar/debug)
(define (min-conflicts csp [max_steps (expt 10 5)])
(($csp?) (integer?) . ->* . generator?)
;; Solve a CSP by stochastic hillclimbing on the number of conflicts.
;; Generate a complete assignment for all variables (probably with conflicts)
(generator ()
(define current (make-hasheq))
(set-$csp-current! csp current)
(for ([var (in-list ($csp-variables csp))])
(define val (min_conflicts_value csp var current))
(assign csp var val current))
;; Now repeatedly choose a random conflicted variable and change it
(for ([i (in-range max_steps)])
(define conflicted (conflicted_vars csp current))
(when (empty? conflicted)
(report i)
(yield current))
(define var (first ((if (current-shuffle) shuffle values) conflicted)))
(define val (min_conflicts_value csp var current))
(assign csp var val current))))
(define/contract (min_conflicts_value csp var current)
($csp? variable? hash? . -> . any/c)
;; Return the value that will give var the least number of conflicts.
;; If there is a tie, choose at random.
(argmin_random_tie (λ (val) (nconflicts csp var val current)) (domain csp var)))
(define current-reset (make-parameter #t))
(define current-solver (make-parameter #f))
(define/contract (solve* csp [solution-limit +inf.0])
(($csp?) (integer?) . ->* . (or/c #f (non-empty-listof any/c)))
(define solver (or (current-solver) backtracking_search))
(begin0
(match (for/list ([solution (in-producer (solver csp) (void))]
[idx (in-range solution-limit)])
solution)
[(list solutions ...) solutions]
[else #false])
(when (current-reset)
(set-$csp-curr_domains! csp #f))))
(define/contract (solve csp)
($csp? . -> . any/c)
(match (solve* csp 1)
[(list solution) solution]
[else #false]))
(require rackunit)
(define vs '(wa nsw t q nt v sa))
(define vds (for/list ([k vs])
($vd k '(red green blue))))
(define (neq? a b) (not (eq? a b)))
(define cs (list
($constraint '(wa nt) neq?)
($constraint '(wa sa) neq?)
($constraint '(nt sa) neq?)
($constraint '(nt q) neq?)
($constraint '(q sa) neq?)
($constraint '(q nsw) neq?)
($constraint '(nsw sa) neq?)
($constraint '(nsw v) neq?)
($constraint '(v sa) neq?)))
(define csp (make-csp vds cs))
(define (tests)
(set-$csp-curr_domains! csp #f)
(check-true ($csp? csp))
(define a (make-hasheq))
(assign csp 'key 42 a)
(check-equal? (hash-ref a 'key) 42)
(unassign csp 'key a)
(check-exn exn:fail? (λ () (hash-ref a 'key)))
(check-equal? 0 (nconflicts csp 'wa 'red (hasheq 'wa 42)))
(support_pruning csp)
(check-true (hash? ($csp-curr_domains csp)))
(check-equal? (suppose csp 'wa 'red) '#&((wa . green) (wa . blue)))
(check-equal? (curr_domain csp 'wa) '(red))
(check-equal? (prune csp 'v 'red (box empty)) '#&((v . red)))
(check-equal? (choices csp 'v) '(green blue))
(check-equal? (choices csp 'wa) '(red))
(check-equal? (infer_assignment csp)
(make-hasheq '((wa . red))))
(check-equal? (suppose csp 'v 'blue) '#&((v . green)))
(check-equal? (infer_assignment csp)
(make-hasheq '((v . blue) (wa . red))))
(restore csp '#&((wa . green)))
(check-equal? (infer_assignment csp)
(make-hasheq '((v . blue))))
(restore csp '#&((v . blue)))
(check-equal? (infer_assignment csp) (make-hasheq))
(check-equal? (first_unassigned_variable (hash) csp) 'wa)
(check-equal? (unordered_domain_values 'wa (hash) csp) '(red green))
(set-$csp-curr_domains! csp #f) ; reset current domains
(check-equal? (solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(40 321))
(check-equal? (length (solve* csp)) 18)
(check-equal? (suppose csp 'nsw 'red) '#&((nsw . green) (nsw . blue)))
(check-equal? (solve csp)
(make-hasheq '((nsw . red) (nt . red) (q . green) (sa . blue) (t . blue) (v . green) (wa . green))))
(check-equal? ($csp-nassigns csp) 368)
(reset-counters! csp)
(check-equal? (suppose csp 'nsw 'red) '#&((nsw . green) (nsw . blue)))
(check-equal? (length (solve* csp)) 6)
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(111 1035))
(parameterize ([current-select-variable mrv]
[current-shuffle #f])
(check-equal?
(solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(39 321)))
(parameterize ([current-order-values lcv])
(check-equal?
(solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(39 1040)))
(parameterize ([current-inference forward_checking])
(forward_checking csp 'sa 'blue (make-hasheq) (box null))
(check-equal? ($csp-curr_domains csp)
(make-hasheq '((nsw . (red green)) (nt . (red green)) (q . (red green)) (sa . (red green blue)) (t . (red green blue)) (v . (red green)) (wa . (red green))))))
(reset-counters! csp)
(set-$csp-curr_domains! csp #f)
(parameterize ([current-inference forward_checking])
(check-equal?
(solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(25 106)))
(set-$csp-curr_domains! csp #f)
(parameterize ([current-inference mac]
[current-reset #f])
(check-equal? (solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(17 175)))
(parameterize ([current-select-variable mrv]
[current-order-values lcv]
[current-inference mac]
[current-reset #f])
(check-equal? (solve csp)
(make-hasheq '((nsw . green) (nt . green) (q . red) (sa . blue) (t . blue) (v . red) (wa . red))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(7 45)))
(set-$csp-curr_domains! csp #f)
(parameterize ([current-shuffle #f]
[current-solver min-conflicts])
(check-equal?
(solve csp)
(make-hasheq '((nsw . red) (nt . red) (q . green) (sa . blue) (t . red) (v . green) (wa . green))))
(check-equal? (begin0 (list ($csp-nassigns csp) ($csp-nchecks csp)) (reset-counters! csp)) '(9 220)))
(define tri (make-csp (list ($vd 'a '(1 2 3))
($vd 'b '(4 5 6))
($vd 'c '(7 8 9)))
(list ($constraint '(a b c) (λ (a b c) (= (+ a b c) 18))))))
(parameterize ([current-select-variable mrv]
[current-order-values lcv]
[current-inference mac]
[current-reset #f]
[current-shuffle #f])
(check-equal? (solve tri) (make-hasheq '((a . 3) (b . 6) (c . 9)))))
(check-equal? (begin0 (list ($csp-nassigns tri) ($csp-nchecks tri)) (reset-counters! tri)) '(13 68))
)
(module+ test
(tests))
#|
(define (abc-test a b c) (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))
(define abc (make-csp (list ($vd 'a (shuffle (range 1 10)))
($vd 'b (range 1 10))
($vd 'c (range 1 10)))))
(argmin (λ (h)
(abc-test (hash-ref h 'a) (hash-ref h 'b) (hash-ref h 'c)))
(parameterize ([current-select-variable mrv]
[current-order-values lcv]
[current-inference mac]
[current-reset #f]
[current-shuffle #f])
(solve* abc)))
|#

24
csp/csp/csp-test-etc.rkt
Unescape Escape View File

@ -0,0 +1,24 @@
#lang at-exp racket
(require "csp.rkt" racket/port rackunit)
(use-mrv? #f)
(use-reduce-arity? #f)
(use-mac? #f)
(use-remove-constraints? #f)
(use-validate-assignments? #t)
(define (neq? x y) (not (eq? x y)))
(define c (make-csp))
(add-vars! c '(wa nsw t q nt v sa) '(red green blue))
(add-constraint! c neq? '(wa nt))
(add-constraint! c neq? '(nt q))
(add-constraint! c neq? '(q nsw))
(add-constraint! c neq? '(nsw v))
(add-constraint! c neq? '(sa wa))
(add-constraint! c neq? '(sa nt))
(add-constraint! c neq? '(sa q))
(add-constraint! c neq? '(sa nsw))
(add-constraint! c neq? '(sa v))
(solve c)

173
csp/csp/csp-test-problems.rkt
Unescape Escape View File

@ -0,0 +1,173 @@
#lang at-exp racket
(require "csp.rkt" rackunit)
(use-mrv? #t)
(use-reduce-arity? #t)
(use-mac? #t)
(use-remove-constraints? #t)
(use-validate-assignments? #t)
(define demo (make-csp))
(add-vars! demo '(t w) (range 7))
(add-var! demo 'o '(2 6 7))
(define (sum-three t w o) (= 3 (+ t w o)))
(add-constraint! demo sum-three '(t w o))
(add-pairwise-constraint! demo alldiff= '(t w o))
(add-pairwise-constraint! demo < '(t w o))
(check-equal? (time (solve demo)) ($csp (list ($var 't '(0)) ($var 'w '(1)) ($var 'o '(2))) '()))
;; TWO + TWO = FOUR
(define (word-value . xs)
(for/sum ([(x idx) (in-indexed (reverse xs))])
(* x (expt 10 idx))))
(define ttf (make-csp))
(add-vars! ttf '(t w o f u r) (reverse (range 10)))
(add-pairwise-constraint! ttf alldiff= '(t w o f u r))
(add-constraint! ttf (λ (o r) (= (modulo (+ o o) 10) r)) '(o r))
(add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o))
(word-value f o u r))) '(t w o f u r))
(add-constraint! ttf positive? '(t))
(add-constraint! ttf positive? '(f))
(define ttf-solution (time (solve ttf)))
(check-equal? ttf-solution
($csp
(list
($var 't '(7))
($var 'w '(3))
($var 'o '(4))
($var 'f '(1))
($var 'u '(6))
($var 'r '(8)))
'()))
(define (ttf-print csp)
(format "~a~a~a + ~a~a~a = ~a~a~a~a" ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 'f) ($csp-ref csp 'o) ($csp-ref csp 'u) ($csp-ref csp 'r)))
(check-equal? (time (solve ttf-solution ttf-print)) "734 + 734 = 1468")
;; ABC problem:
;; what is the minimum value of
;; ABC
;; -------
;; A+B+C
(define abc (make-csp))
(add-vars! abc '(a b c) (range 1 10))
(define (solution-score sol)
(let ([a ($csp-ref sol 'a)]
[b ($csp-ref sol 'b)]
[c ($csp-ref sol 'c)])
(/ (+ (* 100 a) (* 10 b) c) (+ a b c))))
(define abc-sols (time (solve* abc)))
(check-equal? (* 9 9 9) (length abc-sols))
(check-equal?
(argmin solution-score abc-sols)
($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '()))
;; quarter problem:
;; 26 dollars and quarters
;; that add up to $17.
(define quarters (make-csp))
(add-vars! quarters '(dollars quarters) (range 26))
(add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters))
(add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters))
(check-equal? (time (solve quarters))
($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '()))
;; nickel problem
#|
A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there?
|#
(define nickels (make-csp))
(add-vars! nickels '(n d q) (range 33))
(add-constraint! nickels (λ (n d q) (= 33 (+ n d q))) '(n d q) 'count-33)
(add-constraint! nickels (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q) 'total-3.30)
(add-constraint! nickels (λ (n q) (= (* 3 q) n)) '(n q) 'triple-nickel)
(add-constraint! nickels (λ (d n) (= (* 2 d) n)) '(d n) 'double-nickel)
(check-equal? (time (solve nickels))
($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '()))
;; xsum
#|
# Reorganize the following numbers in a way that each line of
# 5 numbers sum to 27.
#
# 1 6
# 2 7
# 3
# 8 4
# 9 5
#
|#
(define xsum (make-csp))
(add-vars! xsum '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10))
(add-pairwise-constraint! xsum < '(l1 l2 l3 l4))
(add-pairwise-constraint! xsum < '(r1 r2 r3 r4))
(add-constraint! xsum (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x))
(add-constraint! xsum (λ (r1 r2 r3 r4 x) (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x))
(add-pairwise-constraint! xsum alldiff= '(l1 l2 l3 l4 r1 r2 r3 r4 x))
(check-equal? (length (time (solve* xsum))) 8)
;; send more money problem
#|
# Assign equal values to equal letters, and different values to
# different letters, in a way that satisfies the following sum:
#
# SEND
# + MORE
# ------
# MONEY
|#
(define smm (make-csp))
(add-vars! smm '(s e n d m o r y) (λ () (range 10)))
(add-constraint! smm positive? '(s))
(add-constraint! smm (curry = 1) '(m))
(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y))
(add-constraint! smm (λ (n d r e y)
(= (modulo (+ (word-value n d) (word-value r e)) 100)
(word-value e y))) '(n d r e y))
(add-constraint! smm (λ (e n d o r y)
(= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y))
(add-constraint! smm (λ (s e n d m o r y)
(= (+ (word-value s e n d) (word-value m o r e))
(word-value m o n e y))) '(s e n d m o r y))
(add-pairwise-constraint! smm alldiff= '(s e n d m o r y))
;; todo: too slow
;(solve smm)
;; 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)
(and
(not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal?
(not (= qa-row qb-row)))) ; same row?
(list qa qb)))
(check-equal? 92 (length (time (solve* queens))))

14
csp/csp/csp-test.rkt
Unescape Escape View File

@ -0,0 +1,14 @@
#lang at-exp racket
(require "csp.rkt" rackunit)
(define creduce (assign-val ($csp (list ($var 'a '(1 2 3)) ($var 'b '(2 3)) ($var 'c '(1 2 3 4 5))) (list ($constraint '(a b c) (procedure-rename (λ (a b c) (= (+ a b c) 4)) 'summer)))) 'a 1))
(check-equal?
(make-arcs-consistent (reduce-constraint-arity creduce))
($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '()))
(define f (λ (a b c d) (+ a b c d)))
(check-equal? 10 ((reduce-arity f '(1 b c d)) 2 3 4))
(check-equal? 10 ((reduce-arity f '(1 2 c d)) 3 4))
(check-equal? 10 ((reduce-arity f '(1 2 3 d)) 4))
(check-equal? 10 ((reduce-arity f '(1 b 3 d)) 2 4))
(check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4))

437
csp/csp/csp.rkt
Unescape Escape View File

@ -0,0 +1,437 @@
#lang debug racket
(require racket/generator racket/control sugar/debug)
(provide (all-defined-out))
(struct $csp ([vars #:mutable]
[constraints #:mutable]) #:transparent)
(define (make-csp [vars null] [constraints null]) ($csp (for/list ([var (in-list vars)])
(let loop ([var var])
(match var
[(list (? symbol? name) vals) (loop ($var name vals))]
[($var name vals) ($varc name vals null)])))
constraints))
(define debug (make-parameter #false))
(define-syntax-rule (in-cartesian x)
(in-generator (let ([argss x])
(let loop ([argss argss][acc empty])
(if (null? argss)
(yield (reverse acc))
(for ([arg (in-list (car argss))])
(loop (cdr argss) (cons arg acc))))))))
(struct $var (name vals) #:transparent)
(struct $varc $var (culprits) #:transparent)
(define $var-name? symbol?)
(struct $constraint (names proc) #:transparent
#:property prop:procedure
(λ (constraint csp)
(unless ($csp? csp)
(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))))
(define/contract (check-name-in-csp! caller csp name)
(symbol? $csp? $var-name? . -> . void?)
(define names (map $var-name ($csp-vars csp)))
(unless (memq name names)
(raise-argument-error caller (format "one of these existing csp var names: ~v" names) name)))
(define (nary-constraint? constraint n)
(= n (constraint-arity constraint)))
(define/contract (unary-constraint? constraint)
($constraint? . -> . boolean?)
(nary-constraint? constraint 1))
(define/contract (binary-constraint? constraint)
($constraint? . -> . boolean?)
(nary-constraint? constraint 2))
(define/contract (add-vars! csp names-or-procedure [vals-or-procedure empty])
(($csp? (or/c (listof $var-name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
(for/fold ([vars ($csp-vars csp)]
#:result (set-$csp-vars! csp vars))
([name (in-list (if (procedure? names-or-procedure)
(names-or-procedure)
names-or-procedure))])
(when (memq name (map $var-name vars))
(raise-argument-error 'add-vars! "var that doesn't already exist" name))
(append vars (list ($varc name
(if (procedure? vals-or-procedure)
(vals-or-procedure)
vals-or-procedure)
null)))))
(define/contract (add-var! csp name [vals-or-procedure empty])
(($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
(add-vars! csp (list name) vals-or-procedure))
(define/contract (add-constraints! csp proc namess [proc-name #false])
(($csp? procedure? (listof (listof $var-name?))) ((or/c #false $var-name?)) . ->* . void?)
(set-$csp-constraints! csp (append ($csp-constraints csp)
(for/list ([names (in-list namess)])
(for ([name (in-list names)])
(check-name-in-csp! 'add-constraints! csp name))
($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 $var-name?)) ($var-name?) . ->* . void?)
(add-constraints! csp proc (combinations var-names 2) proc-name))
(define/contract (add-constraint! csp proc var-names [proc-name #false])
(($csp? procedure? (listof $var-name?)) ($var-name?) . ->* . void?)
(add-constraints! csp proc (list var-names) proc-name))
(define/contract (no-solutions? csp)
($csp? . -> . boolean?)
(zero? (state-count csp)))
(struct inconsistency-signal (csp) #:transparent)
(define use-reduce-arity? (make-parameter #t))
(define use-mac? (make-parameter #t))
(define use-remove-constraints? (make-parameter #t))
(define use-validate-assignments? (make-parameter #t))
(define/contract (apply-unary-constraint csp constraint #:culprit [culprit #f])
(($csp? unary-constraint?) (#:culprit (or/c #f $var-name?)) . ->* . $csp?)
(define (update-csp-vars name vals)
(for/list ([var (in-list ($csp-vars csp))])
(define new-culprits (if (and culprit (< (length vals) (length ($var-vals var))))
(remove-duplicates (cons culprit ($varc-culprits var)) eq?)
($varc-culprits var)))
(if (eq? ($var-name var) name)
($varc name vals new-culprits)
var)))
(match-define ($constraint (list name) proc) constraint)
(match (if (promise? proc)
(force proc)
(filter proc ($csp-vals csp name)))
[(list) (raise (inconsistency-signal csp))]
[(list assigned-val) ((if (use-validate-assignments?) make-nodes-consistent values)
((if (use-remove-constraints?) remove-assigned-constraints values)
((if (use-reduce-arity?) reduce-constraint-arity values)
((if (use-validate-assignments?) validate-assignments values)
(let ([csp ($csp
(update-csp-vars name (list assigned-val))
($csp-constraints csp))])
(if (use-mac?)
(make-arcs-consistent csp #:mac name)
csp))))))]
[(list new-vals ...) ($csp (update-csp-vars name new-vals)
;; once the constraint is applied, it can go away
;; ps this is not the same as an "assigned" constraint
;; because the var may still have multiple values
(if (use-remove-constraints?)
(remove constraint ($csp-constraints csp))
($csp-constraints csp)))]))
(define/contract (make-nodes-consistent csp)
($csp? . -> . $csp?)
(for/fold ([csp csp])
([constraint (in-list ($csp-constraints csp))]
#:when (unary-constraint? constraint))
(apply-unary-constraint csp constraint)))
(define/contract ($csp-var csp name)
($csp? $var-name? . -> . $var?)
(check-name-in-csp! '$csp-var csp name)
(for/first ([var (in-list ($csp-vars csp))]
#:when (eq? name ($var-name var)))
var))
(define/contract ($csp-vals csp name)
($csp? $var-name? . -> . (listof any/c))
(check-name-in-csp! '$csp-vals csp name)
($var-vals ($csp-var csp name)))
(struct $arc (name constraint) #:transparent)
(define/contract (reduce-domains-by-arc csp arc)
($csp? $arc? . -> . $csp?)
(match-define ($arc name ($constraint names constraint-proc)) arc)
(match-define (list other-name) (remove name names))
(define proc (if (eq? name (first names)) ; name is on left
constraint-proc ; so val stays on left
(λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order
(define (satisfies-arc? val)
(for/or ([other-val (in-list ($csp-vals csp other-name))])
(proc val other-val)))
(apply-unary-constraint csp ($constraint (list name)
(procedure-rename
satisfies-arc?
(string->symbol (format "~a-arc-to-~a" (object-name proc) other-name))))
#:culprit other-name))
(define/contract (binary-constraints->arcs constraints)
((listof binary-constraint?) . -> . (listof $arc?))
(for*/list ([constraint (in-list constraints)]
[name (in-list ($constraint-names constraint))])
($arc name constraint)))
(define/contract (terminating-at arcs name)
((listof $arc?) $var-name? . -> . (listof $arc?))
(for/list ([arc (in-list arcs)]
#:when (and
(memq name ($constraint-names ($arc-constraint arc)))
(not (eq? name ($arc-name arc)))))
arc))
(define/contract (constraint-assigned? csp constraint)
($csp? $constraint? . -> . any/c)
(for/and ([name (in-list ($constraint-names constraint))])
(memq name (map $var-name (assigned-vars csp)))))
(define/contract (remove-assigned-constraints csp [arity #false])
(($csp?) ((or/c #false exact-nonnegative-integer?)) . ->* . $csp?)
($csp
($csp-vars csp)
(for/list ([constraint (in-list ($csp-constraints csp))]
#:unless (and (if arity (= arity (constraint-arity constraint)) #true)
(constraint-assigned? csp constraint)))
constraint)))
(define/contract (make-arcs-consistent csp #:mac [mac-name #f])
(($csp?) (#:mac (or/c $var-name? #f)) . ->* . $csp?)
;; csp is arc-consistent if every pair of variables (x y)
;; has values in their domain that satisfy every binary constraint
;; AC-3 as described by AIMA @ 265
(define (mac-condition? arc)
(and
(constraint-contains-name? ($arc-constraint arc) mac-name)
(memq ($arc-name arc) (map $var-name (unassigned-vars csp)))))
(define starting-arcs
(for/list ([arc (in-list (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp))))]
#:when ((if mac-name mac-condition? values) arc))
arc))
(for/fold ([csp csp]
[arcs starting-arcs]
#:result csp)
([i (in-naturals)]
#:break (empty? arcs))
(match-define (cons ($arc name proc) other-arcs) arcs)
(define reduced-csp (reduce-domains-by-arc csp ($arc name proc)))
(values reduced-csp (if (= (length ($csp-vals csp name)) (length ($csp-vals reduced-csp name)))
;; revision did not reduce the domain, so keep going
other-arcs
;; revision reduced the domain, so supplement the list of arcs
(remove-duplicates (append (starting-arcs . terminating-at . name) other-arcs))))))
(define/contract (var-assigned? var)
($var? . -> . boolean?)
(= 1 (remaining-values var)))
(define/contract (solution-complete? csp)
($csp? . -> . 'lean?)
(and (andmap var-assigned? ($csp-vars csp)) (empty? ($csp-constraints csp))))
(define (assigned-helper csp) (partition var-assigned? ($csp-vars csp)))
(define/contract (unassigned-vars csp)
($csp? . -> . (listof $var?))
(match-define-values (assigned unassigned) (assigned-helper csp))
unassigned)
(define/contract (assigned-vars csp)
($csp? . -> . (listof $var?))
(match-define-values (assigned unassigned) (assigned-helper csp))
assigned)
(define/contract (constraint-arity constraint)
($constraint? . -> . exact-nonnegative-integer?)
(length ($constraint-names constraint)))
(define/contract (var-degree csp var)
($csp? $var? . -> . exact-nonnegative-integer?)
(for/sum ([constraint (in-list ($csp-constraints csp))]
#:when (constraint-contains-name? constraint ($var-name var)))
1))
(define use-mrv? (make-parameter #t))
(define/contract (select-unassigned-var csp)
($csp? . -> . (or/c #f $var?))
(match (unassigned-vars csp)
[(list) #f]
[(list uvars ...)
(cond
[(use-mrv?)
;; minimum remaining values (MRV) rule
(define mrv-arg (argmin remaining-values uvars))
(match (filter (λ (var) (= (remaining-values mrv-arg) (remaining-values var))) uvars)
[(list winning-uvar) winning-uvar]
[(list mrv-uvars ...)
;; 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)))])]
[else (first uvars)])]))
(define/contract (order-domain-values vals)
((listof any/c) . -> . (listof any/c))
;; todo: least constraining value sort
vals)
(define/contract (constraint-contains-name? constraint name)
($constraint? $var-name? . -> . boolean?)
(and (memq name ($constraint-names constraint)) #true))
(define/contract (validate-assignments csp)
($csp? . -> . $csp?)
(define assigned-constraints (filter (λ (c) (constraint-assigned? csp c)) ($csp-constraints csp)))
(for ([constraint (in-list (sort assigned-constraints < #:key constraint-arity))]
#:unless (constraint csp))
(raise (inconsistency-signal csp)))
csp)
(define/contract (assign-val csp name val)
($csp? $var-name? any/c . -> . $csp?)
(check-name-in-csp! 'assign-val csp name)
(define assignment-constraint ($constraint (list name) (delay (list val))))
(apply-unary-constraint csp assignment-constraint))
(define/contract (assign-val! csp name val)
($csp? $var-name? any/c . -> . void?)
(check-name-in-csp! 'assign-val! csp name)
(define new-csp (assign-val csp name val))
(set-$csp-vars! csp ($csp-vars new-csp))
(set-$csp-constraints! csp ($csp-constraints new-csp)))
(define (reduce-arity proc pattern)
(unless (match (procedure-arity proc)
[(arity-at-least val) (<= val (length pattern))]
[(? number? val) (= val (length pattern))])
(raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern))
(define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc))))
(define-values (id-names vals) (partition symbol? pattern))
(define new-arity (length id-names))
(procedure-rename
(λ xs
(unless (= (length xs) new-arity)
(apply raise-arity-error reduced-arity-name new-arity xs))
(apply proc (for/fold ([acc empty]
[xs xs]
[vals vals]
#:result (reverse acc))
([pat-item (in-list pattern)])
(if (symbol? pat-item)
(values (cons (car xs) acc) (cdr xs) vals)
(values (cons (car vals) acc) xs (cdr vals))))))
reduced-arity-name))
(define/contract (assigned-name? csp name)
($csp? $var-name? . -> . boolean?)
(and (memq name (map $var-name (assigned-vars csp))) #true))
(define/contract (reduce-constraint-arity csp [minimum-arity #false])
(($csp?) ((or/c #false exact-nonnegative-integer?)) . ->* . $csp?)
(let ([assigned-name? (curry assigned-name? csp)])
(define (partially-assigned? constraint)
(ormap assigned-name? ($constraint-names constraint)))
($csp ($csp-vars csp)
(for/list ([constraint (in-list ($csp-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 symbols (indicating variables to persist)
(let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
(if (assigned-name? cname)
($csp-ref csp cname)
cname))])
(reduce-arity proc reduce-arity-pattern)))]
[else constraint])))))
(define/contract (conflict-set csp name)
($csp? $var-name? . -> . (listof $var-name?))
;; earlier assigned variables that participate in constraints with name
(define assigned-names (reverse (map $var-name (assigned-vars csp))))
(define earlier-assigned-names (memq name assigned-names))
(for*/list ([constraint (in-list ($csp-constraints csp))]
[cnames (in-value ($constraint-names constraint))]
#:when (and (andmap (λ (cname) (memq cname earlier-assigned-names)) cnames)
(constraint-contains-name? constraint name))
[cname (in-list cnames)]
#:unless (eq? cname name))
cname))
(define use-cdj? (make-parameter #f))
(define/contract (select-k sig name krecs)
(inconsistency-signal? $var-name? (listof (cons/c $var-name? continuation?)) . -> . continuation?)
;; select the most recent (ie topmost) k that is in the signal
;; todo: repair backjumping
(cond
[(use-cdj?)
(define assigned-names (map car krecs)) ; already in reverse chron order
(define csp (inconsistency-signal-csp sig))
(define backjump-dest
(let loop ([name name][cset (conflict-set csp name)])
(define next-name (for/first ([previously-assigned-name (in-list (memq name assigned-names))]
#:when (memq previously-assigned-name cset))
previously-assigned-name))
(define next-cset (conflict-set csp next-name))
(if (empty? next-cset)
next-name
(loop next-name (remq next-name (remove-duplicates (append next-cset cset) eq?))))))
(cdr (assq backjump-dest krecs))]
[else (cdr (first krecs))]))
(define/contract (backtrack-solution-generator csp)
($csp? . -> . generator?)
;; as described by AIMA @ 271
(generator () (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]
[backjump-krecs null])
(match (select-unassigned-var csp)
[#f (yield ($csp (for/list ([v (in-list ($csp-vars csp))])
(match v
[($varc name vals _) ($var name vals)]
[(? $var? v) v]))
($csp-constraints csp)))]
[($var name vals)
(call/prompt
(thunk
(for ([val (in-list (order-domain-values vals))])
(let/cc backjump-k
(let ([backjump-krecs (cons (cons name backjump-k) backjump-krecs)])
(with-handlers ([inconsistency-signal?
(λ (sig)
(define backjump-k (select-k sig name backjump-krecs))
(backjump-k))])
(backtrack (assign-val csp name val) backjump-krecs)))))))]))))
(define/contract (solve* csp [finish-proc values][solution-limit +inf.0])
(($csp?) (procedure? integer?) . ->* . (non-empty-listof any/c))
(define solutions
(for/list ([solution (in-producer (backtrack-solution-generator csp) (void))]
[idx (in-range solution-limit)])
(finish-proc solution)))
(unless (pair? solutions) (raise (inconsistency-signal csp)))
solutions)
(define/contract (solve csp [finish-proc values])
(($csp?) (procedure?) . ->* . any/c)
(first (solve* csp finish-proc 1)))
(define ($csp-ref csp name) (first ($csp-vals csp name)))
(define/contract (alldiff . xs)
(() #:rest (listof any/c) . ->* . boolean?)
(= (length (remove-duplicates xs)) (length xs)))
(define/contract (alldiff= x y)
(any/c any/c . -> . boolean?)
(not (= x y)))
(define/contract (remaining-values var)
($var? . -> . exact-nonnegative-integer?)
(length ($var-vals var)))
(define/contract (state-count csp)
($csp? . -> . exact-nonnegative-integer?)
(for/product ([var (in-list ($csp-vars csp))])
(remaining-values var)))

500
csp/csp/euler-sudoku-grids.txt
Unescape Escape View File

@ -0,0 +1,500 @@
Grid 01
003020600
900305001
001806400
008102900
700000008
006708200
002609500
800203009
005010300
Grid 02
200080300
060070084
030500209
000105408
000000000
402706000
301007040
720040060
004010003
Grid 03
000000907
000420180
000705026
100904000
050000040
000507009
920108000
034059000
507000000
Grid 04
030050040
008010500
460000012
070502080
000603000
040109030
250000098
001020600
080060020
Grid 05
020810740
700003100
090002805
009040087
400208003
160030200
302700060
005600008
076051090
Grid 06
100920000
524010000
000000070
050008102
000000000
402700090
060000000
000030945
000071006
Grid 07
043080250
600000000
000001094
900004070
000608000
010200003
820500000
000000005
034090710
Grid 08
480006902
002008001
900370060
840010200
003704100
001060049
020085007
700900600
609200018
Grid 09
000900002
050123400
030000160
908000000
070000090
000000205
091000050
007439020
400007000
Grid 10
001900003
900700160
030005007
050000009
004302600
200000070
600100030
042007006
500006800
Grid 11
000125400
008400000
420800000
030000095
060902010
510000060
000003049
000007200
001298000
Grid 12
062340750
100005600
570000040
000094800
400000006
005830000
030000091
006400007
059083260
Grid 13
300000000
005009000
200504000
020000700
160000058
704310600
000890100
000067080
000005437
Grid 14
630000000
000500008
005674000
000020000
003401020
000000345
000007004
080300902
947100080
Grid 15
000020040
008035000
000070602
031046970
200000000
000501203
049000730
000000010
800004000
Grid 16
361025900
080960010
400000057
008000471
000603000
259000800
740000005
020018060
005470329
Grid 17
050807020
600010090
702540006
070020301
504000908
103080070
900076205
060090003
080103040
Grid 18
080005000
000003457
000070809
060400903
007010500
408007020
901020000
842300000
000100080
Grid 19
003502900
000040000
106000305
900251008
070408030
800763001
308000104
000020000
005104800
Grid 20
000000000
009805100
051907420
290401065
000000000
140508093
026709580
005103600
000000000
Grid 21
020030090
000907000
900208005
004806500
607000208
003102900
800605007
000309000
030020050
Grid 22
005000006
070009020
000500107
804150000
000803000
000092805
907006000
030400010
200000600
Grid 23
040000050
001943600
009000300
600050002
103000506
800020007
005000200
002436700
030000040
Grid 24
004000000
000030002
390700080
400009001
209801307
600200008
010008053
900040000
000000800
Grid 25
360020089
000361000
000000000
803000602
400603007
607000108
000000000
000418000
970030014
Grid 26
500400060
009000800
640020000
000001008
208000501
700500000
000090084
003000600
060003002
Grid 27
007256400
400000005
010030060
000508000
008060200
000107000
030070090
200000004
006312700
Grid 28
000000000
079050180
800000007
007306800
450708096
003502700
700000005
016030420
000000000
Grid 29
030000080
009000500
007509200
700105008
020090030
900402001
004207100
002000800
070000090
Grid 30
200170603
050000100
000006079
000040700
000801000
009050000
310400000
005000060
906037002
Grid 31
000000080
800701040
040020030
374000900
000030000
005000321
010060050
050802006
080000000
Grid 32
000000085
000210009
960080100
500800016
000000000
890006007
009070052
300054000
480000000
Grid 33
608070502
050608070
002000300
500090006
040302050
800050003
005000200
010704090
409060701
Grid 34
050010040
107000602
000905000
208030501
040070020
901080406
000401000
304000709
020060010
Grid 35
053000790
009753400
100000002
090080010
000907000
080030070
500000003
007641200
061000940
Grid 36
006080300
049070250
000405000
600317004
007000800
100826009
000702000
075040190
003090600
Grid 37
005080700
700204005
320000084
060105040
008000500
070803010
450000091
600508007
003010600
Grid 38
000900800
128006400
070800060
800430007
500000009
600079008
090004010
003600284
001007000
Grid 39
000080000
270000054
095000810
009806400
020403060
006905100
017000620
460000038
000090000
Grid 40
000602000
400050001
085010620
038206710
000000000
019407350
026040530
900020007
000809000
Grid 41
000900002
050123400
030000160
908000000
070000090
000000205
091000050
007439020
400007000
Grid 42
380000000
000400785
009020300
060090000
800302009
000040070
001070500
495006000
000000092
Grid 43
000158000
002060800
030000040
027030510
000000000
046080790
050000080
004070100
000325000
Grid 44
010500200
900001000
002008030
500030007
008000500
600080004
040100700
000700006
003004050
Grid 45
080000040
000469000
400000007
005904600
070608030
008502100
900000005
000781000
060000010
Grid 46
904200007
010000000
000706500
000800090
020904060
040002000
001607000
000000030
300005702
Grid 47
000700800
006000031
040002000
024070000
010030080
000060290
000800070
860000500
002006000
Grid 48
001007090
590080001
030000080
000005800
050060020
004100000
080000030
100020079
020700400
Grid 49
000003017
015009008
060000000
100007000
009000200
000500004
000000020
500600340
340200000
Grid 50
300200000
000107000
706030500
070009080
900020004
010800050
009040301
000702000
000008006

29
csp/csp/expander.rkt
Unescape Escape View File

@ -0,0 +1,29 @@
#lang br/quicklang
(require csp racket/stxparam racket/splicing)
(provide (all-defined-out)
(except-out (all-from-out br/quicklang) #%module-begin)
(rename-out [mb #%module-begin]))
(define-syntax-parameter PROB (λ (stx) (error 'not-parameterized)))
(define-syntax-parameter SOLVE (make-rename-transformer #'solve))
(define-macro (mb EXPR0 ... #:output ID EXPR ...)
(with-syntax ([prob #'ID])
#'(#%module-begin
(require csp)
(provide prob SOLVE)
(define prob (make-csp))
(println prob)
(splicing-syntax-parameterize ([PROB (make-rename-transformer #'ID)])
EXPR0 ...
EXPR ...))))
(define-macro (define-variable VID DOMAIN)
#'(begin
(define VID DOMAIN)
(add-var! PROB 'VID DOMAIN)))
(define-macro (define-constraint CID FUNC VARSYMS)
#'(begin
(define CID (constraint FUNC VARSYMS))
(add-constraint! PROB FUNC VARSYMS)))

40
csp/csp/hacs-cryptarithmetic.rkt
Unescape Escape View File

@ -0,0 +1,40 @@
#lang debug racket
(require "hacs.rkt" sugar/debug)
(module+ test (require rackunit))
(define (word-value d str)
(define xs (for/list ([c (in-string str)])
(dict-ref d (string->symbol (string c)))))
(for/sum ([(x idx) (in-indexed (reverse xs))])
(* x (expt 10 idx))))
(define (math-csp str)
(define input str)
(define words (map string-downcase (string-split input)))
(match-define (list terms ... sum) words)
(define vars (map string->symbol (remove-duplicates (for*/list ([word words]
[c word])
(string c)))))
(unless (<= (length vars) 10)
(raise-argument-error 'too-many-letters))
(define (not= x y) (not (= x y)))
(define math (make-csp))
(add-vars! math vars (range 0 10))
;; all letters have different values
(add-pairwise-constraint! math not= vars)
;; first letters cannot be zero
(define firsts (remove-duplicates (map (compose1 string->symbol string car string->list) words) eq?))
(for ([first firsts])
(add-constraint! math positive? (list first)))
(add-constraint! math (λ args
(define dict (map cons vars args))
(= (apply + (map (λ (w) (word-value dict w)) terms)) (word-value dict sum))) vars)
math)
#;(solve (math-csp "TWO TWO FOUR"))
#;(solve (math-csp "DUCK DUCK GOOSE"))
#;(solve (math-csp "TICK TICK BOOM"))
#;(solve (math-csp "SEND MORE MONEY"))
#;(solve (math-csp "THIS THAT OTHER"))

26
csp/csp/hacs-demo-triples.rkt
Unescape Escape View File

@ -0,0 +1,26 @@
#lang br
(require csp sugar)
(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))
(time-avg 10 (solve* triples))
(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)))

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

@ -0,0 +1,58 @@
#lang debug racket
(require "hacs.rkt" sugar/debug)
(module+ test (require rackunit))
(define (map-coloring-csp colors neighbors)
(define names (remove-duplicates (flatten neighbors) eq?))
(define vds (for/list ([name (in-list names)])
(var name colors)))
(define cs (for*/list ([neighbor neighbors]
[target (cdr neighbor)])
(constraint (list (car neighbor) target) neq?)))
(csp vds cs))
(define (parse-colors str) (map string->symbol (map string-downcase (regexp-match* "." str))))
(define(parse-neighbors str)
(define recs (map string-trim (string-split str ";")))
(for/list ([rec recs])
(match-define (cons head tail) (string-split rec ":"))
(map string->symbol (map string-downcase (map string-trim (cons head (string-split (if (pair? tail)
(car tail)
""))))))))
(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: ")))
(module+ test
(check-equal? (length (solve* aus)) 18))
(define usa (map-coloring-csp (parse-colors "RGBY")
(parse-neighbors "WA: OR ID; OR: ID NV CA; CA: NV AZ; NV: ID UT AZ; ID: MT WY UT;
UT: WY CO AZ; MT: ND SD WY; WY: SD NE CO; CO: NE KA OK NM; NM: OK TX;
ND: MN SD; SD: MN IA NE; NE: IA MO KA; KA: MO OK; OK: MO AR TX;
TX: AR LA; MN: WI IA; IA: WI IL MO; MO: IL KY TN AR; AR: MS TN LA;
LA: MS; WI: MI IL; IL: IN KY; IN: OH KY; MS: TN AL; AL: TN GA FL;
MI: OH IN; OH: PA WV KY; KY: WV VA TN; TN: VA NC GA; GA: NC SC FL;
PA: NY NJ DE MD WV; WV: MD VA; VA: MD DC NC; NC: SC; NY: VT MA CT NJ;
NJ: DE; DE: MD; MD: DC; VT: NH MA; MA: NH RI CT; CT: RI; ME: NH;
HI: ; AK:")))
(module+ test
(check-true (pair? (solve usa))))
(define fr (map-coloring-csp (parse-colors "RGBY")
(parse-neighbors "AL: LO FC; AQ: MP LI PC; AU: LI CE BO RA LR MP; BO: CE IF CA FC RA
AU; BR: NB PL; CA: IF PI LO FC BO; CE: PL NB NH IF BO AU LI PC; FC: BO
CA LO AL RA; IF: NH PI CA BO CE; LI: PC CE AU MP AQ; LO: CA AL FC; LR:
MP AU RA PA; MP: AQ LI AU LR; NB: NH CE PL BR; NH: PI IF CE NB; NO:
PI; PA: LR RA; PC: PL CE LI AQ; PI: NH NO CA IF; PL: BR NB CE PC; RA:
AU BO FC PA LR")))
(module+ test
(check-true (pair? (solve fr))))
(module+ main)

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

@ -0,0 +1,35 @@
#lang debug racket
(require sugar/debug "hacs.rkt")
(current-inference forward-check)
(current-select-variable mrv)
(current-order-values shuffle)
;; queens problem
;; place queens on chessboard so they do not intersect
(define board-size 10)
(define queens (make-csp))
(define qs (range board-size))
(define rows (range (length qs)))
(add-vars! queens qs rows)
(for* ([qs (in-combinations qs 2)])
(match-define (list qa qb) qs)
(add-constraint! queens
(λ (qa-row qb-row)
(not (= (abs (- qa-row qb-row)) (abs (- qa qb))))) ; same diag?
(list qa qb)))
(add-all-diff-constraint! queens #:proc eq?)
(define (sol->string sol)
(define assocs (csp->assocs sol))
(displayln (string-join (for/list ([q (in-list (sort assocs < #:key car))])
(apply string (add-between (for/list ([idx (in-range board-size)])
(if (= idx (cdr q)) #\@ #\·)) #\space))) "\n"))
assocs)
(current-thread-count 4)
(parameterize ([current-solver min-conflicts-solver])
(time (solve queens #:finish-proc sol->string)))

118
csp/csp/hacs-test-sudoku.rkt
Unescape Escape View File

@ -0,0 +1,118 @@
#lang debug br
(require sugar/debug "hacs.rkt")
(define (make-base-sudoku)
(define sudoku (make-csp))
(define cells (range 81))
(add-vars! sudoku cells (range 1 10))
(for ([i 9])
(define row-cells (filter (λ (cell) (= (quotient cell 9) i)) cells))
(add-all-diff-constraint! sudoku row-cells)
(define col-cells (filter (λ (cell) (= (remainder cell 9) i)) cells))
(add-all-diff-constraint! sudoku col-cells))
(define box-starts '(0 3 6 27 30 33 54 57 60))
(define box-offsets '(0 1 2 9 10 11 18 19 20))
(for ([start box-starts])
(add-all-diff-constraint! sudoku (map (curry + start) box-offsets)))
sudoku)
(define (make-sudoku-board . strs)
(define sudoku (make-base-sudoku))
(define vals (for*/list ([str (in-list strs)]
[c (in-string str)]
#:unless (memv c '(#\- #\|)))
(string->number (string c))))
(for ([(val vidx) (in-indexed vals)]
#:when val)
(add-constraint! sudoku (curry = val) (list vidx)))
sudoku)
(require racket/sequence)
(define (print-grid sol)
(displayln (string-join (map ~a (for/list ([row (in-slice 9 (csp->assocs sol))])
(map cdr row))) "\n")))
;; http://jeapostrophe.github.io/2013-10-23-sudoku-post.html
(define b1
(make-sudoku-board
"53 | 7 | "
"6 |195| "
" 98| | 6 "
"-----------"
"8 | 6 | 3"
"4 |8 3| 1"
"7 | 2 | 6"
"-----------"
" 6 | |28 "
" |419| 5"
" | 8 | 79"))
;; "Hard" example
(define b2
(make-sudoku-board
" 7 | 2 | 5"
" 9| 87| 3"
" 6 | | 4 "
"-----------"
" | 6 | 17"
"9 4| |8 6"
"71 | 5 | "
"-----------"
" 9 | | 8 "
"5 |21 |4 "
"4 | 9 | 6 "))
;; "Evil" example
(define b3
(make-sudoku-board
" 8| | 45"
" | 8 |9 "
" 2|4 | "
"-----------"
"5 | 1|76 "
" 1 | 7 | 8 "
" 79|5 | 1"
"-----------"
" | 7|4 "
" 7| 6 | "
"65 | |3 "))
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-order-values shuffle)
(current-node-consistency #t)
(current-arity-reduction #t)
(define trials 5)
(time-avg trials (void (solve b1)))
(print-debug-info)
(time-avg trials (void (solve b2)))
(print-debug-info)
(time-avg trials (void (solve b3)))
(print-debug-info)
(define (euler-value sol)
(match sol
[(list (cons 0 h) (cons 1 t) (cons 2 d) _ ...)
(+ (* 100 h) (* 10 t) d)]))
(require rackunit)
(check-equal? (euler-value (solve b1)) 534)
(check-equal? (euler-value (solve b2)) 378)
(check-equal? (euler-value (solve b3)) 938)
;; https://projecteuler.net/problem=96
;; answer 24702
(define (do-euler)
(define bstrs
(for/list ([puz (in-slice 10 (string-split (port->string (open-input-file "euler-sudoku-grids.txt")) "\n"))])
(map (λ (str) (string-replace str "0" " ")) (cdr puz))))
(for/sum ([bstr bstrs])
(euler-value (solve (apply make-sudoku-board bstr)))))

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

@ -0,0 +1,33 @@
#lang debug racket
(require sugar/debug "hacs.rkt")
(current-inference forward-check)
(current-select-variable mrv)
(current-order-values shuffle)
(define (word-value . xs)
(for/sum ([(x idx) (in-indexed (reverse xs))])
(* x (expt 10 idx))))
(define smm (make-csp))
(define vs '(s e n d m o r y))
(add-vars! smm vs (λ () (range 10)))
(add-constraint! smm positive? '(s))
(add-constraint! smm positive? '(m))
(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y))
(add-constraint! smm (λ (n d r e y)
(= (modulo (+ (word-value n d) (word-value r e)) 100)
(word-value e y))) '(n d r e y))
(add-constraint! smm (λ (e n d o r y)
(= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y))
(add-constraint! smm (λ (s e n d m o r y)
(= (+ (word-value s e n d) (word-value m o r e))
(word-value m o n e y))) '(s e n d m o r y))
(add-pairwise-constraint! smm alldiff= '(s e n d m o r y))
(parameterize ([current-select-variable mrv-degree-hybrid] ; todo: why is plain mrv bad here?
#;[current-node-consistency make-nodes-consistent]) ; todo: why is node consistency bad here?
(time-named (solve smm)))
(print-debug-info)

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

@ -0,0 +1,313 @@
#lang debug racket
(require "hacs.rkt" rackunit sugar/list sugar/debug)
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-order-values shuffle)
(current-node-consistency #t)
(current-arity-reduction #t)
(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))))
(check-equal?
(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)) (cvar 'c (seteq 2) '((b . 0) (a . 1)))))
(check-equal?
;; no inconsistency: b≠c not checked when fc is relative to a, so assignment succeeds
(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)) (cvar 'b (seteq 0) '((a . 1))) (var 'c '(0))))
;; inconsistency: b≠c is checked by AC-3, thus assignment fails
(check-exn backtrack?
(λ ()
(csp-vars (ac-3 (csp (list (avar 'a '(1)) (var 'b (range 2)) (var 'c '(0)))
(list (constraint '(a b) (negate =))
(constraint '(b c) (negate =)))) 'a))))
(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)))
(list (constraint '(a b) (negate =))
(constraint '(b c) (negate =)))) 'b))
(list (avar 'a '(1)) (avar 'b '(1)) (cvar 'c (seteq 0) '((b . 1)))))
(check-equal?
;; no inconsistency: a≠b is not checked by AC-3, because it's already assigned
;; todo: is this the right result?
(csp-vars (ac-3 (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 (seteq 0))))
(check-exn backtrack?
(λ () (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 (var 'a '(0))
(var 'b (range 3)))
(list (constraint '(a b) <))) 'a))
(list (var 'a '(0)) (cvar 'b (seteq 1 2) '((a . 0)))))
(check-equal?
(parameterize ([current-inference forward-check])
(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))))
(define cs (list
(constraint '(wa nt) neq?)
(constraint '(wa sa) neq?)
(constraint '(nt sa) neq?)
(constraint '(nt q) neq?)
(constraint '(q sa) neq?)
(constraint '(q nsw) neq?)
(constraint '(nsw sa) neq?)
(constraint '(nsw v) neq?)
(constraint '(v sa) neq?)))
(define aus (csp vds cs))
(check-equal? (length (solve* aus)) 18))
(define quarters (make-csp))
(add-vars! quarters '(dollars quarters) (range 26))
(add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters))
(add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters))
(check-equal? (time-named (solve quarters))
'((dollars . 14) (quarters . 12)))
(print-debug-info)
;; xsum
#|
# Reorganize the following numbers in a way that each line of
# 5 numbers sum to 27.
#
# 1 6
# 2 7
# 3
# 8 4
# 9 5
#
|#
(define xsum (make-csp))
(add-vars! xsum '(1 2 3 4 5 6 7 8 9) '(1 2 3 4 5 6 7 8 9))
(add-transitive-constraint! xsum < '(1 2 4 5))
(add-transitive-constraint! xsum < '(6 7 8 9))
(add-constraints! xsum (λ xs (= 27 (apply + xs))) '((1 2 3 4 5) (6 7 3 8 9)))
(add-all-diff-constraint! xsum)
(check-equal? (length (time-named (solve* xsum))) 8)
(print-debug-info)
;; send more money problem
#|
# Assign equal values to equal letters, and different values to
# different letters, in a way that satisfies the following sum:
#
# SEND
# + MORE
# ------
# MONEY
|#
(define (word-value . xs)
(for/sum ([(x idx) (in-indexed (reverse xs))])
(* x (expt 10 idx))))
(define smm (make-csp))
(add-vars! smm '(s e n d m o r y) (λ () (range 10)))
(add-constraint! smm positive? '(s))
(add-constraint! smm positive? '(m))
(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y))
(add-constraint! smm (λ (n d r e y)
(= (modulo (+ (word-value n d) (word-value r e)) 100)
(word-value e y))) '(n d r e y))
(add-constraint! smm (λ (e n d o r y)
(= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y))
(add-constraint! smm (λ (s e n d m o r y)
(= (+ (word-value s e n d) (word-value m o r e))
(word-value m o n e y))) '(s e n d m o r y))
(add-all-diff-constraint! smm)
(check-equal? (parameterize ([current-select-variable mrv-degree-hybrid]) ; todo: why is plain mrv so bad on this problem?
(time-named (solve smm))) '((s . 9) (e . 5) (n . 6) (d . 7) (m . 1) (o . 0) (r . 8) (y . 2)))
(print-debug-info)
;; 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)
(and
(not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal?
(not (= qa-row qb-row)))) ; same row?
(list qa qb)))
(check-equal? 92 (length (time-named (solve* queens))))
(print-debug-info)
#|
# There are no tricks, just pure logic, so good luck and don't give up.
#
# 1. In a street there are five houses, painted five different colours.
# 2. In each house lives a person of different nationality
# 3. These five homeowners each drink a different kind of beverage, smoke
# different brand of cigar and keep a different pet.
#
# THE QUESTION: WHO OWNS THE zebra?
#
# HINTS
#
# 1. The englishman lives in a red house.
# 2. The spaniard keeps dogs as pets.
# 5. The owner of the Green house drinks coffee.
# 3. The ukrainian drinks tea.
# 4. The Green house is on the left of the ivory house.
# 6. The person who smokes oldgold rears snails.
# 7. The owner of the Yellow house smokes kools.
# 8. The man living in the centre house drinks milk.
# 9. The Norwegian lives in the first house.
# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
# 11. The man who keeps horses lives next to the man who smokes kools.
# 12. The man who smokes luckystrike drinks orangejuice.
# 13. The japanese smokes parliaments.
# 14. The Norwegian lives next to the blue house.
# 15. The man who smokes chesterfields has a neighbour who drinks water.
|#
(define (sym . args) (string->symbol (apply format args)))
(define zebra (make-csp))
(define ns (map (curry sym "nationality-~a") (range 5)))
(define cs (map (curry sym "color-~a") (range 5)))
(define ds (map (curry sym "drink-~a") (range 5)))
(define ss (map (curry sym "smoke-~a") (range 5)))
(define ps (map (curry sym "pet-~a") (range 5)))
(add-vars! zebra ns '(englishman spaniard ukrainian norwegian japanese))
(add-vars! zebra cs '(red ivory green yellow blue))
(add-vars! zebra ds '(tea coffee milk orange-juice water))
(add-vars! zebra ss '(oldgold kools chesterfields luckystrike parliaments))
(add-vars! zebra ps '(dogs snails foxes horses zebra))
(for ([vars (list ns cs ds ss ps)])
(add-all-diff-constraint! zebra vars #:same eq?))
(define (xnor lcond rcond)
(or (and lcond rcond) (and (not lcond) (not rcond))))
(define (paired-with lval left rval right)
(add-constraint! zebra (λ (left right) (xnor (eq? left lval) (eq? rval right))) (list left right)))
(define (paired-with* lval lefts rval rights)
(for ([left lefts][right rights])
(paired-with lval left rval right)))
;# 1. The englishman lives in a red house.
('englishman ns . paired-with* . 'red cs)
;# 2. The spaniard keeps dogs as pets.
('spaniard ns . paired-with* . 'dogs ps)
;# 5. The owner of the Green house drinks coffee.
('green cs . paired-with* . 'coffee ds)
;# 3. The ukrainian drinks tea.
('ukrainian ns . paired-with* . 'tea ds)
;# 4. The Green house is on the left of the ivory house.
('green (drop-right cs 1) . paired-with* . 'ivory (drop cs 1))
(add-constraint! zebra (curry neq? 'ivory) (list 'color-0))
(add-constraint! zebra (curry neq? 'green) (list 'color-4))
;# 6. The person who smokes oldgold rears snails.
('oldgold ss . paired-with* . 'snails ps)
;# 7. The owner of the Yellow house smokes kools.
('yellow cs . paired-with* . 'kools ss)
;# 8. The man living in the centre house drinks milk.
(add-constraint! zebra (λ (d) (eq? d 'milk)) (list 'drink-2))
;# 9. The Norwegian lives in the first house.
(add-constraint! zebra (λ (x) (eq? x 'norwegian)) (list 'nationality-0))
(define (next-to lval lefts rval rights)
(for ([righta (drop-right rights 2)]
[left (cdr lefts)]
[rightb (drop rights 2)])
(add-constraint! zebra (λ (left righta rightb)
(or (not (eq? left lval)) (eq? righta rval) (eq? rval rightb)))
(list left righta rightb)))
(for ([left (list (first lefts) (last lefts))]
[right (list (second rights) (fourth rights))])
(add-constraint! zebra (λ (left right) (xnor (eq? left lval) (eq? rval right)))
(list left right))))
;# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
('chesterfields ss . next-to . 'foxes ps)
;# 11. The man who keeps horses lives next to the man who smokes kools.
('horses ps . next-to . 'kools ss)
;# 12. The man who smokes luckystrike drinks orangejuice.
('luckystrike ss . paired-with* . 'orange-juice ds)
;# 13. The japanese smokes parliaments.
('japanese ns . paired-with* . 'parliaments ss)
;# 14. The Norwegian lives next to the blue house.
('norwegian ns . next-to . 'blue cs)
;# 15. The man who smokes chesterfields has a neighbour who drinks water.
('chesterfields ss . next-to . 'water ds)
(define (finish x)
(apply map list (slice-at x 5)))
(check-equal? (parameterize ([current-select-variable mrv])
(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))
((nationality-2 . englishman) (color-2 . red) (drink-2 . milk) (smoke-2 . oldgold) (pet-2 . snails))
((nationality-3 . japanese) (color-3 . green) (drink-3 . coffee) (smoke-3 . parliaments) (pet-3 . zebra))
((nationality-4 . spaniard) (color-4 . ivory) (drink-4 . orange-juice) (smoke-4 . luckystrike) (pet-4 . dogs))))
(print-debug-info)
(module+ main
(begin
(define-syntax n (λ (stx) #'10))
(time-avg n (void (solve quarters)))
(time-avg n (void (solve* xsum)))
(time-avg n (void (solve smm)))
(time-avg n (void (solve* queens)))
(time-avg n (void (solve zebra)))))

723
csp/csp/hacs.rkt
Unescape Escape View File

@ -0,0 +1,723 @@
#lang debug racket
(require racket/generator graph racket/set)
(provide (except-out (all-defined-out) define/contract))
(define-syntax-rule (define/contract EXPR CONTRACT . BODY)
(define EXPR . BODY))
(define-syntax when-debug
(let ()
(define debug #t)
(if debug
(make-rename-transformer #'begin)
(λ (stx) (syntax-case stx ()
[(_ . rest) #'(void)])))))
(define (print-debug-info)
(when-debug
(displayln (format "assignments: ~a forward checks: ~a checks: ~a " nassns nchecks nfchecks))))
(define-syntax-rule (in-cartesian x)
(in-generator (let ([argss x])
(let loop ([argss argss][acc empty])
(if (null? argss)
(yield (reverse acc))
(for ([arg (in-stream (car argss))])
(loop (cdr argss) (cons arg acc))))))))
(struct csp (vars constraints) #:mutable #:transparent)
(define constraints csp-constraints)
(define vars csp-vars)
(define-syntax-rule (in-constraints csp) (in-list (csp-constraints csp)))
(define-syntax-rule (in-vars csp) (in-list (vars csp)))
(define-syntax-rule (in-var-names csp) (in-list (map var-name (vars csp))))
(struct constraint (names proc) #:transparent
#:property prop:procedure
(λ (const prob)
(unless (csp? prob)
(raise-argument-error 'constraint "csp" prob))
;; apply proc in many-to-many style
(for/and ([args (in-cartesian (map (λ (name) (find-domain prob name)) (constraint-names const)))])
(apply (constraint-proc const) args))))
(define/contract (make-constraint [names null] [proc values])
(() ((listof name?) procedure?) . ->* . constraint?)
(constraint names proc))
(define/contract (csp->graphviz prob)
(csp? . -> . string?)
(define g (csp->graph prob))
(graphviz g #:colors (coloring/brelaz g)))
(define/contract (csp->graph prob)
(csp? . -> . graph?)
(for*/fold ([gr (unweighted-graph/undirected (map var-name (vars prob)))])
([constraint (in-constraints prob)]
[edge (in-combinations (constraint-names constraint) 2)])
(apply add-edge! gr edge)
gr))
(struct var (name domain) #:transparent)
(define (var-name? x) #true) ; anything is ok for now
(define domain var-domain)
(struct checked-variable var (history) #:transparent)
(define history checked-variable-history)
(define cvar checked-variable)
(define cvar? checked-variable?)
(struct assigned-var var () #:transparent)
(define avar assigned-var)
(define avar? assigned-var?)
(define/contract (make-csp [vars null] [consts null])
(() ((listof var?) (listof constraint?)) . ->* . csp?)
(csp vars consts))
(define (varvals->set vals)
(match vals
[(list (or (? fixnum?) (? symbol?)) ...) (list->seteq vals)]
[_ (list->set vals)]))
(define/contract (make-var name [vals null])
((name?) ((listof any/c)) . ->* . var?)
(var name (varvals->set vals)))
(define (make-checked-var name vals history)
(checked-variable name (varvals->set vals) history))
(define/contract (make-var-names prefix vals [suffix ""])
((string? (listof any/c)) ((string?)) . ->* . (listof name?))
(for/list ([val (in-list vals)])
(string->symbol (format "~a~a~a" prefix val suffix))))
(define/contract (add-vars! prob names [vals-or-procedure empty])
((csp? (listof name?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
(for/fold ([vrs (vars prob)]
#:result (set-csp-vars! prob vrs))
([name (in-list names)])
(when (memq name (map var-name vrs))
(raise-argument-error 'add-vars! "var that doesn't already exist" name))
(append vrs (list (make-var name
(match vals-or-procedure
[(? procedure? proc) (proc)]
[vals vals]))))))
(define/contract (add-var! prob name [vals-or-procedure empty])
((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
(add-vars! prob (list name) vals-or-procedure))
(define/contract (add-constraints! prob proc namess [proc-name #false]
#:caller [caller-id 'add-constraints!])
((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?)
(unless (procedure? proc)
(raise-argument-error caller-id "procedure" proc))
(unless (and (list? namess) (andmap list? namess))
(raise-argument-error caller-id "list of lists of names" namess))
(set-csp-constraints! prob (append (constraints prob)
(for/list ([names (in-list namess)])
(for ([name (in-list names)])
(check-name-in-csp! 'add-constraints! prob name))
(make-constraint names (if proc-name
(procedure-rename proc proc-name)
proc))))))
(define/contract (add-pairwise-constraint! prob proc names [proc-name #false])
((csp? procedure? (listof name?)) (name?) . ->* . void?)
(unless (list? names)
(raise-argument-error 'add-pairwise-constraint! "list of names" names))
(add-constraints! prob proc (combinations names 2) proc-name #:caller 'add-pairwise-constraint!))
(define/contract (add-transitive-constraint! prob proc names [proc-name #false])
((csp? procedure? (listof name?)) (name?) . ->* . void?)
(unless (and (list? names) (>= (length names) 2))
(raise-argument-error 'add-transitive-constraint! "list of two or more names" names))
(add-constraints! prob proc (for/list ([name (in-list names)]
[next (in-list (cdr names))])
(list name next)) proc-name #:caller 'add-transitive-constraint!))
(define/contract (add-constraint! prob proc names [proc-name #false])
((csp? procedure? (listof name?)) (name?) . ->* . void?)
(unless (list? names)
(raise-argument-error 'add-constraint! "list of names" names))
(add-constraints! prob proc (list names) proc-name #:caller 'add-constraint!))
(define/contract (alldiff x y)
(any/c any/c . -> . boolean?)
(not (= x y)))
(define alldiff= alldiff)
(define (add-all-diff-constraint! prob [names (map var-name (csp-vars prob))]
#:same [equal-proc equal?])
(add-pairwise-constraint! prob (λ (x y) (not (equal-proc x y))) names
(string->symbol (format "all-diff-~a" (object-name equal-proc)))))
(struct backtrack (histories) #:transparent)
(define (backtrack! [names null]) (raise (backtrack names)))
(define/contract (check-name-in-csp! caller prob name)
(symbol? csp? name? . -> . void?)
(define names (map var-name (vars prob)))
(unless (memq name names)
(raise-argument-error caller (format "one of these existing csp var names: ~v" names) name)))
(define/contract (find-var prob name)
(csp? name? . -> . var?)
(check-name-in-csp! 'find-var prob name)
(for/first ([vr (in-vars prob)]
#:when (eq? name (var-name vr)))
vr))
(define/contract (find-domain prob name)
(csp? name? . -> . (listof any/c))
(check-name-in-csp! 'find-domain prob name)
(domain (find-var prob name)))
(define order-domain-values values)
(define/contract (assigned-name? prob name)
(csp? name? . -> . any/c)
(assigned-var? (find-var prob name)))
(define/contract (reduce-function-arity proc pattern)
(procedure? (listof any/c) . -> . procedure?)
(unless (match (procedure-arity proc)
[(arity-at-least val) (<= val (length pattern))]
[(? number? val) (= val (length pattern))])
(raise-argument-error 'reduce-function-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern))
(define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc))))
(define-values (boxed-id-names vals) (partition box? pattern))
(define new-arity (length boxed-id-names))
(procedure-rename
(λ xs
(unless (= (length xs) new-arity)
(apply raise-arity-error reduced-arity-name new-arity xs))
(apply proc (for/fold ([acc empty]
[xs xs]
[vals vals]
#:result (reverse acc))
([pat-item (in-list pattern)])
(if (box? pat-item)
(values (cons (car xs) acc) (cdr xs) vals)
(values (cons (car vals) acc) xs (cdr vals))))))
reduced-arity-name))
(define/contract (reduce-constraint-arity prob [minimum-arity 3])
((csp?) ((or/c #false natural?)) . ->* . csp?)
(define assigned? (curry assigned-name? prob))
(define (partially-assigned? constraint)
(ormap assigned? (constraint-names constraint)))
(make-csp (vars prob)
(for/list ([const (in-constraints prob)])
(cond
;; no point reducing 2-arity functions because they will be consumed by forward checking
[(and (or (not minimum-arity) (<= minimum-arity (constraint-arity const)))
(partially-assigned? const))
(match-define (constraint cnames proc) const)
;; 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
(define arity-reduction-pattern (for/list ([cname (in-list cnames)])
(if (assigned? cname)
(first (find-domain prob cname))
(box cname))))
(constraint (filter-not assigned? cnames)
(reduce-function-arity proc arity-reduction-pattern))]
[else const]))))
(define nassns 0)
(define nfchecks 0)
(define nchecks 0)
(define (reset-nassns!) (set! nassns 0))
(define (reset-nfchecks!) (set! nfchecks 0))
(define (reset-nchecks!) (set! nchecks 0))
(define/contract (assign-val prob name val)
(csp? name? any/c . -> . csp?)
(begin0
(make-csp
(for/list ([vr (in-vars prob)])
(if (eq? name (var-name vr))
(assigned-var name (list val))
vr))
(constraints prob))
(when-debug (set! nassns (add1 nassns)))))
(define/contract (assigned-vars prob [invert? #f])
((csp?) (any/c) . ->* . (listof var?))
((if invert? filter-not filter) assigned-var? (vars prob)))
(define/contract (unassigned-vars prob)
(csp? . -> . (listof var?))
(assigned-vars prob 'invert))
(define/contract (first-unassigned-variable csp)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars csp)
[(== empty) #false]
[uvars (first uvars)]))
(define/contract (argmin* proc xs [max-style? #f])
((procedure? (listof any/c)) (any/c) . ->* . (listof any/c))
;; return all elements that have min value.
(match xs
[(== empty) xs]
[(list x) xs]
[xs
(define vals (map proc xs))
(define target-val (apply (if max-style? max min) vals))
(for/list ([x (in-list xs)]
[val (in-list vals)]
#:when (= val target-val))
x)]))
(define/contract (argmax* proc xs)
(procedure? (listof any/c) . -> . (listof any/c))
;; return all elements that have max value.
(argmin* proc xs 'max-mode!))
(define/contract (minimum-remaining-values prob)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars prob)
[(== empty) #false]
[uvars (random-pick (argmin* domain-length uvars))]))
(define/contract (max-degree prob)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars prob)
[(== empty) #false]
[uvars (random-pick (argmax* (λ (var) (var-degree prob var)) uvars))]))
(define mrv minimum-remaining-values)
(define/contract (var-degree prob var)
(csp? var? . -> . natural?)
(for/sum ([const (in-constraints prob)]
#:when (memq (var-name var) (constraint-names const)))
1))
(define/contract (domain-length var)
(var? . -> . natural?)
(set-count (domain var)))
(define/contract (state-count csp)
(csp? . -> . natural?)
(for/product ([vr (in-vars csp)])
(domain-length vr)))
(define/contract (mrv-degree-hybrid prob)
(csp? . -> . (or/c #f var?))
(match (unassigned-vars prob)
[(== empty) #false]
[uvars
(max-degree (make-csp (argmin* domain-length uvars) (constraints prob)))]))
(define first-domain-value values)
(define (no-inference prob name) prob)
(define/contract (relating-only constraints names)
((listof constraint?) (listof name?) . -> . (listof constraint?))
(for*/list ([const (in-list constraints)]
[cnames (in-value (constraint-names const))]
#:when (and (= (length names) (length cnames))
(for/and ([name (in-list names)])
(memq name cnames))))
const))
(define (one-arity? const) (= 1 (constraint-arity const)))
(define (two-arity? const) (= 2 (constraint-arity const)))
(define (constraint-relates? const name)
(memq name (constraint-names const)))
(struct arc (name const) #:transparent)
(define/contract (two-arity-constraints->arcs constraints)
((listof (and/c constraint? two-arity?)) . -> . (listof arc?))
(for*/list ([const (in-list constraints)]
[name (in-list (constraint-names const))])
(arc name const)))
(require sugar/debug)
(define/contract (reduce-domain prob ark)
(csp? arc? . -> . csp?)
(match-define (arc name (constraint names constraint-proc)) ark)
(match-define (list other-name) (remove name names))
(define proc (if (eq? name (first names)) ; name is on left
constraint-proc ; so val stays on left
(λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order
(define (satisfies-arc? val)
(for/or ([other-val (in-set (find-domain prob other-name))])
(proc val other-val)))
(make-csp
(for/list ([vr (in-vars prob)])
(cond
[(assigned-var? vr) vr]
[(eq? name (var-name vr))
(make-var name (match (filter satisfies-arc? (set->list (domain vr)))
[(? empty?) (backtrack!)]
[vals vals]))]
[else vr]))
(constraints prob)))
(define/contract (terminating-at? arcs name)
((listof arc?) name? . -> . (listof arc?))
(for/list ([arc (in-list arcs)]
#:when (and
(memq name (constraint-names (arc-const arc)))
(not (eq? name (arc-name arc)))))
arc))
(define/contract (ac-3 prob ref-name)
(csp? name? . -> . csp?)
;; csp is arc-consistent if every pair of variables (x y)
;; has values in their domain that satisfy every binary constraint
(define checkable-names (cons ref-name (filter-not (λ (vn) (assigned-name? prob vn)) (map var-name (vars prob)))))
(define starting-arcs
(two-arity-constraints->arcs
(for/list ([const (in-constraints prob)]
#:when (and (two-arity? const)
(for/and ([cname (in-list (constraint-names const))])
(memq cname checkable-names))))
const)))
(for/fold ([prob prob]
[arcs (sort starting-arcs < #:key (λ (a) (domain-length (find-var prob (arc-name a)))) #:cache-keys? #true)]
#:result (prune-singleton-constraints prob))
([i (in-naturals)]
#:break (empty? arcs))
(match-define (cons (and first-arc (arc name _)) other-arcs) arcs)
(define reduced-csp (reduce-domain prob first-arc))
(define domain-reduced?
(< (domain-length (find-var reduced-csp name)) (domain-length (find-var prob name))))
(values reduced-csp
(if domain-reduced?
;; revision reduced the domain, so supplement the list of arcs
(remove-duplicates (append (starting-arcs . terminating-at? . name) other-arcs))
;; revision did not reduce the domain, so keep going
other-arcs))))
(define/contract (forward-check-var prob ref-name vr)
(csp? name? var? . -> . var?)
(match vr
;; don't check against assigned vars, or the reference var
;; (which is probably assigned but maybe not)
[(? assigned-var? vr) vr]
[(var (== ref-name eq?) _) vr]
[(var name vals)
(match ((constraints prob) . relating-only . (list ref-name name))
[(? empty?) vr]
[constraints
(define ref-val (first (find-domain prob ref-name)))
(define new-vals
(for/list ([val (in-set vals)]
#:when (for/and ([const (in-list constraints)])
(match const
[(constraint (list (== name eq?) _) proc) (proc val ref-val)]
[(constraint _ proc) (proc ref-val val)])))
val))
(make-checked-var name new-vals (cons (cons ref-name ref-val) (match vr
[(checked-variable _ _ history) history]
[_ null])))])]))
(define/contract (prune-singleton-constraints prob [ref-name #false])
((csp?) ((or/c #false name?)) . ->* . csp?)
(define singleton-var-names (for/list ([vr (in-vars prob)]
#:when (singleton-var? vr))
(var-name vr)))
(make-csp
(vars prob)
(for/list ([const (in-constraints prob)]
#:unless (and (two-arity? const)
(or (not ref-name) (constraint-relates? const ref-name))
(for/and ([cname (in-list (constraint-names const))])
(memq cname singleton-var-names))))
const)))
(define/contract (forward-check prob ref-name)
(csp? name? . -> . csp?)
(define checked-vars (map (λ (vr) (forward-check-var prob ref-name vr)) (vars prob)))
(when-debug (set! nfchecks (+ (length checked-vars) nchecks)))
;; 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)]
#:when (set-empty? (domain cvr)))
(history cvr)))
;; 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.
;; If we just bail out at the first conflict, we may backjump too far based on its history
;; (and thereby miss parts of the search tree)
(unless (empty? conflict-set)
(backtrack! conflict-set))
;; Discard constraints that have produced singleton domains
;; (they have no further use)
(prune-singleton-constraints (make-csp checked-vars (constraints prob)) ref-name))
(define/contract (constraint-checkable? const names)
(constraint? (listof name?) . -> . any/c)
;; constraint is checkable if all constraint names
;; are in target list of names.
(for/and ([cname (in-list (constraint-names const))])
(memq cname names)))
(define/contract (constraint-arity const)
(constraint? . -> . natural?)
(length (constraint-names const)))
(define/contract (singleton-var? var)
(var? . -> . boolean?)
(= 1 (domain-length var)))
(define/contract (check-constraints prob [mandatory-names #f] #:conflicts [conflict-count? #f])
((csp?) ((listof name?) #:conflicts boolean?) . ->* . (or/c csp? natural?))
(define assigned-varnames (map var-name (assigned-vars prob)))
(define-values (checkable-consts other-consts)
(partition (λ (const) (and (constraint-checkable? const assigned-varnames)
(or (not mandatory-names)
(for/and ([name (in-list mandatory-names)])
(constraint-relates? const name)))))
(constraints prob)))
(cond
[conflict-count?
(define conflict-count
(for/sum ([constraint (in-list checkable-consts)]
#:unless (constraint prob))
1))
(when-debug (set! nchecks (+ conflict-count nchecks)))
conflict-count]
[else
(for ([(constraint idx) (in-indexed checkable-consts)]
#:unless (constraint prob))
(when-debug (set! nchecks (+ (add1 idx) nchecks)))
(backtrack!))
;; discard checked constraints, since they have no further reason to live
(make-csp (vars prob) other-consts)]))
(define/contract (make-nodes-consistent prob)
(csp? . -> . csp?)
(define-values (unary-constraints other-constraints)
(partition one-arity? (constraints prob)))
(if (empty? unary-constraints)
prob
(make-csp
(for/list ([vr (in-vars prob)])
(match-define (var name vals) vr)
(define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints))
(make-var name (for/list ([val (in-set vals)]
#:when (for/and ([const (in-list name-constraints)])
((constraint-proc const) val)))
val)))
other-constraints)))
(define ((make-hist-proc assocs) . xs)
(not
(for/and ([x (in-list xs)]
[val (in-list (map cdr assocs))])
(equal? x val))))
(struct solver (generator kill) #:transparent
#:property prop:procedure 0)
(define/contract (backtracking-solver
prob
#:select-variable [select-unassigned-variable
(or (current-select-variable) first-unassigned-variable)]
#:order-values [order-domain-values (or (current-order-values) first-domain-value)]
#:inference [inference (or (current-inference) no-inference)])
((csp?) (#:select-variable procedure? #:order-values procedure? #:inference procedure?) . ->* . solver?)
(solver
(generator ()
(define starting-state-count (state-count prob))
(define states-examined 0)
(define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values))
(let loop ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)])
(match (select-unassigned-variable prob)
[#false (yield prob)]
[(var name domain)
(define (wants-backtrack? exn)
(and (backtrack? exn) (or (let ([bths (backtrack-histories exn)])
(or (empty? bths) (for*/or ([bth (in-list bths)]
[rec (in-list bth)])
(eq? name (car rec))))))))
(for/fold ([conflicts null]
#:result (void))
([val (in-list (order-domain-values (set->list domain)))])
(with-handlers ([wants-backtrack?
(λ (bt)
(define bths (backtrack-histories bt))
(append conflicts (remq name (remove-duplicates
(for*/list ([bth (in-list bths)]
[rec (in-list bth)])
(car rec)) eq?))))])
(let* ([prob (assign-val prob name val)]
;; reduce constraints before inference,
;; to create more forward-checkable (binary) constraints
[prob (reduce-arity-proc prob)]
[prob (inference prob name)]
[prob (check-constraints prob)])
(loop prob))
;; conflicts goes inside the handler expression
;; so raises can supersede it
conflicts))])))
void))
(define/contract (random-pick xs)
((non-empty-listof any/c) . -> . any/c)
(match xs
[(list x) x]
[(app set->list xs) (list-ref xs (random (length xs)))]))
(define (assign-random-vals prob)
(for/fold ([new-csp prob])
([name (in-var-names prob)])
(assign-val new-csp name (random-pick (find-domain prob name)))))
(define (make-min-conflcts-thread prob-start thread-count max-steps [main-thread (current-thread)])
(thread
(λ ()
(let loop ()
;; Generate a complete assignment for all variables (probably with conflicts)
(for/fold ([prob (assign-random-vals prob-start)])
([nth-step (in-range max-steps)])
;; Now repeatedly choose a random conflicted variable and change it
(match (conflicted-variable-names prob)
[(? empty?) (thread-send main-thread prob) (loop)]
[names
(define name (random-pick names))
(define val (min-conflicts-value prob name (find-domain prob-start name)))
(assign-val prob name val)]))))))
(define/contract (min-conflicts-solver prob [max-steps 100])
((csp?) (exact-positive-integer?) . ->* . solver?)
; todo: what is ideal thread count?
(define threads (for/list ([thread-count (or (current-thread-count) 1)])
(make-min-conflcts-thread prob thread-count max-steps)))
(solver
(generator ()
(let loop ()
(yield (thread-receive))
(loop)))
(λ () (for-each kill-thread threads) )))
(define/contract (optimal-stop-min proc xs)
(procedure? (listof any/c) . -> . any/c)
;; coefficient from
;; https://www.math.ucla.edu/~tom/Stopping/sr2.pdf
(define optimal-stopping-coefficient .458)
(define-values (sample candidates)
(split-at xs (inexact->exact (floor (* optimal-stopping-coefficient (length xs))))))
(define threshold (argmin proc sample))
(or (for/first ([candidate (in-list candidates)]
#:when (<= (proc candidate) threshold))
candidate)
(last candidates)))
(define/contract (conflicted-variable-names prob)
(csp? . -> . (listof name?))
;; Return a list of variables in current assignment that are conflicted
(for/list ([name (in-var-names prob)]
#:when (positive? (nconflicts prob name)))
name))
(define/contract (min-conflicts-value prob name vals)
(csp? name? (listof any/c) . -> . any/c)
;; Return the value that will give var the least number of conflicts
(define vals-by-conflict (sort (set->list vals) < #:key (λ (val) (nconflicts prob name val))
#:cache-keys? #true))
(for/first ([val (in-list vals-by-conflict)]
#:unless (equal? val (first (find-domain prob name)))) ;; but change the value
val))
(define no-value-sig (gensym))
(define/contract (nconflicts prob name [val no-value-sig])
((csp? name?) (any/c) . ->* . natural?)
;; How many conflicts var: val assignment has with other variables.
(check-constraints (if (eq? val no-value-sig)
prob
(assign-val prob name val)) (list name) #:conflicts #true))
(define/contract (csp->assocs prob [keys #f])
((csp?) ((listof name?)) . ->* . (listof (cons/c name? any/c)))
(define assocs
(for/list ([vr (in-vars prob)])
(match vr
[(var name (list val)) (cons name val)])))
(if keys
(for/list ([key (in-list keys)])
(assq key assocs))
assocs))
(define/contract (combine-csps probs)
((listof csp?) . -> . csp?)
(make-csp
(apply append (map vars probs))
(apply append (map csp-constraints probs))))
(define/contract (extract-subcsp prob names)
(csp? (listof name?) . -> . csp?)
(make-csp
(for/list ([vr (in-vars prob)]
#:when (memq (var-name vr) names))
vr)
(for/list ([const (in-constraints prob)]
#:when (constraint-checkable? const names))
const)))
(define (decompose-prob prob)
; decompose into independent csps. `cc` determines "connected components"
(if (current-decompose)
(for/list ([nodeset (in-list (cc (csp->graph prob)))])
(extract-subcsp prob nodeset))
(list prob)))
(define (make-solution-generator prob [max-solutions #false])
(generator ()
(define subprobs (decompose-prob prob))
(define solgens (map (current-solver) subprobs))
(define solstreams (for/list ([solgen (in-list solgens)])
(for/stream ([sol (in-producer solgen (void))])
sol)))
(for ([solution-pieces (in-cartesian solstreams)]
[count (in-range (or max-solutions +inf.0))])
(yield (combine-csps solution-pieces)))
(for-each solver-kill solgens)))
(define-syntax (in-solutions stx)
(syntax-case stx ()
[(_ PROB) #'(in-solutions PROB #false)]
[(_ PROB MAX-SOLUTIONS) #'(in-producer (make-solution-generator PROB MAX-SOLUTIONS) (void))]))
(define/contract (solve* prob [max-solutions #false]
#:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))]
#:solver [solver #f])
((csp?) (natural? #:finish-proc procedure? #:solver procedure?) . ->* . (listof any/c))
(when-debug (reset-nassns!) (reset-nfchecks!) (reset-nchecks!))
(parameterize ([current-solver (or solver (current-solver))])
(for/list ([sol (in-solutions prob max-solutions)])
(finish-proc sol))))
(define/contract (solve prob
#:finish-proc [finish-proc (λ (p) (csp->assocs p (map var-name (vars prob))))]
#:solver [solver #f])
((csp?) (#:finish-proc procedure? #:solver procedure?)
. ->* . (or/c #false any/c))
(match (solve* prob 1 #:finish-proc finish-proc #:solver solver)
[(list solution) solution]
[_ #false]))
(define (<> a b) (not (= a b)))
(define (neq? a b) (not (eq? a b)))
(define current-select-variable (make-parameter #f))
(define current-order-values (make-parameter #f))
(define current-inference (make-parameter forward-check))
(define current-solver (make-parameter backtracking-solver))
(define current-decompose (make-parameter #t))
(define current-thread-count (make-parameter 4))
(define current-node-consistency (make-parameter #f))
(define current-arity-reduction (make-parameter #t))
(define current-learning (make-parameter #f))

4
csp/csp/info.rkt
Unescape Escape View File

@ -0,0 +1,4 @@
#lang info
(define scribblings '(("scribblings/csp.scrbl" ())))
(define test-omit-paths 'all)

8
csp/csp/main.rkt
Unescape Escape View File

@ -0,0 +1,8 @@
#lang racket/base
(require "hacs.rkt")
(module reader syntax/module-reader
csp/expander)
(provide (all-from-out "hacs.rkt"))

674
csp/csp/scribblings/csp.scrbl
Unescape Escape View File

@ -0,0 +1,674 @@
#lang scribble/manual
@(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))
@(my-eval `(require csp racket/list))
@(define-syntax-rule (my-examples ARG ...)
(examples #:label #f #:eval my-eval ARG ...))
@title{Constraint-satisfaction problems (and how to solve them)}
@author[(author+email "Matthew Butterick" "mb@mbtype.com")]
@defmodule[csp]
@margin-note{This package is in development. I make no commitment to maintaining the public interface documented below.}
Simple solvers for simple constraint-satisfaction problems. It uses the forward-checking + conflict-directed backjumping algorithm described in @link["http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.225.3123&rep=rep1&type=pdf"]{@italic{Hybrid Algorithms for the Constraint Satisfaction Problem}} by Patrick Prosser. Plus other improvements of my own devising.
@section{Installation & usage}
At the command line:
@verbatim{raco pkg install csp}
After that, you can update the package like so:
@verbatim{raco pkg update csp}
Import into your program like so:
@verbatim{(require csp)}
@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 its @deftech{domain}). The other is a set of @deftech{constraints} — a fancy word for @italic{rules} — that describe relationships among the variables.
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.)
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{So this is the ultimate tool for the lazy programmer?}
It allows us to describe a problem to the computer in higher-level terms than we usually do. That can be helpful when we have no idea how to create a specialized algorithm, or we just don't feel like it.
But there's still some finesse and artistry involved in setting up the CSP, especially its constraints. In general, a CSP with more constraints will converge on a solution faster. Furthermore, since we're not just lazy but also impatient, we usually want our answer in a few seconds, not tomorrow or next week. So it's usually worth spending a little extra effort to specify the constraints as carefully as we can, to maximize our chances of getting an answer in a reasonable time.
@section{First example}
Suppose we wanted to find @link["http://www.friesian.com/pythag.htm"]{Pythagorean triples} with sides between 1 and 29, inclusive.
First we create a new CSP called @racket[triples], using @racket[make-csp]:
@examples[#:label #f #:eval my-eval
(require csp)
(define triples (make-csp))
]
We use CSP variables to represent the values in the triple. We insert each one with @racket[add-var!], where each variable has a symbol for its name and a list of values for its domain:
@examples[#:label #f #:eval my-eval
(add-var! triples 'a (range 1 30))
(add-var! triples 'b (range 1 30))
(add-var! triples 'c (range 1 30))
]
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[#:label #f #:eval my-eval
(define (valid-triple? x y z)
(= (expt z 2) (+ (expt x 2) (expt y 2))))
(add-constraint! triples valid-triple? '(a b c))
]
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):
@examples[#:label #f #:eval my-eval
(solve triples)
]
Perhaps we're curious to see how many of these triples exist. We use @racket[solve*] to find all 20 solutions:
@examples[#:label #f #:eval my-eval
(solve* triples)
]
``But some of those solutions are just multiples of others, like 3--4--5 and 6--8--10.'' True. Suppose we want to ensure that the values in each solution have no common factors. We add a new @racket[coprime?] constraint:
@examples[#:label #f #:eval my-eval
(require math/number-theory)
(add-constraint! triples coprime? '(a b c))
]
We @racket[solve*] again to see the reduced set of 10 results:
@examples[#:label #f #:eval my-eval
(solve* triples)
]
``But really there's only five unique solutions — the values for @racket[a] and @racket[b] are swapped in the other five.'' 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[#:label #f #:eval my-eval
(add-constraint! triples <= '(a b))
(solve* triples)
]
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?
@examples[#:label #f #:eval my-eval
(add-constraint! triples <= '(a b c))
(solve* triples)
]
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. It's good practice to not duplicate constraints between the same sets of variables — the ``belt and suspenders'' approach just adds work for no benefit.
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 29 × 29 × 29 = 24,389. 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[#:label #f #:eval my-eval
(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 argument that will only generate a certain number of solutions:
@examples[#:label #f #:eval my-eval
(time (solve* triples))
(time (solve* triples 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.
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[#:label #f #:eval my-eval
(add-constraint! triples = '(a b c))
(solve triples)
]
Disappointing but accurate.
The whole example in one block:
@racketblock[
(require csp)
(define triples (make-csp))
(add-var! triples 'a (range 1 30))
(add-var! triples 'b (range 1 30))
(add-var! triples 'c (range 1 30))
(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)
]
@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 1 30)]
[b (in-range 1 30)]
#:when (<= a b)
[c (in-range 1 30)]
#: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 24,389 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)
]
@racketmod[
#:file "sudoku.rkt"
racket
(require csp)
(define (make-base-sudoku)
(define sudoku (make-csp))
(define cells (range 81))
(add-vars! sudoku cells (range 1 10))
(for ([i 9])
(define row-cells (filter (λ (cell) (= (quotient cell 9) i)) cells))
(add-all-diff-constraint! sudoku row-cells)
(define col-cells (filter (λ (cell) (= (remainder cell 9) i)) cells))
(add-all-diff-constraint! sudoku col-cells))
(define box-starts '(0 3 6 27 30 33 54 57 60))
(define box-offsets '(0 1 2 9 10 11 18 19 20))
(for ([start box-starts])
(add-all-diff-constraint! sudoku (map (curry + start) box-offsets)))
sudoku)
(define (make-sudoku-board . strs)
(define sudoku (make-base-sudoku))
(define vals (for*/list ([str (in-list strs)]
[c (in-string str)]
#:unless (memv c '(#\- #\|)))
(string->number (string c))))
(for ([(val vidx) (in-indexed vals)]
#:when val)
(add-constraint! sudoku (curry = val) (list vidx)))
sudoku)
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-order-values shuffle)
(current-node-consistency #t)
(current-arity-reduction #t)
(solve (make-sudoku-board
" 8| | 45"
" | 8 |9 "
" 2|4 | "
"-----------"
"5 | 1|76 "
" 1 | 7 | 8 "
" 79|5 | 1"
"-----------"
" | 7|4 "
" 7| 6 | "
"65 | |3 "))
]
@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}
The variables in a CSP, and the possible values (aka the @italic{domains}) of each, are usually determined by the problem itself. So when we create a CSP, there are really only two areas of artistry and finesse: the choice of constraints and the choice of solver (and related solver settings). It's usually pretty easy to try different solvers & settings on a trial-and-error basis. So ultimately, most of the programming effort in CSPs comes down to designing constraints.
What makes a good list of constraints? In general, our goal is to use constraints to tell the solver things that are true about our CSP so that it can converge on a solution as fast as possible. Given that most CSP search spaces are as vast and barren as the Mojave, our constraints are often not just the difference between a fast solution and a slow one, but whether the solver can finish in a non-boring amount of time.
As it traverses the search space, the solver is constantly trying out partial assignments and learning about which avenues are likely to be fruitful. To that end, it wants to be able to avoid descending into parts of the search space that will be dead ends. For that reason, the most powerful tools for the CSP auteur are @bold{constraints relating two variables} (aka @italic{two-arity constraints}). Two-arity constraints can be checked early in the search process, and help the solver eliminate useless parts of the search space quickly. Two-arity constraints also work with inference functions like @racket[forward-check] and @racket[ac-3]. Once one of the variables is assigned, a two-arity constraint can be reduced to a one-arity constraint, which cooperates with node consistency (see @racket[current-node-consistency]).
Say it with me again: two-arity constraints! OK, you got it.
Some other tips:
@itemlist[#:style 'ordered
@item{The golden rule is to use as many two-arity constraints as necessary. If you can express your CSP using nothing but two-arity constraints, so much the better.}
@item{Constraints with @italic{fewer} variables are generally preferable to those with @italic{more} variables. In programming we call this idea @italic{arity}; in CSP solving it's known as @italic{degree}.}
@item{@italic{More} constraints are better than @italic{fewer} if the extra constraints use fewer variables. That is, lower-degree constraints are enough of a win that even if the lower-degree constraint overlaps with a higher-degree constraint, it's still better to include it. Why? Because it lets the solver eliminate fruitless parts of the search tree by considering fewer variables.}
@item{Corollary: if a higher-degree constraint can be completely expressed in terms of lower-degree constraints, then do that, and get rid of the higher-degree constraint altogether. For an example, see @racket[add-pairwise-constraint!].}
@item{In cases where the constraints have the same degree, and they completely overlap in terms of what they prove, use the @italic{fewest possible} consrtaints. For an example, see @racket[add-transitive-constraint!].}
]
By the way, in terms of the program itself, it doesn't matter what order you add the constraints. The CSP solver will visit them in whatever way it needs to.
@defproc[(make-csp [vars (listof var?) null]
[constraints (listof constraint?) empty])
csp?]{
Create a new CSP. Variables and constraints can be added to the CSP by passing them as arguments. Or you can create an empty CSP and then add variables and constraints imperatively (e.g., with @racket[add-var!] or @racket[add-constraint!]).
}
@deftogether[(
@defproc[(add-var!
[prob csp?]
[name var-name?]
[domain (or/c (listof any/c) procedure?) empty])
void?]
@defproc[(add-vars!
[prob csp?]
[names (listof var-name?)]
[domain (or/c (listof any/c) procedure?) empty])
void?]
)]{
Imperatively add a new variable called @racket[_name] to the CSP with permissible values listed in @racket[_domain]. The solution to a CSP is a list of pairs where each variable has been assigned a value from its domain.
@racket[add-vars!] is the same, but adds multiple variables that have the same domain.
}
@deftogether[(
@defproc[(add-constraint!
[prob csp?]
[func procedure?]
[names (listof var-name?)]
[func-name (or/c #false var-name?) #f])
void?]
@defproc[(add-constraints!
[prob csp?]
[func procedure?]
[namess (listof (listof var-name?))]
[func-name (or/c #false var-name?) #f])
void?]
)]{
Imperatively add a new constraint. The constraint applies the function @racket[_func] to the list of variable names given in @racket[_names]. The return value of @racket[_func] does not need to be a Boolean, but any return value other than @racket[#false] is treated as if it were @racket[#true].
@racket[add-constraints!] is the same, but adds the constraint @racket[_func] to each list of variable names in @racket[_namess] (which is therefore a list of lists of variable names).
}
@defproc[(add-all-diff-constraint!
[prob csp?]
[names (listof var-name?) (map var-name (csp-vars prob))]
[#:same equal-proc equal?])
void?]{
Imperatively add an ``all diff'' constraint, which is a pairwise @racket[(compose1 not equal?)] constraint. A equality function other than @racket[equal?] can be passed via the @racket[#:same] argument. There is nothing special about using this function vs. applying the constraint manually.
}
@defproc[(add-pairwise-constraint!
[prob csp?]
[func procedure?]
[names (listof var-name?)]
[func-name (or/c #false var-name?) #f])
void?]{
Similar to @racket[add-constraint!], but it takes a two-arity procedure @racket[_func] and adds it as a constraint between each pair of names in @racket[_names].
Why? CSPs are more efficient with lower-arity constraints (roughly, because you can rule out invalid values sooner). So usually, decomposing a larger-arity constraint into a group of smaller ones is a good idea.
For instance, suppose you have three variables, and you want them to end up holding values that are coprime. Your constraint function is @racket[coprime?]. This function is variadic (meaning, it can take any number of arguments) so you could use @racket[add-constraint!] like so:
@racketblock[
(add-constraint! my-csp coprime? '(a b c))
]
But because the comparison can be done two at a time, we could write this instead:
@racketblock[
(add-pairwise-constraint! my-csp coprime? '(a b c))
]
Which would be equivalent to:
@racketblock[
(add-constraint! my-csp coprime? '(a b))
(add-constraint! my-csp coprime? '(b c))
(add-constraint! my-csp coprime? '(a c))
]
Still, @racket[add-pairwise-constraint!] doesn't substitute for thoughtful constraint design. For instance, suppose instead we want our variables to be strictly increasing. This time, our constraint function is @racket[<]:
@racketblock[
(add-constraint! my-csp < '(a b c))
]
And we could instead write:
@racketblock[
(add-pairwise-constraint! my-csp < '(a b c))
]
Which would become:
@racketblock[
(add-constraint! my-csp < '(a b))
(add-constraint! my-csp < '(b c))
(add-constraint! my-csp < '(a c))
]
This isn't wrong, but if @racket[(< a b)] and @racket[(< b c)], then by transitivity, @racket[(< a c)] is necessarily true. So pairwise expansion results in more constraints than we need, which in turn can make the search slower than it could be. In these situations, @racket[add-transitive-constraint!] is the better choice.
}
@defproc[(add-transitive-constraint!
[prob csp?]
[func procedure?]
[names (listof var-name?)]
[func-name (or/c #false var-name?) #f])
void?]{
Similar to @racket[add-pairwise-constraint!], but adds the constraint between every @italic{sequential} pair of names in @racket[_names] (not every @italic{possible} pair).
For instance, consider this use of @racket[add-pairwise-constraint!]:
@racketblock[
(add-pairwise-constraint! my-csp < '(a b c d))
]
This applies the constraint between every possible pair, so the result is equivalent to:
@racketblock[
(add-constraint! my-csp < '(a b))
(add-constraint! my-csp < '(a c))
(add-constraint! my-csp < '(a d))
(add-constraint! my-csp < '(b c))
(add-constraint! my-csp < '(b d))
(add-constraint! my-csp < '(c d))
]
This isn't wrong, but as any seventh grader could tell you, it's overkill. @racket[<] is a transitive relation, therefore if it's true that @racket[(< a b)] and @racket[(< b c)], it's necessarily also true that @racket[(< a c)]. So there's no need to apply a separate constraint for that.
This is the behavior we get from @racket[add-transitive-constraint!]. For instance if we instead write this:
@racketblock[
(add-transitive-constraint! my-csp < '(a b c d))
]
The constraint is applied between every sequential pair, so the result is equivalent to:
@racketblock[
(add-constraint! my-csp < '(a b))
(add-constraint! my-csp < '(b c))
(add-constraint! my-csp < '(c d))
]
Same truth in half the constraints.
}
@defproc[(make-var-names
[prefix string?]
[vals (listof any/c)]
[suffix string? ""])
(listof symbol?)]{
Helper function to generate mass quantities of variable names. The @racket[_prefix] and (optional) @racket[_suffix] strings are wrapped around each value in @racket[_vals], and converted to a symbol.
@my-examples[
(make-var-names "foo" (range 6) "bar")
(make-var-names "col" (range 10))
]
}
@defproc[(solve
[prob csp?] )
(or/c #false (listof (cons/c symbol? any/c)))]{
Return a solution for the CSP, or @racket[#false] if no solution exists.
}
@defproc[(solve*
[prob csp?]
[count natural? +inf.0])
(listof (listof (cons/c symbol? any/c)))]{
Return all the solutions for the CSP. If there are none, returns @racket[null]. The optional @racket[_count] argument returns a certain number of solutions (or fewer, if not that many solutions exist)
}
@defform[(in-solutions prob count)]{
Iterator form for use with @racket[for] loops that incrementally returns solutions to @racket[_prob], up to a maximum of @racket[_count].
}
@section{Sideshows}
@defproc[(state-count
[prob csp?])
natural?]{
Number of possible variable assignments for @racket[_prob], otherwise known as the state space. This is the product of the domain sizes of each variable. So a CSP that assigns five variables, each of which can have the values @racket["a-z"], has a state count of @racket[(expt 5 26)] = @racket[1490116119384765625].
}
@defproc[(csp->graph
[prob csp?])
graph?]{
Create an undirected graph (using Racket's @racketmodname[graph] library) where each CSP variable is represented in the graph as a vertex, and each constraint between any pair of variables is represented as an edge.
}
@defproc[(csp->graphviz
[prob csp?])
string?]{
Produce a Graphviz representation of the CSP that can be rendered into a beautiful diagram.
}
@section{Parameters}
@defparam[current-select-variable val (or/c #false procedure?) #:value #f]{
Next variable that the CSP solver will attempt to assign a value to. If @racket[#false], solver just picks the first unassigned variable.
}
@defparam[current-order-values val (or/c #false procedure?) #:value #f]{
Procedure that orders the remaining values in a domain. Default is @racket[#false], which means that the domain values are tried in their original order. If bad values are likely to be clustered together, it can be worth trying @racket[shuffle] for this parameter, which randomizes which value gets chosen next. Shuffling is also helpful in CSPs where all the variable values must be different (because otherwise, the values for every variable are tried in the same order, which means that the search space is front-loaded with failure).
}
@defparam[current-inference val (or/c #false procedure?) #:value forward-check]{
Current inference rule used by the solver. If @racket[#false], solver uses @racket[no-inference]. Default is @racket[forward-check].
}
@defparam[current-solver val procedure? #:value backtracking-solver]{
Current solver algorithm used to solve the CSP. Default is @racket[backtracking-solver].
}
@defparam[current-decompose val (or/c #false procedure?) #:value #t]{
Whether the CSP will be decomposed into independent subproblems (if possible), because smaller CSPs are typically easier to solve than larger ones (and then the component solutions are reassembled into a larger solution).
}
@defparam[current-thread-count val (or/c #false natural?) #:value 4]{
Number of threads used by the @racket[min-conflicts-solver].
}
@defparam[current-node-consistency val (or/c #false procedure?) #:value #f]{
Whether node consistency is applied. Node consistency is helpful for certain CSPs, but not others, so it is @racket[#false] by default.
Helpful for which CSPs? @italic{Node consistency} means that for any one-arity (aka unary) constraints on a variable, we can filter out any domain values that don't satisfy the constraint, thereby reducing the size of the search space. So if the CSP starts with unary constraints, and the constraints foreclose certain values, node consistency can be useful. The cost of node consistency is proportional to the number of values in the domain (because all of them have to be tested).
Node consistency tends to be especially helpful in CSPs where all the assignment values have to be different, and even more so where the variables all have the same domain (say, 100 variables, each with a value between 0 and 99 inclusive). In a case like this, any assignment to one variable means that value can no longer be used by any other variable. Node consistency will remove these values from the other variable domains, thereby pruning the search space aggressively.
}
@defparam[current-arity-reduction val (or/c #false procedure?) #:value #t]{
Whether constraints are reduced in arity where possible. This usually helps, so the default is @racket[#true].
Why does it help? Because lower-arity constraints tend to be faster to test, and the solver can use node consistency on one-arity constraints (see @racket[current-node-consistency]).
For instance, suppose we have variables representing positive integers @racket[a] and @racket[b] and the constraint says @racket[(< a b)]. Further suppose that @racket[b] is assigned value @racket[5]. At that point, this constraint can be expressed instead as the one-arity function @racket[(< a 5)]. This implies that there are only four possible values for @racket[a] (namely, @racket['(1 2 3 4)])). If node consistency is active, the domain of @racket[a] can immediately be checked to see if it includes any of those values. But none of this is possible if we don't reduce the arity.
}
@section{Solvers}
Pass these functions to @racket[current-solver].
@defproc[(backtracking-solver
[prob csp?])
generator?]{
The default solver. Conducts an exhaustive, deterministic search of the state space. @italic{Backtracking} means that when the solver reaches a dead end in the search space, it unwinds to the last successful variable assignment and tries again. The details of its behavior are modified by @racket[current-select-variable], @racket[current-inference], and @racket[current-node-consistency].
The advantage of the backtracking solver: it proceeds through the search space in a systematic matter. If there is a solution, the backtracking solver will find it. Eventually.
The disadvantage: the same. Some search spaces are so huge, and the solutions so rare, that concentrating the effort on searching any particular branch is likely to be futile. For a more probabilistic approach, try @racket[min-conflicts-solver].
}
@defproc[(min-conflicts-solver
[prob csp?]
[max-steps exact-positive-integer? 100])
generator?]{
An alternative solver. Begins with a random assignment and then tries to minimize the number of conflicts (that is, constraint violations), up to @racket[_max-steps] (which defaults to 100). In essence, this is a probabilistic hill-climbing algorithm, where the solver makes random guesses and then tries to nudge those guesses toward the correct answer.
I like to imagine the solver flying above the search space with a planeload of paratroopers, who are dropped into the search territory. Each of them tries to walk from the place they land (= the initial random assignment) toward a solution.
It's a little weird that this works at all, but it does. Sometimes even better than the @racket[backtracking-solver], because the minimum-conflicts solver is ``sampling'' the search space at many diverse locations. Whereas the @racket[backtracking-solver] can get stuck in a fruitless area of the search space, the minimum-conflicts solver keeps moving around.
Of course, to avoid getting stuck, the minimum-conflicts solver has to abandon guesses that aren't panning out. Hence the @racket[_max-steps] argument, which controls the number of steps the solver takes on a certain attempt before giving up.
The other parameter that affects this solver is @racket[current-thread-count], which defaults to 4. The solver is multithreaded in the sense that it pursues multiple solutions simultaneously. This way, if one thread finds a solution earlier, it will not be blocked by the others.
}
@section{Selecting the next variable}
Pass these functions to @racket[current-select-variable].
@defproc[(mrv-degree-hybrid
[prob csp?])
(or/c #false var?)]{
Selects next variable for assignment by choosing the one with the fewest values in its domain (aka @italic{minimum remaining values} or @italic{mrv}; see also @racket[minimum-remaining-values]) and largest number of constraints (aka @italic{degree}; see also @racket[max-degree]). The idea is that this variable is likely to fail more quickly than others, so we'd rather trigger that failure as soon as we can (in which case we know we need to explore a different part of the state space).
}
@defproc[(minimum-remaining-values
[prob csp?])
(or/c #false var?)]{
Selects next variable for assignment by choosing the one with the fewest values in its domain.
}
@defproc[(max-degree
[prob csp?])
(or/c #false var?)]{
Selects next variable for assignment by choosing the one with the largest number of constraints.
}
@section{Inference}
Pass these functions to @racket[current-inference].
@defproc[(forward-check
[prob csp?]
[name var-name?])
csp?]{
Used for inference when @racket[current-inference] is not otherwise set. Forward checking determines whether the assignment to @racket[_name] necessarily causes another variable domain to become empty. How? It examines the remaining two-arity constraints that link variable @racket[_name] to an unassigned variable. For each of these constraints, it plugs in the new value for @racket[_name] and checks that the other variable still has values in its domain that can meet the constraint. If not, the assignment to @racket[_name] must fail. Forward checking can discover failures faster than backtracking alone.
}
@defproc[(ac-3
[prob csp?]
[name var-name?])
csp?]{
Applies the AC-3 arc-consistency algorithm. Similar to forward checking, but checks farther ahead. For that reason, it will usually take longer. (It is not necessarily better, however.)
Specifically: following a new variable assignment, AC-3 examines all constraints that link exactly two unassigned variables. It checks that each variable has at least one value in its domain that can be paired with the other to satisfy the constraint (this pair comprises the eponymous @italic{arc}). If no such pair exists, then the constraint can never be satisfied, so the new variable assignment must fail.
``So AC-3 is a superset of @racket[forward-check]?'' Yes. Both techniques examine two-arity constraints after variable @racket[_name] has been assigned a value. Forward checking, however, only examines two-arity functions that include variable @racket[_name] in the constraint. Whereas AC-3 checks @italic{all} two-arity functions (even those that don't include @racket[_name]).
In this way, AC-3 can detect inconsistencies that forward checking would miss. For instance, consider a CSP with three variables @italic{a} @italic{b} and @italic{c}, and three constraints @italic{ab}, @italic{ac}, and @italic{ab}. We assign a value to @italic{a}. Forward checking would then check constraints @italic{ab} and @italic{ac}, perhaps removing values from the domains of @italic{b} and @italic{c} to be consistent with the new value of @italic{a}. These domain reductions, however, might be inconsistent with constraint @italic{bc}. Forward checking won't notice this, because it never tests @italic{bc}. But AC-3 does test @italic{bc}, so it would notice the inconsistency.
The problem with AC-3 is that it's necessarily recursive: each time it eliminates a domain value from a certain variable, it has to recheck all the two-arity constraints (because any of them might have been made inconsistent by the removal of this value). AC-3 only stops when it can no longer remove any value from any domain. So yes, compared to simple forward checking, it does more. But it also potentially costs a lot more, especially if the variables have large domains.
}
@defproc[(no-inference
[prob csp?]
[name var-name?])
csp?]{
Truth in advertising: performs no inference.
}
@section{Structure types & predicates}
@defstruct[csp ([vars (listof var?)]
[constraints (listof constraint?)])
#:transparent]{
Represents a CSP.
}
@defstruct[var ([name var-name?]
[domain (listof any/c)])
#:transparent]{
Represents a variable in a CSP.
}
@defstruct[constraint ([names (listof var-name?)]
[proc procedure?])
#:transparent]{
Represents a constraint in a CSP.
}
@defproc[(var-name?
[x any/c])
boolean?]{
Check whether @racket[_x] is a valid CSP variable name, which today can mean any value, but I might change my mind.
}
@section{License & source code}
This module is licensed under the MIT license.
Source repository at @link["http://github.com/mbutterick/csp"]{http://github.com/mbutterick/csp}. Suggestions & corrections welcome.

302
csp/csp/sudoku-jm.rkt
Unescape Escape View File

@ -0,0 +1,302 @@
#lang debug racket/base
(require racket/match
racket/list
racket/set)
(define anything (seteq 1 2 3 4 5 6 7 8 9))
(struct cell (x y can-be) #:transparent)
(define (cell-solved? c)
(= 1 (set-count (cell-can-be c))))
(define (floor3 x)
(floor (/ x 3)))
(define (neighbor-of? l r)
(or (same-row? l r)
(same-col? l r)
(same-box? l r)))
(define (same-box? l r)
(and (= (floor3 (cell-x l)) (floor3 (cell-x r)))
(= (floor3 (cell-y l)) (floor3 (cell-y r)))))
(define (same-row? l r)
(= (cell-x l) (cell-x r)))
(define (same-col? l r)
(= (cell-y l) (cell-y r)))
;; a grid is a list of cells
;; board : string ... -> grid
(define (board . ss)
(for*/fold ([cells null]
#:result (reverse cells))
([str (in-list ss)]
[c (in-port read-char (open-input-string str))]
#:unless (memv c '(#\- #\|)))
(define-values (row col) (quotient/remainder (length cells) 9))
(cons (cell col row (cond
[(string->number (string c)) => seteq]
[else anything])) cells)))
(define (propagate-one top cs)
(let/ec return
;; If this is solved, then push its constraints to neighbors
(when (cell-solved? top)
(define-values (changed? ncs)
(for/fold ([changed? #f] [ncs empty])
([c (in-list cs)])
(cond
[(neighbor-of? top c)
(define before
(cell-can-be c))
(define after
(set-subtract before (cell-can-be top)))
(if (= (set-count before)
(set-count after))
(values changed?
(cons c ncs))
(values #t
(cons (struct-copy cell c
[can-be after])
ncs)))]
[else
(values changed? (cons c ncs))])))
(return changed? top ncs))
;; If this is not solved, then look for cliques that force it to
;; be one thing
(define (try-clique same-x?)
(define before (cell-can-be top))
(define after
(for/fold ([before before])
([c (in-list cs)])
(if (same-x? top c)
(set-subtract before (cell-can-be c))
before)))
(when (= (set-count after) 1)
(return #t
(struct-copy cell top
[can-be after])
cs)))
(try-clique same-row?)
(try-clique same-col?)
(try-clique same-box?)
;; Look for two cells in our clique that have the same can-be sets
;; and remove them from everything else
(define (only2-clique same-x?)
(define before (cell-can-be top))
(when (= (set-count before) 2)
(define other
(for/or ([c (in-list cs)])
(and (same-x? top c) (equal? before (cell-can-be c)) c)))
(when other
(define changed? #f)
(define ncs
(for/list ([c (in-list cs)])
(cond
[(and (not (eq? other c)) (same-x? top c))
(define cbefore
(cell-can-be c))
(define cafter
(set-subtract cbefore before))
(unless (equal? cbefore cafter)
(set! changed? #t))
(struct-copy cell c
[can-be cafter])]
[else
c])))
(return changed? top
ncs))))
(only2-clique same-row?)
(only2-clique same-col?)
(only2-clique same-box?)
(values #f
top
cs)))
(define (find-pivot f l)
(let loop ([tried empty]
[to-try l])
(match to-try
[(list)
(values #f l)]
[(list-rest top more)
(define-values (changed? ntop nmore)
(f top (append tried more)))
(if changed?
(values #t (cons ntop nmore))
(loop (cons top tried) more))])))
(define (propagate g)
(find-pivot propagate-one g))
(define (until-fixed-point f o bad? end-f)
(define-values (changed? no) (f o))
(if changed?
(cons
no
(if (bad? no)
(end-f no)
(until-fixed-point f no bad? end-f)))
(end-f o)))
(define (solved? g)
(andmap (λ (c) (= (set-count (cell-can-be c)) 1)) g))
(define (failed-solution? g)
(ormap (λ (c) (= (set-count (cell-can-be c)) 0)) g))
;; solve-it : grid -> (listof grid)
(define (solve-it g)
(let solve-loop
([g g]
[backtrack!
(λ (i)
(error 'solve-it "Failed!"))])
(define (done? g)
(cond
[(solved? g)
empty]
[(failed-solution? g)
(backtrack! #f)]
[else
(search g)]))
(define (search g)
(define sg (sort g < #:key (λ (c) (set-count (cell-can-be c)))))
(let iter-loop ([before empty]
[after sg])
(cond
[(empty? after)
(backtrack! #f)]
[else
(define c (first after))
(define cb (cell-can-be c))
(or (and (not (= (set-count cb) 1))
(for/or ([o (in-set cb)])
(let/ec new-backtrack!
(define nc
(struct-copy cell c
[can-be (seteq o)]))
(solve-loop
(cons
nc
(append before (rest after)))
new-backtrack!))))
(iter-loop (cons c before)
(rest after)))])))
(until-fixed-point propagate g failed-solution? done?)))
(require 2htdp/image
2htdp/universe)
(define (fig s) (text/font s 12 "black" #f 'modern 'normal 'normal #f))
(define MIN-FIG (fig "1"))
(define CELL-W (* 3 (image-width MIN-FIG)))
(define CELL-H (* 3 (image-height MIN-FIG)))
(struct draw-state (i before after))
(define (draw-it! gs)
(define (move-right ds)
(match-define (draw-state i before after) ds)
(cond
[(empty? (rest after))
ds]
[else
(draw-state (add1 i)
(cons (first after) before)
(rest after))]))
(define (draw-can-be can-be)
(define (figi i)
(if (set-member? can-be i)
(fig (number->string i))
(fig " ")))
(place-image/align
(if (= 1 (set-count can-be))
(scale 3 (fig (number->string (set-first can-be))))
(above (beside (figi 1) (figi 2) (figi 3))
(beside (figi 4) (figi 5) (figi 6))
(beside (figi 7) (figi 8) (figi 9))))
0 0
"left" "top"
(rectangle CELL-W CELL-H
"outline" "black")))
(define (draw-draw-state ds)
(match-define (draw-state i before after) ds)
(define g (first after))
(for/fold ([i
(empty-scene (* CELL-W 11)
(* CELL-H 11))])
([c (in-list g)])
(match-define (cell x y can-be) c)
(place-image/align
(draw-can-be can-be)
(* CELL-W
(cond [(<= x 2) (+ x 0)]
[(<= x 5) (+ x 1)]
[ else (+ x 2)]))
(* CELL-H
(cond [(<= y 2) (+ y 0)]
[(<= y 5) (+ y 1)]
[ else (+ y 2)]))
"left" "top"
i)))
(big-bang (draw-state 0 empty gs)
(on-tick move-right 1/8)
(on-draw draw-draw-state)))
;; Wikipedia Example
(define b1
(board
"53 | 7 | "
"6 |195| "
" 98| | 6 "
"-----------"
"8 | 6 | 3"
"4 |8 3| 1"
"7 | 2 | 6"
"-----------"
" 6 | |28 "
" |419| 5"
" | 8 | 79"))
;; "Hard" example
(define b2
(board
" 7 | 2 | 5"
" 9| 87| 3"
" 6 | | 4 "
"-----------"
" | 6 | 17"
"9 4| |8 6"
"71 | 5 | "
"-----------"
" 9 | | 8 "
"5 |21 |4 "
"4 | 9 | 6 "))
;; "Evil" example
(define b3
(board
" 8| | 45"
" | 8 |9 "
" 2|4 | "
"-----------"
"5 | 1|76 "
" 1 | 7 | 8 "
" 79|5 | 1"
"-----------"
" | 7|4 "
" 7| 6 | "
"65 | |3 "))
#;(draw-state-i
(draw-it!
(solve-it
b2)))
(require sugar/debug)
(time-avg 10 (void (solve-it b1)))
(time-avg 10 (void (solve-it b2)))
(time-avg 10 (void (solve-it b3)))

14
csp/csp/test-lang.rkt
Unescape Escape View File

@ -0,0 +1,14 @@
#lang csp
(require csp racket/list)
#:output foo
(define-variable q (range 33))
foo
(define-variable n (range 33))
(define-constraint c (λ (q n) (= (+ q n) 33)) '(q n))
(solve foo)

10
csp/info.rkt
Unescape Escape View File

@ -0,0 +1,10 @@
#lang info
(define collection 'multi)
(define deps '("beautiful-racket-lib"
"htdp-lib"
"math-lib"
("base" #:version "6.0") "sugar" "rackunit-lib" "debug" "graph"))
(define update-implies '("sugar"))(define build-deps '("at-exp-lib"
"math-doc"
"racket-doc"
"scribble-lib"))
Write Preview
Loading…
Cancel
Save