sudoku anyone? [Lisp]

Prev: CL to generate native docs
Next: ATTENTION: RETAIL FANZ OUT HERE : )/ CHECK THIS OUT : )

From: John Thingstad on 29 Jan 2010 20:18

Been learning unix system administration lately so I haven't had much
time to program. (Unless you call basic scripting programming.) Today I
took some time off so I made a rough prototype of a sudoku. To make this
elegant and general would require some more work but still a fun
diversion.

--------------------------------------------------------------------------
Output SBCL

CL-USER> *sudoku-data*
#2A((6 _ _ 2 _ 5)
(_ _ _ 6 _ _)
(2 4 6 3 _ _)
(_ _ 3 4 6 2)
(_ _ 2 _ _ _)
(4 _ 5 _ _ 3))
CL-USER> (sudoku *sudoku-data*)
#2A((6 3 4 2 1 5)
(5 2 1 6 3 4)
(2 4 6 3 5 1)
(1 5 3 4 6 2)
(3 1 2 5 4 6)
(4 6 5 1 2 3))

-------------------------------------------------------------------------
Program: sudoku.lisp

;;; start form
(defparameter *sudoku-data*
'#2A((6 _ _ 2 _ 5)
(_ _ _ 6 _ _)
(2 4 6 3 _ _)
(_ _ 3 4 6 2)
(_ _ 2 _ _ _)
(4 _ 5 _ _ 3)))

;;; Internal format of sudoku board at start:
;;; ;2A(((6) NIL NIL (2) NIL (5))
;;; (NIL NIL NIL (6) NIL NIL)
;;; ((2) (4) (6) (3) NIL NIL)
;;; (NIL NIL (3) (4) (6) (2))
;;; (NIL NIL (2) NIL NIL NIL)
;;; ((4) NIL (5) NIL NIL (3)))

