source: genesis/nodes/channelea.ml@ 1997

(**
  Experimental channel assigning program using an evolutionary algorithm.

  The scoring function is simple:
    - the score of a combination of two interfaces is 1 if there's two or more
      channels between them, -1 if there's 1 channel between them, -5 if
      there's no channels between them (they're on adjacent channels) and -10
      if they're on the same channel
    - the score for a node is the sum of the scores of all the combinations of
      interfaces for that node, minus any node-specific penalties (eg.
      channels 7, 8 and 9 are unusable and score -1000 on node x), scaled by
      the number of interfaces to give more weight to larger nodes (the
      assumption being that larger nodes are more important nodes)
    - the total score of the network is the sum of the score of the nodes,
      minus any network-wide penalties (eg. the omni's for node x and node y
      can see eachother, so they should be apart)

   special cases:
     - on node x, interfaces y and z are well separated and can live on the
       same channel
     - the link between x on y and z on w is very important, make sure it is
       well separated on both ends of the link
     - interface x on node y will bother interface z on node w and need to
       be on separate channels
     - on node x, channels y, z and w are not usable
     - node x y and z should be treated as one node
     - if at all possible, do not put accesspoints above channel 11

 - install an O'Caml compiler. /usr/ports/lang/ocaml/ in FreeBSD, ocaml in
   Debian.

 - compile with
  
    $ ocamlopt -o foo str.cmxa channelga.ml

 - run with

   $ ./foo f

 where f is the result of running prepconf.py on a file with a list of 
 paths to the wleiden.conf's to consider.

 Lodewijk Voge <lvoge@cs.vu.nl>
*)

(* a few constants suitable for twiddling *)
(** How large a population should the system maintain? *)
let population_size = 20
(** How long should the system iterate after an improvement? *)
and max_stagnant_iterations = 2000
(** What is the chance for an ESSID-to-channel assignment to mutate to a 
    random channel? *)
and mutation_rate = 0.1
(** The most basic score table *)
and scoretable = [ (<=) 2,  1;
                   (==) 2, -30;
                   (==) 1, -70;
                   (==) 0, -100 ]

(* the type definitions. note that Caml has trouble with mutually recursive
   data structures. you can define them, you just can't ever instantiate them.
   this is why the fields in wi are all loose references by way of strings *)
type wi = {
        wi_name: string;
        wi_nodename: string;
        wi_essid: string;
};;
type group = {
        group_essid: string;
        mutable group_wis: wi list;
};;
type node = {
        node_name: string;
        node_wis: wi list;
};;
(** A configuration is an assignment of groups, identified by essid, to a
    channel, plus a score. The code should be careful not to use the score
    between mutating an re-evaluating. *)
type configuration = {
        mutable score: int;
        conf: (string, int) Hashtbl.t;
};;
type 'a maybe = Nothing | Just of 'a;;

(** The global nodes hash, mapping from node name to node struct. *)
let nodes = Hashtbl.create 4
(** The global groups hash, mapping from essid to group struct. *)
let groups = Hashtbl.create 4

(* Now the hashes for the special cases *)
(** Hash mapping from nodename to a list of winame's indicating the wi's that
    don't interfere with eachother for the given node *)
let nointerference = Hashtbl.create 4
(** List of (nodename1, winame1, nodename2, winame2) tuples indicating a very
    important link that should be well-separated on both ends *)
let importantlinks = ref []
(** Hash mapping from nodename to a list of unusable channels for that node *)
let unusable = Hashtbl.create 4
(** List of (nodename1, winame1, nodename2, winame2) tuples indicating two
    interfering interfaces on different nodes *)
let interference = ref []

(** Run the given diff against the given scoretable and return the score *)
let rec runtable t diff =
     match t with
        []              -> assert false
     | (cond, s)::xs    -> if (cond diff) then s
                           else runtable xs diff

(* some convenience functions *)

(** Function composition. *)
let compose f g = fun x -> f(g(x))
let ($) = compose
(** Turn two individual values into a tuple *)
let maketuple a b = (a, b)
(** Shorthand for List.hd *)
let head = List.hd
(** Shorthand for List.tail *)
let tail = List.tl
let just x = match x with
               Nothing -> assert false
             | Just s -> s
(** Given a hashtable, return all the keys as a list *)
let keys t = Hashtbl.fold (fun k d a -> k::a) t []
(** Given a hashtable, return all the values as a list *)
let values t = Hashtbl.fold (fun k d a -> d::a) t []
(** Copy one array into the other *)
let copyarray src dest = Array.blit src 0 dest 0 (Array.length src)

(** Is the given element in the given list? uses compare, so it works on
    strings as well *)
let in_list l e = try
                        let _ = List.find (fun x -> (compare e x) == 0) l in
                        true
                  with Not_found -> false

(** Given a list, return a list of pairs with all possible combinations of 
   items from the given list *)
let rec combinations l =
        match l with
          []    -> []
        | x::xs -> (List.map (maketuple x) xs)@(combinations xs)

(** Given a configuration and two wi's, return the score *)
let wi_score c unusable nointerference wi1 wi2 =
        let channel1 = c wi1.wi_essid in
        let channel2 = c wi2.wi_essid in
        let diff = abs (channel1 - channel2) in
        let is_unusable = in_list unusable in
        if (is_unusable channel1) || (is_unusable channel2) then -10000
        else if (in_list nointerference wi1.wi_name) &&
                (in_list nointerference wi2.wi_name) then 1
        else runtable scoretable diff;;

(** Given a configuration and a node, return the score. this is simply the sum of
   the scores of all the combinations of interfaces, written down as a fold for
   efficiency *)
let node_score c n =
        let nointerference_ = try Hashtbl.find nointerference n.node_name
                              with Not_found -> [] in
        let unusable_ = try Hashtbl.find unusable n.node_name
                        with Not_found -> [] in
        let foldfunc acc (wi1, wi2) = acc + (wi_score c unusable_ nointerference_ wi1 wi2) in
        let base_score = List.fold_left foldfunc 0 (combinations n.node_wis) in
        base_score * (List.length n.node_wis)

(** Score the given pair of interferent interfaces against the given
    configuration *)
let score_interference c (nodename1, winame1, nodename2, winame2) = 
        let wi1 = List.find (fun wi -> (compare wi.wi_name winame1) == 0) (Hashtbl.find nodes nodename1).node_wis in
        let wi2 = List.find (fun wi -> (compare wi.wi_name winame2) == 0) (Hashtbl.find nodes nodename2).node_wis in
        let channel1 = c wi1.wi_essid in
        let channel2 = c wi2.wi_essid in
        let diff = abs (channel1 - channel2) in
        let res = runtable scoretable diff in
        res

(** Given a list of nodes and a configuration, return the score for the whole
    configuration. This is the sum of the scores for all nodes, plus the sum
    of the scores for all user-specified interferent pairs of interfaces. *)
let score_configuration ns c =
        let mapper = Hashtbl.find c in
        let foldfunc acc n = acc + (node_score mapper n) in
        let nodescores = List.fold_left foldfunc 0 ns in
        let interference_score = List.fold_left (fun a i -> a + score_interference mapper i) 0 !interference in
        nodescores + interference_score;;

(** Return a random configuration. For some reason, if this function accesses
  the global 'groups' hash instead of getting it passed in from above, that
  hash is empty. *)
let random_configuration groups evaluate =
        let h = Hashtbl.create 30 in
        Hashtbl.iter (fun k _ -> Hashtbl.add h k (1 + (Random.int 12))) groups;
        { score = (evaluate h); conf = h }

let print_conf conf = 
        let print_wi wi = wi.wi_name ^ ": " ^ (string_of_int (Hashtbl.find conf wi.wi_essid)) in
        let wis node = List.fold_left (fun acc wi -> acc ^ " " ^ (print_wi wi)) "" node.node_wis in
        let sorted_nodes = List.sort (fun a b -> compare (a.node_name) (b.node_name)) (values nodes) in
        List.iter (fun n -> print_string (n.node_name ^ ":" ^ (wis n) ^ "\n")) sorted_nodes

(** Generalized evolutionary algorithm driver. 
      initialize: () -> configuration array
      recombine:
      mutate: configuration array -> configuration array
      evaluate: configuration array -> configuration array
      select: configuration array -> configuration array
      
    and the result is the best configuration *)
let evolutionary_algorithm initialize recombine mutate evaluate select = 
        let population = (evaluate $ initialize) () in
        let last_high_score = ref population.(0).score in
        let iterations_since_new_high_score = ref 0 in
        let generation = ref 0 in
        let all_nodes = values nodes in
        let _ = while !iterations_since_new_high_score < max_stagnant_iterations do
                let newpop = (recombine $ mutate $ evaluate $ select) population in
                Array.sort (fun a b -> compare b.score a.score) newpop;
                copyarray newpop population;
                let high_score = population.(0).score in
                if high_score > !last_high_score then begin
                        last_high_score := high_score;
                        iterations_since_new_high_score := 0
                end;
                assert (!last_high_score >= high_score);
                if (!generation mod 10) == 0 then begin
                        print_int !generation;
                        print_string ": ";
                        print_int !last_high_score;
                        print_newline();
                end;
                incr iterations_since_new_high_score;
                incr generation
        done in
        population.(0);;

(** BEGIN PARSING CODE *)

(** Given a filename, return a list of all the lines in the file with the given
   filename. Don't count on the order of the lines in the result. *)
let snarf_lines fname =
        let infile = open_in fname in
        let result = ref [] in
        try
                while true do
                        result := (input_line infile)::!result
                done;
                !result (* never gets here *)
        with End_of_file -> !result

(** Read the main input from the given filename *)
let parse_file fname =
        let spacere = Str.regexp " " in
        (** Given the name of the node currently being parsed, parse the given tuple
            that consists of a wi name and an essid. *)
        let parse_pair nodename (wname, essid) = 
                let new_wi = { wi_name = wname; wi_nodename = nodename; wi_essid = essid} in
                let foo = try
                                let group = Hashtbl.find groups essid in
                                group.group_wis <- new_wi::group.group_wis;
                          with Not_found ->
                                let group = { group_essid = essid; group_wis = [ new_wi ] } in
                                Hashtbl.add groups essid group in
                new_wi in
        let parse_fields fields = 
                let nodename = head fields in
                let rec makepairs l = match l with
                                        []              -> []
                                      | x::[]           -> assert false
                                      | a::b::xs        -> (a, b)::(makepairs xs) in
                let wis = List.map (parse_pair nodename) (makepairs (tail fields)) in
                let sorted_wis = List.sort compare wis in
                let node = { node_name = nodename; node_wis = sorted_wis } in
                Hashtbl.add nodes nodename node in
        List.iter (parse_fields $ (Str.split spacere)) (snarf_lines fname)
        ;;

(* the parsers for the special case components *)

(** The first field is the nodename, the rest are interface names *)
let parse_nointerference fs = Hashtbl.add nointerference (head fs) (tail fs)
(** Read four fields from the given list and add them as a tuple to the given
    list reference *)
let parse_quadruplet l fs = 
        let f = List.nth fs in
        l := (f 0, f 1, f 2, f 3)::!l
(** The first field is the nodename, the rest are channels.*)
let parse_unusable fs =
        let channels = List.map int_of_string (tail fs) in
        Hashtbl.add unusable (head fs) channels
(** The first field is the supernode name, the rest are the names of the
    subnodes. Construct a new node for the supernode and remove the subnodes
    from the nodes hash *)
let parse_supernode fs =
        let nodename = head fs in
        let subnodenames = tail fs in
        let subnodes = List.map (Hashtbl.find nodes) subnodenames in
        List.iter (Hashtbl.remove nodes) subnodenames;
        let prefixed_wis n = List.map (fun w -> { w with wi_name = n.node_name ^ "." ^ w.wi_name}) n.node_wis in
        let wis = List.fold_left (fun a s -> a@(prefixed_wis s)) [] subnodes in
        let node = { node_name = nodename; node_wis = wis } in
        Hashtbl.add nodes nodename node

let parse_special_conf fname =
        let spacere = Str.regexp " " in
        let functable = [ "nointerference", parse_nointerference;
                          "important", parse_quadruplet importantlinks;
                          "interference", parse_quadruplet interference;
                          "unusable", parse_unusable;
                          "supernode", parse_supernode ] in
        let do_line fs = (List.assoc (head fs) functable) (tail fs) in
        try 
                List.iter (do_line $ Str.split spacere) (snarf_lines fname)
        with x -> ()

(** END PARSING CODE *)

let main = 
        parse_file Sys.argv.(1);
        parse_special_conf "special.conf";
        Random.self_init();
        let all_nodes = values nodes in
        let evaluate_hash = score_configuration all_nodes in
        let initialize () = Array.init population_size (fun _ -> random_configuration groups evaluate_hash) in
        let recombine x = x in
        let mutate_conf conf =
                Hashtbl.iter (fun essid _ -> let f = Random.float 1.0 in
                                             let group = Hashtbl.find groups essid in
                                             let maxchannel = if (List.length group.group_wis) == 1 then 11
                                                              else 13 in
                                             if (f < mutation_rate) then
                                                     Hashtbl.replace conf essid (1 + (Random.int maxchannel))) conf in
        let mutate population = let mutants = Array.map (fun c -> let hash = Hashtbl.copy c.conf in
                                                                  mutate_conf hash;
                                                                  { score = evaluate_hash hash;
                                                                    conf = hash}) population in
                                Array.append population mutants in
        let evaluate population = Array.iter (fun c -> c.score <- evaluate_hash c.conf) population;
                                  population in
        let select p = Array.sub p 0 ((Array.length p) / 2) in
        let best = evolutionary_algorithm initialize recombine mutate evaluate select in
        print_conf best.conf;;

main