Newer
Older
(in-package :sudoku-algorithm)
(defparameter *board-width* 9)
;;; This class represents units that contain a list of cells.
;;; A unit can include cells in a row of Sudoku board,
;;; cells in a column of board, or cells in a square of board.
(defclass unit ()
((%cells :initarg :cells :accessor cells)))
(make-instance 'unit :cells (make-list 0)))
;;; Given a unit, make sure this unit is the
;;; parent of all its cells.
(defun add-parent-to-cells-of-unit (unit)
(loop for cell in (cells unit)
do (push unit (parents cell))))
;;; This class represents cells that contain possible values.
;;; These cells also contain a list of units to which they belong.
((%parents :initarg :parents :accessor parents)
(%possibilities :initarg :possibilities :accessor possibilities)))
(defun make-cell (board-width)
:parents '()
:possibilities (make-array board-width
:element-type 'bit
:initial-element 1)))
(loop for i from 0 below (length (possibilities cell))
do (setf (aref (possibilities cell) i) 0)))
(defun set-possibilities (cell index value)
(setf (aref (possibilities cell) index) value))
;;; return a true value if and only if there is more than one
;;; possible value for the cell.
(/= (symbolset-cardinality (possibilities cell)) 1))
(let* ((leng (length (possibilities cell)))
(tmp (make-array leng :element-type 'bit :initial-element 1)))
(loop for unit across (parents cell)
do (loop for cell1 across (cells unit)
do (unless (check-hole cell1)
(let ((order-1 (position 1 (possibilities cell1))))
(setf (aref tmp order-1) 0)))))
(setf (possibilities cell) tmp)))
;;; We either need to change the name of the `game' class to `board',
;;; or change the comment to say that it represents a Sudoku `game'.
;;; RS 2010-04-19
;;; This class represents a Sudoku board.
;;; It includes an array of symbols that is used to display characters,
;;; an array of cells in the board,
;;; and a list of all units (row-units, column-units, square-units).
((%symbols :initarg :symbols :accessor symbols)
(%cells :initarg :cells :accessor cells)
(%units :initarg :units :accessor units)))
(defun make-game (board-width)
:symbols (make-array board-width)
:cells (make-array (list board-width board-width))
(defun create-mapping-vector (board-width)
(let ((v (make-array board-width)))
(loop for i from 0 below board-width
do (setf (aref v i) (1+ i)))
;;(shuffle-vector v) This statement is commented for easy checking
(return-from create-mapping-vector v)))
(defun map-over-rectangle (fun game start-row height start-col width)
(loop for row from start-row
repeat height
do (loop for col from start-col
repeat width
do (funcall fun (aref (cells game) row col)))))
(defun copy-rectangle-to-unit (game start-row height start-col width unit)
(map-over-rectangle (lambda (cell) (push cell unit))
game start-row height start-col width))
(defun symbolset-cardinality (symbolset)
(count 1 symbolset))
(defun symbolset-union (symbolset1 symbolset2)
(bit-ior symbolset1 symbolset2))
(defun symbolset-difference (symbolset1 symbolset2)
(bit-andc2 symbolset1 symbolset2))
(defun create-unit-for-testing (choice)
(let ((board-width *board-width*)
(unit (make-unit))
(unit1 (make-unit))
;; initialize cells for unit1
;; strategy1 can be applied for unit1
(loop for i from 0 below board-width
do (let ((cell (make-cell board-width)))
(push cell (cells unit1))))
(setf (possibilities (second (cells unit1))) #*000000110)
;; initialize cells for unit2
;; strategy2 can be applied for unit2
(loop for i from 0 below board-width
do (let ((cell (make-cell board-width)))
(push cell (cells unit2))))
(setf (possibilities (second (cells unit2))) #*000001100)
(setf (possibilities (fourth (cells unit2))) #*000001010)
;; initialize cells for unit3
;; strategy3 can be applied for unit3
(loop for i from 0 below board-width
do (let ((cell (make-cell board-width)))
(push cell (cells unit3))))
(setf (possibilities (second (cells unit3))) #*001000000)
(setf (possibilities (fourth (cells unit3))) #*000010000)
((= choice 2) (setf (cells unit) (cells unit2)))
((= choice 3) (setf (cells unit) (cells unit3))))
(return-from create-unit-for-testing unit)))
(let ((ambiguous-cells (remove-if-not #'check-hole (cells unit))))
;; then the strategy is applicable
(let ((cell (first ambiguous-cells)))
(setf (possibilities cell)
(symbolset-difference
(possibilities cell)
(reduce #'symbolset-union
(remove cell (cells unit))
:key #'possibilities)))
(return-from strategy1 (list cell)))
;; else return an empty list
(return-from strategy1 '()))))
(let ((ambiguous-cells (remove-if-not #'check-hole (cells unit))))
(loop for cell in ambiguous-cells
do (let ((diff
(symbolset-difference
(possibilities cell)
(reduce #'symbolset-union
(remove cell (cells unit))
:key #'possibilities))))
(when (= (symbolset-cardinality diff) 1)
(setf (possibilities cell) diff)
(return-from strategy2 (list cell))))
finally (return-from strategy2 '()))))
(let ((ambiguous-cells (remove-if-not #'check-hole (cells unit)))
(unchanged-cells (remove-if #'check-hole (cells unit))))
(loop for cell in unchanged-cells
(loop for hole in ambiguous-cells
do (when (= (aref (possibilities hole) order-1) 1)
(set-possibilities hole order-1 0)
(return-from strategy3 (list hole)))))
finally (return-from strategy3 '()))))
(defun create-initial-board (board-width)
(let* ((board (make-array (list board-width board-width)))
(sqrt-board-width (isqrt board-width)))
(loop for offset1 from 0 below sqrt-board-width
for block-start from 0 below board-width by sqrt-board-width
do (loop for row from block-start
for offset2 from 0 by sqrt-board-width
repeat sqrt-board-width
do (loop for col from 0 below board-width
do (setf (aref board row col)
(mod (+ col offset1 offset2)
board-width)))))
(return-from create-initial-board board)))
;;; Exchange two non-overlapping rectangles having the same shape
;;; in a 2-dimensional array.
(defun exchange-rectangles (array
start-row-1 start-col-1
height width
start-row-2 start-col-2)
(unless (and (= start-row-1 start-row-2) (= start-col-1 start-col-2))
(loop for row-1 from start-row-1
for row-2 from start-row-2
repeat height
do (loop for col-1 from start-col-1
for col-2 from start-col-2
repeat width
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
do (rotatef (aref array row-1 col-1)
(aref array row-2 col-2))))))
;;; Exchange two rows in a 2-dimensional array.
(defun exchange-rows (array row-1 row-2)
(let ((width (array-dimension array 0)))
(exchange-rectangles array row-1 0 1 width row-2 0)))
;;; Exchange two columns in a 2-dimensional array.
(defun exchange-columns (array col-1 col-2)
(let ((height (array-dimension array 1)))
(exchange-rectangles array 0 col-1 height 1 0 col-2)))
;;; This function is more limited than the previous ones.
;;; It exchanges two block of rows, where each block has
;;; a height which is the square root of the hight of
;;; the array.
(defun exchange-blocks-of-rows (array row-1 row-2)
(let* ((width (array-dimension array 1))
(sqrt-height (isqrt (array-dimension array 0))))
(exchange-rectangles array row-1 0 sqrt-height width row-2 0)))
;;; This function exchanges two blocks of columns, where
;;; each block has width which is the square root of the
;;; width of the array
(defun exchange-blocks-of-columns (array col-1 col-2)
(let* ((height (array-dimension array 0))
(sqrt-width (isqrt (array-dimension array 1))))
(exchange-rectangles array 0 col-1 height sqrt-width 0 col-2)))
;;; This function computes a random permutation of n elements. It
;;; works as follows: At each iteration, there is a prefix of i random
;;; elements (initially 0) , and another element of the prefix is
;;; computed by exchanging element i and a random element among the
;;; elements from i to n-1 inclusive. There are n-i [(n-1) - i + 1]
;;; such elements, so the RANDOM function has to be called with n-i,
;;; which gives us a value between 0 and n-i-1 inclusive. By adding i
;;; to that value, we get a value between i and n-1 inclusive.
;;; Instead of stipulating how the elements are stored, we take as an
;;; argument an exchange function that is called with i and the
;;; element number of the element to exchange with element i. This function
;;; is responsible for accessing the exact physical representation of the n
;;; elements.
(defun compute-random-permutation (n exchange-fun)
(loop for i from 0 to (- n 2)
do (let ((e (+ i (random (- n i)))))
(unless (= i e)
(funcall exchange-fun i e)))))
;;; To shuffle a vector, compute a random permutation
;;; of its elements.
(compute-random-permutation
(length vector)
(lambda (i j)
(rotatef (aref vector i) (aref vector j)))))
(defun shuffle-rows-within-block (board block-start)
(let ((N (isqrt (array-dimension board 0))))
(compute-random-permutation
N (lambda (r1 r2)
(exchange-rows board (+ block-start r1) (+ block-start r2))))))
(defun shuffle-columns-within-block (board block-start)
(let ((N (isqrt (array-dimension board 0))))
(compute-random-permutation
N (lambda (c1 c2)
(exchange-columns board (+ block-start c1) (+ block-start c2))))))
(defun shuffle-blocks-of-rows (board)
(let ((N (isqrt (array-dimension board 0))))
(compute-random-permutation
N (lambda (r1 r2)
(exchange-blocks-of-rows board (* r1 N) (* r2 N))))))
(defun shuffle-blocks-of-columns (board)
(let ((N (isqrt (array-dimension board 0))))
(compute-random-permutation
N (lambda (c1 c2)
(exchange-blocks-of-columns board (* c1 N) (* c2 N))))))
(defun shuffle-board (board)
(let* ((board-width (array-dimension board 0))
(sqrt-board-width (isqrt board-width)))
(loop for block-start from 0 below board-width by sqrt-board-width
do (shuffle-rows-within-block board block-start))
(loop for block-start from 0 below board-width by sqrt-board-width
do (shuffle-columns-within-block board block-start))
(shuffle-blocks-of-rows board)
(shuffle-blocks-of-columns board)))
(defun set-sample-game (game)
(let* ((board-width (array-dimension (cells game) 0))
(easy-board (make-array (list board-width board-width)
:initial-contents '((0 6 5 0 2 0 0 7 0)
(7 2 9 5 3 0 0 0 0)
(0 4 0 8 0 0 2 0 9)
(0 5 1 0 8 0 7 0 2)
(0 0 0 7 0 2 0 0 0)
(2 0 7 0 4 0 3 9 0)
(6 0 4 0 0 1 0 2 0)
(0 0 0 0 9 8 6 3 7)
(0 9 0 0 6 0 1 4 0))))
(hard-board (make-array (list board-width board-width)
:initial-contents '((0 0 0 3 0 8 0 5 4)
(8 5 0 6 9 0 0 0 0)
(2 0 0 0 4 0 0 8 0)
(6 0 0 0 0 0 7 0 1)
(7 2 0 0 0 0 0 4 5)
(3 0 5 0 0 0 0 0 2)
(0 7 0 0 5 0 0 0 3)
(0 0 0 0 8 6 0 2 9)
(4 6 0 9 0 3 0 0 0))))
(used-board (make-array (list board-width board-width))))
(loop for row from 0 below board-width
do (loop for col from 0 below board-width
for value = (aref used-board row col)
do (when (> value 0)
(erase-possibilities (aref (cells game) row col))
(set-possibilities (aref (cells game) row col)
(- value 1) 1))))))
(defun create-game (board)
(let* ((board-width (array-dimension board 0))
(sqrt-board-width (isqrt board-width))
(game (make-game board-width)))
;; Create mapping vector
(setf (symbols game) (create-mapping-vector board-width))
;; Create an array of cell instances
(loop for row from 0 below board-width
do (loop for col from 0 below board-width
do (setf (aref (cells game) row col)
(make-cell board-width))))
;; Initiate values for all cells of game
;; We will replace this call by the function which finds a game
(set-sample-game game)
;; Create unit instances corresponding to rows
(loop for row from 0 below board-width
do (let ((unit (make-unit)))
(copy-rectangle-to-unit game row 1 0 board-width unit)
(push unit (units game))
;; Create unit instances corresponding to columns
(loop for col from 0 below board-width
do (let ((unit (make-unit)))
(copy-rectangle-to-unit game 0 board-width col 1 unit)
(push unit (units game))
(loop for row from 0 below board-width by sqrt-board-width
do (loop for col from 0 below board-width by sqrt-board-width
do (let ((unit (make-unit)))
(copy-rectangle-to-unit
game row sqrt-board-width col sqrt-board-width unit)
(push unit (units game))
(return-from create-game game)))
(defun copy-game (game)
(let* ((board-width (array-dimension (cells game) 0))
(copied-game (make-game board-width)))
(setf (symbols copied-game) (symbols game))
(setf (cells copied-game) (cells game))
(setf (units copied-game) (units game))
(return-from copy-game copied-game)))
(defun print-board (game)
(let ((board-width (array-dimension (cells game) 0)))
(loop for row from 0 below board-width
do (format t "~%")
(loop for col from 0 below board-width
for cell = (aref (cells game) row col)
do (if (check-hole cell)
(format t "- ")
(let ((order-1 (position 1 (possibilities cell))))
(format t "~S " (aref (symbols game) order-1))))))))
(let* ((board (create-initial-board *board-width*))
(game (create-game board))
(copied-game (copy-game game)))
(print-board game)
(print-board copied-game)))
(defun test-strategy (choice)
(let ((unit (create-unit-for-testing choice))
(changed-cells nil))
(loop for cell in (cells unit)
do (describe cell))
(cond ((= choice 1) (setf changed-cells (strategy1 unit)))
((= choice 2) (setf changed-cells (strategy2 unit)))
((= choice 3) (setf changed-cells (strategy3 unit))))
(format t "~%The changed cell is:")
(describe (first changed-cells))))