Commit 7494faaf authored by Robert Ricci's avatar Robert Ricci

Many changes to make the GA more 'real':

 * Add some new terminaiton options - a maximum number of generations,
   and a 'king of the hill' termination condidtion
 * Added elitism
 * Start out by putting a bunch of random individuals in the population
 * Make many things options (liek population size and comparator)
 * Added roulette and rank selection
parent ae492405
......@@ -4,12 +4,6 @@
* ricci@cs.utah.edu, testbed-ops@emulab.net
*)
(*
* EMULAB-COPYRIGHT
* Copyright (c) 2005 University of Utah and the Flux Group.
* All rights reserved.
*)
type individual = int array;;
(* Parameters to the GA - see the default_opts below *)
......@@ -21,11 +15,21 @@ type ga_options = {
breeder_size : int;
crossover_pct : float;
verbose : bool;
termination_score : float;
termination_score : float option;
max_generations : int option;
rand_seed : int;
elite_pct : float
elite_pct : float;
score_comparator : float -> float -> int;
victory_generations : int option
};;
(*
* Use the Mersenne Twister from mathlib to make a random number generator for
* ints
*)
(* module MyRNG = Rand.UniformDist2(Math.IntOps)(MtRand.IntSource);;
let myrand = new MyRNG.rng 0 100 in print_int myrand#genrand; print_newline ();; *)
(* Simple mutation for permutation encoding *)
let permutation_mutation (parent : individual) : individual =
let child = Array.copy parent in
......@@ -67,6 +71,18 @@ let permutation_crossover (mom : individual) (dad : individual) : individual =
child
;;
(*
* Randomize an individual - useful for starting configurations
*)
let permutation_randomize (initial : individual) : individual =
let mutations = (Array.length initial) * 2 in
let rec randomize (ind : individual) (n : int) : individual =
if n > mutations then ind else
randomize (permutation_mutation ind) (n + 1)
in
randomize initial 0
;;
(* Some null functions for testing *)
let null_crossover (mom : individual) (dad : individual) : individual =
mom
......@@ -88,10 +104,10 @@ let ordered_fitness (ind : individual) : float =
(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
(* Compare the first element of a two-tuple list *)
let first_compare comparator x y =
match x with (x1,_) -> match y with (y1,_) ->
comparator x1 y1
;;
......@@ -144,17 +160,54 @@ let roulette_select (candidates : poplist) (howmany : int) : poplist =
get_n_individuals howmany
;;
let rank_select (candidates : poplist) (howmany : int) : poplist =
(* Simple optimization *)
if (List.length candidates) <= howmany then candidates else
let rec sum_ranks (i : int) (l : 'a list) : int =
match l with
[] -> 0
| x :: xs -> i + (sum_ranks (i + 1) xs) in
let clen = List.length candidates in
let rec select_individual (target_rank : int) (current_rank : int)
(candidates : poplist) : (float * individual) =
match candidates with
x :: [] -> (print_endline "Case 1"; x)
| x :: xs -> if target_rank <= 0 then (
(*print_endline ("Case 2: len=" ^ (string_of_int (List.length
candidates)) ^ " cr=" ^ (string_of_int current_rank) ^ " tr=" ^
(string_of_int target_rank) ^ " abs=" ^ (string_of_int (clen -
current_rank + 1)));*) x) else
select_individual (target_rank - current_rank) (current_rank - 1) xs
| [] -> raise (Failure "Empty population in rank_select")
in
let rank_sum = sum_ranks 1 candidates in
let rec get_n_individuals (i : int) : poplist =
let target_rank = Random.int rank_sum in
(*print_endline ("Selecting " ^ (string_of_int target_rank) ^ " of " ^
(string_of_int rank_sum) ^ " - list size " ^ (string_of_int
(List.length candidates))); *)
if i = 0 then [] else
(select_individual (target_rank - (List.length candidates)) (List.length candidates) candidates)
:: (get_n_individuals (i - 1))
in
get_n_individuals howmany
;;
let select_for_breeding (candidates : poplist) (howmany : int) : poplist =
(* select_first_n candidates howmany *)
roulette_select candidates howmany
(* roulette_select candidates howmany *)
rank_select candidates howmany
;;
let select_for_survival (candidates : poplist) (howmany : int) (elite_pct : float) : poplist =
let select_for_survival (comparator : float -> float -> int) (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))
elites @ List.fast_sort (first_compare comparator)
(* (roulette_select plebs (howmany - num_elites)) *)
(rank_select plebs (howmany - num_elites))
;;
(* It's better if this list passed to this function is _not_ in sorted order! *)
......@@ -178,12 +231,16 @@ let default_opts = {
mutation_function = permutation_mutation;
crossover_function = permutation_crossover;
pop_size = 50;
breeder_size = 30;
breeder_size = 50;
crossover_pct = 0.8;
verbose = false;
termination_score = 0.99;
termination_score = Some 0.99;
max_generations = None;
rand_seed = 0;
elite_pct = 0.05
elite_pct = 0.05;
(* Default to desceding, meaning high scores are good *)
score_comparator = (fun x y -> Pervasives.compare y x);
victory_generations = None
};;
......@@ -191,7 +248,8 @@ let default_opts = {
* Do the actual optimization!
*)
exception GADone of individual * int;;
let optimize (initial_pop : individual list) (opts : ga_options) : (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 ()
......@@ -200,30 +258,46 @@ let optimize (initial_pop : individual list) (opts : ga_options) : (individual *
(* Compute fitness for an individual *)
let calc_fitness (ind : individual) : (float * individual) =
(opts.fitness_function ind, ind) in
let pop = List.fast_sort desc_compare (List.map calc_fitness initial_pop) in
let pop = List.fast_sort (first_compare opts.score_comparator)
(List.map calc_fitness initial_pop) in
(* This function "returns" by raising an exception with the champion *)
let rec run_ga (pop : poplist) (generations : int) : (individual * int) =
match List.hd pop with (score, champion) ->
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)
let rec run_ga (pop : poplist) (generations : int) (king_score : float)
(reign_period : int) : (individual * int) =
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 opts.score_comparator
(List.fast_sort (first_compare opts.score_comparator)
(List.rev_append (List.rev_append pop
children) mutants)) opts.pop_size opts.elite_pct in
let (topscore,champion) = List.hd nextgen in
if opts.verbose then
output_string stderr ("Best of generation " ^ (string_of_int generations)
^ ": " ^ (string_of_float topscore) ^
" of " ^ (string_of_int (List.length pop)) ^ "\n");
(* Termination conditions *)
match opts.max_generations with
Some(x) when generations >= x -> raise (GADone (champion, generations))
| _ ->
match opts.termination_score with
Some(x) when topscore >= x -> raise (GADone (champion, generations))
| _ ->
let new_reign_period =
if topscore == king_score then reign_period + 1 else 0 in
match opts.victory_generations with
Some(x) when reign_period == x -> raise (GADone (champion, generations))
| _ ->
run_ga nextgen (generations + 1) topscore new_reign_period
in
try run_ga pop 1
try run_ga pop 1 0.0 0
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 big_pop_size = 300 in
......@@ -237,3 +311,4 @@ 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