The driver was written by my profe. The solver was written by myself and my partner.
- Code: Select all
;; ---------------------------------------------
;; John Paxton
;; CS 436
;; October 11, 2005
;; ---------------------------------------------
;; driver.l
;; This file contains the driver for Program 3,
;; Sudoku.
;; ---------------------------------------------
;; ---------------------------------------------
;; solve
;; ---------------------------------------------
;; input-file: the name of the input file
;; that contains the Sudoku problem
;; ---------------------------------------------
;; This function is the main driver function
;; for Program 3.
;; ---------------------------------------------
(defun solve ( input-file )
(let*
(
;; problem to solve
(original (create-puzzle (make-array '(9 9)) input-file))
(solution (make-copy original)) ;; solution to problem
)
(print-puzzle original "The original problem")
(setf solution (time (solve-puzzle solution)))
(print-puzzle solution "The solved problem")
(format t "~2%Results:~%")
(format t "-------~%")
(if (initial-constraints-ok-p original solution)
(evaluate-all solution)
)
)
)
;; ---------------------------------------------
;; initial-constraints-ok-p
;; ---------------------------------------------
;; original: the original puzzle
;; solution: the proposed solution
;; ---------------------------------------------
;; Returns true if the "solution" is consistent
;; with the solved part of the "original" puzzle.
;; ---------------------------------------------
(defun initial-constraints-ok-p (original solution)
(let
(
(ok t) ;; are the constraints consistent?
(count 0) ;; the number of solved positions in the original problem
)
(dotimes (row (array-dimension original 0))
(dotimes (col (array-dimension original 1))
(if (numberp (aref original row col))
(if (equal (aref original row col) (aref solution row col))
(setf count (+ 1 count)) ;; consistent square
(setf ok nil) ;; inconsistent square
)
)
)
)
(if ok
(format t "All ~a initial constraints are ok.~%" count)
(format t "ERROR - some initial constraints are violated.~%")
)
ok
)
)
;; ---------------------------------------------
;; evaluate-all
;; ---------------------------------------------
;; solution: the proposed Sudoku solution
;; ---------------------------------------------
;; Evaluates each completely solved square in the
;; "solution" to decide if it violates any Sudoku
;; constraints. Prints the results.
;; ---------------------------------------------
(defun evaluate-all ( solution )
(let
(
(ok t) ;; are there any constraint violations?
(count 0) ;; number of solved squares
)
(dotimes (row (array-dimension solution 0))
(dotimes (col (array-dimension solution 1))
(cond
((numberp (aref solution row col))
(if (cell-ok-p row col solution)
(setf count (+ 1 count)) ;; this square is solved
(setf ok nil) ;; constraint violation
)
)
)
)
)
(if ok
(format t "The number of Sudoku cells solved is ~a.~%" count)
(format t "ERROR - there was at least one constraint violation.~%")
)
)
)
;; ---------------------------------------------
;; cell-ok-p
;; ---------------------------------------------
;; row: the row of the cell to examine
;; col: the column of the cell to examine
;; solution: the proposed Sudoku solution
;; ---------------------------------------------
;; Returns true if the cell being examined does
;; not violate any Sudoku constraints.
;; ---------------------------------------------
(defun cell-ok-p (row col solution)
(and
(line-ok-p solution (aref solution row col) row 0 0 1) ;; column
(line-ok-p solution (aref solution row col) 0 col 1 0) ;; row
(square-ok-p solution (aref solution row col) ;; 3 by 3 square
(* 3 (floor (/ row 3))) (* 3 (floor (/ col 3))))
)
)
;; ---------------------------------------------
;; square-ok-p
;; ---------------------------------------------
;; matrix: the matrix being examined
;; value: the value being sought
;; start-row: the starting row of the 3 by 3 square
;; start-col: the starting column of the 3 by 3 square
;; ---------------------------------------------
;; Returns true if the 3 by 3 square does not contain
;; more than 1 instance of "value".
;; ---------------------------------------------
(defun square-ok-p (matrix value start-row start-col)
(do
(
(count 0) ;; number of times "value" found
(row start-row (+ 1 row)) ;; current row
)
((>= row (+ start-row 3))
(if (> count 1) ;; print out violation information
(format t " ERROR - square violation in ~a ~a~%" start-row start-col)
)
(<= count 1) ;; loop exit value
)
(do
(
(col start-col (+ 1 col)) ;; current column
)
((>= col (+ start-col 3)))
(if (equal value (aref matrix row col))
(setf count (+ 1 count))
)
)
)
)
;; ---------------------------------------------
;; line-ok-p
;; ---------------------------------------------
;; matrix: the Sudoku puzzle
;; value: the value being sought
;; row: the starting row
;; col: the starting column
;; row-inc: how to increment the row
;; col-inc: how to increment the column
;; ---------------------------------------------
;; Go through the appropriate line (it might be
;; either a row or a column depending on the parameter
;; values) and find out whether "value" occurs
;; more than once. If it does, the Sudoku constraints
;; are violated.
;; ---------------------------------------------
(defun line-ok-p (matrix value row col row-inc col-inc)
(let
(
(count 0) ;; number of "value" occurrences
(original-row row) ;; the original row passed in
(original-col col) ;; the original column passed in
)
(dotimes (i (array-dimension matrix 0))
(if (equal value (aref matrix row col))
(setf count (+ 1 count))
)
(setf row (+ row row-inc))
(setf col (+ col col-inc))
)
(if (> count 1)
(format t " ERROR - line violation at ~a ~a ~%" original-row original-col)
)
(<= count 1) ;; return value
)
)
;; ---------------------------------------------
;; make-copy
;; ---------------------------------------------
;; original: the original Sudoku puzzle
;; ---------------------------------------------
;; Create and return a shallow copy of the "original".
;; The copy will be given to the Program 3 Sudoku
;; problem solvers.
;; ---------------------------------------------
(defun make-copy ( original )
(let
(
(copy (make-array `( ,(array-dimension original 0) ;; Sudoku copy
,(array-dimension original 1))))
)
(dotimes (row (array-dimension original 0) copy)
(dotimes (col (array-dimension original 1) copy)
(setf (aref copy row col) (aref original row col))
)
)
)
)
;; ---------------------------------------------
;; print-puzzle
;; ---------------------------------------------
;; matrix: representation of a Sudoku puzzle
;; message: an appropriate message to print
;; ---------------------------------------------
;; Prints out an appropriate representation of
;; a Sudoku puzzle. Any unsolved squares are
;; printed as question marks, ?.
;; ---------------------------------------------
(defun print-puzzle ( matrix message )
(format t "~%~a~2%" message)
(dotimes (row (array-dimension matrix 0))
(dotimes (col (array-dimension matrix 1))
(if (listp (aref matrix row col))
(format t "? ")
(format t "~a " (aref matrix row col))
)
)
(format t "~%")
)
(format t "-----------------~%")
)
;; ---------------------------------------------
;; create-puzzle
;; ---------------------------------------------
;; matrix: the initial representation of the Sudoku problem
;; file: the input file containing the problem
;; ---------------------------------------------
;; This function reads the appropropriate input
;; file in order to create an internal representation
;; of a Sudoku puzzle. Any question mark in the input
;; file is replaced with the list '(1 2 3 4 5 6 7 8 9)
;; representing the possible answers for this cell.
;; ---------------------------------------------
(defun create-puzzle ( matrix file )
(with-open-file (input-stream file :direction :input)
(dotimes (row (array-dimension matrix 0) matrix)
(dotimes (column (array-dimension matrix 1))
(setf (aref matrix row column) (read input-stream nil))
(if (equal '? (aref matrix row column))
(setf (aref matrix row column)
(generate-guesses (array-dimension matrix 0)))
)
)
)
)
)
;; ---------------------------------------------
;; generate-guesses
;; ---------------------------------------------
;; how-many
;; ---------------------------------------------
;; Make and return a *unique* list containing all of the
;; integers from 1 through "how-many".
;; ---------------------------------------------
(defun generate-guesses ( how-many )
(let
(
(result nil) ;; the resulting list
)
(dotimes (i how-many (reverse result))
(setf result (cons (+ 1 i) result))
)
)
)
;; ***** Here's solver.l
(defun solve-puzzle (board)
(let*
(
(size (array-dimension board 0))
(row-removal-array (make-array (list size)))
(col-removal-array (make-array (list size)))
(box-removal-array (make-array (list (/ size 3) (/ size 3))))
(initial-unknown) ;; the next unknown element list
(counter-timer 0) ;; the counter to time our program
(exit-on-count 150000) ;; when we should stop, if the program will run over 10 seconds
)
;; first we need to eliminate duplicates from rows, columns, and boxes
(dotimes (row size ) ;; go through each row
(dotimes (col size) ;; go through each col
(cond
( (atom (aref board row col))
(setf (aref row-removal-array row) (cons (aref board row col) (aref row-removal-array row))) ;; add element to list of elements to remove from row
(setf (aref col-removal-array col) (cons (aref board row col) (aref col-removal-array col))) ;; add element to list of elements to remove from column
(setf (aref box-removal-array (floor (/ row 3)) (floor (/ col 3))) (cons (aref board row col) (aref box-removal-array (floor (/ row 3)) (floor (/ col 3)))))
)
)
)
)
;; go through the rows again and columns and boxes and remove the elements from the removal arrays
(dotimes (row size ) ;; go through each row
(dotimes (col size) ;; go through each col
(cond
( (listp (aref board row col))
(dolist (number-to-remove (aref row-removal-array row))
(setf (aref board row col) (remove number-to-remove (aref board row col))) ;; remove from the board the list of elements to remove for this row
)
(dolist (number-to-remove (aref col-removal-array col))
(setf (aref board row col) (remove number-to-remove (aref board row col))) ;; remove from the board the list of elements to remove for this column
)
(dolist (number-to-remove (aref box-removal-array (floor (/ row 3)) (floor (/ col 3)))) ;; remove from the board the list of elements to remove for this box
(setf (aref board row col) (remove number-to-remove (aref board row col)))
)
)
)
)
)
;; we have now removed all obviously impossible placements
;;;;
;; implement a loop that checks for 1: singles in row/col 2: singles in box
;; 3: Pointing pairs? very effective, takes hardest.dat from 7sec to hardest2.dat 0.6 seconds.
;; scanraid.com/sudoku.htm
;; if done, we need to know how long until our program will reach 10 seconds
;; and need to quit
;;;;
(defun try (row col given-num-list)
(cond
( (> counter-timer exit-on-count) t )
(t
(do*
(
(num-list given-num-list)
(done-p nil) ;; whether a solution has been found
(num (first num-list) (first num-list)) ;; num is going through the list of elements possible for this location on the board
(next-row-col-list (find-next-unknown row col))
(next-row (first next-row-col-list))
(next-col (first (rest next-row-col-list)))
)
((or done-p (null num-list)) done-p) ;; do until done or num-list is null...
;; if num is in the row, col, or box, skip over calling (try... with this location)
(setf num-list (rest num-list)) ;; drop first item from num-list
(cond
( (can-exist-p row col num)
(setf (aref board row col) num) ;; set the place to the current num, cause it can exist here (thus far)
(cond
( (null next-row-col-list) ;; there board is full
;; we know the board is full and that each placement can exist, so we're done
(setf done-p t)
)
( t
(setf counter-timer (+ 1 counter-timer))
(setf done-p (try next-row next-col (aref board next-row next-col))) ;; recursive call on unknown
)
);; end inner cond
;; else, it can't exist in location given
)
)
(if (and (not done-p) (null num-list))
(setf (aref board row col) given-num-list) ;; reset the square we messed with, nothing worked here
)
;; let do* choose next number
)
)
)
)
;; checks if the given number can possibly exist in the row and col given
(defun can-exist-p (row col num)
;; check the row and see if the num is already in it
;; check the col, and box likewise
(let
(
(can-exist t) ;; assume it can exist until proven otherwise
)
(dotimes (current-row size) ;; check col
(if (eq (aref board current-row col) num)
(setf can-exist nil)
)
)
(if can-exist
(dotimes (current-col size) ;; check row
(if (eq (aref board row current-col) num)
(setf can-exist nil)
)
)
)
(if can-exist
(dotimes (current-row (/ size 3)) ;; check box
(dotimes (current-col (/ size 3))
(if (eq (aref board (+ (* 3 (floor (/ row 3))) current-row) (+ (* 3 (floor (/ col 3))) current-col)) num)
(setf can-exist nil)
)
)
)
)
can-exist
)
)
;; Finds the next list of elements in the board
(defun find-next-unknown (current-row current-col)
(do
(
(row current-row)
(col current-col)
(location)
)
( (or location (and (= row (- size 1)) (= col (- size 1)))) location) ;; do until the location is not an empty list, return location
(setf col (+ 1 col)) ;; add one to the column
(cond
(
(>= col size) ;; if the column is greater than the dimension of the board
(setf col 0) ;; wrap around, set column to 0
(setf row (+ 1 row)) ;; increment the row
)
)
;; check the row/col for a list of possible elements
(if (listp (aref board row col))
(setf location (list row col)) ;; error, out of bounds; check it *********************************************
)
)
)
;; time to try the search
;; find the first unknown element, call try on that element
(setf initial-unknown (find-next-unknown 0 -1))
(if initial-unknown
(try (first initial-unknown) (first (rest initial-unknown)) (aref board (first initial-unknown) (first (rest initial-unknown))))
)
)
board ;; return the solved board
)
Usage:
Fire up clisp.
(compile-file "sudoku.l")
(load "driver.l")
(load "sudoku")
(solve "somepuz.l")
Where "somepuz.l" is in the format:
? ? 4 ? ? 3 ? 2 ?
...
in a 9x9 square.
