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 * 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 @@ ...@@ -10,13 +12,22 @@
type individual = int array;; type individual = int array;;
(* If we get a child this good, we stop - should be a parameter *) (* Parameters to the GA - see the default_opts below *)
let threshold = 0.99;; type ga_options = {
fitness_function : (individual -> float);
Random.self_init ();; mutation_function : (individual -> individual);
crossover_function : (individual -> individual -> individual);
(* Simple mutation for an array *) pop_size : int;
let sample_mutation (parent : individual) : individual = 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 child = Array.copy parent in
let ngenes = Array.length child in let ngenes = Array.length child in
let gene1 = Random.int ngenes in let gene1 = Random.int ngenes in
...@@ -27,6 +38,36 @@ let sample_mutation (parent : individual) : individual = ...@@ -27,6 +38,36 @@ let sample_mutation (parent : individual) : individual =
child 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 = let null_crossover (mom : individual) (dad : individual) : individual =
mom mom
;; ;;
...@@ -35,10 +76,8 @@ let null_fitness (ind : individual) : float = ...@@ -35,10 +76,8 @@ let null_fitness (ind : individual) : float =
0.0 0.0
;; ;;
let lame_fitness (ind : individual) : float = (* A fitness function that returns the number of elements whose cell contents
float_of_int ind.(0) * equal its index *)
;;
let ordered_fitness (ind : individual) : float = let ordered_fitness (ind : individual) : float =
let rec ordered_helper (i : int) : int = let rec ordered_helper (i : int) : int =
if i >= (Array.length ind) then if i >= (Array.length ind) then
...@@ -58,7 +97,6 @@ let desc_compare x y = ...@@ -58,7 +97,6 @@ let desc_compare x y =
type poplist = (float * individual) list;; type poplist = (float * individual) list;;
exception GAError of string;; exception GAError of string;;
exception GADone of individual;;
let rec select_first_n (l : 'a list) (n : int) : 'a list = let rec select_first_n (l : 'a list) (n : int) : 'a list =
if n = 0 then [] else if n = 0 then [] else
...@@ -68,42 +106,134 @@ let rec select_first_n (l : 'a list) (n : int) : 'a list = ...@@ -68,42 +106,134 @@ let rec select_first_n (l : 'a list) (n : int) : 'a list =
x :: select_first_n xs (n - 1) x :: select_first_n xs (n - 1)
;; ;;
let select_for_breeding (candidates : poplist) : poplist = let rec split_after_n (l : 'a list) (n : int) : ('a list * 'a list) =
select_first_n candidates 10 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) let select_for_breeding (candidates : poplist) (howmany : int) : poplist =
(fitness_function : (individual -> float)) (* select_first_n candidates howmany *)
(mutation_function : (individual -> individual)) roulette_select candidates howmany
(crossover_function : (individual -> individual -> individual)) ;;
: individual =
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 *) (* Compute fitness for an individual *)
let calc_fitness (ind : individual) : (float * 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 let pop = List.fast_sort desc_compare (List.map calc_fitness initial_pop) in
(* This function "returns" by raising an exception with the champion *) (* 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) -> match List.hd pop with (score, champion) ->
print_endline ("Best this generation: " ^ (string_of_float score) ^ if opts.verbose then
" of " ^ (string_of_int (List.length pop))); print_endline ("Best this generation: " ^ (string_of_float score) ^
if score >= threshold then raise (GADone champion) else " of " ^ (string_of_int (List.length pop)));
let (_,breeders) = List.split (select_for_breeding pop) in if score >= opts.termination_score then raise (GADone (champion, generations));
let children = List.map calc_fitness (List.map mutation_function breeders) in let breeders = select_for_breeding pop opts.breeder_size in
let nextgen = select_for_survival let (lparents,lmutators) = split_breeders breeders opts.crossover_pct in
(List.fast_sort desc_compare (List.rev_append pop let (_,parents) = List.split lparents in
children)) in let (_,mutators) = List.split lmutators in
run_ga nextgen 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 in
try run_ga pop try run_ga pop 1
with GADone(champion) -> champion with GADone(champion, generations) -> (champion, generations)
;; ;;
(* Some test populations *)
let test_pop = [ [| 4; 1 |]; [| 1; 0 |]; ];; 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 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
let ubermensch = optimize test_pop2 ordered_fitness sample_mutation null_crossover in let big_test_array = Array.create big_pop_size 0 in
Array.iter (fun x -> print_endline (string_of_int x)) ubermensch 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