Solving Sudoku with McCarthy's amb Operator

Sudoku is an interesting puzzle game. The goal of Sudoku is to fill a 9x9 grid with numbers from 1 to 9, which makes the sum of each row, each column, and each 3x3 block are the same. In other words, every row, column and block must contains all of the numbers from 1 to 9.

Writing a program to solve a Sudoku is not hard, but this post shows another programming technique – solving Sudoku with McCarthy’s amb operator. It was first proposed by John McCarthy to represent non-deterministic computation, and the word amb stands for ambiguity. The amb operator takes a set of candidate values, tries to find a value that satisfies some constraints. The constraints can be specified in the later program. The amb operator may choose a value from the set randomly, or may sequentially. If the current chosen value not satisfies the constraints, amb operator will atomatically try the next one until some value that satisfies the constraints is found. The Chapter 4 of book Structure and Interpretation of Computer Programs is also a good material of non-deterministic computation.

The following code is a implementation of amb using call/cc and a stack to save the captured continuations. We use assert to specify constraints.

#lang racket

(require math/base)

;; Amb operator
;; The amb operator implementation is from Matt Might's blog:
;; http://matt.might.net/articles/programming-with-continuations--exceptions-backtracking-search-threads-generators-coroutines/

(define current-continuation
  (λ () (call/cc (lambda (cc) (cc cc)))))

(define fail-stack '())

(define (fail)
  (if (not (pair? fail-stack))
      (error "back-tracking stack exhausted!")
      (let ([back-track-point (car fail-stack)])
        (set! fail-stack (cdr fail-stack))
        (back-track-point back-track-point))))

(define (amb choices)
  (let ([cc (current-continuation)])
    (cond [(null? choices) (fail)]
          [(pair? choices)
           (let ([choice (car choices)])
             (set! choices (cdr choices))
             (set! fail-stack (cons cc fail-stack))
             choice)])))

(define (assert pred) (if (not pred) (fail) #t))

To see how amb works, let’s see and example. Declare that x and y both could be 1, 2 or 3, and x-plus-y is the sum of x and y. Then we assert that x-plus-y should be 6. If we change the assertion line to be equal 7, then there is no combination of x and y‘s possible value can be sumed to 7, so the search will be exhausted (failed).

(let* ([x (amb '(1 2 3))]
       [y (amb '(1 2 3))]
       [x-plus-y (+ x y)])
  (assert (eq? x-plus-y 6))
  (displayln x-plus-y)))])]))

The Solver is shown as follows. Most of the code are auxiliary and used to get the element on the grid. The interesting one is function gen-constraints, which assigns a set of possible values for each hole given the known numbers on the grid. Then at the bottom of the code, given the filled grid g, we assert that for every row, column, and block, their sum should be equal to a number total. total is calculated by the side length of the grid.

;; Sudoku Solver

(define (transpose grid)
    (if (null? grid) '()
        (map (λ (i) (map (λ (line) (list-ref line i)) grid))
             (range (length (car grid))))))

(define get-col (λ (g i) (map (λ (line) (list-ref line i)) g)))

(define (get-block grid M N row col)
  (let ([row (add1 (floor (/ row N)))]
        [col (floor (/ col M))])
    (flatten (for/list ([i (range (* (sub1 row) N) (* row N))])
      (take (drop (list-ref grid i) (* col M)) M)))))

(define (each-block grid M N)
  (foldl append '()
         (for/list ([row (range 0 (* M N) N)])
           (for/list ([col (range 0 (* M N) M)])
             (get-block grid M N row col)))))

(define get-used-num (curry filter (λ (x) (not (eq? '_ x)))))

(define (grid-get grid row col) (list-ref (list-ref grid row) col))

(define (grid-set grid row col ele)
  (list-set grid row (list-set (list-ref grid row) col ele)))

(define (solve grid M N)
  (define side-length (* M N))
  (define total (sum (range 1 (add1 side-length))))
  (define (end? row col) (and (= side-length row) (= 0 col)))
  (define (next-row row col)
    (if (zero? (modulo (add1 col) side-length)) (add1 row) row))
  (define (next-col row col)
    (if (zero? (modulo (add1 col) side-length)) 0 (add1 col)))
  (define (get-possible-choices grid row col)
    (if (not (eq? '_ (grid-get grid row col))) '()
        (let ([row-cns (get-used-num (list-ref grid row))]
              [col-cns (get-used-num (get-col grid col))]
              [blk-cns (get-used-num (get-block grid M N row col))])
          (remv* (remove-duplicates (flatten `(,row-cns ,col-cns ,blk-cns)))
                 (range 1 (add1 side-length))))))
  (define (gen-constraints grid row col)
    (cond [(end? row col) grid]
          [(eq? '_ (grid-get grid row col))
           (gen-constraints 
            (grid-set grid row col (amb (get-possible-choices grid row col)))
            (next-row row col) (next-col row col))]
          [else (gen-constraints grid (next-row row col) (next-col row col))]))

  ;; Setup the constraints
  (let ([g (gen-constraints grid 0 0)])
    (for/list ([line g]) (assert (= total (sum line))))
    (for/list ([line (transpose g)]) (assert (= total (sum line))))
    (for/list ([block (each-block g M N)]) (assert (= total (sum block))))
    g))

Finally, let’s try our Sudoku solver!

(define grid
  '([3 _ 6  5 _ 8  4 _ _]
    [5 2 _  _ _ _  _ _ _]
    [_ 8 7  _ _ _  _ 3 1]
    [_ _ 3  _ 1 _  _ 8 _]
    [9 _ _  8 6 3  _ _ 5]
    [_ 5 _  _ 9 _  6 _ _]
    [1 3 _  _ _ _  2 5 _]
    [_ _ _  _ _ _  _ 7 4]
    [_ _ 5  2 _ 6  3 _ _]))

(solve grid 3 3)

The code can be also found in my Github repo.