@@ -95,10 +95,14 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defun new-rule (rule-fun) "Defines a new instance of the RULE struct from the list generated by rule-fun." - (let ((rule (funcall rule-fun))) - (make-rule :list rule - :fun - (eval (list 'lambda '(num) (list 'ignore-errors rule)))))) + (labels ((gen-new-rule (fun) + (let ((rule (funcall fun))) + (make-rule :list rule + :fun + (eval (list 'lambda '(num) + rule)))))) + (do ((rule (gen-new-rule rule-fun) (gen-new-rule rule-fun))) + ((not (null (prune-bad-rules (list rule)))) rule)))) (defun add-to-rule-list (f list) @@ -174,8 +178,7 @@ replacing rules." `(progn (when (coin-flip) (setf ,rules (remove-random-item ,rules))) (when (coin-flip) (setf ,rules (add-to-rule-list ,rule-fun ,rules))) - (when (coin-flip) (setf ,rules (modify-rule-list ,rule-fun ,rules))) - (setf ,rules (prune-bad-rules ,rules)))) + (when (coin-flip) (setf ,rules (modify-rule-list ,rule-fun ,rules))))) (defun random-merge-rules (rule1 rule2) @@ -246,7 +249,7 @@ replacing rules." (let* ((cur-rule (aref *CURRENT-POPULATION* rulenum)) (rules-score (funcall fitness-fun cur-rule)) (rule-variation (copy-list cur-rule))) - (if (coin-flip) + (if (< 0 (random 6)) (mutate-rule-list rule-fun rule-variation) (breed-rules rule-variation (copy-list (random-array-element *CURRENT-POPULATION*)))) @@ -265,5 +268,7 @@ replacing rules." 'rule-fun', and the evaluation function is 'fitness-fun'" (setf *CURRENT-POPULATION* (prep-population starting-rules population-size)) (dotimes (gen-num generations) + (format t "~A~%" gen-num) + (sb-ext:gc :full t) ; SBCL's performance is awful without this (run-generation rule-fun fitness-fun))) genesis.lisp @@ -32,7 +32,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. and the input number.") -(defvar *sample-nodes* #(leaf + leaf - leaf / leaf * leaf) +(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.") @@ -45,10 +45,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (case elt (randomnum (random 1024)) (randomfrac - (let ((val (ignore-errors (/ (random 1024) (random 1024))))) - (when (null val) - (setf val (/ 1 2))) - val)) + (/ (random 1024) (+ (random 1024) 1))) (t elt)))) square-root-sample.lisp @@ -21,6 +21,10 @@ - [X] Replacement of random subsequences <2008-12-18 Thu 22:54> + +* Metrics +** TODO Allow progress functions to be defined and called. + * Performance ** TODO Multithreading todo.org bd7e41215e5aa40f2658744b6f0a952df4ceae6d Jake Voytko jakevoytko@gmail.com http://github.com/jakevoytko/genesis/commit/eee9a45ed864f5de5dbed6b987d99845134da92a eee9a45ed864f5de5dbed6b987d99845134da92a 2008-12-20T08:34:24-08:00 2008-12-20T08:34:24-08:00 Added manual garbage collection initiation in the main loop. SBCL's automatic GC kickoff is way too slow for this program. This cuts the runtime down by at least a factor of 10 on my machine. a835843418eefb9aaa18d159530ad470a767a564 Jake Voytko jakevoytko@gmail.com