Author: abaine Date: Tue Aug 14 00:48:37 2007 New Revision: 135
Modified: trunk/funds/src/examples/sudoku.lisp Log: Start of a solver added.
Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Tue Aug 14 00:48:37 2007 @@ -1,16 +1,144 @@
(in-package :funds)
+(defconstant +false+ 0) +(defconstant +true+ 1) +(defconstant +unknown+ 2) + +(defun true-p (n) (= n +true+)) +(defun false-p (n) (= n +false+)) +(defun unknown-p (n) (= n +unknown+)) +(defun solved-p (n) (not (unknown-p n))) + +(defun range (size) + (case size + (0 '()) + (1 '(1)) + (4 '(0 1 2 3)) + (9 '(0 1 2 3 4 5 6 7 8)) + (25 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)) + (otherwise (loop for i below size collecting i)))) + +(defstruct puzzle + size + tree) + (defun puzzle-from-list (list-rep) (let ((size (length list-rep))) - (make-f-array (expt size 3) - :initial-contents (mapcan #'(lambda (row) - (mapcan #'(lambda (elt) - (loop for i below size - collect (= i (1- elt)))) - row)) - list-rep)))) - - - - + (make-puzzle + :size size + :tree + (make-f-array (expt size 3) + :initial-contents + (mapcan #'(lambda (row) + (mapcan #'(lambda (elt) + (loop for i below size + collect (cond ((zerop elt) +unknown+) + ((= i (1- elt)) +true+) + (t +false+)))) + row)) + list-rep))))) + +(defun list-from-puzzle (puzzle) + (let ((size (puzzle-size puzzle))) + (loop for i below size collect + (loop for j below size collect + (loop for k below size + when (true-p (puzzle-elt puzzle i j k)) + do (return (1+ k)) + finally (return 0)))))) + +(defun puzzle-elt (puzzle row column number) + (f-array-elt (puzzle-tree puzzle) + (index-from-coordinates row column number (puzzle-size puzzle)))) + +(defun puzzle-complete (puzzle) + (let ((size (puzzle-size puzzle))) + (loop for i below size always + (loop for j below size always + (loop for k below size always + (not (unknown-p (puzzle-elt puzzle i j k)))))))) + +(defun set-to-true (puzzle i j k) + (fill-falses (make-puzzle :size (puzzle-size puzzle) + :tree (tree-insert (puzzle-tree puzzle) + (index-from-coordinates + i j k + (puzzle-size puzzle)) + +true+)) + i j k)) + +(defun set-to-false (puzzle i j k) + (let ((size (puzzle-size puzzle))) + (make-puzzle :size size + :tree (tree-insert (puzzle-tree puzzle) + (index-from-coordinates i j k) + +false+)))) + +(defun fill-falses (puzzle i j k) + (let ((size (puzzle-size puzzle))) + (make-puzzle :size size + :tree (reduce #'(lambda (tree index) + (reduce #'(lambda (tr x) + (if (unknown-p (tree-find tr x)) + (tree-insert tr x +false+) + tr)) + (list (index-from-coordinates i j index size) + (index-from-coordinates i index k size) + (index-from-coordinates index j k size) + (index-from-coordinates + (calc-i i j index size) + (calc-j i j index size) + k size)) + :initial-value tree)) + (range size) + :initial-value (puzzle-tree puzzle))))) + +(defun calc-i (i j index size) + (let ((order (order size))) + (+ (start i order) + (floor index order)))) + +(defun calc-j (i j index size) + (let ((order (order size))) + (+ (start j order) + (mod index order)))) + + +(defun start (x order) + (* order (floor x order))) + +(defun order (size) + (round (sqrt size))) + +(defun index-from-coordinates (i j k size) + (+ (* i size size) + (* j size) + k)) + +(defun complete-p (puzzle) + (labels ((f (tree) + (or (tree-empty-p tree) + (and (solved-p (bt-value tree)) + (f (bt-left tree)) + (f (bt-right tree)))))) + (f (puzzle-tree puzzle)))) + +(defun solvable-p (puzzle) + (let ((size (puzzle-size puzzle))) + (loop for i below size always + (loop for j below size always + (not (or (loop for k below size always (false-p (puzzle-elt puzzle i j k))) + (loop for k below size always (false-p (puzzle-elt puzzle i k j))) + (loop for k below size always (false-p (puzzle-elt puzzle k i j))) + (loop for k below size always + (false-p (puzzle-elt-by-box puzzle i j k))))))))) + +(defun puzzle-elt-by-box (puzzle number box index) + (let ((order (order (puzzle-size puzzle)))) + (puzzle-elt puzzle + (+ (* order (floor box order)) + (floor index order)) + (+ (* order (mod box order)) + (mod index order)) + number)))