[funds-cvs] r140 - trunk/funds/src/examples

[abaine at common-lisp.net]

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