funds-cvs August 2007

funds-cvs@common-lisp.net

1 participants
113 discussions

[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

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

18 Aug '07

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

1 0

[funds-cvs] r137 - in trunk/funds/src: . examples
by abaine＠common-lisp.net 17 Aug '07

17 Aug '07

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

1 0

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

16 Aug '07

Author: abaine Date: Wed Aug 15 23:28:16 2007 New Revision: 136 Modified: trunk/funds/src/examples/sudoku.lisp Log: Closer to working solver. Modified: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- trunk/funds/src/examples/sudoku.lisp (original) +++ trunk/funds/src/examples/sudoku.lisp Wed Aug 15 23:28:16 2007 @@ -104,7 +104,6 @@ (+ (start j order) (mod index order)))) - (defun start (x order) (* order (floor x order))) @@ -142,3 +141,70 @@ (+ (* order (mod box order)) (mod index order)) number))) + +(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))))))) + +(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 ))))) +)))) + + + + +(defun i-j-k-coordinates (i j k) + (values i j k)) + +(defun j-k-i-coordinates (j k i) + (values i j k)) + +(defun k-i-j-coordinates (k i j) + (values i j k)) \ No newline at end of file

1 0

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

14 Aug '07

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

1 0

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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

funds-cvs August 2007