funds-cvs

funds-cvs@common-lisp.net

225 discussions

[funds-cvs] r148 - trunk/funds/src/examples
by abaine＠common-lisp.net 19 Aug '07

19 Aug '07

Author: abaine Date: Sun Aug 19 11:03:31 2007 New Revision: 148 Added: trunk/funds/src/examples/puzzles.lisp Log: Added puzzles. Added: trunk/funds/src/examples/puzzles.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/examples/puzzles.lisp Sun Aug 19 11:03:31 2007 @@ -0,0 +1,22 @@ + +(in-package :funds-examples) + +(defconstant p1 '((7 0 0 1 0 8 0 0 0) + (0 9 0 0 0 0 0 3 2) + (0 0 0 0 0 5 0 0 0) + (0 0 0 0 0 0 1 0 0) + (9 6 0 0 2 0 0 0 0) + (0 0 0 0 0 0 8 0 0) + (0 0 0 0 0 0 0 0 0) + (0 0 5 0 0 1 0 0 0) + (3 2 0 0 0 0 0 0 6))) + +(defconstant p2 '((0 8 2 0 1 0 0 0 0) + (7 0 0 0 0 0 0 3 0) + (0 0 0 0 0 6 0 0 5) + (0 0 0 0 0 0 0 8 0) + (3 0 0 7 0 0 0 0 0) + (0 0 0 0 0 0 1 0 4) + (4 0 1 0 0 0 0 0 6) + (0 0 0 0 5 0 0 0 0) + (0 0 0 8 0 0 0 0 0)))

1 0

[funds-cvs] r147 - trunk/funds/src/examples
by abaine＠common-lisp.net 19 Aug '07

19 Aug '07

Author: abaine Date: Sun Aug 19 11:03:03 2007 New Revision: 147 Modified: trunk/funds/src/examples/funds-examples.asd Log: Added puzzles to defsystem. Modified: trunk/funds/src/examples/funds-examples.asd ============================================================================== --- trunk/funds/src/examples/funds-examples.asd (original) +++ trunk/funds/src/examples/funds-examples.asd Sun Aug 19 11:03:03 2007 @@ -11,5 +11,6 @@ (defsystem funds-examples :serial t :components ((:file "package") - (:file "sudoku")) + (:file "sudoku") + (:file "puzzles")) :depends-on (:iterate :funds))

1 0

[funds-cvs] r146 - trunk/funds/src/examples
by abaine＠common-lisp.net 19 Aug '07

19 Aug '07

Author: abaine Date: Sun Aug 19 10:58:45 2007 New Revision: 146 Modified: trunk/funds/src/examples/package.lisp Log: Exported solve from example. Modified: trunk/funds/src/examples/package.lisp ============================================================================== --- trunk/funds/src/examples/package.lisp (original) +++ trunk/funds/src/examples/package.lisp Sun Aug 19 10:58:45 2007 @@ -2,4 +2,6 @@ (in-package :cl-user) (defpackage :funds-examples - (:use :cl :funds :iterate)) \ No newline at end of file + (:use :cl :funds :iterate) + (:export :solve + :p1 :p2)) \ No newline at end of file

1 0

[funds-cvs] r145 - trunk/funds/src/examples
by abaine＠common-lisp.net 19 Aug '07

19 Aug '07

