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 = Crypto.sha1 s in
  let f_of_hash p = float (Char.code hash.[p]) /. 256. in
  (* take 8 bits for hue *)
  let hue = f_of_hash 5 in
  (* take 8 bits for lightness  and map to [75% .. 90%] *)
  let li  = f_of_hash 1 *. 0.15 +. 0.55 in
  (* take 8 bits for saturation and map to [50% .. 80%]*)
  let sat = f_of_hash 2 *. 0.5 +. 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 quasi_random n =
  let v = ref (float n) in
  for i = 1 to 8 do
    let d = float (n lsr i) /. float (1 lsl i) in
    if i mod 2 = 1
    then v := !v -. d
    else v := !v +. d
  done ;
  fst (modf (!v /. 2.))

let hex = [| 0.; 1./.3.; 2./.3.; 1./.6.; 3./.6.; 5./.6. |]
let quasi_random_hue n =
  let displ = quasi_random (n / 6) in
  hex.(n mod 6) +. displ /. 6.

let white = 0xffffffffl

let autocolor_quasi_random db s =
  try
    let id = Database.get_key_rowid db s in
    let hue = quasi_random_hue id in
    let (r, g, b) as triplet = hls_to_rgb hue 0.75 0.75 in
    if Viz_misc.debug "color"
    then Printf.eprintf
	"autocolor (%30s) = id=%2d H=%.2f                R=%3d G=%3d B=%3d\n%!" s id hue r g b ;
    rgba_color triplet
  with Not_found ->
    white

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