Add sudoku.lisp

sudoku.lisp

@@ -0,0 +1,134 @@
+(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 get-file (filename)
+  (with-open-file (stream filename)
+    (loop for line = (read-line stream nil)
+          while line
+          collect line)))
+
+(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))
+
+(defun build-map-list (strlst)
+  "Builds a list of map arrays from a list of strings"
+  (let ((lineno 1)
+	(maplist nil))
+    (loop while (< lineno (length strlst)) do
+      (push (build-map (subseq strlst lineno (+ 9 lineno))) maplist)
+      (setf lineno (+ lineno 10)))
+    maplist))
+
+(defun solve ()
+  (let ((maplist (build-map-list (get-file "p096_sudoku.txt")))
+	(sum 0))
+    (loop for map in maplist do
+      (setf map (solve-map map))
+      (if (not (equal nil map))
+	  (setf sum (+ sum
+		       (* 100 (aref map 0 0))
+		       (* 10 (aref map 0 1))
+		       (aref map 0 2)))))
+    sum))