funds-cvs

funds-cvs@common-lisp.net

225 discussions

[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

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

11 Aug '07

Author: abaine Date: Fri Aug 10 20:12:23 2007 New Revision: 134 Added: trunk/funds/src/examples/ trunk/funds/src/examples/sudoku.lisp Log: Added sudoku example file. Added: trunk/funds/src/examples/sudoku.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/examples/sudoku.lisp Fri Aug 10 20:12:23 2007 @@ -0,0 +1,16 @@ + +(in-package :funds) + +(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)))) + + + +

1 0

[funds-cvs] r133 - trunk/funds/src
by abaine＠common-lisp.net 10 Aug '07

10 Aug '07

Author: abaine Date: Fri Aug 10 18:33:42 2007 New Revision: 133 Modified: trunk/funds/src/package.lisp Log: Exported f-array-size. Modified: trunk/funds/src/package.lisp ============================================================================== --- trunk/funds/src/package.lisp (original) +++ trunk/funds/src/package.lisp Fri Aug 10 18:33:42 2007 @@ -55,4 +55,5 @@ :make-f-array :f-array-elt - :f-array-replace)) + :f-array-replace + :f-array-size))

1 0

[funds-cvs] r132 - trunk/funds/src
by abaine＠common-lisp.net 10 Aug '07

10 Aug '07

Author: abaine Date: Fri Aug 10 18:32:46 2007 New Revision: 132 Modified: trunk/funds/src/f-array.lisp Log: Fixed f-array-size. Modified: trunk/funds/src/f-array.lisp ============================================================================== --- trunk/funds/src/f-array.lisp (original) +++ trunk/funds/src/f-array.lisp Fri Aug 10 18:32:46 2007 @@ -25,5 +25,5 @@ (labels ((f (tree amount) (if (tree-empty-p tree) amount - (f (bt-right tree) (bt-key tree))))) + (f (bt-right tree) (1+ (bt-key tree)))))) (f array 0)))

1 0

[funds-cvs] r131 - trunk/funds/src
by abaine＠common-lisp.net 10 Aug '07

10 Aug '07

Author: abaine Date: Fri Aug 10 18:26:43 2007 New Revision: 131 Modified: trunk/funds/src/f-array.lisp Log: Implemented f-array-elt, f-array-replace, and f-array-size. Modified: trunk/funds/src/f-array.lisp ============================================================================== --- trunk/funds/src/f-array.lisp (original) +++ trunk/funds/src/f-array.lisp Fri Aug 10 18:26:43 2007 @@ -16,7 +16,14 @@ (f 0 size)))) (defun f-array-elt (array index) - ) + (tree-find array index :test #'=)) (defun f-array-replace (array index item) - ) + (tree-insert array index item :test #'=)) + +(defun f-array-size (array) + (labels ((f (tree amount) + (if (tree-empty-p tree) + amount + (f (bt-right tree) (bt-key tree))))) + (f array 0)))

1 0

[funds-cvs] r130 - trunk/funds/src
by abaine＠common-lisp.net 10 Aug '07

10 Aug '07

Author: abaine Date: Fri Aug 10 18:15:27 2007 New Revision: 130 Modified: trunk/funds/src/f-array.lisp Log: Implemented make-f-array. Modified: trunk/funds/src/f-array.lisp ============================================================================== --- trunk/funds/src/f-array.lisp (original) +++ trunk/funds/src/f-array.lisp Fri Aug 10 18:15:27 2007 @@ -2,7 +2,18 @@ (in-package :funds) (defun make-f-array (size &key (initial-contents nil)) - ) + (let ((length (length initial-contents))) + (labels ((f (start end) + (if (= start end) + (make-binary-tree) + (let ((midpoint (floor (+ end start) 2))) + (make-instance 'binary-tree + :key midpoint :value (if (< start length) + (elt initial-contents midpoint) + nil) + :left (f start midpoint) + :right (f (1+ midpoint) end)))))) + (f 0 size)))) (defun f-array-elt (array index) )

1 0

[funds-cvs] r129 - trunk/funds/src/trees
by abaine＠common-lisp.net 10 Aug '07

10 Aug '07

Author: abaine Date: Fri Aug 10 18:14:53 2007 New Revision: 129 Modified: trunk/funds/src/trees/tree-find.lisp Log: Corrected problem with tree-find algorithm. Modified: trunk/funds/src/trees/tree-find.lisp ============================================================================== --- trunk/funds/src/trees/tree-find.lisp (original) +++ trunk/funds/src/trees/tree-find.lisp Fri Aug 10 18:14:53 2007 @@ -39,4 +39,4 @@ (cond ((funcall test key (bt-key tree)) (values (bt-value tree) t)) ((funcall order key (bt-key tree)) (tree-find (bt-left tree) key :test test :order order)) - (t (tree-find (bt-left tree) key :test test :order order)))) + (t (tree-find (bt-right tree) key :test test :order order))))

1 0

← Newer
1
...
6
7
8
9
10
11
12
...
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