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

changes

Browse Source
main
Matthew Butterick 6 years ago
parent 5b047e72ce
commit a427cb0ee4
3 changed files with 157 additions and 42 deletions
Show Stats Download Patch File Download Diff File

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

@ -0,0 +1,104 @@
#lang debug br
(require sugar/debug "hacs.rkt")
(define names (for/list ([i (in-range 81)])
(string->symbol (format "c~a" i))))
(define (make-sudoku)
(define sudoku (make-csp))
(add-vars! sudoku names (range 1 10))
(define (not= . xs) (= (length xs) (length (remove-duplicates xs =))))
(for ([i (in-range 9)])
(define row-cells (for/list ([(name idx) (in-indexed names)]
#:when (= (quotient idx 9) i))
name))
(add-pairwise-constraint! sudoku not= row-cells)
(define col-cells (for/list ([(name idx) (in-indexed names)]
#:when (= (remainder idx 9) i))
name))
(add-pairwise-constraint! sudoku not= col-cells))
(for ([i '(0 3 6 27 30 33 54 57 60)])
(define box-cells (for/list ([j '(0 1 2 9 10 11 18 19 20)])
(string->symbol (format "c~a" (+ i j)))))
(add-pairwise-constraint! sudoku not= box-cells))
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")))
(define (board . strs)
(define sudoku (make-sudoku))
(define vals
(for*/list ([str strs]
[c (in-port read-char (open-input-string str))]
#:unless (memv c '(#\- #\|)))
(match (string c)
[(? string->number num) (string->number num)]
[else #f])))
(for ([name names]
[val vals]
#:when val)
(add-constraint! sudoku (curry = val) (list name) (string->symbol (format "is-~a" val))))
sudoku)
;; http://jeapostrophe.github.io/2013-10-23-sudoku-post.html
(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 "))
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-order-values shuffle)
(current-random #true)
(current-node-consistency #t)
(current-arity-reduction #t)
(time-avg 10 (solve b1 #:finish-proc print-grid))
(time-avg 10 (solve b2 #:finish-proc print-grid))
(time-avg 10 (solve b3 #:finish-proc print-grid))

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

@ -57,7 +57,7 @@
(apply add-edge! gr edge)
gr))
(struct var (name domain) #:transparent)
(struct var (name domain) #:transparent #:mutable)
(define domain var-domain)
(struct checked-variable var (history) #:transparent)
@ -246,13 +246,14 @@
(define/contract (state-count csp)
(csp? . -> . natural?)
(for/product ([var (in-vars csp)])
(domain-length var)))
(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]
[(cons (? singleton-var? uvar) _) uvar]
[uvars
;; minimum remaining values (MRV) rule
(define mrv-arg (argmin domain-length uvars))
@ -476,6 +477,12 @@
(define (history->constraint hst)
(constraint (map car hst) (make-hist-proc hst)))
(define/contract (assign-singletons prob)
(csp? . -> . csp?)
(for/fold ([prob prob])
([vr (in-vars prob)]
#:when (singleton-var? vr))
(assign-val prob (var-name vr) (first (var-domain vr)))))
(define/contract (backtracking-solver
prob
@ -488,45 +495,47 @@
(define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values))
(define learned-constraints null)
(define learning? (current-learning))
(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 bths]
[rec bth])
(eq? name (car rec))))))))
(for/fold ([conflicts null]
#:result (void))
([val (in-list (order-domain-values domain))])
(with-handlers ([wants-backtrack?
(λ (bt)
(define bths (backtrack-histories bt))
(when learning?
(set! learned-constraints (append
(map history->constraint (filter (λ (bth) (<= 2 (length bth) 4)) bths))
learned-constraints)))
(append conflicts (remq name (remove-duplicates
(for*/list ([bth bths]
[rec bth])
(car rec)) eq?))))])
(let* ([prob (assign-val prob name val)]
[prob (if learning?
(and (for ([lc learned-constraints]
#:when (for/and ([cname (constraint-names lc)])
(memq cname (map var-name (filter assigned-var? (vars prob))))))
(unless (lc prob)
(println 'boing)
(backtrack!))) prob)
prob)]
;; 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)]))))
(let* ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)]
[prob (assign-singletons prob)])
(let loop ([prob 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 bths]
[rec bth])
(eq? name (car rec))))))))
(for/fold ([conflicts null]
#:result (void))
([val (in-list (order-domain-values domain))])
(with-handlers ([wants-backtrack?
(λ (bt)
(define bths (backtrack-histories bt))
(when learning?
(set! learned-constraints (append
(map history->constraint (filter (λ (bth) (<= 2 (length bth) 4)) bths))
learned-constraints)))
(append conflicts (remq name (remove-duplicates
(for*/list ([bth bths]
[rec bth])
(car rec)) eq?))))])
(let* ([prob (assign-val prob name val)]
[prob (if learning?
(and (for ([lc learned-constraints]
#:when (for/and ([cname (constraint-names lc)])
(memq cname (map var-name (filter assigned-var? (vars prob))))))
(unless (lc prob)
(println 'boing)
(backtrack!))) prob)
prob)]
;; 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)])))))
(define (random-pick xs)
(list-ref xs (random (length xs))))

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

@ -136,6 +136,8 @@ Of course, when we use ordinary @racket[solve], we don't know how many assignmen
Disappointing but accurate.
@section{Making & solving CSPs}

Write Preview
Loading…
Cancel
Save