Ruby book Sudoku solver in Common Lisp

sudoku-test.lisp

(defmacro deftestpackage (package-name for-package &optional (test-library-package-name :unit-test))
  "Define a new package PACKAGE-NAME used to test the package
  designated by FOR-PACKAGE.  The new package will import all symbols
  from FOR-PACKAGE and :USE the package designated by
  TEST-LIBRARY-PACKAGE-NAME which supposedly contains unit testing
  functions and macros."
  `(defpackage ,package-name
       (:use ,test-library-package-name ,@(mapcar #'package-name (package-use-list for-package)))
     (:import-from ,for-package
                   ,@(let (symbols)
                       (do-symbols (symbol for-package symbols)
                         (when (eql (symbol-package symbol) (find-package for-package))
                           (push (symbol-name symbol) symbols)))))))

(deftestpackage :sudoku-test :sudoku)

(in-package :sudoku-test)

(defun set-equal (a b)
  (and (null (set-difference a b))
       (null (set-difference b a))))

(defmacro test-equal-set (expected-set result)
  `(test-assert (set-equal ,expected-set ,result)))
                
(deftest 'sudoku "basics"
  (let ((grid (make-grid '((0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)

                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)

                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)))))
    (test-equal-set nil (row-digits grid 0))
    (test-equal-set nil (col-digits grid 0))
    (test-equal-set nil (box-digits grid 0))
    (setf (at grid 0 0) 1)
    (test-equal-set '(1) (row-digits grid 0))
    (test-equal-set '(1) (col-digits grid 0))
    (test-equal-set '(1) (box-digits grid 0))
    (test-equal-set nil (row-digits grid 1))
    (test-equal-set nil (col-digits grid 1))
    (test-equal-set nil (box-digits grid 1)))
  (let ((grid (make-grid '((0 0 0  1 2 3  0 0 0)
                           (0 0 0  4 5 6  0 0 0)
                           (0 0 0  7 8 9  0 0 0)

                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)

                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)
                           (0 0 0  0 0 0  0 0 0)))))
    (test-equal-set '(1 2 3) (row-digits grid 0))
    (test-equal-set '(4 5 6) (row-digits grid 1))
    (test-equal-set '(7 8 9) (row-digits grid 2))
    (test-equal-set nil (row-digits grid 3))

    (test-equal-set nil (col-digits grid 2))
    (test-equal-set '(1 4 7) (col-digits grid 3))
    (test-equal-set '(2 5 8) (col-digits grid 4))
    (test-equal-set '(3 6 9) (col-digits grid 5))
    (test-equal-set nil (col-digits grid 6))

    (test-equal-set nil (box-digits grid 0))
    (test-equal-set '(1 2 3 4 5 6 7 8 9) (box-digits grid 1))
    (test-equal-set nil (box-digits grid 2))
    (test-equal-set nil (box-digits grid 4))))

sudoku.lisp

(defpackage :sudoku
    (:use :cl))

(in-package :sudoku)

(defun make-grid (contents)
  (make-array '(9 9) :initial-contents contents))

(defun clone-grid (old)
  (alexandria:copy-array old))

(defun at (grid row col)
  (aref grid row col))

(defun (setf at) (digit grid row col)
  (setf (aref grid row col) digit))

(defun row-digits (grid row)
  (let (digits)
    (dotimes (col 9 digits)
      (unless (zerop (at grid row col))
        (push (at grid row col) digits)))))

(defun col-digits (grid col)
  (let (digits)
    (dotimes (row 9 digits)
      (unless (zerop (at grid row col))
        (push (at grid row col) digits)))))

(defun box-digits (grid box-number)
  (multiple-value-bind (row-offset col-offset) (floor box-number 3)
    (loop with col-offset = (* 3 col-offset)
          with row-offset = (* 3 row-offset)
          for col from col-offset below (+ col-offset 3)
          nconc (loop for row from row-offset below (+ row-offset 3)
                      for digit = (at grid row col)
                      unless (zerop digit)
                        collect digit))))

(defun row-col-to-box (row col)
  (+ (* (floor row 3) 3)
     (floor col 3)))

(defun digits-possible-at (grid row col)
  (set-difference '(1 2 3 4 5 6 7 8 9)
                  (append (row-digits grid row)
                          (col-digits grid col)
                          (box-digits grid (row-col-to-box row col)))))

(defmacro do-unknowns ((row col box grid) &body body)
  `(dotimes (,row 9)
     (dotimes (,col 9)
       (when (zerop (at ,grid ,row ,col))
         (let ((,box (row-col-to-box ,row ,col)))
           (declare (ignorable ,box))
           ,@body)))))

(define-condition not-possible (error)
  ())

(defun scan (grid)
  (let (min
        row-min
        col-min
        possible-min
        (changed t))
    (loop
      (unless changed
        (return-from scan (list row-min col-min possible-min)))
      (setf changed nil
            row-min nil
            col-min nil
            possible-min nil
            min 10)
      (do-unknowns (row col box grid)
        (let ((possible (digits-possible-at grid row col)))
          (cond
            ((null possible)
             (error 'not-possible))
            ((null (cdr possible))
             (setf (at grid row col) (first possible)
                   changed t))
            (t
             (when (and (null changed)
                        (< (length possible) min))
               (setf min (length possible)
                     row-min row
                     col-min col
                     possible-min possible)))))))))

(defun solve (grid)
  (let ((grid (clone-grid grid)))
    (destructuring-bind (row col possible) (scan grid)
      (unless row
        (return-from solve grid))
      (dolist (digit possible)
        (setf (at grid row col) digit)
        (handler-case
            (return-from solve (solve grid))
          (not-possible ()
            ; catch and try next
            )))
      (error 'not-possible))))

(defun print-grid (grid)
  (dotimes (row 9)
    (format t "~{~A ~A ~A | ~A ~A ~A | ~A ~A ~A~}~%"
            (loop for col below 9 collect (at grid row col)))
    (when (member row '(2 5))
      (format t "------+-------+-------~%"))))

transcript.lisp

SUDOKU> (setf *grid* (make-grid '((0 0 7  0 0 0  0 0 4)
                                  (0 0 0  0 0 0  0 9 0)
                                  (0 0 0  2 5 0  0 0 0)

                                  (0 0 0  0 0 4  0 0 0)
                                  (0 0 0  0 0 0  6 0 0)
                                  (1 5 0  0 0 0  2 0 0)

                                  (8 0 0  0 0 0  5 0 0)
                                  (0 0 9  4 0 7  0 0 0)
                                  (0 0 0  0 0 3  0 0 7))))
#2A((0 0 7 0 0 0 0 0 4) (0 0 0 0 0 0 0 9 0) (0 0 0 2 5 0 0 0 0) (0 0 0 0 0 4 0 0 0) (0 0 0 0 0 0 6 0 0) (1 5 0 0 0 0 2 0 0) (8 0 0 0 0 0 5 0 0) (0 0 9 4 0 7 0 0 0) (0 0 0 0 0 3 0 0 7))
SUDOKU> (time (solve *grid*))
(SOLVE *GRID*) took 92,251 microseconds (0.092251 seconds) to run 
                    with 2 available CPU cores.
During that period, 78,290 microseconds (0.078290 seconds) were spent in user mode
                    5,001 microseconds (0.005001 seconds) were spent in system mode
9,717 microseconds (0.009717 seconds) was spent in GC.
 11,465,856 bytes of memory allocated.
#2A((9 2 7 6 3 1 8 5 4) (6 1 5 7 4 8 3 9 2) (3 4 8 2 5 9 7 6 1) (7 8 6 3 2 4 9 1 5) (4 9 2 8 1 5 6 7 3) (1 5 3 9 7 6 2 4 8) (8 7 4 1 6 2 5 3 9) (5 3 9 4 8 7 1 2 6) (2 6 1 5 9 3 4 8 7))
SUDOKU> (print-grid (solve *grid*))
9 2 7 | 6 3 1 | 8 5 4
6 1 5 | 7 4 8 | 3 9 2
3 4 8 | 2 5 9 | 7 6 1
------+-------+-------
7 8 6 | 3 2 4 | 9 1 5
4 9 2 | 8 1 5 | 6 7 3
1 5 3 | 9 7 6 | 2 4 8
------+-------+-------
8 7 4 | 1 6 2 | 5 3 9
5 3 9 | 4 8 7 | 1 2 6
2 6 1 | 5 9 3 | 4 8 7
NIL