Shared/sudoku.lisp

(defvar *map* (make-array '(9 9)))

(defun get-row (map x)
  "Returns a list of all values present in row x of map"
  (let ((row nil))
    (loop for i from 0 to 8 do
      (setf row (cons (aref map x i) row)))
    (remove-if (lambda (e) (= e 0)) row)))

(defun get-col (map y)
  "Returns a list of all values in column y of map"
  (let ((col nil))
    (loop for i from 0 to 8 do
      (setf col (cons (aref map i y) col)))
    (remove-if (lambda (e) (= e 0)) col)))

(defun get-zone (map x y)
  "Returns a list of all values for the zone which contains cell x,y."
  (let ((zone nil)
	(zx (* 3 (floor (/ x 3))))
	(zy (* 3 (floor (/ y 3)))))
    (loop for i from 0 to 2 do
      (loop for j from 0 to 2 do
	(setf zone (cons (aref map (+ zx i) (+ zy j)) zone))))
    (remove-if (lambda (e) (= e 0)) zone)))

(defun get-valid-for-pos (map x y)
  "Returns the list of presently-valid remaining values for cell x,y in map"
  (if (= 0 (aref map x y))
      (let ((row (get-row map x))
	    (col (get-col map y))
	    (zone (get-zone map x y))
	    (valid '(1 2 3 4 5 6 7 8 9)))
	(setf valid (set-difference valid row))
	(setf valid (set-difference valid col))
	(set-difference valid zone))))

(defun get-min-move-count (map)
  "Returns the cell coordinates in list form '(x y) for the cell with the lowest number of presently-valid remaining values. It also returns the count of this quantity"
  (let ((min-move-count 10)
	(min-move-coords nil))
    (loop for i from 0 to 8 do
      (loop for j from 0 to 8 do
	(let ((move-count (length (aref map i j))))
	  (if (and (not (= move-count 0)) (< move-count min-move-count))
	      (progn
		(setf min-move-count move-count)
		(setf min-move-coords (list i j)))))))
    (values min-move-coords min-move-count)))

(defun build-move-map (map)
  "Returns an array where each cell contains a list of values which are presently-valid for map"
  (let ((move-map (make-array '(9 9))))
    (loop for i from 0 to 8 do
      (loop for j from 0 to 8 do
	(setf (aref move-map i j) (get-valid-for-pos map i j))))
	  move-map))

(defun map-complete (map)
  "Checks whether all cells are filled with a non-zero value in map"
  (loop for i from 0 to 8 do
    (loop for j from 0 to 8 do
      (if (= 0 (aref map i j))
	  (return-from map-complete nil))))
  t)

(defun copy-array (arr)
  "Creates a value copy of an array, assumes 9 x 9 dimensions"
  (let ((arr2 (make-array '(9 9))))
    (loop for i from 0 to 8 do
      (loop for j from 0 to 8 do
	(setf (aref arr2 i j) (aref arr i j))))
    arr2))

(defun solve-map-r (map)
  "Resursive solver for a sudoku puzzle map, saves result to global *map*"
  (let ((move-map (build-move-map map))
	(mapc (copy-array map))
	(min-move nil))
    (setf min-move (get-min-move-count move-map))
    (if (equal nil min-move)
	(if (map-complete mapc)
	    (progn
	      (setf *map* mapc)
	      (return-from solve-map-r t))
	    (return-from solve-map-r nil)))
	  (loop for val in (aref move-map (first min-move) (second  min-move)) do
	    (setf (aref mapc (nth 0 min-move) (nth 1 min-move)) val)
	    (if (solve-map-r mapc)
		(return-from solve-map-r t))))
    nil)

(defun solve-map (map)
  "Wrapper function for recursive solver. Returns value *map* saved by solver"
  (if (solve-map-r map)
      *map*
      nil))


(defun build-map (strlst)
  "Builds a map array from a list of strings. Expects 9 strings of 9 characters each"
  (let ((map (make-array '(9 9)))
	(row 0))
    (loop for str in strlst do
      (loop for i from 0 to 8 do
	(setf (aref map row i) (digit-char-p (aref str i))))
      (setf row (1+ row)))
    map))

; example: 
(solve-map (build-map '("003020600" "900305001" "001806400" "008102900" "700000008" "006708200" "002609500" "800203009" "005010300")))