This Common Lisp system implements a DSL for running Genetic Algorithm.
(in-package genetic-algorithm)
(run-ga (((x 0 10)
(y -10 10 :mutation-rate 0.05)
(z (:foo :bar :bazz)))
:max-iterations 100
:mutation-rate 0.01
may be some other params
with reasonable defaults)
;; This code should calculate if
;; given x y z are good enough.
;; This code should return a number.
;; Buy default algorithm searches parameters
;; which minimize result of this function
(abs (- (ecase z
(:foo 10)
(:bar 100)
(:bazz 1000))
(+ x y))))
This example solves a + 2*b + 3*c + 4*d = 30 equation:
(run-ga (((a 1.0 100.0)
(b 1.0 100.0)
(c 1.0 100.0)
(d 1.0 100.0))
:max-iterations 50
:mutation-rate 0.01)
(abs (- 30
(+ a
(* 2 b)
(* 3 c)
(* 4 d)))))
In our case, genome is a definition of all properties we want to
crossover and mutate. First argument of run-ga is genome.
Genome is a list of gen definitions.
Each gen definition has a name and a range of values. Or it maybe be not a number but a discrete value from a list. Here are examples of gen definitions:
(x 0 10)- an integer value in[0..10]range.(x 0.0 10.0)- a float value in[0.0, 10.0]interval.(x (:foo :bar :bazz))- a one of the given keywords.(x (nil t))- eithernilort.
Here is a class to define the gen. Each gen has a name and two functions. One function creates a random value for a new gen, and second function mutates gen with some probability. These two functions will be created from gen definition, provided by user:
(export '(gen get-name))
(def class gen ()
((name :type symbol
:initarg :name
:reader get-name)
(new-value-generator :type function
:initarg :new-value-generator
:reader get-new-value-generator)
(mutator :type function
:initarg :mutator
:reader get-mutator)))
(defmethod print-object ((gen gen) stream)
(print-unreadable-object (gen stream :type t)
(format stream "~A"
(get-name gen))))
Now we’ll define a function to create a new value generator:
(def function make-new-value-generator (gen-definition)
(destructuring-bind (name from &optional to)
(take-until-keyword gen-definition)
(declare (ignorable name))
(cond
((and from to)
(unless (and (typep from 'number)
(typep to 'number))
(error "Both \"from\" and \"to\" values should be numbers but you provided ~S and ~S"
from to))
(lambda ()
(+ from
(random (- to from)))))
(from
(unless (typep from 'list)
(error "When only \"from\" is supplied, it should be a list of posible gen values."))
(lambda ()
(random-elt from))))))
The function which mutates gen is similar to the
make-new-value-generator it takes current value, and changes it with
given probability
(def (function d) make-mutator (gen-definition &key
(mutation-rate 0.01)
(mutation-sigma 1.0))
(destructuring-bind (name from &optional to)
(take-until-keyword gen-definition)
(declare (ignorable name))
(destructuring-bind (&key (mutation-rate mutation-rate)
(mutation-sigma mutation-sigma))
(take-starting-from-keyword gen-definition)
(cond
((and from to)
(unless (and (typep from 'number)
(typep to 'number))
(error "Both \"from\" and \"to\" values should be numbers but you provided ~S and ~S"
from to))
(lambda (value)
(if (<= (random 1.0)
mutation-rate)
(let ((new-value (arrows:-> (random-gauss value mutation-sigma)
(min to)
(max from))))
;; If original range was specified as integers,
;; then we need to coerce the new value to an integer
(typecase from
(integer (round new-value))
(single-float (coerce new-value
'single-float))
(t new-value)))
;; or return current value
value)))
(from
(unless (typep from 'list)
(error "When only \"from\" is supplied, it should be a list of posible gen values."))
(lambda (value)
(if (<= (random 1.0)
mutation-rate)
(random-elt from)
;; or return current value
value)))))))
We’ll need gen names to bind these variables and to print being’s gens. This function extracts gen names from their definitions:
(def function get-var-names (genome)
(mapcar #'get-name genome))
Now we can define a function which will make a gen object:
(def (function io) make-gen (definition &key
(mutation-rate 0.01)
(mutation-sigma 1.0))
(make-instance 'gen
:name (car definition)
:new-value-generator (make-new-value-generator definition)
:mutator (make-mutator definition
:mutation-rate mutation-rate
:mutation-sigma mutation-sigma)))
Genetic algorithm works with a population of beings. To describe the state of each being, it gens, we’ll use this class and some helpers to create and modify it:
(def (class ea) being ()
((fit :initform nil
:initarg :fit
:accessor get-fit
:documentation "A value characterizing this being's performance. How good it's gens for our business logic.")
(gens :initarg :gens
:documentation "A list of values for each gen from the genome."
:reader get-gens)
(genome :initarg :genome
:type (list-of:list-of gen)
:documentation "A genome definition, passed to the algorigthm."
:reader get-genome)))
This nice printer will allow us to view all objects characteristics in the REPL:
(def print-object being
(format t "gens: ~A fit: ~A"
(rutils:interleave (get-var-names (get-genome -self-))
(get-gens -self-))
(get-fit -self-)))
This function choosed random values for each gen. It is used to create initial population in the first phase of the Genetic Algorithm.
(def function make-random-being (genome)
"Genome is '((x 0 10) (y -3 3))
gens are randomly selected from the ranges."
(check-type genome (list-of:list-of gen))
(make-instance 'being
:genome genome
:gens (loop for gen in genome
collect (funcall (get-new-value-generator gen)))))
Initial population just a number of beings with random gens:
(defun make-population (genome size)
(loop repeat size
collect (make-random-being genome)))
What Genetic Algorithm does? It tests if each being is good enough. If it isn’t, then it kills it and let others to be fruitful and multiply.
User of this library provides us a code which calculates if gens are good enought. All what we need now is to apply this function to every being in the population and to save results for further processing:
(def (function d) calculate-fit (population fit)
(loop for obj in population
for gens = (get-gens obj)
unless (get-fit obj)
do (setf (get-fit obj)
(apply fit gens)))
population)
Next, we need to select good enougth beings. To simplify, we’ll just sort results and take some percents of the best species to the next iteration. Rest will die:
(def (function e) select-survivors (population ratio &key (maximize nil))
(let* ((with-fit (remove-if #'null population
:key #'get-fit))
(sorted (sort with-fit (if maximize
#'>
#'<)
:key #'get-fit)))
(rutils:take (ceiling (* (length sorted)
ratio))
sorted)))
Also we’ll need this function to select the best of the best gens at the end of the algorigthm:
(def (function ei) select-the-best (population &key (maximize nil))
(first (select-survivors population 0.01
:maximize maximize)))
This little helper function can be used in after-each-iteration code to
select the best being:
(def (function ei) remove-if-null-fit (population)
(remove-if-not #'get-fit
population))
At this stage, the population was reduced and we need to make children
to fill the population up to it’s desired size. That is what our
crossover function does:
(def (function oi) make-child (survivors &key (num-parents 2))
(let* ((parents (random-sample:random-sample survivors num-parents))
(first-parent (first parents))
(genome (get-genome first-parent))
(gens (apply #'mapcar
#'select-gen
(mapcar #'get-gens parents))))
(make-instance 'being
:genome genome
:gens gens)))
(def function crossover (survivors population-size &key (num-parents 2))
;; It is important to keep survivors at
;; front, because we'll protect the best of them
;; from mutation.
(append survivors
(when (>= (length survivors)
num-parents)
(loop with num-children = (- population-size
(length survivors))
repeat num-children
collect (make-child survivors)))))
Also we’ll need a function to fill our population with completely random beings. This way we’ll inject a “fresh blood” and add a chance to find a better solution.
(def function add-random-beings (current-population population-size genome)
;; It is important to keep current-population at
;; front, because we'll protect the best of them
;; from mutation.
(append current-population
(loop with num-beings-to-create = (- population-size
(length current-population))
repeat num-beings-to-create
collect (make-random-being genome))))
For mutation, we’ll call a mutator for each gen and it will return a new
value with given probability mutation-rate:
(def (function eo) mutate-being (being)
"This function can be used to check how does mutation work for your species.
Returns a `t' if being was mutated."
(let (mutated)
(setf (slot-value being 'gens)
(loop with genome = (get-genome being)
for gen-value in (get-gens being)
for gen in genome
for mutator = (get-mutator gen)
for new-value = (funcall mutator gen-value)
unless (eql new-value gen-value)
do (setf mutated t)
collect new-value
;; Later we'll recalculate fit
;; only for mutated beings.
finally (when mutated
(setf (get-fit being)
nil))))
mutated))
(def (function e) copy-being (being)
(make-instance 'being
:fit (get-fit being)
;; Genome list is the same for all beings
:genome (get-genome being)
;; Also we aren't copying gens,
;; because during mutation they we be replaced
;; with a new list.
;; If this will be ever replaced by a vector,
;; then it will be need to be copied.
:gens (get-gens being)))
(def function mutate (population &key (num-beings-to-protect 0))
"This function modifies population in-place.
Here we skip N the best beings to protect them
from mutation."
(check-type num-beings-to-protect (integer 0 65535))
(loop for being in (nthcdr num-beings-to-protect
population)
do (mutate-being being))
(append population
;; We add to the population a 'num-beings-to-protect'
;; clones of the best species. And these clones will be
;; always mutated:
(loop repeat num-beings-to-protect
for being in population
for clone = (copy-being being)
do (loop until (mutate-being clone))
collect clone)))
Mutation has these parameters to tune:
- mutation-rate - a probability of change a single gen.
- mutation-sigma - a value of squared sigma for gaussian distribution. This distribution will be used to change gen’s value if it is a number in given range.
Entry point to running algorithm is the run-ga macro. It allows to set
some algorithm parameters and a code to calculate fitness function.
This code will be called with every gen’s value, bound to corresponding gen name.
Also, you can define a code to be executed after each iteration:
(run-ga (((a 1.0 10.0)
(b 1.0 10.0))
:max-iterations 10
:after-each-iteration (format t "Fit: ~A~%"
(arrows:-> -population-
(remove-if-null-fit)
(select-the-best)
(get-fit)))
:maximize t)
(+ a b))
Variables genetic-algorithm:-population- and genetic-algorithm:-fit- will be available during this
code execution. First one contains whole population, second - the fit value
of the best being in the current population.
First, we need to define some special variables which can be used in the user’s code:
(def (special-variable e :documentation "Contains a number of the current generation starting from 1.")
-iteration-)
(def (special-variable e :documentation "All beings for current generation.")
-population-)
(def (special-variable e :documentation "Contains the best being in the current generation.")
-best-being-)
(def (special-variable e :documentation "Contains the best fit value in the current generation.")
-fit-)
(def (special-variable e :documentation "Contains the worst fit value in the current generation.")
-worst-fit-)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'stop-algorithm))
(def function make-genome-by-definition (definition &key
(mutation-rate 0.01)
(mutation-sigma 1.0))
(loop for item in definition
collect (make-gen item
:mutation-rate mutation-rate
:mutation-sigma mutation-sigma)))
(def (function e) make-being (genome-definition &rest rest
&key fit
mutation-rate
mutation-sigma
&allow-other-keys)
"This function can be useful to create being manually.
Genome definition is the same like you pass to run-ga '((x 0 10) (y -3 3))"
(declare (ignorable fit mutation-rate mutation-sigma))
(let* ((fit (getf rest :fit))
(mutation-rate (getf mutation-rate :mutation-rate))
(mutation-sigma (getf mutation-rate :mutation-sigma))
(genome (apply #'make-genome-by-definition
(append (list genome-definition)
(when mutation-rate
(list :mutation-rate mutation-rate))
(when mutation-sigma
(list :mutation-sigma mutation-sigma))))))
(make-instance 'being
:fit fit
:genome genome
:gens (loop with gen-values = (alexandria:remove-from-plist
rest
:fit
:mutation-rate
:mutation-sigma)
for gen in genome
for gen-name = (alexandria:make-keyword
(get-name gen))
collect (getf gen-values
gen-name)))))
(def (macro e) run-ga ((genome &key
(population-size 100)
(max-iterations 1000)
(maximize nil)
(num-beings-to-protect 1)
(survive-ratio 0.5)
;; Then percentage of population
;; which should be reproduced by
;; crossover. Other part will be
;; filled by new random beings.
(children-ratio 0.25)
(mutation-rate 0.01)
(mutation-sigma 1.0)
;; This can be a list of beings to be used
;; as a first generation. It will be filled
;; up-to population-size by random beings
(first-generation nil)
;; A code to be executed after each iteration:
(after-each-iteration nil)
;; This code will be executed at the end.
;; With -population- bound to the last generation.
(finally nil)
(calculate-fit 'calculate-fit))
&body fitness-code)
(let ((var-names (mapcar #'car genome)))
(unless genome
(error "Please, provide :genome parameter"))
`(flet ((fit (,@var-names)
,@fitness-code))
;; If we have some being at the beginning,
;; we need to reset their fit, to recalculate
;; it on first iteration in new circumstances:
(when ,first-generation
(loop for being in ,first-generation
do (setf (get-fit being)
nil)))
(let* ((genome (make-genome-by-definition ',genome
:mutation-rate ,mutation-rate
:mutation-sigma ,mutation-sigma))
(-population- (append ,first-generation
(make-population genome
(- ,population-size
(length ,first-generation))))))
(with-simple-restart (stop-algorithm "Stop Genetic Algorithm evaluation and return the best result.")
(loop for -iteration- from 1 upto ,max-iterations
for survivors = (arrows:-> -population-
;; Here we are making a little bit lesser beings,
;; because for each being to protect we have to make
;; a mutated copy.
(crossover (floor
(* (- ,population-size
,num-beings-to-protect)
,children-ratio)))
(add-random-beings (- ,population-size
,num-beings-to-protect)
genome)
(mutate :num-beings-to-protect ,num-beings-to-protect)
(,calculate-fit #'fit)
(select-survivors ,survive-ratio :maximize ,maximize))
for -best-being- = (first survivors)
for worst-being = (car (last survivors))
for -fit- = (when -best-being-
(get-fit -best-being-))
for -worst-fit- = (when worst-being
(get-fit worst-being))
do (setf -population- survivors)
(progn ,after-each-iteration)
(format t "Num survivors: ~A with some fit: ~A~%"
(length survivors)
(count-if (lambda (item)
(not (null (get-fit item))))
survivors))
finally (log:warn "Algorithm stopped after" ,max-iterations "iterations")))
(progn ,finally)
(arrows:-> -population-
(remove-if-null-fit)
(select-the-best :maximize ,maximize))))))
As you can see, this macro established a simple restart with name
stop-algorithm. You can either invoke it interactively from Emacs, by
pressing C-c C-c first, or to use
(invoke-restart genetic-algorithm:stop-algorithm) from
:after-each-iteration code.
To make run-ga macro arguments looks nice, we’ll add a special indentation
rule for the Emacs:
(trivial-indent:define-indentation run-ga
((&whole &lambda &rest -4) &body))
Often you don’t want to wait while all max-iterations will be calculated
if found gens are good enough. In this case you might invoke
stop-algorithm restart from the :after-each-iteration code.
To make it easier for most cases, you can use this function which creates an automatic checker if fit value does not evolve much during the last N iterations:
(def (function e) make-learn-rate-checker (n delta)
"This function returns a checker - function which accepts a fit value
and invokes stop-algorithm restart if a \"learn rate\" become less than `delta'."
(let ((last-values nil))
(lambda (fit)
(unless (or (null fit)
(zerop fit))
(push fit last-values)
(setf last-values
(rutils:take n last-values))
(when (= (length last-values)
n)
(loop with prev = (car last-values)
for current in (cdr last-values)
for difference = (abs (- current prev))
do (setf prev current)
summing difference into diffs
finally (let* ((average-difference
(/ diffs
(1- (length last-values))))
(normalized-average-difference
(/ average-difference
fit)))
(when (< normalized-average-difference
delta)
(invoke-restart 'stop-algorithm)))))))))
Here is how this learn rate checker can be used:
GENETIC-ALGORITHM> (let ((check-learn-rate (make-learn-rate-checker 10 0.001)))
(run-ga (((a 1.0 100.0)
(b 1.0 100.0))
:max-iterations 100
:after-each-iteration (progn
(format t "~A Fit: ~,3F~%"
-iteration-
-fit-)
(funcall check-learn-rate -fit-))
:maximize t)
(+ a b)))
1 Fit: 182.498
2 Fit: 186.917
3 Fit: 189.060
4 Fit: 195.029
5 Fit: 197.085
6 Fit: 197.085
7 Fit: 197.085
8 Fit: 197.085
9 Fit: 197.085
10 Fit: 197.085
11 Fit: 197.437
12 Fit: 197.437
13 Fit: 197.496
14 Fit: 197.496
#<BEING gens: (A 99.85181 B 97.58560609207429d0) fit: 197.43741273269927d0 {100D575743}>
Algorithm was interrupted on 14 iteration instead of going upto 100.
There is also a similar way to stop algorithm if the fit improved more than some ratio from the first iteration’s fit.
This can be useful when you are training existing population but want avoid overfitting.
(def (function e) make-fit-improvement-checker (max-ratio)
"This function returns a checker - function which accepts a fit value
and invokes stop-algorithm current fit is greater than the first fit
to a given ratio.
For example, if max-ratio is 1.5 and first fit was 100, then algorith
will be stopped when fit become 150 or above."
(let ((first-fit nil))
(lambda (fit)
(cond
((null first-fit)
(setf first-fit fit))
(t
(when (>= (/ fit first-fit)
max-ratio)
(invoke-restart 'stop-algorithm)))))))
Similar as we interrupted GA when the fit is good enough, we might want to stop after some time period.
(def (function e) make-timeout-checker (seconds)
"This function returns a checker - function without arguments
which invokes stop-algorithm restart after a given number seconds."
(let ((time-to-stop (+ (get-universal-time)
seconds)))
(lambda ()
(when (> (get-universal-time)
time-to-stop)
(invoke-restart 'stop-algorithm)))))
If a being was saved and restored from disk, then we have to restore
callbacks before we can use it in the next run-ga call. This is the
purpose of the next function:
(def (function e) restore-genome (being definition
&key
(mutation-rate 0.01)
(mutation-sigma 1.0))
(loop for gen-definition in definition
for gen in (get-genome being)
do (restore-gen-funcs
gen
gen-definition
:mutation-rate mutation-rate
:mutation-sigma mutation-sigma)))
Also, we’ll need this function to restore mutator and new-value-generator closures after the gen was restored from disk:
(def (function io) restore-gen-funcs (gen definition
&key
(mutation-rate 0.01)
(mutation-sigma 1.0))
(setf (slot-value gen 'new-value-generator)
(make-new-value-generator definition)
(slot-value gen 'mutator)
(make-mutator definition
:mutation-rate mutation-rate
:mutation-sigma mutation-sigma)))
- Add ability to stop iterations when fit function is good enough.
- Check with cl-flamegraph if some performance optimize are required.
(asdf-finalizers:final-forms)