OCaml Forge

Browse | Submit A New Snippet | Create A Package

Genetic Minimal Sorting Network

Type:
Full Script
Category:
Other
License:
BSD License
Language:
Other Language
 
Description:
A Genetic Algorithm to find Minimal Sorting Networks.

Versions Of This Snippet:

Snippet ID Download Version Date Posted Author Delete
21.02008-08-05 23:18Matías Giovannini

Download a raw-text version of this code by clicking on "Download Version"

 


Latest Snippet Version: 1.0

(* * A program to find minimal sorting networks using Genetic Algorithms. * * Copyright (c) 2008, Matias Giovannini. * * Permission is granted to use this program without restrictions, * except the above copyright notice must be preserved. * * For a description of the program, see * http://alaska-kamtchatka.blogspot.com/2008/08/sorting-out-evolution.html * * Save it to ganet.ml, and compile it with * ocamlopt -inline 10 -unsafe -o ganet ganet.ml *) (* http://www.cs.brandeis.edu/~hugues/sorting_networks.html *) let known_best_bounds = [| (* size, depth L.B., depth U.B.) *) (* 0 *) 0, 0, 0; (* 1 *) 0, 0, 0; (* 2 *) 1, 1, 1; (* 3 *) 3, 3, 3; (* 4 *) 5, 3, 3; (* 5 *) 9, 5, 5; (* 6 *) 12, 5, 5; (* 7 *) 16, 6, 6; (* 8 *) 19, 6, 6; (* 9 *) 25, 7, 7; (* 10 *) 29, 7, 7; (* 11 *) 35, 7, 8; (* 12 *) 39, 7, 8; (* 13 *) 45, 7, 9; (* 14 *) 51, 7, 9; (* 15 *) 56, 7, 9; (* 16 *) 60, 7, 9; |] let target_fitness (size, depth) = let size, depth = float size, float depth in 1. +. size /. ((size -. 1.) *. depth) (* let overhead = size +. depth /. size in overhead /. (overhead -. 1.) *) let rec random_ordered_pair n = let i, j = Random.int n, Random.int n in if i <= j then i, j else random_ordered_pair n let random_disjoint_pair n = let p = Random.int n in let q = Random.int (pred n) in if p > q then (p, q) else (p, succ q) let sort a word = Array.fold_left (fun word (i, j) -> (* i <= j *) word lor (word lsr (j - i) land (1 lsl i)) land (word lsl (j - i) lor lnot (1 lsl j)) ) word a let is_sorted word = word land (word + 1) == 0 let network_width = ref 7 and genome_length = ref 50 and pool_size = ref 50 and crossover_rate = ref 0.6 and mutation_rate = ref 0.01 let set_network_width w = network_width := w; genome_length := w * w let set_random_seed s = if s == 0 then begin Random.self_init (); let s = Random.int max_int in Random.init s; Printf.fprintf stderr "Random seed: %d\n" s end else Random.init s type genome = (int * int) array let new_gene () = random_ordered_pair !network_width let mutate_gene (i, j) = let k = Random.int !network_width in if k < j then (k, j) else (j, k) let fold_genome f e (g : genome) = let bounds = Array.make !network_width 0 in fst (Array.fold_left (fun (e, depth) (i, j) -> if i == j then (e, depth) else let d = max depth (1 + max bounds.(i) bounds.(j)) in bounds.(i) <- d; bounds.(j) <- d; (f (d > depth) e (i, j), d)) (e, 0) g) let count_genome = fold_genome (fun is_sequential (size, depth) _ -> succ size, if is_sequential then succ depth else depth) (0, 0) let string_of_genome (g : genome) = let buffer = Buffer.create 16 in ignore (fold_genome (fun is_sequential any (i, j) -> if any then Buffer.add_char buffer (if is_sequential then ';' else ','); Printf.bprintf buffer "%d:%d" i j; true) false g); Buffer.contents buffer exception Unsorted of int let evaluate_fitness (g : genome) = let tests = 1 lsl !network_width in try for i = 0 to pred tests do if not (is_sorted (sort g i)) then raise (Unsorted i) done; target_fitness (count_genome g) with Unsorted i -> float i /. float tests type individual = { mutable score : float; genes : genome; } let new_individual () = let g = Array.init !genome_length (fun _ -> new_gene ()) in { score = evaluate_fitness g; genes = g; } type population = { mutable best : individual; pool : individual array; } let find_best pool = Array.fold_left (fun w g -> if w.score > g.score then w else g) pool.(0) pool let new_population () = let p = Array.init !pool_size (fun _ -> new_individual ()) in { best = find_best p; pool = p; } (* http://www.cogs.susx.ac.uk/users/inmanh/Microbial.pdf *) let microbial_tournament p (i, j) = let g1, g2 = p.pool.(i), p.pool.(j) in let winner, loser = if g1.score < g2.score || g1.score = g2.score && g2 == p.best then g2, g1 else g1, g2 in assert (p.best != loser); (* Recombination *) for i = 0 to !genome_length - 1 do if Random.float 1. < !crossover_rate then loser.genes.(i) <- winner.genes.(i); done; (* Mutation *) for i = 0 to !genome_length - 1 do if Random.float 1. < !mutation_rate then loser.genes.(i) <- mutate_gene loser.genes.(i) done; loser.score <- evaluate_fitness loser.genes; if p.best.score <= loser.score then p.best <- loser let tournament fitness p = let iter = ref 0 and last = ref 0. in Sys.catch_break true; begin try while p.best.score < fitness do microbial_tournament p (random_disjoint_pair !pool_size); incr iter; if 1. <= p.best.score && !last < p.best.score then begin let (s, d) = count_genome p.best.genes in last := p.best.score; let sum, act = Array.fold_left (fun (s, n as p) g -> if g.score < 1. then p else (s +. g.score, succ n)) (0., 0) p.pool in Printf.fprintf stderr "%7d act = %3.0f%%, avg = %7.5f, max = %7.5f (%2d/%2d)\n" !iter (100. *. float act /. float !pool_size) (sum /. float act) !last s d; flush stderr end done with Sys.Break -> prerr_endline "Interrupted.\n" end; !iter let test () = let (size, _, depth) = known_best_bounds.(!network_width) in let fitness = target_fitness (size, depth) in Printf.fprintf stderr "Searching for a %d-network of size %d and depth %d (fitness = %7.5f)\n" !network_width size depth fitness; flush stderr; let pool = new_population () in let iter = tournament fitness pool in let n, d = count_genome pool.best.genes in Printf.fprintf stderr "Solution in %d rounds with fitness %f\n" iter pool.best.score; Printf.fprintf stderr "Found a %d-network of size %d and depth %d\n" !network_width n d; print_endline (string_of_genome pool.best.genes) let () = let usage = "usage - ganet [-m <f>] [-x <f>] [-p <n>] [-s <n>] -w <n>" in let spec = [ "-m", Arg.Set_float mutation_rate, "mutation rate"; "-x", Arg.Set_float crossover_rate, "crossover rate"; "-p", Arg.Set_int pool_size, "population pool"; "-s", Arg.Int set_random_seed, "random seed"; "-w", Arg.Int set_network_width, "network width"; ] in Arg.parse spec (fun _ -> raise (Arg.Bad "extra argument")) usage; if 0. >= !mutation_rate || !mutation_rate >= 1. then begin prerr_endline "mutation rate must be between 0 and 1 (exclusive)"; exit 2 end else if 0. >= !crossover_rate || !crossover_rate >= 1. then begin prerr_endline "crossover rate must be between 0 and 1 (exclusive)"; exit 2 end else if !pool_size < !network_width then begin prerr_endline "population pool must be as large as the width"; exit 2 end else if !network_width < 2 || !network_width > 16 then begin prerr_endline "network width must be between 2 and 16"; exit 2 end else test ()

Submit a new version

You can submit a new version of this snippet if you have modified it and you feel it is appropriate to share with others..