Author: abaine Date: Sat Aug 18 16:45:39 2007 New Revision: 140
Modified: trunk/funds/src/examples/sudoku.lisp Log: Working solver.
Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 16:45:39 2007 @@ -24,9 +24,6 @@ (defun elt-true-p (elt) (and elt (= elt +true+)))
-(defun elt-false-p (elt) - (and elt (= elt +false+))) - (defun elt-unknown-p (elt) (null elt))
@@ -139,7 +136,7 @@ (collect (or (puzzle-elt puzzle i j k) "")))))))))
-(defun best-solver (puzzle) +(defun solve (puzzle) (iter (for f in (list #'best-row #'best-column #'best-number @@ -190,18 +187,26 @@ (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c) (finally (return (enlarge-zero c size) )))))
+ + + (defun column-freedom (puzzle j k) (let ((size (puzzle-size puzzle))) (iter (for i below size) (counting (elt-unknown-p (puzzle-elt puzzle i j k)) into c) (finally (return (enlarge-zero c size))))))
+ + (defun number-freedom (puzzle i j) (let ((size (puzzle-size puzzle))) (iter (for k below size) (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))) @@ -219,3 +224,56 @@ (if (zerop count) (1+ size) count)) + +(defun solve-row (puzzle i k) + (solve-group puzzle #'i-k-j-coordinates i k)) + +(defun solve-column (puzzle j k) + (solve-group puzzle #'j-k-i-coordinates j k)) + +(defun solve-number (puzzle i j) + (solve-group puzzle #'i-j-k-coordinates i j)) + +(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)))))))) + + (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)) + (values i j k)) + +(defun i-k-j-coordinates (i k j puzzle) + (declare (ignore puzzle)) + (values i j k)) + +(defun j-k-i-coordinates (j k i puzzle) + (declare (ignore puzzle)) + (values i j k)) + +(defun b-k-x-coordinates (b k x puzzle) + (let ((order (order (puzzle-size puzzle)))) + (values (+ (* order (floor b order)) + (floor x order)) + (+ (* order (mod b order)) + (mod x order)) + k))) \ No newline at end of file