Skip to content

Instantly share code, notes, and snippets.

@hanshuebner
Created December 11, 2011 10:46
Show Gist options
  • Save hanshuebner/1459896 to your computer and use it in GitHub Desktop.
Save hanshuebner/1459896 to your computer and use it in GitHub Desktop.
Ruby book Sudoku solver in Common 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))))
(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 "------+-------+-------~%"))))
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
@wikimatze
Copy link

Looks pretty clean, even if I can just guess what this all means.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment