Commit bcf2eb6a authored by Robert Ricci's avatar Robert Ricci

Start of a simple Genetic Algorithm core.

I've sucesfully used this core to 'evolve' a sorted list of 18
elements. It takes negligible time, and ~100 generations.

Right now, I am only using mutation, not crossover. To do crossover,
I'm going to have to start studying permutation encoding.
parent c47cefa1
(*
* Core of a genetic algorithm
* Copyright 2005 Robert Ricci for the University of Utah
* ricci@cs.utah.edu, testbed-ops@emulab.net
*)
type individual = int array;;
(* If we get a child this good, we stop - should be a parameter *)
let threshold = 0.99;;
Random.self_init ();;
(* Simple mutation for an array *)
let sample_mutation (parent : individual) : individual =
let child = Array.copy parent in
let ngenes = Array.length child in
let gene1 = Random.int ngenes in
let gene2 = Random.int ngenes in
let tmp = child.(gene1) in
child.(gene1) <- child.(gene2);
child.(gene2) <- tmp;
child
;;
let null_crossover (mom : individual) (dad : individual) : individual =
mom
;;
let null_fitness (ind : individual) : float =
0.0
;;
let lame_fitness (ind : individual) : float =
float_of_int ind.(0)
;;
let ordered_fitness (ind : individual) : float =
let rec ordered_helper (i : int) : int =
if i >= (Array.length ind) then
0
else
(if ind.(i) = i then 1 else 0) + ordered_helper (i + 1)
in
(float_of_int (ordered_helper 0)) /. (float_of_int (Array.length ind))
;;
(* Reverse the order of the regular compare function *)
let desc_compare x y =
match x with (x1,x2) -> match y with (y1,y2) ->
Pervasives.compare y1 x1
;;
type poplist = (float * individual) list;;
exception GAError of string;;
exception GADone of individual;;
let rec select_first_n (l : 'a list) (n : int) : 'a list =
if n = 0 then [] else
match l with
[] -> []
| x :: xs ->
x :: select_first_n xs (n - 1)
;;
let select_for_breeding (candidates : poplist) : poplist =
select_first_n candidates 10
;;
let select_for_survival (candidates : poplist) : poplist =
select_first_n candidates 20
;;
let optimize (initial_pop : individual list)
(fitness_function : (individual -> float))
(mutation_function : (individual -> individual))
(crossover_function : (individual -> individual -> individual))
: individual =
(* Compute fitness for an individual *)
let calc_fitness (ind : individual) : (float * individual) =
(fitness_function ind, ind) in
let pop = List.fast_sort desc_compare (List.map calc_fitness initial_pop) in
(* This function "returns" by raising an exception with the champion *)
let rec run_ga (pop : poplist) : individual =
match List.hd pop with (score, champion) ->
print_endline ("Best this generation: " ^ (string_of_float score) ^
" of " ^ (string_of_int (List.length pop)));
if score >= threshold then raise (GADone champion) else
let (_,breeders) = List.split (select_for_breeding pop) in
let children = List.map calc_fitness (List.map mutation_function breeders) in
let nextgen = select_for_survival
(List.fast_sort desc_compare (List.rev_append pop
children)) in
run_ga nextgen
in
try run_ga pop
with GADone(champion) -> champion
;;
let test_pop = [ [| 4; 1 |]; [| 1; 0 |]; ];;
let test_pop2 = [ [| 10; 3; 13; 0; 16; 11; 2; 12; 4; 17; 15; 5; 14; 1; 6; 9; 8; 7; |]; ];;
let ubermensch = optimize test_pop2 ordered_fitness sample_mutation null_crossover in
Array.iter (fun x -> print_endline (string_of_int x)) ubermensch
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment