open Format

module S = Set.Make(struct type t = int let compare = compare end)
module M = Map.Make(struct type t = int let compare = compare end)

type graph = S.t M.t

type coloring = int M.t

(* trouve un noeud de degré < k et le renvoie; lève Not_found sinon *)

exception Found of int

let find_trivial k g =
  (* M.iter (fun n sn -> printf "%d: %d voisins@." n (S.cardinal sn)) g;  *)
  try
    M.iter (fun n sn -> if S.cardinal sn < k then raise (Found n)) g;
    raise Not_found
  with Found n ->
    (* printf "trivial %d@." n; *)
    n

(* supprimme le noeud n du graphe g *)

let remove_node g n =
  M.mapi (fun n' sn' -> S.remove n sn') (M.remove n g)


(* étend c avec une couleur < k pour n, sachant que c'est possible  *)

let all_colors k =
  let rec make s i = if i = k then s else make (S.add i s) (i+1) in
  make S.empty 0

let set_color k g cm n =
  let possible =
    S.fold
      (fun n' s ->
         let cn' = M.find n' cm in if cn' <> -1 then S.remove cn' s else s)
      (M.find n g) (all_colors k)
  in
  if S.is_empty possible then raise Not_found;
  M.add n (S.choose possible) cm

(* choisit un sommet au hasard *)

let any_node g =
  try
    M.iter (fun n -> raise (Found n)) g; raise Not_found
  with Found n ->
    n

(* coloriage optimiste *)

let rec color k g =
  if M.is_empty g then
    M.empty
  else
    let n = try find_trivial k g with Not_found -> any_node g in
    let c = color k (remove_node g n) in
    try set_color k g c n with Not_found -> M.add n (-1) c

(* coloriage avec une infinité de couleurs *)

let spill g =
  let next_color = ref 0 in
  let rec color g =
    if M.is_empty g then
      M.empty
    else begin
      let n = any_node g in
      let c = color (remove_node g n) in
      let used = Array.create !next_color false in
      S.iter (fun n' -> used.(M.find n' c) <- true) (M.find n g);
      let rec look i =
        if i = !next_color then begin incr next_color; !next_color - 1 end
        else if used.(i) then look (i+1) else i
      in
      M.add n (look 0) c
    end
  in
  color g


(* tests *)

open Bench

module B = Make(S)(M)

let () = let g = B.parse "tests/full-4.dot" in B.show_graph g

let () = B.bench1 3 color

let () = B.show1 3 color "tests/full-4.dot"

let () = B.bench2 spill

let () = B.show2 spill "tests/random-10-15.dot"

This document was generated using caml2html