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)

Defining your own Lie Group

Today I was asked how to define your own Lie Group using my functional differential geometry software (see this post and subsequent posts). Basically, you have to provide five things:

1. Chi : G -> R^n. This is the coordinate function on the group manifold.
2. Chi^-1 : R^n -> G. The inverse of Chi.
3. e \in G. The identity element.
4. inverse: G -> G. The inverse function (on the group manifold: g -> g^-1).
5. *: GxG -> G. The group multiplication function.

1&2 are provided through a <chart> object. Note carefully the signatures of these functions; in particular, note that only Chi and Chi^-1 deal with R^n while all others deal directly with group elements.

See lie-group-SO3.ss for an example of how this is done. It's a bit tricky, because the <chart> (which contains Chi and Chi^-1) must take and produce objects of the <lie-group-element> class, which require the <lie-group> class for one of the slots; but the <lie-group> class requires the <chart> object, so they must be recursively defined.