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

[abaine at common-lisp.net]

Author: abaine
Date: Tue Aug 14 00:48:37 2007
New Revision: 135

Modified:
   trunk/funds/src/examples/sudoku.lisp
Log:
Start of a solver added.

Modified: trunk/funds/src/examples/sudoku.lisp
==============================================================================
--- trunk/funds/src/examples/sudoku.lisp	(original)
+++ trunk/funds/src/examples/sudoku.lisp	Tue Aug 14 00:48:37 2007
@@ -1,16 +1,144 @@
 
 (in-package :funds)
 
+(defconstant +false+ 0)
+(defconstant +true+ 1)
+(defconstant +unknown+ 2)
+
+(defun true-p (n) (= n +true+))
+(defun false-p (n) (= n +false+))
+(defun unknown-p (n) (= n +unknown+))
+(defun solved-p (n) (not (unknown-p n)))
+
+(defun range (size)
+  (case size 
+    (0 '())
+    (1 '(1))
+    (4 '(0 1 2 3))
+    (9 '(0 1 2 3 4 5 6 7 8))
+    (25 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24))
+    (otherwise (loop for i below size collecting i))))
+
+(defstruct puzzle
+  size 
+  tree)
+
 (defun puzzle-from-list (list-rep)
   (let ((size (length list-rep)))
-    (make-f-array (expt size 3)
-		  :initial-contents (mapcan #'(lambda (row)
-						(mapcan #'(lambda (elt)
-							    (loop for i below size 
-								  collect (= i (1- elt))))
-							row))
-					    list-rep))))
-
-
-
-
+    (make-puzzle 
+     :size size
+     :tree
+     (make-f-array (expt size 3)
+		   :initial-contents 
+		   (mapcan #'(lambda (row)
+			       (mapcan #'(lambda (elt)
+					   (loop for i below size 
+						 collect (cond ((zerop elt) +unknown+)
+							       ((= i (1- elt)) +true+)
+							       (t +false+))))
+				       row))
+			   list-rep)))))
+
+(defun list-from-puzzle (puzzle)
+  (let ((size (puzzle-size puzzle)))
+    (loop for i below size collect 
+	  (loop for j below size collect
+		(loop for k below size
+		      when (true-p (puzzle-elt puzzle i j k))
+		      do (return (1+ k))
+		      finally (return 0))))))
+
+(defun puzzle-elt (puzzle row column number)
+  (f-array-elt (puzzle-tree puzzle) 
+	       (index-from-coordinates row column number (puzzle-size puzzle))))
+
+(defun puzzle-complete (puzzle)
+  (let ((size (puzzle-size puzzle)))
+    (loop for i below size always
+	  (loop for j below size always
+		(loop for k below size always
+		      (not (unknown-p (puzzle-elt puzzle i j k))))))))
+
+(defun set-to-true (puzzle i j k)
+  (fill-falses (make-puzzle :size (puzzle-size puzzle)
+			    :tree (tree-insert (puzzle-tree puzzle)
+					       (index-from-coordinates 
+						i j k
+						(puzzle-size puzzle))
+					       +true+))
+	       i j k))
+
+(defun set-to-false (puzzle i j k)
+  (let ((size (puzzle-size puzzle)))
+    (make-puzzle :size size
+		 :tree (tree-insert (puzzle-tree puzzle)
+				    (index-from-coordinates i j k)
+				    +false+))))
+
+(defun fill-falses (puzzle i j k)
+  (let ((size (puzzle-size puzzle)))
+    (make-puzzle :size size 
+		 :tree (reduce #'(lambda (tree index)
+				   (reduce #'(lambda (tr x)
+					       (if (unknown-p (tree-find tr x))
+						   (tree-insert tr x +false+)
+						   tr))
+					   (list (index-from-coordinates i j index size)
+						 (index-from-coordinates i index k size)
+						 (index-from-coordinates index j k size)
+						 (index-from-coordinates
+						  (calc-i i j index size)
+						  (calc-j i j index size)
+						  k size))
+					   :initial-value tree))
+			       (range size)
+			       :initial-value (puzzle-tree puzzle)))))
+
+(defun calc-i (i j index size)
+  (let ((order (order size)))
+    (+ (start i order)
+       (floor index order))))
+
+(defun calc-j (i j index size)
+  (let ((order (order size)))
+    (+ (start j order)
+     (mod index order))))
+
+
+(defun start (x order)
+  (* order (floor x order)))
+
+(defun order (size)
+  (round (sqrt size)))
+
+(defun index-from-coordinates (i j k size)
+  (+ (* i size size)
+     (* j size)
+     k))
+
+(defun complete-p (puzzle)
+  (labels ((f (tree)
+	     (or (tree-empty-p tree)
+		 (and (solved-p (bt-value tree))
+		      (f (bt-left tree))
+		      (f (bt-right tree))))))
+    (f (puzzle-tree puzzle))))
+
+(defun solvable-p (puzzle)
+  (let ((size (puzzle-size puzzle)))
+    (loop for i below size always
+	  (loop for j below size always
+		(not (or (loop for k below size always (false-p (puzzle-elt puzzle i j k)))		       
+			 (loop for k below size always (false-p (puzzle-elt puzzle i k j)))
+			 (loop for k below size always (false-p (puzzle-elt puzzle k i j)))
+			 (loop for k below size always 
+			       (false-p (puzzle-elt-by-box puzzle i j k)))))))))
+
+(defun puzzle-elt-by-box (puzzle number box index)
+  (let ((order (order (puzzle-size puzzle))))
+    (puzzle-elt puzzle 
+		(+ (* order (floor box order))
+		   (floor index order))
+		(+ (* order (mod box order))
+		   (mod index order))
+		number)))