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

[abaine at common-lisp.net]

Author: abaine
Date: Sat Aug 18 20:19:01 2007
New Revision: 144

Modified:
   trunk/funds/src/examples/sudoku.lisp
Log:
Solver's getting good.

Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp	(original)
+++ trunk/funds/src/examples/sudoku.lisp	Sat Aug 18 20:19:01 2007
@@ -122,40 +122,19 @@
       (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))
-
-(defun best-column (puzzle)
-  (best-group puzzle #'column-freedom))
+      (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))))))
 
-(defun best-number (puzzle)
-  (best-group puzzle #'number-freedom))
-
-(defun best-box (puzzle)
-  (best-group puzzle #'box-freedom))
-
-(defun best-group (puzzle freedom-function)
+(defun best-group (puzzle x-y-z-function)
   (let ((size (puzzle-size puzzle)))
     (iter (for x below size)
 	  (for (values y n) = 
 	       (iter (for y below size)
-		     (for n = (funcall freedom-function puzzle x y))
+		     (for n = (group-freedom puzzle x-y-z-function x y))
 		     (finding y minimizing n into (best-y min))
 		     (when (= min 1)
 		       (return (values best-y min)))
@@ -166,65 +145,19 @@
 	    (return (values best-x best-y best-n)))
 	  (finally (return (values best-x best-y best-n))))))
 
-(defun row-freedom (puzzle i k)
-  (let ((size (puzzle-size puzzle)))
-    (iter (for j below size)
-	  (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)))
-    (iter (for x below size)
-	  (counting (elt-unknown-p (puzzle-elt puzzle 
-					       (+ (* order (floor b order))
-						  (floor x order))
-					       (+ (* order (mod b order))
-						  (mod x order))
-					       k))
-		    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)))))))
+    (enlarge-zero
+     (iter (for z below size)
+	   (counting (elt-unknown-p (multiple-value-call #'puzzle-elt puzzle
+							 (funcall x-y-z-function x y z size)))))
+     size)))
 
 (defun enlarge-zero (count size)
   (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 x-y-z-function x y)
   (let ((size (puzzle-size puzzle)))  
     (labels ((f (z)
@@ -246,12 +179,8 @@
   (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)))))))))
+		       (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))
@@ -279,3 +208,23 @@
 	       (count (elt-true-p (multiple-value-call
 				      #'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)
+	  (for elt = (multiple-value-call #'puzzle-elt
+		       puzzle (funcall x-y-z-function x y z size)))
+	  (thereis (or (elt-unknown-p elt)
+		       (elt-true-p elt))))))
+
+(defvar x-y-z-functions (list #'i-j-k-coordinates
+			      #'i-k-j-coordinates
+			      #'j-k-i-coordinates
+			      #'b-k-x-coordinates))