| cwbowron
| | Joined: 27 Aug 2005 | | Posts: 1 | | : | | Location: East Lansing, MI |
Items |
|
 Posted: Sat Aug 27, 2005 1:17 pm Post subject: Sudoku in Lisp |
 |
|
I put together a sudoku solver and generator in lisp and thought I would share. Tested with CLISP but should work with any Common Lisp.
| Code: |
;;; SUDOKU solver and generator
;;; Christopher "Puzzle Man" Bowron <puzzleman@bowron.us>
(proclaim '(optimize (speed 3)))
(defun solve-puzzle (puzzle &key debug randomize reverse)
(dotimes (row 9)
(dotimes (col 9)
(unless (get-number puzzle row col)
(let ((possibilities
(get-possibilities puzzle row col)))
(when debug
(format t "~%~%row = ~A, col = ~A~%" row col)
(format t "possibilities:: ~A~%" possibilities)
(format t "~A~%" puzzle))
(dolist (poss (cond
(reverse (nreverse possibilities))
(randomize (randomize-list possibilities))
(t possibilities)))
(let ((working-copy (copy-tree puzzle)))
(setf (nth col (nth row working-copy)) poss)
(let ((r (solve-puzzle working-copy
:debug debug
:randomize randomize
:reverse reverse)))
(when r
(return-from solve-puzzle r))))))
(return-from solve-puzzle nil))))
puzzle)
;;; optimize by solving for rows/cols/squares with the fewest
;;; possibilties first
(defun solve-puzzle-fast (puzzle &key debug randomize reverse)
(let ((ordering (get-ordering puzzle)))
(dolist (item ordering)
(let ((row (car (car item)))
(col (cdr (car item))))
(unless (get-number puzzle row col)
(let ((possibilities (get-possibilities puzzle row col)))
(when debug
(format t "~%~%row = ~A, col = ~A~%" row col)
(format t "possibilities:: ~A~%" possibilities)
(format t "~A~%" puzzle))
(dolist (poss (cond
(reverse (nreverse possibilities))
(randomize (randomize-list possibilities))
(t possibilities)))
(let ((working-copy (copy-tree puzzle)))
(setf (nth col (nth row working-copy)) poss)
(let ((r (solve-puzzle-fast working-copy
:debug debug
:randomize randomize
:reverse reverse)))
(when r
(return-from solve-puzzle-fast r))))))
(return-from solve-puzzle-fast nil)))))
puzzle)
;;; generate a solution by "solving" a blank grid using
;;; random permutation
;;; then randomly remove items that allow for the puzzle to still
;;; be solved to the original solution
;;; returns the puzzle and the solution
(defun generate-puzzle (&key debug min)
(let ((solution (solve-puzzle-fast *blank* :randomize t)))
(let ((puzzle (copy-tree solution)))
(dolist (index (randomize-list (number-list 0 80)))
(when (or (not min) (< min (count-numbers puzzle)))
(let ((working-copy (copy-tree puzzle))
(row (floor (/ index 9)))
(col (mod index 9)))
(setf (nth col (nth row working-copy)) nil)
(when (and
(equal solution (solve-puzzle-fast working-copy))
(equal solution
(solve-puzzle-fast working-copy :reverse t)))
(when debug (print working-copy))
(setq puzzle working-copy)))))
(values puzzle solution))))
;;; returns a list of numbers from min to max inclusive
(defun number-list (min max)
(let ((numbers nil)
(n (+ 1 (- max min))))
(dotimes (i n)
(setq numbers (cons (+ min i) numbers)))
(nreverse numbers)))
;;; returns a list in random order
(defun randomize-list (some-list)
(do ((randomized-list nil))
((null some-list) randomized-list)
(let ((item-number (random (length some-list))))
(push (elt some-list item-number)
randomized-list)
(setf some-list
(remove (elt some-list item-number) some-list)))))
(defvar *all-possible-numbers-forward*
(list 1 2 3 4 5 6 7 8 9))
(defvar *all-possible-numbers-backward*
(list 9 8 7 6 5 4 3 2 1))
(defun possible-numbers (list)
(set-difference *all-possible-numbers-forward* list))
(defun get-column (puzzle column)
(map 'list #'(lambda (x) (nth column x)) puzzle))
(defun get-row (puzzle row)
(nth row puzzle))
(defun get-number (puzzle r c)
(nth c (nth r puzzle)))
;; gets the contents of the 3x3 square in which this (row,col) resides
(defun get-ninth (puzzle row col)
(let ((r (floor (/ row 3)))
(c (floor (/ col 3))))
(let ((ninth nil))
(dotimes (x 3)
(dotimes (y 3)
(push
(get-number puzzle (+ (* r 3) y) (+ (* c 3) x))
ninth)))
(nreverse ninth))))
;;; Count how many missing numbers there are in the list
(defun count-missing (list)
(count-if #'null list))
;;; count the numbers in a row or puzzle
(defun count-numbers (list)
(cond ((numberp list) 1)
((null list) 0)
(t (reduce #'+ (map 'list #'count-numbers list)))))
(defun get-possibilities (puzzle row col)
(possible-numbers
(union
(union (get-row puzzle row)
(get-column puzzle col))
(get-ninth puzzle row col))))
(defun get-ordering (puzzle)
(let ((ordering nil))
(dotimes (row 9)
(dotimes (col 9)
(unless (get-number puzzle row col)
(let ((value
(length (get-possibilities puzzle row col))))
(push (cons (cons row col) value) ordering)))))
(sort ordering #'< :key #'cdr)))
(defun pretty-print-puzzle (puzzle)
(let ((row-divider "+-------+-------+-------+~%"))
(dotimes (row 9)
(when (= 0 (mod row 3))
(format t row-divider))
(dotimes (col 9)
(when (= 0 (mod col 3))
(format t "| "))
(let ((n (get-number puzzle row col)))
(format t "~A " (if n n "_"))))
(format t "|~%"))
(format t row-divider)))
(defvar
*puzzle*
'((6 nil nil nil 4 nil nil nil nil)
(nil 3 nil 8 nil nil 6 nil nil)
(nil 9 2 nil 1 7 nil 4 3)
(nil nil nil nil nil 2 4 nil nil)
(nil 4 5 1 3 6 8 7 nil)
(nil nil 6 4 nil nil nil nil nil)
(3 7 nil 2 8 nil 9 6 nil)
(nil nil 9 nil nil 1 nil 2 nil)
(nil nil nil nil 7 nil nil nil 1)))
(defvar
*evil*
'((4 nil nil nil 5 6 nil nil 3)
(nil nil nil nil 9 nil 5 nil nil)
(nil nil nil 7 nil nil 6 nil nil)
(nil nil 8 nil nil 4 nil 1 nil)
(6 1 nil nil nil nil nil 9 7)
(nil 5 nil 8 nil nil 2 nil nil)
(nil nil 2 nil nil 7 nil nil nil)
(nil nil 7 nil 8 nil nil nil nil)
(1 nil nil 6 4 nil nil nil 9)))
(defvar
*blank*
'((nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)
(nil nil nil nil nil nil nil nil nil)))
;; (solve-puzzle *puzzle*)
;; (solve-puzzle *evil*)
|
|
|
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in
Log in to check your private messages
