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) + ""))))))))) + +