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

let string_is_prefix a ?(offset=0) b =
  let l_a = String.length a in
  let l_b = String.length b - offset in
  l_a <= l_b && a = String.sub b offset l_a

let string_split ?(collapse=true) ?(max_elem=0) c s =
  let len = String.length s in
  let rec split n i = function
    | j when j > len -> []
    | j when j = len || s.[j] = c ->
	if collapse && j = i
	then split n (j+1) (j+1)
	else
	  if max_elem > 0 && n >= max_elem
	  then [ if i = 0 then s else String.sub s i (String.length s -i) ]
	  else (String.sub s i (j-i)) :: (split (n+1) (j+1) (j+1))
    | j ->
	split n i (j+1) in
  split 1 0 0

let string_slice ?s ?e str =
  let len = String.length str in
  let start = match s with
  | None -> 0
  | Some i when i < 0 -> i + len
  | Some i -> i in
  let stop = match e with
  | None -> len
  | Some e when e < 0 -> e + len
  | Some e -> e in
  String.sub str start (stop - start)

let string_contains p =
  let r = Str.regexp_string_case_fold p in
  fun s ->
    try ignore (Str.search_forward r s 0) ; true
    with Not_found -> false

let option_of_list = function
  | [] -> None
  | x :: _ -> Some x

let list_uniq l =
  let rec uniq = function
    | x :: y :: tl when x = y -> x :: uniq tl
    | x :: tl -> x :: uniq tl
    | [] -> [] in
  uniq (List.sort compare l)

let rec list_assoc_all k = function
  | (a, b) :: tl when a = k -> b :: list_assoc_all k tl
  | _ :: tl -> list_assoc_all k tl
  | [] -> []

let rec list_rassoc v = function
  | (a, b) :: _ when b = v -> a
  | _ :: tl -> list_rassoc v tl
  | [] -> raise Not_found

let array_index a v =
  let rec loop i =
    if i >= Array.length a
    then raise Not_found ;
    if a.(i) = v
    then i
    else loop (i + 1) in
  loop 0

let some = function
  | Some v -> v
  | None -> invalid_arg "some"

let may f = function
  | None -> ()
  | Some v -> f v

let maybe f = function
  | None -> None
  | Some v -> Some (f v)

let default v = function
  | None -> v
  | Some x -> x

let may_assoc el l =
  try Some (List.assoc el l) with Not_found -> None

let may_cons v l =
  match v with
  | Some v -> v :: l
  | None -> l

let bracket ~before ~action ~after arg =
  let resource = before arg in
  let result =
    try action resource
    with exn -> after resource ; raise exn in
  after resource ;
  result

let with_file_in f = function
  | "-"   -> f stdin
  | fname ->
      bracket ~before:open_in ~after:close_in ~action:f fname

let with_file_out f = function
  | "-"   -> f stdout
  | fname ->
      bracket ~before:open_out ~after:close_out ~action:f fname

let input_lines ic =
  let lines = ref [] in
  begin try
    while true do
      lines := (input_line ic) :: !lines
    done
  with End_of_file -> () end ;
  List.rev !lines

let input_channel ic =
  (* Buffer.add_channel sucks *)
  let buff = Buffer.create 1024 in
  begin
    let s = String.create 1024 in
    let r = ref (-1) in
    while !r <> 0 do
      r := input ic s 0 (String.length s) ;
      Buffer.add_substring buff s 0 !r
    done
  end ;
  Buffer.contents buff

let get_home_dir = Viz_gmisc.get_home_dir

let debug_kwd =
  try
    let v = Sys.getenv "MONOTONE_VIZ_DEBUG" in
    string_split ':' v
  with Not_found -> []
let debug kwd = List.mem kwd debug_kwd || List.mem "all" debug_kwd

let log kwd fmt =
  Printf.kprintf
    (fun s -> if debug kwd then Printf.eprintf "### %s: %s\n%!" kwd s)
    fmt

module Signal =
  struct
    type 'a t = ('a -> unit) list ref

    let make () = ref []
    let emit s arg =
      List.iter
	(fun f -> f arg)
	!s
    let connect s f = s := f :: !s
  end

(* not used right now ...

let hex_of_char = function
  | '0' .. '9' as c ->
      Char.code c - Char.code '0'
  | 'a' .. 'f' as c ->
      0xa + Char.code c - Char.code 'a'
  | 'A' .. 'F' as c ->
      0xa + Char.code c - Char.code 'A'
  | _ ->
      invalid_arg "hex_of_char"

let hex_dec s =
  let len = String.length s in
  if len mod 2 <> 0 then invalid_arg "hex_dec" ;
  let o = String.create (len / 2) in
  for i = 0 to len / 2 - 1 do
    o.[i] <- Char.chr (hex_of_char s.[2*i] lsl 4 lor hex_of_char s.[2*i+1])
  done ;
  o
*)

let char_of_hex v =
  if v < 0xa
  then Char.chr (v + Char.code '0')
  else Char.chr (v - 0xa + Char.code 'a')

let hex_enc s =
  let len = String.length s in
  let o = String.create (2 * len) in
  for i = 0 to len - 1 do
    let c = int_of_char s.[i] in
    let hi = c lsr 4 in
    o.[2*i] <- char_of_hex hi ;
    let lo = c land 0xf in
    o.[2*i + 1] <- char_of_hex lo
  done ;
  o

let make_cache g =
  let tbl = Hashtbl.create 17 in
  fun k ->
    try Hashtbl.find tbl k
    with Not_found ->
      let v = g k in
      Hashtbl.add tbl k v ;
      v