Commit 3bb95b4c authored by Robert Ricci's avatar Robert Ricci

New version of the GA, now with proper crossover, roulette selection,

eletism, and much better parameterization.

Tested by sorting lists of up to hundreds of numbers.
parent e0c96253
(*
* Core of a genetic algorithm
* Copyright 2005 Robert Ricci for the University of Utah
* ricci@cs.utah.edu, testbed-ops@emulab.net
*)
(*
......@@ -10,13 +12,22 @@
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 =
(* Parameters to the GA - see the default_opts below *)
type ga_options = {
fitness_function : (individual -> float);
mutation_function : (individual -> individual);
crossover_function : (individual -> individual -> individual);
pop_size : int;
breeder_size : int;
crossover_pct : float;
verbose : bool;
termination_score : float;
rand_seed : int;
elite_pct : float
};;
(* Simple mutation for permutation encoding *)
let permutation_mutation (parent : individual) : individual =
let child = Array.copy parent in
let ngenes = Array.length child in
let gene1 = Random.int ngenes in
......@@ -27,6 +38,36 @@ let sample_mutation (parent : individual) : individual =
child
;;
(* Simple crossover for permutation encoding *)
let permutation_crossover (mom : individual) (dad : individual) : individual =
let ngenes = Array.length mom in
let child = Array.create ngenes 65535 in (* XXX - we have to supply a default *)
let child_contains_gene (gene : int) : bool =
let rec contain_helper (i : int) : bool =
if i == (Array.length child) then
false
else
(child.(i) = gene) || contain_helper (i + 1)
in
contain_helper 0
in
let crosspoint = Random.int ngenes in
for i = 0 to crosspoint do
child.(i) <- mom.(i)
done;
let childindex = ref (crosspoint + 1) in
(* TODO - this certainly could be done in a more efficient manner *)
for i = 0 to (ngenes - 1) do
if not (child_contains_gene dad.(i)) then begin
child.(!childindex) <- dad.(i);
childindex := !childindex + 1
end
done;
child
;;
(* Some null functions for testing *)
let null_crossover (mom : individual) (dad : individual) : individual =
mom
;;
......@@ -35,10 +76,8 @@ let null_fitness (ind : individual) : float =
0.0
;;
let lame_fitness (ind : individual) : float =
float_of_int ind.(0)
;;
(* A fitness function that returns the number of elements whose cell contents
* equal its index *)
let ordered_fitness (ind : individual) : float =
let rec ordered_helper (i : int) : int =
if i >= (Array.length ind) then
......@@ -58,7 +97,6 @@ let desc_compare x y =
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
......@@ -68,42 +106,134 @@ let rec select_first_n (l : 'a list) (n : int) : 'a list =
x :: select_first_n xs (n - 1)
;;
let select_for_breeding (candidates : poplist) : poplist =
select_first_n candidates 10
let rec split_after_n (l : 'a list) (n : int) : ('a list * 'a list) =
if n = 0 then ([],l) else
match l with
[] -> ([],[])
| x :: xs ->
match (split_after_n xs (n - 1)) with (y,ys) ->
(x :: y, ys)
;;
let select_for_survival (candidates : poplist) : poplist =
select_first_n candidates 20
(*
* Simple roulette selector - does sampling with replacement, so it could
* end up selecting an individual more than once. This makes it much more
* efficient, though
*)
let roulette_select (candidates : poplist) (howmany : int) : poplist =
(* Simple optimization *)
if (List.length candidates) <= howmany then candidates else
let accum_score (accum : float) (thing : (float * 'a)) : float =
match thing with (score,_) -> accum +. score in
let score_sum = List.fold_left accum_score 0.0 candidates in
let rec get_individual (l : poplist) (s : float) : (float * individual) =
match l with
x :: [] -> x
| x :: xs -> (match x with (score,individual) ->
if score <= s then
(score, individual)
else
get_individual xs (s -. score))
| [] -> raise (Failure "Empty population in roulette_select")
in
let rec get_n_individuals (i : int) : poplist =
let target_score = Random.float score_sum in
if i = 0 then [] else
(get_individual candidates target_score) :: (get_n_individuals (i - 1))
in
get_n_individuals howmany
;;
let optimize (initial_pop : individual list)
(fitness_function : (individual -> float))
(mutation_function : (individual -> individual))
(crossover_function : (individual -> individual -> individual))
: individual =
let select_for_breeding (candidates : poplist) (howmany : int) : poplist =
(* select_first_n candidates howmany *)
roulette_select candidates howmany
;;
let select_for_survival (candidates : poplist) (howmany : int) (elite_pct : float) : poplist =
(* Elitism - the best few survive, no matter what *)
let num_elites = int_of_float((float_of_int howmany) *. elite_pct) in
let (elites, plebs) = split_after_n candidates num_elites in
elites @ List.fast_sort desc_compare (roulette_select plebs (howmany - num_elites))
;;
(* It's better if this list passed to this function is _not_ in sorted order! *)
let split_breeders (candidates : poplist) (percentage : float) : (poplist * poplist) =
let splitpoint = int_of_float ((float_of_int (List.length candidates)) *. percentage) in
split_after_n candidates splitpoint
;;
(* It's better if this list passed to this function is _not_ in sorted order! *)
let rec pair_off (cross : (individual -> individual -> individual))
(parents : individual list) : individual list =
(* TODO: Mate each one more than once? *)
match parents with
mom :: dad :: others -> (cross mom dad) :: (pair_off cross others)
| _ -> []
;;
(* Default options for the GA *)
let default_opts = {
fitness_function = ordered_fitness;
mutation_function = permutation_mutation;
crossover_function = permutation_crossover;
pop_size = 50;
breeder_size = 30;
crossover_pct = 0.8;
verbose = false;
termination_score = 0.99;
rand_seed = 0;
elite_pct = 0.05
};;
(*
* Do the actual optimization!
*)
exception GADone of individual * int;;
let optimize (initial_pop : individual list) (opts : ga_options) : (individual * int) =
(* Initialize the PRNG *)
if opts.rand_seed = 0 then
Random.self_init ()
else
Random.init opts.rand_seed;
(* Compute fitness for an individual *)
let calc_fitness (ind : individual) : (float * individual) =
(fitness_function ind, ind) in
(opts.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 =
let rec run_ga (pop : poplist) (generations : int) : (individual * int) =
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
if opts.verbose then
print_endline ("Best this generation: " ^ (string_of_float score) ^
" of " ^ (string_of_int (List.length pop)));
if score >= opts.termination_score then raise (GADone (champion, generations));
let breeders = select_for_breeding pop opts.breeder_size in
let (lparents,lmutators) = split_breeders breeders opts.crossover_pct in
let (_,parents) = List.split lparents in
let (_,mutators) = List.split lmutators in
let children = List.map calc_fitness (pair_off opts.crossover_function parents) in
let mutants = List.map calc_fitness (List.map opts.mutation_function mutators) in
let nextgen = select_for_survival
(List.fast_sort desc_compare (List.rev_append (List.rev_append pop
children) mutants)) opts.pop_size opts.elite_pct in
run_ga nextgen (generations + 1)
in
try run_ga pop
with GADone(champion) -> champion
try run_ga pop 1
with GADone(champion, generations) -> (champion, generations)
;;
(* Some test populations *)
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
let big_pop_size = 300 in
let big_test_array = Array.create big_pop_size 0 in
for i = 0 to big_pop_size - 1 do
(* Start in reverse order *)
big_test_array.(i) <- big_pop_size - i - 1
done;
let big_test_pop = [ big_test_array ] in
let (ubermensch, gens) = optimize big_test_pop default_opts in
(* Array.iter (fun x -> print_endline (string_of_int x)) ubermensch *)
print_endline ("Found solution after " ^ (string_of_int gens) ^ " generations")
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