square-root-sample.lisp @@ -25,6 +25,22 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |# + +(defpackage "GENESIS" + (:use "CL" "LISP-UNIT") + (:export "RULE" + "*CURRENT-POPULATION*" + "COIN-FLIP" + "AT-LEAST-ONCE" + "RANDOM-ARRAY-ELEMENT" + "GENETIC-ALGORITHM" + "FUNCALL-RULES" + "FUNCALL-BEST")) + +(in-package "GENESIS") + + + (defstruct RULE "Defines a Genesis rule, consisting of a function (of arbitrary arguments) and a list that evaluates to the function." @@ -40,56 +56,6 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. "Since some of the evolution functions cause the size of a rule set to grow non-linearly, we provide a maximum rule size.") -(defvar *sample-values* - #(-1 1 num num randomnum randomfrac) - "Sample values that can be produced. You can get either -1, 0, 1, - a random number between 0 and 1023, a fraction of random integers, - and the input number.") - - -(defvar *sample-nodes* #(leaf + leaf - leaf / leaf * leaf) - "Sample nodes: a leaf, +, -, /, and * - The leafs are the elements of sample-values, and have an equal - chance of appearing as a node does.") - - -(defun sample-generate-leaf (array) - "Picks a random element from 'list' and translates it into the proper atom - or list." - (let ((elt (random-array-element array))) - (case elt - (randomnum (random 1024)) - (randomfrac - (let ((val (ignore-errors (/ (random 1024) (random 1024))))) - (when (null val) - (setf val (/ 1 2))) - val)) - (t elt)))) - - -(defun sample-rule-fun () - "Example random rule generator. Generates a random arithmetical - expression." - (let ((elt (random-array-element *sample-nodes*))) - (case elt - (leaf (sample-generate-leaf *sample-values*)) - (t - (append (list elt) (at-least-once #'sample-rule-fun)))))) - - -(defun sample-fitness-function (rules) - "Evaluates made-rules by the sum of the squared error of the - integer square roots less than 100" - (catch 'abort - (let ((sqr-err 0)) - (dotimes (i 100) - (let ((res (funcall-rules rules i))) - (when (null res) - (throw 'abort 99999999999)) - (incf sqr-err (expt (- i (* res res)) 2)))) - sqr-err))) - - (defun prep-population (starting-rules population-size) "Sets 'rule-array' to an array of 'population-size' length, and with the initial element 'starting-rules'." @@ -158,6 +124,19 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (aref array (random (length array)))) +(defun funcall-best (population fitness-fun arg) + "Calls (funcall-rules .. 'arg') with the best function in 'population' + as determined by 'fitness-fun'" + (funcall-rules + (reduce (lambda (a b) + (let ((fit-a (funcall fitness-fun a)) + (fit-b (funcall fitness-fun a))) + (if (< fit-a fit-b) a b))) + population) + arg)) + + + (defun funcall-rules (rules arg) "Actually perform a function call with the rules!" (let ((val arg)) @@ -238,3 +217,4 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (setf *CURRENT-POPULATION* (prep-population starting-rules population-size)) (dotimes (gen-num generations) (run-generation rule-fun fitness-fun))) + genesis.lisp @@ -28,24 +28,24 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (require "../genesis.lisp") ;; Test the function prep-population in genesis.lisp. -(define-test test-prep-population +(lisp-unit:define-test test-prep-population (let ((population (prep-population nil 5))) (format t "~A~%" population) - (assert-equal 5 (length population)) + (lisp-unit:assert-equal 5 (length population)) (dotimes (i 5) - (assert-true (null (aref population 0))))) + (lisp-unit:assert-true (null (aref population 0))))) (let ((population (prep-population "HELLO" 1))) - (assert-equal 1 (length population)) - (assert-equal "HELLO" (aref population 0)))) + (lisp-unit:assert-equal 1 (length population)) + (lisp-unit:assert-equal "HELLO" (aref population 0)))) ;; Test the function (coin-flip) in genesis.lisp. -(define-test test-coin-flip +(lisp-unit:define-test test-coin-flip (let ((t-called? nil) (nil-called? nil)) (dotimes (i 128) ;; Improbably low fail rate, quick to run. (if (coin-flip) (setf t-called? t) (setf nil-called? t))) - (assert-true t-called?) - (assert-true nil-called?))) + (lisp-unit:assert-true t-called?) + (lisp-unit:assert-true nil-called?))) test/genesis-test.lisp @@ -25,8 +25,10 @@ ** DONE Start tests for all standard functions. ** TODO Add tests for all standard functions. ** TODO Make a package. +** TODO Split project into proper files. ** TODO Form into an asdf-install package. -** TODO Figure out where I'm documenting this piece. +** TODO Figure out where I'm documenting this piece. * Interface -** Give key arguments to give (genetic-algorithm) much more control. +** TODO Give key arguments to give (genetic-algorithm) much more control. +** TODO (funcall-best population) todo.org 4a1e641e38b6e1c6bb4d6f523cc3f761e0ea4b48 Jake Voytko jakevoytko@gmail.com http://github.com/jakevoytko/genesis/commit/b2cc9e9bd1238a4570f7820e3dd98bdc5b1f5441 b2cc9e9bd1238a4570f7820e3dd98bdc5b1f5441 2008-12-13T09:03:00-08:00 2008-12-13T09:03:00-08:00 Added 'funcall-best', which allows you to call the best rule in a population (according to some fitness function) automatically. Split the square root sample into its own file. Added a function that allows you to run the sample (square-root-sample generations population-size). Moved Genesis into a package, and modified the tests to reflect this. c0b1a2fd0a69f0c73d63c29e606d49eca314097b Jake Voytko jakevoytko@gmail.com