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)))
;;; 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
(defun exchange-rectangles (board
start-row-1 start-col-1
height width
start-row-2 start-col-2)
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
(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
do (rotatef (aref board row-1 col-1)
(aref board row-2 col-2))))))
(defun exchange-rows (board row-1 row-2)
(let ((board-width (array-dimension board 0)))
(exchange-rectangles board row-1 0 1 board-width row-2 0)))
(defun exchange-columns (board col-1 col-2)
(let ((board-height (array-dimension board 1)))
(exchange-rectangles board 0 col-1 board-height 1 0 col-2)))
(defun exchange-blocks-of-rows (board row-1 row-2)
(let* ((board-width (array-dimension board 0))
(sqrt-board-width (isqrt board-width)))
(exchange-rectangles board row-1 0 sqrt-board-width board-width row-2 0)))
(defun exchange-blocks-of-columns (board col-1 col-2)
(let* ((board-width (array-dimension board 0))
(sqrt-board-width (isqrt board-width)))
(exchange-rectangles board 0 col-1 board-width sqrt-board-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))))