`(amb ...)`.

A primary goal here for reasonable performance was to minimize (within reasonable coding effort) the number of continuations which have to be captured by the `amb` operator---hence the repeated narrowing of possibilities before calls to `amb`. Here's the code (including a nifty macro which allows specifying a puzzle easily):

(module sudoku mzscheme (require (all-except (lib "43.ss" "srfi") vector-fill! vector->list) (only (lib "1.ss" "srfi") filter take drop) (lib "extra.ss" "swindle")) (provide sudoku-board solve write-sudoku-board) ;; Sudoku board is eventually represented as a vector of rows ;; which are themselves vectors of length nine. The syntax ;; sudoku-board produces such a board from a list of numbers or ;; '?, which represents an unknown square. (define (any) (list 1 2 3 4 5 6 7 8 9)) (define (list->board lst) (apply vector (let loop ((lst lst) (list-of-nines '())) (if (null? lst) (reverse list-of-nines) (loop (drop lst 9) (cons (apply vector (take lst 9)) list-of-nines)))))) (define-syntax sudoku-board (syntax-rules () ((sudoku-board elt ...) (list->board (process-elts (processed ) elt ...))))) (define-syntax process-elts (syntax-rules (processed ?) ((process-elts (processed pelt ...) ?) (reverse (list (any) pelt ...))) ((process-elts (processed pelt ...) elt) (reverse (list elt pelt ...))) ((process-elts (processed pelt ...) ? elt ...) (process-elts (processed (any) pelt ...) elt ...)) ((process-elts (processed pelt ...) elt elt2 ...) (process-elts (processed elt pelt ...) elt2 ...)))) (define (cubant i) (floor (/ i 3))) (define (same-cubant? ii jj i j) (and (= (cubant i) (cubant ii)) (= (cubant j) (cubant jj)))) (define (known? elt) (number? elt)) (define (unknown? elt) (list? elt)) (define (board-map fn board) (vector-map (lambda (i row) (vector-map (lambda (j elt) (fn i j elt)) row)) board)) (define (board-fold fn start board) (vector-fold (lambda (i start row) (vector-fold (lambda (j start elt) (fn i j start elt)) start row)) start board)) (define (board-ref b i j) (vector-ref (vector-ref b i) j)) (define (prune ii jj number board) (board-map (lambda (i j elt) (if (known? elt) elt (cond ((= i ii) (filter (lambda (elt) (not (= elt number))) elt)) ((= j jj) (filter (lambda (elt) (not (= elt number))) elt)) ((same-cubant? ii jj i j) (filter (lambda (elt) (not (= elt number))) elt)) (else elt)))) board)) (define (singleton? elt) (and (pair? elt) (null? (cdr elt)))) (define (expand-singletons board) (board-map (lambda (i j elt) (if (singleton? elt) (car elt) elt)) board)) (define (prune-all board) (let ((new-board (expand-singletons (board-fold (lambda (i j nb elt) (if (known? elt) (prune i j elt nb) nb)) board board)))) (if (equal? new-board board) new-board (prune-all new-board)))) (define (amb-list list) (if (null? list) (amb) (amb (car list) (amb-list (cdr list))))) (define (amb-board board) (board-fold (lambda (i j nb elt) (let ((elt (board-ref nb i j))) (if (known? elt) nb (let ((choice (amb-list elt))) (prune-all (board-map (lambda (ii jj elt) (if (and (= i ii) (= j jj)) choice elt)) nb)))))) board board)) (define (board-assertions board) (board-fold (lambda (i j dummy elt1) (board-fold (lambda (ii jj dummy elt2) (cond ((and (= ii i) (= jj j))) ((= ii i) (amb-assert (not (= elt1 elt2)))) ((= jj j) (amb-assert (not (= elt1 elt2)))) ((same-cubant? ii jj i j) (amb-assert (not (= elt1 elt2)))))) '() board)) '() board)) (define (solve board) (let ((new-board (prune-all board))) (let ((final-board (amb-board new-board))) (board-assertions final-board) final-board))) (define (write-sudoku-board board) (printf "(sudoku-board") (board-fold (lambda (i j dummy elt) (if (= j 0) (newline)) (if (pair? elt) (printf " ?") (printf " ~a" elt)) (if (and (= i 8) (= j 8)) (printf ")~%"))) '() board)))

Example of use:

(write-sudoku-board (solve (sudoku-board ? ? 8 ? ? ? 1 5 ? ? ? ? ? ? 1 8 ? ? 3 ? 5 4 ? ? ? ? 9 5 ? ? ? ? 9 ? ? ? ? 9 ? 2 3 4 ? 7 ? ? ? ? 1 ? ? ? ? 8 4 ? ? ? ? 5 9 ? 1 ? ? 6 7 ? ? ? ? ? ? 5 3 ? ? ? 2 ? ?)))which evaluates to

(sudoku-board 7 4 8 3 9 2 1 5 6 2 6 9 5 7 1 8 4 3 3 1 5 4 8 6 7 2 9 5 7 4 8 6 9 3 1 2 8 9 1 2 3 4 6 7 5 6 3 2 1 5 7 4 9 8 4 8 7 6 2 5 9 3 1 9 2 6 7 1 3 5 8 4 1 5 3 9 4 8 2 6 7)

## 3 comments:

Hi! why am i getting reference to undefined identifier: write-sudoku-board....quite new to scheme..

jee,

I'm guessing that you have input the code that defines the sudoku module, but have not required that module to import the definitions into the current namespace. I just ran the code successfully by doing the following:

1. Start mzscheme (if you're tracking the latest repository, it is now called racket ).

2. Paste the code above at the REPL.

3. (require 'sudoku)

4. Paste the example (write-sudoku-board ...)

5. Watch the solution.

Good luck!

Post a Comment