My Sudoku solver (in Common Lisp)

I do realise this has been done multiple times already, but I wanted to publish something really programming-related in this blog finally.

It’s almost uncommented, but should be understandable in spite of that because I used mostly very short functions with (hopefully) speaking names.

So here’s my code:

(defpackage sudoku
  (:use #:cl)
  (:export #:solve))

(in-package #:sudoku)

(defun empty-fields (array)
  (loop for row from 0 below 9
     nconc (loop for col from 0 below 9
	      when (null (aref array row col))
	      collect (cons row col))))

(defun legal-sudoku-p (array row col n)
  (and (unique-p n (array-row array row))
       (unique-p n (array-col array col))
       (unique-p n (array-box array row col))))

(defun unique-p (item seq)
  (= 1 (count item seq)))

(defun array-row (array row)
  (loop for col from 0 below 9 collect (aref array row col)))

(defun array-col (array col)
  (loop for row from 0 below 9 collect (aref array row col)))

(defun array-box (array row col)
  (loop
     with upper = (- row (mod row 3))
     and left = (- col (mod col 3))
     for i from 0 below 9
     collect (box-ref array upper left i)))

(defun box-ref (array upper left index)
  (multiple-value-bind (row col) (floor index 3)
    (aref array (+ upper row) (+ left col))))

(defun solve (lists &optional just-one)
  (let ((array (make-array '(9 9) :initial-contents lists)))
    (catch 'just-one
      (backtrace array (empty-fields array) just-one))))

(defun backtrace (array empty-fields just-one)
  (if (endp empty-fields)
      (if just-one
	  (throw 'just-one array)
	  (list (adjust-array		; this will copy the array
		 (make-array '(9 9) :displaced-to array)
		 '(9 9))))
      (loop
	 with row = (caar empty-fields)
	 and col = (cdar empty-fields)
	 for i from 1 to 9
	 do (setf (aref array row col) i)
	 when (legal-sudoku-p array row col i)
	 nconc (backtrace array (cdr empty-fields) just-one)
	 finally (setf (aref array row col) nil))))

Usage examples:

CL-USER> (time
	  (sudoku:solve '(( 3  nil nil  1   8   5   6   2   9 )
			  (nil nil  5  nil nil nil  8  nil  4 )
			  (nil  6   8  nil nil nil nil nil nil)
			  (nil nil nil  7  nil nil  5  nil nil)
			  (nil  2  nil nil  6  nil nil  8  nil)
			  (nil nil  3  nil nil  9  nil nil nil)
			  (nil nil nil nil  5  nil  1   6  nil)
			  ( 4  nil nil nil  3  nil nil nil nil)
			  ( 7  nil nil nil nil  2  nil nil nil))))
Evaluation took:
  1.093 seconds of real time
  1.056066 seconds of user run time
  0.008 seconds of system run time
  [Run times include 0.056 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  41,767,504 bytes consed.
(#2A((3 4 7 1 8 5 6 2 9)
     (1 9 5 2 7 6 8 3 4)
     (2 6 8 3 9 4 7 5 1)
     (6 8 4 7 2 1 5 9 3)
     (9 2 1 5 6 3 4 8 7)
     (5 7 3 8 4 9 2 1 6)
     (8 3 9 4 5 7 1 6 2)
     (4 1 2 6 3 8 9 7 5)
     (7 5 6 9 1 2 3 4 8)))
CL-USER> (time
	  (sudoku:solve '(( 3  nil nil  1   8   5   6   2   9 )
			  (nil nil  5  nil nil nil  8  nil  4 )
			  (nil  6   8  nil nil nil nil nil nil)
			  (nil nil nil  7  nil nil  5  nil nil)
			  (nil  2  nil nil  6  nil nil  8  nil)
			  (nil nil  3  nil nil  9  nil nil nil)
			  (nil nil nil nil  5  nil  1   6  nil)
			  ( 4  nil nil nil  3  nil nil nil nil)
			  ( 7  nil nil nil nil  2  nil nil nil)) t))
Evaluation took:
  0.012 seconds of real time
  0.012001 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  499,712 bytes consed.
#2A((3 4 7 1 8 5 6 2 9)
    (1 9 5 2 7 6 8 3 4)
    (2 6 8 3 9 4 7 5 1)
    (6 8 4 7 2 1 5 9 3)
    (9 2 1 5 6 3 4 8 7)
    (5 7 3 8 4 9 2 1 6)
    (8 3 9 4 5 7 1 6 2)
    (4 1 2 6 3 8 9 7 5)
    (7 5 6 9 1 2 3 4 8))