[funds-cvs] r138 - trunk/funds/src/examples
abaine at common-lisp.net
abaine at common-lisp.net
Sat Aug 18 03:08:21 UTC 2007
Author: abaine
Date: Fri Aug 17 23:08:21 2007
New Revision: 138
Modified:
trunk/funds/src/examples/package.lisp
trunk/funds/src/examples/sudoku.lisp
Log:
Improved example.
Modified: trunk/funds/src/examples/package.lisp
==============================================================================
--- trunk/funds/src/examples/package.lisp (original)
+++ trunk/funds/src/examples/package.lisp Fri Aug 17 23:08:21 2007
@@ -2,4 +2,4 @@
(in-package :cl-user)
(defpackage :funds-examples
- (:use :funds :iterate))
\ No newline at end of file
+ (:use :cl :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 Fri Aug 17 23:08:21 2007
@@ -1,202 +1,139 @@
-(in-package :funds)
+(in-package :funds-examples)
(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
+ 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))
+
+(defun elt-true-p (elt)
+ (and elt (= elt +true+)))
+
+(defun elt-false-p (elt)
+ (and elt (= elt +false+)))
+
(defun puzzle-from-list (list-rep)
- (let ((size (length 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)))))
+ (labels ((f (puzzle list row i j)
+ (cond ((null list) puzzle)
+ ((null row) (f puzzle (rest list) (first (rest list)) (1+ i) 0))
+ (t (f (if (zerop (first row))
+ puzzle
+ (fill-true puzzle i j (1- (first row))))
+ list (rest row) i (1+ j))))))
+ (f (make-puzzle :size (length list-rep)
+ :tree (make-avl-tree))
+ list-rep (first list-rep) 0 0)))
(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))))
+ (iter (for i below size)
+ (collect (iter (for j below size)
+ (collect (iter (for k below size)
+ (when (elt-true-p (puzzle-elt puzzle i j k))
+ (return (1+ k)))
+ (finally (return 0)))))))))
-(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 fill-true (puzzle i j k)
+ (fill-falses (set-to-true puzzle i j k) 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 fill-falses (puzzle i j k)
+ (fill-falses-row
+ (fill-falses-column
+ (fill-falses-number
+ (fill-falses-box puzzle i j k)
+ i j k)
+ i j k)
+ 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)
+
+(defun fill-falses-row (puzzle i j k)
+ (fill-falses-group puzzle #'row-coordinates i j k) )
+
+(defun fill-falses-column (puzzle i j k)
+ (fill-falses-group puzzle #'column-coordinates i j k))
+
+(defun fill-falses-number (puzzle i j k)
+ (fill-falses-group puzzle #'number-coordinates i j k))
+
+(defun fill-falses-box (puzzle i j k)
+ (fill-falses-group puzzle #'box-coordinates i j k))
+
+(defun fill-falses-group (puzzle c-function 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))))
+ (labels ((f (puzzle x)
+ (if (= x size)
+ puzzle
+ (f (multiple-value-call #'set-to-false
+ puzzle (funcall c-function i j k x size))
+ (1+ x)))))
+ (f puzzle 0))))
+
+(defun box-coordinates (i j k x size)
+(let ((order (order size)))
+ (values (+ (* order (floor i order))
+ (floor x order))
+ (+ (* order (floor j order))
+ (mod x order))
+ k)))
+
+
+(defun row-coordinates (i j k x size)
+ (declare (ignore i size))
+ (values x j k))
+
+(defun column-coordinates (i j k x size)
+ (declare (ignore j size))
+ (values i x k))
+
+(defun number-coordinates (i j k x size)
+ (declare (ignore k size))
+ (values i j x))
-(defun start (x order)
- (* order (floor x order)))
+(defun set-to-true (puzzle i j k)
+ (set-value puzzle i j k +true+))
+(defun set-to-false (puzzle i j k)
+ (set-value puzzle i j k +false+))
+
+(defun set-value (puzzle i j k value)
+ (if (puzzle-elt puzzle i j k)
+ puzzle
+ (let ((size (puzzle-size puzzle)))
+ (make-puzzle :size size
+ :tree (tree-insert (puzzle-tree puzzle)
+ (index i j k size)
+ value)))))
(defun order (size)
(round (sqrt size)))
-(defun index-from-coordinates (i j k size)
+(defun index (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)
+(defun debug-print (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)))
-
-(defun solve (puzzle)
- (cond ((complete-p puzzle) puzzle)
- ((not (solvable-p puzzle)) nil)
- (t (multiple-value-call #'solve-by-group
- puzzle (most-constrained-group)))))
-
-(defun most-constrained-coordinates (puzzle)
- (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 j-k-i-coordinates (j k i size)
- (declare (ignore size))
- (values i j k))
-
-(defun k-i-j-coordinates (k i j size)
- (declare (ignore size))
- (values i j k))
-
-(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)))
+ (iter (for k below size)
+ (format t "~%~%~{~&~{~2A~}~}"
+ (iter (for i below size)
+ (collect (iter (for j below size)
+ (collect (or (puzzle-elt puzzle i j k)
+ "")))))))))
+
+
More information about the Funds-cvs
mailing list