Below is the file 'autocolor.ml' from this revision. You can also download the file.

open Viz_types

(* HLS to RGB conversion, taken from CSS3 spec *)
let hue_to_rgb m1 m2 h =
  let h = if h < 0. then h +. 1. else if h > 1. then h -. 1. else h in
  if h *. 6. < 1.
  then m1 +. (m2 -. m1) *. h *. 6.
  else if h *. 2. < 1.
  then m2
  else if h *. 3. < 2.
  then m1 +. (m2 -. m1) *. (2. /. 3. -. h) *. 6.
  else m1
let hls_to_rgb hue li sat =
  let m2 =
    if li <= 0.5
    then li *. (sat +. 1.)
    else li +. sat -. li *. sat in
  let m1 = li *. 2. -. m2 in
  let r = hue_to_rgb m1 m2 (hue +. 1./.3.) in
  let g = hue_to_rgb m1 m2 hue in
  let b = hue_to_rgb m1 m2 (hue -. 1./.3.) in
  let to_int v = int_of_float (v *. 256.) in
  (to_int r, to_int g, to_int b)

let rgba_color (r, g, b) =
  Int32.logor
    (Int32.shift_left (Int32.of_int (r lsl 16 + g lsl 8 + b)) 8)
    0xffl

let autocolor_hash s =
  let hash = Digest.string s in
  let f_of_hash p = float (Char.code hash.[p]) /. 256. in
  (* take 8 bits for hue *)
  let hue = f_of_hash 0 in
  (* take 8 bits for lightness  and map to [75% .. 90%] *)
  let li  = f_of_hash 1 *. 0.15 +. 0.75 in
  (* take 8 bits for saturation and map to [50% .. 80%]*)
  let sat = f_of_hash 2 *. 0.3 +. 0.5 in
  let (r, g, b) as triplet = hls_to_rgb hue li sat in
  if Viz_misc.debug "color"
  then
    Printf.eprintf
      "autocolor (%30s) =       H=%.2f L=%.2f S=%.2f  R=%3d G=%3d B=%3d\n%!"
      s hue li sat r g b ;
  rgba_color triplet

let white = 0xffffffffl

let autocolor kind =
  let lookup_autocolor =
    Viz_misc.make_cache
      begin
	match kind with
	| NONE -> (fun id -> white)
	| BY_AUTHOR_HASH -> autocolor_hash
	| BY_BRANCH_HASH -> autocolor_hash
      end in
  function
    | c :: _ -> lookup_autocolor c
    | []     -> white