From 3bb95b4cc7b684980a657caddb8eb22d0a022463 Mon Sep 17 00:00:00 2001 From: Robert Ricci Date: Tue, 17 May 2005 23:33:40 +0000 Subject: [PATCH] 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 | 204 ++++++++++++++++++++++++++++++------- 1 file changed, 167 insertions(+), 37 deletions(-) diff --git a/tbsetup/ipassign/dre/ga.ml b/tbsetup/ipassign/dre/ga.ml index 3a7881436..91fbb2cb9 100644 --- a/tbsetup/ipassign/dre/ga.ml +++ b/tbsetup/ipassign/dre/ga.ml @@ -1,5 +1,7 @@ (* * 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") -- GitLab