(defun make-sudoku-board (sudoku-data)
(let ((sudoky-board (make-array '(6 6))))
(loop for row from 0 to 5 do
(loop for col from 0 to 5 do
(setf (aref sudoky-board row col)
(etypecase (aref sudoku-data row col)
(integer (list (aref sudoku-data row col)))
(symbol nil)))))
sudoky-board))

;;; back to the format of the start form
(defun make-solution-board (sudoky-board)
(let ((board (make-array '(6 6))))
(loop for row from 0 to 5 do
(loop for col from 0 to 5 do
(setf (aref board row col)
(first (aref sudoky-board row col)))))
board))

(defun set- (list1 list2)
(loop for element in list2 do
(when (member element list2)
(setf list1 (remove element list1))))
list1)

;; Human description
;;; 1. look for the columns or rows of boxes for filled in numbers.
;;; 2. list the alternatives that are left in the empty boxes.
;;; 3. eliminate the ones that are on the orthogonal row or column or in
the box
;;; 4. if only one is left I fill in the number that place.
;;; 5. repeat from 1 until all numbers are determined.

(defun solve-colums-first-time (sudoku-board)
;; first time around all values are possible except the ones on that
column
(let ((value-list (loop for i from 1 to 6 collect i)))
(loop for row from 0 to 5 do
;; take all the values on a column (0..5)
(let ((values (copy-list value-list)))
;; remove the values that are on the colomn
(loop for col from 0 to 5 do
(when (aref sudoku-board row col)
(setf values (delete (first (aref sudoku-board row
col)) values))))
;; in the empty positions put a list of possible values
;; (whatever we didn't remove)
(loop for col from 0 to 5 do
(when (null (aref sudoku-board row col))
(setf (aref sudoku-board row col) values)))))))

(defun solve-colums (sudoku-board)
;; take the values on a row (0..5)
(loop for row from 0 to 5 do
;; collect values that it knows are right
;; (lists of length 1)
(let ((values
(loop for col from 0 to 5
when (= (length (aref sudoku-board row col)) 1)
collect (first (aref sudoku-board row col)))))
;; if value is undetermined (length of list > 1)
;; then eliminate the values it knows is right
(loop for col from 0 to 5 do
(when (> (length (aref sudoku-board row col)) 1)
(setf (aref sudoku-board row col)
(set- (aref sudoku-board row col) values)))))))

(defun solve-rows (sudoku-board)
;; take the values on a row (0..5)
(loop for col from 0 to 5 do
;; collect values that it knows are right
;; (lists of length 1)
(let ((values
(loop for row from 0 to 5
when (= (length (aref sudoku-board row col)) 1)
collect (first (aref sudoku-board row col)))))
;; if value is undetermined (length of list > 1)
;; then eliminate the values it knows are right
(loop for row from 0 to 5 do
(when (> (length (aref sudoku-board row col)) 1)
(setf (aref sudoku-board row col)
(set- (aref sudoku-board row col) values)))))))

(defun solve-boxes (sudoku-board)
;; take the boxes ((0-2) (0-1))
(loop for row from 0 to 2 do
(loop for col from 0 to 1 do
;; calculate the offsets into the sudoku board
(let (values
(row-start (* row 2))
(row-end (1- (* (1+ row) 2)))
(col-start (* col 3))
(col-end (1- (* (1+ col) 3))))
;; collect values that it knows are right
;; (lists of length 1)
(loop for box-row from row-start to row-end do
(loop for box-col from col-start to col-end do
(when (= (length (aref sudoku-board box-row box-
col)) 1)
(push (first (aref sudoku-board box-row box-
col))
values))))
;; if value is undetermined (length of list > 1)
;; then eliminate the values it knows are right
(loop for box-row from row-start to row-end do
(loop for box-col from col-start to col-end do
(when (> (length (aref sudoku-board box-row box-
col)) 1)
(setf (aref sudoku-board box-row box-col)
(set- (aref sudoku-board box-row box-col)
values)))))))))
(defun solved (sudoku-board)
;; solved is all lists in sudoku-board are of length 1
(loop for row from 0 to 5 do
(loop for col from 0 to 5 do
(if (> (length (aref sudoku-board row col)) 1)
(return-from solved nil))))
t)

(defun solve-sudoku (sudoku-board)
(solve-colums-first-time sudoku-board)
(solve-rows sudoku-board)
(solve-boxes sudoku-board)
(loop do
(solve-colums sudoku-board)
(solve-rows sudoku-board)
(solve-boxes sudoku-board)
until (solved sudoku-board))
sudoku-board)

(defun sudoku (data)
(make-solution-board (solve-sudoku (make-sudoku-board data))))

--
John Thingstad

From: John Thingstad on 29 Jan 2010 20:29

The Fri, 29 Jan 2010 19:18:10 -0600, John Thingstad wrote:

> Been learning unix system administration lately so I haven't had much
> time to program. (Unless you call basic scripting programming.) Today I
> took some time off so I made a rough prototype of a sudoku. To make this
> elegant and general would require some more work but still a fun
> diversion.
>
>
> (defun set- (list1 list2)
> (loop for element in list2 do
> (when (member element list2)
> (setf list1 (remove element list1))))
> list1)
>

OOPS..

(defun set- (list1 list2)
(loop for element in list2 do
(setf list1 (remove element list1)))
list1)

From: Helmut Eller on 30 Jan 2010 03:40

* John Thingstad [2010-01-30 02:18+0100] writes:

> Been learning unix system administration lately so I haven't had much
> time to program. (Unless you call basic scripting programming.) Today I
> took some time off so I made a rough prototype of a sudoku. To make this
> elegant and general would require some more work but still a fun
> diversion.

I once translated Peter Norvig's Python code
http://norvig.com/sudoku.html to Lisp. While the Lisp version runs a
bit faster, I have to admit that the Python version is shorter and
easier to read.

(defpackage :sudo
(:use :cl))
(in-package :sudo)

(defun square (row col) (+ (* row 9) col))
(defun row (square) (floor square 9))
(defun col (square) (mod square 9))
(defun boxstart (coord) (- coord (mod coord 3)))

(defun rect (row height col width)
(loop for r from row repeat height
append (loop for c from col repeat width
collect (square r c))))

(defparameter *squares* (rect 0 9 0 9))

(defparameter *units*
(map 'vector
(lambda (s)
(list (rect (row s) 1 0 9)
(rect 0 9 (col s) 1)
(rect (boxstart (row s)) 3 (boxstart (col s)) 3)))
*squares*))

(defparameter *peers*
(map 'vector
(lambda (s) (remove s (reduce #'union (aref *units* s))))
*squares*))

(defvar *digits* (loop for i from 1 to 9 collect i))

(defun dfsearch (board)
(cond ((not board) nil)
((let* ((s (most-constrained-square board)))
(cond ((not s) board)
((some (lambda (d) (dfsearch (assign (copy-seq board) s d)))
(svref board s))))))))

(defun most-constrained-square (board)
(let ((min 10)
(sq nil))
(loop for vs across board for i from 0 do
(let ((len (length vs)))
(cond ((= len 2) (return i))
((< 1 len min) (setq min len sq i))))
finally (return sq))))

(defun assign (board s d)
(catch 'inconsistent
(loop for d2 in (aref board s)
unless (= d d2) do (eliminate board s d2))
board))

(defun eliminate (board s d)
(unless (member d (aref board s))
(return-from eliminate board))
(let ((set (setf (aref board s) (remove d (aref board s)))))
(when (null set)
(throw 'inconsistent nil))
(when (singelton? set)
(loop for s2 in (aref *peers* s) do
(eliminate board s2 (car set))))
(dolist (u (aref *units* s))
(let ((dplaces (loop for ss in u
if (member d (aref board ss)) collect ss)))
(when (null dplaces)
(throw 'inconsistent nil))
(when (singelton? dplaces)
(or (assign board (car dplaces) d) (throw 'inconsistent nil)))))
board))

(defun parse-grid (ggrid)
(let ((grid (loop for c across ggrid
if (find c "0.-123456789") collect c))
(board (coerce (loop for s in *squares* collect *digits*) 'vector)))
(loop for d in grid for s in *squares* do
(unless (find d "0.-")
(unless (assign board s (- (char-code d) (char-code #\0)))
(return-from parse-grid nil))))
board))

(defun singelton? (set) (and set (null (cdr set))))

;; (dfsearch (parse-grid "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......"))

(defun test-top95 (filename)
(with-open-file (s filename)
(loop for line = (read-line s nil) for i from 0
while line do
(format t "line: ~d~%" i)
(force-output)
(dfsearch (parse-grid line)))))

;; (time (test-top95 "top95.txt"))

Helmut

From: Pascal J. Bourguignon on 30 Jan 2010 07:22

John Thingstad <jpthing(a)online.no> writes:

You're really asking for trouble.

> (defparameter *sudoku-data*
> '#2A((6 _ _ 2 _ 5)

Not only do you use a literal data #2A(...) but what's more you're quoting it!

> (setf (aref sudoky-board row col)

and you expect this setf to work???
Well, perhaps in your implementation, but not in CL.

--
__Pascal Bourguignon__

From: Pascal J. Bourguignon on 30 Jan 2010 07:34

| Next | Last
Pages: 1 2 3 4 5
Prev: CL to generate native docs
Next: ATTENTION: RETAIL FANZ OUT HERE : )/ CHECK THIS OUT : )