[funds-cvs] r137 - in trunk/funds/src: . examples

[abaine at common-lisp.net]

Author: abaine
Date: Thu Aug 16 23:41:22 2007
New Revision: 137

Added:
   trunk/funds/src/examples/funds-examples.asd
   trunk/funds/src/examples/package.lisp
Modified:
   trunk/funds/src/examples/sudoku.lisp
   trunk/funds/src/funds.asd
Log:
Improved example.

Added: trunk/funds/src/examples/funds-examples.asd
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/funds-examples.asd	Thu Aug 16 23:41:22 2007
@@ -0,0 +1,15 @@
+
+;;;; -*- Lisp -*-
+
+(in-package :cl-user)
+
+(defpackage #:funds-examples-asd
+  (:use :cl :asdf))
+
+(in-package :funds-examples-asd)
+
+(defsystem funds-examples
+  :serial t
+  :components ((:file "package")
+	       (:file "sudoku"))
+  :depends-on (:iterate :funds))

Added: trunk/funds/src/examples/package.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/src/examples/package.lisp	Thu Aug 16 23:41:22 2007
@@ -0,0 +1,5 @@
+
+(in-package :cl-user)
+
+(defpackage :funds-examples
+  (:use :funds :iterate))
\ No newline at end of file

Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp	(original)
+++ trunk/funds/src/examples/sudoku.lisp	Thu Aug 16 23:41:22 2007
@@ -145,66 +145,58 @@
 (defun solve (puzzle)
   (cond ((complete-p puzzle) puzzle)
 	((not (solvable-p puzzle)) nil)
-	(t (multiple-value-bind (x y z) (most-constrained-coordinates puzzle)
-	     (or (solve (set-to-true puzzle x y z))
-		 (solve (set-to-false puzzle x y z)))))))
+	(t (multiple-value-call #'solve-by-group
+	     puzzle (most-constrained-group)))))
 
 (defun most-constrained-coordinates (puzzle)
-  (let* ((best-i -1)
-	 (best-j -1)
-	 (best-k -1)
-	 (size (puzzle-size puzzle))
-	 (best-n (1+ size)))
-    (loop for i below size do
-	  when 
-	  finally (return (values best-i best-j best-k)))))
-
-
-
-(defun solve-row (puzzle j k)
-  (let ((size (puzzle-size puzzle)))
-    (labels ((f (puzzle i)
-	       (cond ((= i size) nil)
-		     ((solved-p (puzzle-elt puzzle i j k) (f puzzle (1+ i))))
-		     (t (or (solve (set-to-true puzzle i j k))
-			    (f (set-to-false puzzle i j k) (1+ i)))))))
-      (f puzzle 0))))
-
-(defun solve-column (puzzle i k)
-  (let ((size (puzzle-size puzzle)))
-    (labels ((f (puzzle j)
-	       (cond ((= j size) nil)
-		     ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ j)))
-		     (t (or (solve (set-to-true puzzle i j k))
-			    (f (set-to-false puzzle i j k) (1+ j)))))))
-      (f puzzle 0))))
-
-(defun solve-number (puzzle i j)
-  (let ((size (puzzle-size puzzle)))
-   (labels ((f (puzzle k)
-	      (cond ((= k size) nil)
-		    ((solved-p (puzzle-elt puzzle i j k)) (f puzzle (1+ k))
-		     (t (or (solve (set-to-true puzzle i j k))
-			    (f (set-to-false puzzle i j k) (1+ k))))))))
-     (f puzzle 0))))
-
-(defun solve-box (puzzle box number)
-  (let ((size (puzzle-size puzzle)))
-    (labels ((f (puzzle index)
-	       (cond ((= index size)nil)
-		     ((solved-p (puzzle-elt-by-box puzzle box number index)
-				(f (puzzle 1+ index)))
-		      (t (or solve )))))
-))))
-
-
+  (let ((best-c #'i-j-k-coordinates)
+	(best-x -1)
+	(best-y -1)
+	(size (puzzle-size puzzle))
+	(least-n nil))
+    (loop :for x :below size :do
+	  (loop :for y :below size :do
+		(loop :for c-function :in '(#'i-j-k-coordinates
+					    #'j-k-i-coordinates
+					    #'k-i-j-coordinates
+					    #'b-n-i-coordinates)
+		      :do (let ((n (loop :for z :below size :count
+					 (unknown-p (multiple-value-call 
+							#'puzzle-elt
+						      (c-function x y z size))))))
+			    (if (< n least-n)
+				(setf best-c c-function
+				      best-x x
+				      best-y y))))))
+    (values best-c best-x best-y)))
+
+(defun solve-by-group (puzzle c-function x y)
+  (let ((size (pussle-size puzzle)))
+    (labels ((f (puzzle z)
+	       (if (= index size)
+		   nil
+		   (multiple-value-bind (i j k) (funcall c-function x y z size)
+		     (if (solved-p (puzzle-elt puzzle i j k))
+			 (f puzzle (1+ z))
+			 (or (solve (set-to-true puzzle x y z))
+			     (f (set-to-false puzzle i j k) (1+ z)))))))))))
 
+(defun i-j-k-coordinates (i j k size)
+  (declare (ignore size))
+  (values i j k))
 
-(defun i-j-k-coordinates (i j k)
+(defun j-k-i-coordinates (j k i size)
+  (declare (ignore size))
   (values i j k))
 
-(defun j-k-i-coordinates (j k i)
+(defun k-i-j-coordinates (k i j size)
+  (declare (ignore size))
   (values i j k))
 
-(defun k-i-j-coordinates (k i j)
-  (values i j k))
\ No newline at end of file
+(defun b-n-i-coordinates (box number index size)
+  (let ((order (order size)))
+    (values (+ (* order (floor box order))
+	       (floor index order))
+	    (+ (* order (mod box order))
+	       (mod index order))
+	    number)))

Modified: trunk/funds/src/funds.asd
==============================================================================
--- trunk/funds/src/funds.asd	(original)
+++ trunk/funds/src/funds.asd	Thu Aug 16 23:41:22 2007
@@ -51,4 +51,3 @@
 	       (:file "f-array")
 	       (:file "dictionary")
 	       (:file "queue")))
-