Author: abaine Date: Sat Aug 18 21:02:29 2007 New Revision: 145 Modified: trunk/funds/src/examples/sudoku.lisp Log: Good solver. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 21:02:29 2007 @@ -8,18 +8,8 @@ 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)) + (tree-find (puzzle-tree puzzle) (index i j k (puzzle-size puzzle)))) (defun elt-true-p (elt) (and elt (= elt +true+))) @@ -48,6 +38,24 @@ (return (1+ k))) (finally (return 0))))))))) +(defun puzzle-complete-p (puzzle) + (= (tree-weight (puzzle-tree puzzle)) + (round (expt (puzzle-size puzzle) 3)))) + +(defun puzzle-solved-p (puzzle) + (let ((size (puzzle-size puzzle))) + (iter (for x below size) + (always (iter (for y below size) + (always (iter (for f in x-y-z-functions) + (always (group-solved puzzle f x y))))))))) + +(defun puzzle-solvable-p (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 fill-true (puzzle i j k) (fill-falses (set-to-true puzzle i j k) i j k)) @@ -118,16 +126,16 @@ ""))))))))) (defun solve (puzzle) - (if (complete-p puzzle) - (if (solved-p puzzle) + (if (puzzle-solvable-p puzzle) + (if (puzzle-complete-p puzzle) puzzle - nil) - (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)))))) + (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))))) + nil)) (defun best-group (puzzle x-y-z-function) (let ((size (puzzle-size puzzle))) @@ -164,24 +172,12 @@ (if (= z size) nil (multiple-value-bind (i j k) (funcall x-y-z-function x y z size) - (if (puzzle-elt-solved puzzle i j k) + (if (puzzle-elt puzzle i j k) (f (1+ z)) (or (solve (fill-true puzzle i j k)) (f (1+ z)))))))) - (f 0)))) -(defun complete-p (puzzle) - (= (tree-weight (puzzle-tree puzzle)) - (round (expt (puzzle-size puzzle) 3)))) - -(defun solved-p (puzzle) - (let ((size (puzzle-size puzzle))) - (iter (for x below size) - (always (iter (for y below size) - (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)) (values i j k)) @@ -209,13 +205,6 @@ #'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)

1 0

[funds-cvs] r144 - trunk/funds/src/examples
by abaine＠common-lisp.net 19 Aug '07

19 Aug '07

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

1 0

[funds-cvs] r143 - trunk/funds/src/examples
by abaine＠common-lisp.net 18 Aug '07

18 Aug '07

Author: abaine Date: Sat Aug 18 19:43:06 2007 New Revision: 143 Modified: trunk/funds/src/examples/sudoku.lisp Log: Improved solver. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 19:43:06 2007 @@ -52,25 +52,14 @@ (fill-falses (set-to-true puzzle i j k) 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 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)) + (let ((b (box-number puzzle i j))) + (reduce #'(lambda (p group) + (apply #'fill-falses-group-2 p group)) + (list (list #'i-j-k-coordinates i j) + (list #'j-k-i-coordinates j k) + (list #'i-k-j-coordinates i k) + (list #'b-k-x-coordinates b k)) + :initial-value puzzle))) (defun fill-falses-group (puzzle c-function i j k) (let ((size (puzzle-size puzzle))) @@ -97,27 +86,6 @@ (1+ z))))) (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 set-to-true (puzzle i j k) (set-value puzzle i j k +true+))

1 0

[funds-cvs] r142 - trunk/funds/src/examples
by abaine＠common-lisp.net 18 Aug '07

18 Aug '07

Author: abaine Date: Sat Aug 18 19:15:57 2007 New Revision: 142 Modified: trunk/funds/src/examples/sudoku.lisp Log: Box-number. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 19:15:57 2007 @@ -82,6 +82,21 @@ (1+ x))))) (f puzzle 0)))) +(defun box-number (puzzle i j) + (let ((order (order (puzzle-size puzzle)))) + (+ (* order (floor i order)) + (floor j order)))) + +(defun fill-falses-group-2 (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (labels ((f (puzzle z) + (if (= z size) + puzzle + (f (multiple-value-call #'set-to-false + puzzle (funcall x-y-z-function x y z size)) + (1+ z))))) + (f puzzle 0)))) + (defun box-coordinates (i j k x size) (let ((order (order size))) (values (+ (* order (floor i order)) @@ -296,4 +311,3 @@ (count (elt-true-p (multiple-value-call #'puzzle-elt puzzle (funcall x-y-z-function x y z size)))))))) -

1 0

[funds-cvs] r141 - trunk/funds/src/examples
by abaine＠common-lisp.net 18 Aug '07

18 Aug '07

Author: abaine Date: Sat Aug 18 18:56:29 2007 New Revision: 141 Modified: trunk/funds/src/examples/sudoku.lisp Log: Minor changes to solver. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 18:56:29 2007 @@ -60,8 +60,6 @@ i j k) i j k)) - - (defun fill-falses-row (puzzle i j k) (fill-falses-group puzzle #'row-coordinates i j k) ) @@ -137,21 +135,25 @@ ""))))))))) (defun solve (puzzle) - (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))))) + (if (complete-p puzzle) + (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)) @@ -204,9 +206,6 @@ (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))) @@ -220,6 +219,12 @@ 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))))))) + (defun enlarge-zero (count size) (if (zerop count) (1+ size) @@ -237,43 +242,58 @@ (defun solve-box (puzzle b k) (solve-group puzzle #'b-k-x-coordinates b k)) -(defun solve-group (puzzle c-function x y) - (if (complete-p puzzle) - puzzle - (let ((size (puzzle-size puzzle))) - (labels ((f (z) - (if (= z size) nil - (multiple-value-bind (i j k) - (funcall c-function x y z puzzle) - (if (puzzle-elt-solved puzzle i j k) - (f (1+ z)) - (or (solve (multiple-value-call - #'fill-true puzzle - (funcall c-function x y z puzzle))) - (f (1+ z)))))))) +(defun solve-group (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (labels ((f (z) + (if (= z size) nil + (multiple-value-bind (i j k) + (funcall x-y-z-function x y z size) + (if (puzzle-elt-solved puzzle i j k) + (f (1+ z)) + (or (solve (fill-true puzzle i j k)) + (f (1+ z)))))))) - (f 0))))) + (f 0)))) (defun complete-p (puzzle) (= (tree-weight (puzzle-tree puzzle)) (round (expt (puzzle-size puzzle) 3)))) -(defun i-j-k-coordinates (i j k puzzle) - (declare (ignore puzzle)) +(defun solved-p (puzzle) + (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))))))))) + +(defun i-j-k-coordinates (i j k size) + (declare (ignore size)) (values i j k)) -(defun i-k-j-coordinates (i k j puzzle) - (declare (ignore puzzle)) +(defun i-k-j-coordinates (i k j size) + (declare (ignore size)) (values i j k)) -(defun j-k-i-coordinates (j k i puzzle) - (declare (ignore puzzle)) +(defun j-k-i-coordinates (j k i size) + (declare (ignore size)) (values i j k)) -(defun b-k-x-coordinates (b k x puzzle) - (let ((order (order (puzzle-size puzzle)))) +(defun b-k-x-coordinates (b k x size) + (let ((order (order size))) (values (+ (* order (floor b order)) (floor x order)) (+ (* order (mod b order)) (mod x order)) - k))) \ No newline at end of file + k))) + +(defun group-solved (puzzle x-y-z-function x y) + (let ((size (puzzle-size puzzle))) + (= 1 (iter (for z below size) + (count (elt-true-p (multiple-value-call + #'puzzle-elt puzzle + (funcall x-y-z-function x y z size)))))))) +

1 0

[funds-cvs] r140 - trunk/funds/src/examples
by abaine＠common-lisp.net 18 Aug '07

18 Aug '07

Author: abaine Date: Sat Aug 18 16:45:39 2007 New Revision: 140 Modified: trunk/funds/src/examples/sudoku.lisp Log: Working solver. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 16:45:39 2007 @@ -24,9 +24,6 @@ (defun elt-true-p (elt) (and elt (= elt +true+))) -(defun elt-false-p (elt) - (and elt (= elt +false+))) - (defun elt-unknown-p (elt) (null elt)) @@ -139,7 +136,7 @@ (collect (or (puzzle-elt puzzle i j k) ""))))))))) -(defun best-solver (puzzle) +(defun solve (puzzle) (iter (for f in (list #'best-row #'best-column #'best-number @@ -190,18 +187,26 @@ (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))) @@ -219,3 +224,56 @@ (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 c-function x y) + (if (complete-p puzzle) + puzzle + (let ((size (puzzle-size puzzle))) + (labels ((f (z) + (if (= z size) nil + (multiple-value-bind (i j k) + (funcall c-function x y z puzzle) + (if (puzzle-elt-solved puzzle i j k) + (f (1+ z)) + (or (solve (multiple-value-call + #'fill-true puzzle + (funcall c-function x y z puzzle))) + (f (1+ z)))))))) + + (f 0))))) + +(defun complete-p (puzzle) + (= (tree-weight (puzzle-tree puzzle)) + (round (expt (puzzle-size puzzle) 3)))) + +(defun i-j-k-coordinates (i j k puzzle) + (declare (ignore puzzle)) + (values i j k)) + +(defun i-k-j-coordinates (i k j puzzle) + (declare (ignore puzzle)) + (values i j k)) + +(defun j-k-i-coordinates (j k i puzzle) + (declare (ignore puzzle)) + (values i j k)) + +(defun b-k-x-coordinates (b k x puzzle) + (let ((order (order (puzzle-size puzzle)))) + (values (+ (* order (floor b order)) + (floor x order)) + (+ (* order (mod b order)) + (mod x order)) + k))) \ No newline at end of file

1 0

[funds-cvs] r139 - trunk/funds/src/examples
by abaine＠common-lisp.net 18 Aug '07

18 Aug '07

Author: abaine Date: Sat Aug 18 01:45:36 2007 New Revision: 139 Modified: trunk/funds/src/examples/sudoku.lisp Log: Continued improving example. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Sat Aug 18 01:45:36 2007 @@ -27,6 +27,9 @@ (defun elt-false-p (elt) (and elt (= elt +false+))) +(defun elt-unknown-p (elt) + (null elt)) + (defun puzzle-from-list (list-rep) (labels ((f (puzzle list row i j) (cond ((null list) puzzle) @@ -136,4 +139,83 @@ (collect (or (puzzle-elt puzzle i j k) ""))))))))) +(defun best-solver (puzzle) + (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)) + +(defun best-number (puzzle) + (best-group puzzle #'number-freedom)) + +(defun best-box (puzzle) + (best-group puzzle #'box-freedom)) + +(defun best-group (puzzle freedom-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)) + (finding y minimizing n into (best-y min)) + (when (= min 1) + (return (values best-y min))) + (finally (return (values best-y min))))) + (finding x minimizing n into best-x) + (finding y minimizing n into (best-y best-n)) + (when (= best-n 1) + (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 enlarge-zero (count size) + (if (zerop count) + (1+ size) + count))

1 0

← Newer
1
...
5
6
7
8
9
10
11
...
23
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs