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.

tbsetup/ipassign/dre/ga.ml

 (*
  * 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")