Yet Another Sudoku Solver

While flying home from vacation, I composed the following Sudoku solver. It seems to solve all the puzzles I throw at it, but definitely is not the most efficient algorithm possible. Basically it applies the Sudoku constraints (no repeat numbers in a row, column, or 3x3 block) to the puzzle (represented as a vector of vectors, with lists for elements which may have more than one possible number at a given point in the solution) until it cannot narrow the possibilities further. If there remain elements with more than one possible number, it makes an ambiguous choice of one of the multiple possibilities. Given this choice, the algorithm again tries to narrow the remaining multiple possibilities, and, if that fails, chooses ambiguously again, ad infinitum. Once there are no more multiple possibilities, the algorithm checks the sudoku constraints one more time---if they are not met, then we fail and choose a different (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)