Author: abaine Date: Sat Aug 18 18:56:29 2007 New Revision: 141
Modified: trunk/funds/src/examples/sudoku.lisp Log: Minor changes to solver.
Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 18:56:29 2007 @@ -60,8 +60,6 @@ i j k) i j k))
- - (defun fill-falses-row (puzzle i j k) (fill-falses-group puzzle #'row-coordinates i j k) )
@@ -137,21 +135,25 @@ "")))))))))
(defun solve (puzzle) - (iter (for f in (list #'best-row - #'best-column - #'best-number - #'best-box)) - (for s in (list #'solve-row - #'solve-column - #'solve-number - #'solve-box)) - (for (values x y n) = (funcall f puzzle)) - (finding x minimizing n into best-x) - (finding y minimizing n into best-y) - (finding s minimizing n into (best-s min)) - (when (= min 1) - (return (funcall best-s puzzle best-x best-y))) - (finally (return (funcall best-s puzzle best-x best-y))))) + (if (complete-p puzzle) + (if (solved-p puzzle) + puzzle + nil) + (iter (for f in (list #'best-row + #'best-column + #'best-number + #'best-box)) + (for s in (list #'solve-row + #'solve-column + #'solve-number + #'solve-box)) + (for (values x y n) = (funcall f puzzle)) + (finding x minimizing n into best-x) + (finding y minimizing n into best-y) + (finding s minimizing n into (best-s min)) + (when (= min 1) + (return (funcall best-s puzzle best-x best-y))) + (finally (return (funcall best-s puzzle best-x best-y))))))
(defun best-row (puzzle) (best-group puzzle #'row-freedom)) @@ -204,9 +206,6 @@ (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c) (finally (return (enlarge-zero c size))))))
- - - (defun box-freedom (puzzle b k) (let* ((size (puzzle-size puzzle)) (order (order size))) @@ -220,6 +219,12 @@ into c) (finally (return (enlarge-zero c size))))))
+(defun group-freedom (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (iter (for z below size) + (counting (elt-unknown-p (multiple-value-call #'puzzle-elt puzzle + (funcall x-y-z-function x y z size))))))) + (defun enlarge-zero (count size) (if (zerop count) (1+ size) @@ -237,43 +242,58 @@ (defun solve-box (puzzle b k) (solve-group puzzle #'b-k-x-coordinates b k))
-(defun solve-group (puzzle c-function x y) - (if (complete-p puzzle) - puzzle - (let ((size (puzzle-size puzzle))) - (labels ((f (z) - (if (= z size) nil - (multiple-value-bind (i j k) - (funcall c-function x y z puzzle) - (if (puzzle-elt-solved puzzle i j k) - (f (1+ z)) - (or (solve (multiple-value-call - #'fill-true puzzle - (funcall c-function x y z puzzle))) - (f (1+ z)))))))) +(defun solve-group (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (labels ((f (z) + (if (= z size) nil + (multiple-value-bind (i j k) + (funcall x-y-z-function x y z size) + (if (puzzle-elt-solved puzzle i j k) + (f (1+ z)) + (or (solve (fill-true puzzle i j k)) + (f (1+ z))))))))
- (f 0))))) + (f 0))))
(defun complete-p (puzzle) (= (tree-weight (puzzle-tree puzzle)) (round (expt (puzzle-size puzzle) 3))))
-(defun i-j-k-coordinates (i j k puzzle) - (declare (ignore puzzle)) +(defun solved-p (puzzle) + (let ((size (puzzle-size puzzle))) + (iter (for x below size) + (always (iter (for y below size) + (always (iter (for x-y-z-function in (list + #'i-j-k-coordinates + #'i-k-j-coordinates + #'j-k-i-coordinates + #'b-k-x-coordinates)) + (always (group-solved puzzle x-y-z-function x y))))))))) + +(defun i-j-k-coordinates (i j k size) + (declare (ignore size)) (values i j k))
-(defun i-k-j-coordinates (i k j puzzle) - (declare (ignore puzzle)) +(defun i-k-j-coordinates (i k j size) + (declare (ignore size)) (values i j k))
-(defun j-k-i-coordinates (j k i puzzle) - (declare (ignore puzzle)) +(defun j-k-i-coordinates (j k i size) + (declare (ignore size)) (values i j k))
-(defun b-k-x-coordinates (b k x puzzle) - (let ((order (order (puzzle-size puzzle)))) +(defun b-k-x-coordinates (b k x size) + (let ((order (order size))) (values (+ (* order (floor b order)) (floor x order)) (+ (* order (mod b order)) (mod x order)) - k))) \ No newline at end of file + k))) + +(defun group-solved (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (= 1 (iter (for z below size) + (count (elt-true-p (multiple-value-call + #'puzzle-elt puzzle + (funcall x-y-z-function x y z size)))))))) +