After being inspired by this amazing genetic algorithm demo I decided to get learning.
For my first attempt at anything like this I found a
great guide  and programmed the example. The algorithm had the task of making an equation that equaled a goal number. So for example I might tell it “Make me an equation 9 long that creates 13” and it could come back with (1 * 9 + 2 + 6 - 4).
It took quite a while to get it working because there’s lots of randomness involved and mistakes anywhere stop the whole algorithm working, turning the result seemingly completely random. It all works well now though and I’m quite pleased with the code, it’s clean and I manged to optimise it to run a lot faster.
(defvar *genes* '((0 (0 0 0 0))
(1 (0 0 0 1))
(2 (0 0 1 0))
(3 (0 0 1 1))
(4 (0 1 0 0))
(5 (0 1 0 1))
(6 (0 1 1 0))
(7 (0 1 1 1))
(8 (1 0 0 0))
(9 (1 0 0 1))
(+ (1 0 1 0))
(- (1 0 1 1))
(* (1 1 1 1))
(/ (1 1 0 1))))
(defvar *mutation-rate* 0.001)
(defvar *crossover-rate* 0.7)
(defun random-item (list)
"Take a list and return one item from it at random"
(nth (random (length list)) list))
(defun generate-random-chromosome (size)
(loop for i from 1 to size
append (cadr (random-item *genes*))))
(defun decode-gene (gene)
(car (rassoc gene *genes* :key #'car :test #'equal)))
(defun decode-chromosome (chromosome)
(remove nil (loop for (a b c d) on chromosome by #'cddddr
collect (decode-gene (list a b c d)))))
; FIXME x / 0 is silently dropped and operator precedence isn't correct
(defun find-answer (dc)
"Find the answer given by a decoded-chromosome"
(cond ((not (consp dc)) dc)
((< (list-length dc) 3) (car (remove-if-not 'numberp dc)))
((not (numberp (car dc))) (find-answer (cdr dc)))
((numberp (cadr dc)) (find-answer (cons (car dc) (cddr dc))))
((not (numberp (caddr dc)))
(find-answer (append (subseq dc 0 2) (cdddr dc))))
((and (eql '/ (cadr dc))
(eql 0 (caddr dc)))
(find-answer (cons (car dc) (cddr dc))))
(let ((simplified (eval (list (cadr dc) (car dc) (caddr dc)))))
(if (consp (cdddr dc))
(find-answer (cons simplified (cdddr dc)))
(defun count-flaws (dc)
"Return the number of items in a chromosome which are semantically wrong e.g. '(* / +) would be 3"
(let ((should-be-number t)
(loop for gene in dc
if (not (eql (numberp gene) should-be-number))
do (incf flaw-count)
do (setf should-be-number (if should-be-number nil t)))
; FIXME -100 is given to all symbol chromosomes, probably a bad idea?
(defun fitness (chromosome goal)
"Return a fitness based on the distance from the answer and the number of flaws"
(let ((answer (find-answer (decode-chromosome chromosome))))
(if (numberp answer)
(let ((distance (abs (- goal answer)))
(flaws (count-flaws (decode-chromosome chromosome))))
(+ (if (eql distance 0) 0 (/ 1 distance))
(if (eql flaws 0) 0 (/ 1 flaws))))
(defun pool-fitness (pool goal)
(loop for chromosome in pool
collect (fitness chromosome goal)))
(defun mutate-bit (bit)
"Take a 1 or 0 and mutate it."
(if (< (random 1.0) *mutation-rate*)
(if (eql bit 0) 1 0)
(defun mutate (chromosome)
"Returns a possibly mutated version of chromosome"
(loop for bit in chromosome
collect (mutate-bit bit)))
(defun crossover (first second)
"Returns a mix of two chromosomes (might be the same)"
(if (< (random 1.0) *crossover-rate*)
(let ((point (+ (random (- (length first) 1)) 1)))
(append (subseq first 0 point)
(subseq second point)))
(random-item (list first second))))
(defun make-roulette-wheel (fitness)
(let* ((total-fitness (reduce #'+ fitness))
(append (loop for x in fitness
do (incf total-probability (/ x total-fitness))) '(1.0))))
(defun spin-the-wheel (pool roulette-wheel)
(let ((ball (random 1.0)))
(declare (type float ball))
(loop for chromosome in pool
for (position next-pos) of-type (float float) on roulette-wheel
if (<= ball next-pos)
do (return chromosome))))
(defun re-populate (pool fitness)
(let ((roulette-wheel (make-roulette-wheel fitness)))
(loop for i from 1 to (length pool)
collect (mutate (crossover (spin-the-wheel pool roulette-wheel)
(spin-the-wheel pool roulette-wheel))))))
(defun create-initial-pool (pool-size chromosome-size)
(loop for i from 1 to pool-size
collect (generate-random-chromosome chromosome-size)))
(defun find-best-chromosome (pool fitness)
"Returns the fittest chromosome in the pool."
(let ((best-score) (best-chromosome))
(loop for chromosome in pool
for score in fitness
do (when (or (equalp score 0) (not best-score) (> score best-score))
(setf best-score score)
(setf best-chromosome chromosome)))
(values best-chromosome best-score)))
(defun there-is-a-winner (pool fitness)
"If any of the chromosomes in the pool have the answer return the first one that does."
(let ((winner (position 0 fitness)))
(if winner (nth winner pool))))
(defun display-turn (pool fitness turn)
(multiple-value-bind (chromosome score) (find-best-chromosome pool fitness)
(let ((avg-fitness (/ (reduce #'+ fitness) (+ 1 (length pool))))
(format t "~a - Average Fitness: ~F Best: ~w (fitness ~F)~%" turn avg-fitness (decode-chromosome chromosome) score))))
(defun genetic-algorithm (goal pop-size chromosome-size tries)
(let ((pool (create-initial-pool pop-size chromosome-size))
(loop for i from 1 to tries
do (setf fitness (pool-fitness pool goal))
if (there-is-a-winner pool fitness) return it
do (display-turn pool fitness i)
do (setf pool (re-populate pool fitness))
finally (return (find-best-chromosome pool fitness)))))
(defun skynet (&key goal pop-size chromosome-size tries mutation-rate crossover-rate)
(let ((best (genetic-algorithm goal pop-size chromosome-size tries))
(format t "~w gave ~F (Aim was ~A)" (decode-chromosome best) (find-answer (decode-chromosome best)) goal)))
; Sensible parameter values according to t'internet:
; - 0.1 to 0.001 for mutation rate
; - 0.7 to 0.9 for crossover rate
(skynet :goal 13
As always feel free to use the code, any feedback would be useful. Next up I’m going to apply GA to a more interesting problem.
Edit: I optimised the code by using the SBCL profiler to see what was slowing things down. It turned out that the spin-the-wheel function was taking about 92% of the time with the functions it called. Firstly I examined the function and realised I could reduce the comparisons, that reduced it to about 87%. Next the guys in #lisp explained that I should declare the variables in that function as float’s so that SBCL could optimise things for me. I tried that and it was reduced to around 36%!
I found it surprising that the ‘roulette wheel spinning’ function that’s used to select which chromosomes are used for crossover was the most computer intensive part of my code but at least now it runs a lot faster. Although I am curious to know if my findings are normal. Also if you have any idea how I could optimise more I would be grateful, here is the profiler output.
 - Apparently that guide is teaching very out of date methods, possibly consider a different source of information!
Edit: Before I replaced Wordpress there were some really good comments that were lost. I’ve pasted there below so you can follow their tips
That tutorial is really quite astonishingly crappy. So what I’m going to say is obviously exaggeration but is close to the truth:
(1) NO ONE has done roulette selection in the last ten years. Tournament selection, truncation selection, etc., yes. Roulette selection? Laughable.
(2) NO ONE has done binary encodings of non-binary problems in the last ten years. You use an encoding which matches your actual problem.
(3) NO ONE does one-point crossover any more. A parametrisation uniform crossover. Or at LEAST, heaven forbid, a two-point crossover.
(4) NO ONE does genetic programming (the little encoding of math the guy’s showing) in a fixed-length string. It borders on the hilariously ignorant.
Hey, it’s all fine if you’re doing this for the first time, and you go pick up a 1970 book on genetic algorithms and publish a web page on how you coded it up. But to claim that you’re doing a TUTORIAL? This guy should have been taken out behind the shed and shot.
You might find this tutorial useful: http://www.obitko.com/tutorials/genetic-algorithms/index.php
Also, the “field guide to genetic programming” by Poli, Langdon and McPhee is very up-to-date, and can be downloaded for free: http://www.lulu.com/content/2167025