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

Write Preview
Loading…
Cancel
Save