My Sudoku solver (in Common Lisp) 2008-02-04

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))