Created
October 9, 2015 02:45
-
-
Save orthecreedence/5629d528db3560321b8f to your computer and use it in GitHub Desktop.
Common Lisp optimal formula finder (using genetic algorithms)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(ql:quickload :bordeaux-threads) | |
(defpackage :genetic | |
(:use :cl)) | |
(in-package :genetic) | |
(defvar *target* 345) | |
(defun ^ (num pow) | |
(if (< pow 1) | |
1 | |
(* num (^ num (1- pow))))) | |
(defparameter *target-size* (^ 10 (length (write-to-string (abs *target*))))) | |
(defparameter *subform-probability* 0.3) | |
(defparameter *default-max-rand-value* (* *target-size* 2)) | |
(defparameter *symbol-table* #(+ - *)) | |
(defparameter *mutate-prob* 0.03) | |
(defparameter *mutate-value-max* 4) | |
(defparameter *fitness-survival-minimum* 1/1000) | |
(defparameter *num-animals* 64) | |
(defun random-symbol (&key exclude) | |
"Grab a random symbol from the global symbol table. Supports excluding of a | |
particular symbol (only one at the moment, though)." | |
(let ((symbol-table (if exclude | |
(remove-if (lambda (x) | |
(eql x exclude)) | |
*symbol-table*) | |
*symbol-table*))) | |
(aref symbol-table (random (length symbol-table))))) | |
(defun random-number (&key (max *default-max-rand-value*)) | |
"Wrapper around random number generator." | |
(random max)) | |
(defun random-genome (&key (min-depth 1) (max-depth 2) (depth-level 0)) | |
"Create a random genome." | |
(when (> depth-level max-depth) | |
(return-from random-genome (random-number))) | |
(if (or (< depth-level min-depth) (< (random 1.0) *subform-probability*)) | |
(list (random-symbol) | |
(random-genome :depth-level (1+ depth-level)) | |
(random-genome :depth-level (1+ depth-level))) | |
(random-number))) | |
(defmacro appendf (list value) | |
"Append a value to a list, destructive" | |
`(setf ,list (append ,list (list ,value)))) | |
(defun get-tree-locations (tree &key parent) | |
"Given a list (with or without embedded lists) find each leaf node of that | |
tree and compile a list of paths to get the them. For instance for the list: | |
'(1 2 (8 (3 4) 4)) | |
you get | |
((0) (1) (2 0) (2 1 0) (2 1 1) (2 2)) | |
Each one of those elements is an (nth ...)able set of values. For instance in | |
this case, the path (2 1 1) would expand to (nth 1 (nth 1 (nth 2 tree))), and | |
yield the value 4. | |
This is very useful for being able to locate/modify specific leaf nodes of a | |
tree by putting all the nodes in a flat list that's easy to select from." | |
(let ((locations nil) | |
(i 0) | |
(num-items 0)) | |
(dolist (leaf tree) | |
(let ((cur-loc (append parent (list i)))) | |
(if (listp leaf) | |
(multiple-value-bind (new-locations count) (get-tree-locations leaf :parent cur-loc) | |
(setf locations (append locations new-locations)) | |
(incf num-items count)) | |
(progn | |
(appendf locations cur-loc) | |
(incf num-items)))) | |
(incf i)) | |
(values locations | |
num-items))) | |
(defun get-tree-location-from-path (tree tree-path) | |
"Takes a path generated by get-tree-locations and given the same tree given to | |
get-tree-locations, will return the parent list of the element referenced by | |
the path and the nth element of the parent list the value exists in. The | |
reason for returning the parent list is so that the parent list can be changed | |
and the references to that list can be updated as well. | |
This works really well with the mutate function, which needs to actually | |
modify the genome tree structure." | |
(let ((leaf tree) | |
(path tree-path) | |
(nodes (length tree-path)) | |
(i 0)) | |
(dolist (n path) | |
(when (= i (- nodes 1)) | |
(return)) | |
(setf leaf (nth n leaf)) | |
(incf i)) | |
(values leaf | |
(car (last path))))) | |
(defun mutate-value (value) | |
"If a value is numeric, mutate it via addition/subtraction. Otherwise, pretend | |
we never called this function." | |
(if (numberp value) | |
(+ value (- (random (* 2 *mutate-value-max*)) *mutate-value-max*)) | |
value)) | |
(defun mutate (genome) | |
"Performs a mutation on a genome (assuming probability allows it). Works by | |
parsing the genome tree and pulling out direct paths to all the nodes. It | |
picks a path at random and mutates the contained value." | |
(let ((genome (copy-tree genome))) | |
(when (< (random 1.0) *mutate-prob*) | |
(let* ((nodes (get-tree-locations genome)) | |
(random-node (nth (random (length nodes)) nodes))) | |
(multiple-value-bind (node index) | |
(get-tree-location-from-path genome random-node) | |
(let ((val (nth index node))) | |
(setf (nth index node) (if (symbolp val) | |
(random-symbol :exclude val) | |
(mutate-value val))))))) | |
genome)) | |
(defun crossover (mom dad) | |
"Crossover two genomes." | |
(let ((mom (copy-tree mom)) | |
(dad (copy-tree dad))) | |
(let ((tmp (nth 1 dad))) | |
(setf (nth 1 dad) (nth 1 mom) | |
(nth 1 mom) tmp) | |
(values mom dad)))) | |
(defun calculate-fitness (genome) | |
(handler-case | |
(let ((val (eval genome)) | |
(complexity (multiple-value-bind (paths num-items) (get-tree-locations genome) num-items))) | |
(let ((performance (/ 1 (1+ (abs (- *target* val)))))) | |
(if (= performance 1) | |
performance | |
;(* performance (- 1 (* (log complexity) .08)))))) | |
performance))) | |
(error () nil))) | |
(defclass animal () | |
((genome :accessor animal-genome :initarg :genome :initform (random-genome)) | |
(fitness :accessor animal-fitness :initform 0))) | |
(defmethod find-mate ((animal animal) (pop list)) | |
(let ((pop (sort (remove-if (lambda (a) (equal animal a)) pop) | |
(lambda (a1 a2) (< (animal-fitness a1) (animal-fitness a2)))))) | |
(let* ((pop-min (animal-fitness (car (last pop)))) | |
(adjusted-fitness (mapcar (lambda (a) (list (* (animal-fitness a) (/ 1 pop-min)) a)) pop)) | |
(pop-max-adjusted (car (car (last adjusted-fitness)))) | |
(rand-val (random (coerce pop-max-adjusted 'double-float)))) | |
(dolist (f adjusted-fitness) | |
;(when (>= (car f) rand-val) | |
(return-from find-mate (cadr f)))))) | |
(defun epoch (population) | |
(let ((new-population nil) | |
(winner nil) | |
(avg-fitness 0) | |
(max-fitness 0) | |
(min-fitness 99999)) | |
(dolist (a population) | |
(let ((fitness (animal-fitness a))) | |
(when (or (null fitness) (< fitness *fitness-survival-minimum*)) | |
;; die motherfucker | |
(format t "(died) ") | |
(setf (animal-genome a) (random-genome)) | |
(setf (animal-fitness a) (calculate-fitness (animal-genome a))) | |
(setf fitness (animal-fitness a))) | |
(format t "animal: ~a ~a~%" fitness (animal-genome a)) | |
(when (< max-fitness fitness) | |
(setf max-fitness fitness)) | |
(when (< fitness min-fitness) | |
(setf min-fitness fitness)) | |
(when (= fitness 1) | |
(format t "WINNER!~%") | |
(setf winner a)) | |
(incf avg-fitness fitness)) | |
(multiple-value-bind (mom dad) | |
(crossover (animal-genome a) | |
(animal-genome (find-mate a population))) | |
(push (make-instance 'animal :genome (mutate mom)) new-population) | |
(push (make-instance 'animal :genome (mutate dad)) new-population)) | |
(when (<= *num-animals* (length new-population)) | |
(return))) | |
(values new-population | |
winner | |
(/ avg-fitness (length new-population)) | |
max-fitness | |
min-fitness))) | |
(defun run-population (population) | |
(dolist (a population) | |
(setf (animal-fitness a) (calculate-fitness (animal-genome a)))) | |
population) | |
(defun main () | |
(let ((population (loop for x from 1 to *num-animals* collect (make-instance 'animal)))) | |
(dotimes (i 1000) | |
(setf population (run-population population)) | |
(multiple-value-bind (new-population winner avg-fitness max-fitness min-fitness) | |
(epoch population) | |
(when winner | |
(format t "~%~%We got a winner! (only took ~a generations)~% ~a = ~a~%" i (animal-genome winner) (eval (animal-genome winner))) | |
(return-from main winner)) | |
(setf population new-population) | |
(format t "~%pop avg: ~f, pop max: ~f, pop min: ~f~%-------------~%" avg-fitness max-fitness min-fitness))))) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment