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

[abaine at common-lisp.net]

Author: abaine
Date: Sat Aug 18 21:02:29 2007
New Revision: 145

Modified:
   trunk/funds/src/examples/sudoku.lisp
Log:
Good solver.

Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp	(original)
+++ trunk/funds/src/examples/sudoku.lisp	Sat Aug 18 21:02:29 2007
@@ -8,18 +8,8 @@
   size
   tree)
 
-(defun puzzle-find (puzzle i j k)
-  (multiple-value-bind (v found) 
-      (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle)))
-    (values v found)))
-
-(defun puzzle-elt-solved (puzzle i j k)
-  (multiple-value-bind (v found)
-      (puzzle-find puzzle i j k)
-    found))
-
 (defun puzzle-elt (puzzle i j k)
-  (puzzle-find puzzle i j k))
+  (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle))))
 
 (defun elt-true-p (elt)
   (and elt (= elt +true+)))
@@ -48,6 +38,24 @@
 					  (return (1+ k)))
 					(finally (return 0)))))))))
 
+(defun puzzle-complete-p (puzzle)
+  (= (tree-weight (puzzle-tree puzzle))
+     (round (expt (puzzle-size puzzle) 3))))
+
+(defun puzzle-solved-p (puzzle)
+  (let ((size (puzzle-size puzzle))) 
+    (iter (for x below size)
+	 (always (iter (for y below size)
+		       (always (iter (for f in x-y-z-functions)
+				     (always (group-solved puzzle f x y)))))))))
+
+(defun puzzle-solvable-p (puzzle)
+  (let ((size (puzzle-size puzzle)))
+    (iter (for f in x-y-z-functions)
+	  (always (iter (for x below size)
+			(always (iter (for y below size)
+				      (always (group-solvable puzzle f x y)))))))))
+
 (defun fill-true (puzzle i j k)
   (fill-falses (set-to-true puzzle i j k) i j k))
 
@@ -118,16 +126,16 @@
 					     "")))))))))
 
 (defun solve (puzzle)
-  (if (complete-p puzzle)
-      (if (solved-p puzzle)
+  (if (puzzle-solvable-p puzzle)
+      (if (puzzle-complete-p puzzle)
 	  puzzle
-	  nil)
-      (iter (for f in x-y-z-functions)
-	    (for (values x y n) = (best-group puzzle f))
-	    (finding (list f x y) minimizing n into (best-list min))
-	    (when (= min 1)
-	      (return (apply #'solve-group puzzle best-list)))
-	    (finally (return (apply #'solve-group puzzle best-list))))))
+	  (iter (for f in x-y-z-functions)
+		(for (values x y n) = (best-group puzzle f))
+		(finding (list f x y) minimizing n into (best-list min))
+		(when (= min 1)
+		  (return (apply #'solve-group puzzle best-list)))
+		(finally (return (apply #'solve-group puzzle best-list)))))
+      nil))
 
 (defun best-group (puzzle x-y-z-function)
   (let ((size (puzzle-size puzzle)))
@@ -164,24 +172,12 @@
 	       (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)
+		      (if (puzzle-elt puzzle i j k)
 			  (f (1+ z))
 			  (or (solve (fill-true puzzle i j k))
 			      (f (1+ z))))))))
-      
       (f 0))))
 
-(defun complete-p (puzzle)
-  (= (tree-weight (puzzle-tree puzzle))
-     (round (expt (puzzle-size puzzle) 3))))
-
-(defun solved-p (puzzle)
-  (let ((size (puzzle-size puzzle))) 
-    (iter (for x below size)
-	 (always (iter (for y below size)
-		       (always (iter (for f in x-y-z-functions)
-				     (always (group-solved puzzle f x y)))))))))
-
 (defun i-j-k-coordinates (i j k size)
   (declare (ignore size))
   (values i j k))
@@ -209,13 +205,6 @@
 				      #'puzzle-elt puzzle
 				      (funcall x-y-z-function x y z size))))))))
 
-(defun puzzle-solvable (puzzle)
-  (let ((size (puzzle-size puzzle)))
-    (iter (for f in x-y-z-functions)
-	  (always (iter (for x below size)
-			(always (iter (for y below size)
-				      (always (group-solvable puzzle f x y)))))))))
-
 (defun group-solvable (puzzle x-y-z-function x y)
   (let ((size (puzzle-size puzzle)))
     (iter (for z below size)