From a9ec24a78d151127a3c6c8b640b610f26b62d6e5 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 28 Dec 2020 11:16:37 -0800 Subject: [PATCH] sudoku example --- csp/csp/hacs-test-sudoku.rkt | 69 +++++++++++++++-------------------- csp/csp/hacs.rkt | 1 - csp/csp/scribblings/csp.scrbl | 56 ++++++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 40 deletions(-) diff --git a/csp/csp/hacs-test-sudoku.rkt b/csp/csp/hacs-test-sudoku.rkt index fc07715e..ce442b91 100644 --- a/csp/csp/hacs-test-sudoku.rkt +++ b/csp/csp/hacs-test-sudoku.rkt @@ -1,54 +1,46 @@ #lang debug br (require sugar/debug "hacs.rkt") -(define cells (for/list ([i (in-range 81)]) - (string->symbol (format "c~a" i)))) - -(define (make-sudoku) +(define (make-base-sudoku) (define sudoku (make-csp)) + + (define cells (range 81)) (add-vars! sudoku cells (range 1 10)) - (define (not= . xs) (not (check-duplicates xs =))) - - (for ([i (in-range 9)]) - (define row-cells (for/list ([(name idx) (in-indexed cells)] - #:when (= (quotient idx 9) i)) - name)) - (add-pairwise-constraint! sudoku not= row-cells) - (define col-cells (for/list ([(name idx) (in-indexed cells)] - #: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 ([offset '(0 1 2 9 10 11 18 19 20)]) - (string->symbol (format "c~a" (+ i offset))))) - (add-pairwise-constraint! sudoku not= box-cells)) + (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"))) -(define (board . strs) - (define sudoku (make-sudoku)) - (define vals - (for*/list ([str (in-list strs)] - [c (in-string str)] - #:unless (memv c '(#\- #\|))) - (string->number (string c)))) - (for ([name cells] - [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 + (make-sudoku-board "53 | 7 | " "6 |195| " " 98| | 6 " @@ -63,7 +55,7 @@ ;; "Hard" example (define b2 - (board + (make-sudoku-board " 7 | 2 | 5" " 9| 87| 3" " 6 | | 4 " @@ -78,7 +70,7 @@ ;; "Evil" example (define b3 - (board + (make-sudoku-board " 8| | 45" " | 8 |9 " " 2|4 | " @@ -94,7 +86,6 @@ (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) (define trials 5) @@ -108,7 +99,7 @@ (define (euler-value sol) (match sol - [(list (cons (== 'c0) h) (cons (== 'c1) t) (cons (== 'c2) d) _ ...) + [(list (cons 0 h) (cons 1 t) (cons 2 d) _ ...) (+ (* 100 h) (* 10 t) d)])) @@ -124,4 +115,4 @@ (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 board bstr))))) + (euler-value (solve (apply make-sudoku-board bstr))))) diff --git a/csp/csp/hacs.rkt b/csp/csp/hacs.rkt index 9578d15c..be175117 100644 --- a/csp/csp/hacs.rkt +++ b/csp/csp/hacs.rkt @@ -144,7 +144,6 @@ (define current-order-values (make-parameter #f)) (define current-inference (make-parameter #f)) (define current-solver (make-parameter #f)) -(define current-random (make-parameter #t)) (define current-decompose (make-parameter #t)) (define current-thread-count (make-parameter 4)) (define current-node-consistency (make-parameter #f)) diff --git a/csp/csp/scribblings/csp.scrbl b/csp/csp/scribblings/csp.scrbl index bf1c64b2..196f6009 100644 --- a/csp/csp/scribblings/csp.scrbl +++ b/csp/csp/scribblings/csp.scrbl @@ -202,6 +202,62 @@ Well over a zillion, certainly. Let's optimistically suppose that the 3.7GHz pro (/ 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}