path: root/src/tools.ml

let u = UTF8.from_utf8string

module Option = struct

  let map f = function
  | Some x -> Some (f x)
  | None -> None

  let iter f = function
  | Some x -> f x
  | None -> ()

  let bind f = function
  | None -> None
  | Some x -> f x

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

  let test f v = begin
  match f v with
  | Some x -> x
  | None -> v
  end


end

module String = struct

  include String

  let split str ~by:sep = begin
    let p = String.index str sep in
    let slen = String.length str in
    String.sub str 0 p, String.sub str (p + 1) (slen - p - 1)
  end

  let cut str ~by:sep = begin
    try String.sub str 0 @@ String.index str sep with
    | Not_found -> str
  end

  let string_of_ints v = begin
    let buff = Buffer.create 1 in
    let rec convert value = begin
      Buffer.add_char buff @@ char_of_int @@ value land 0xFF;
      let rem = value lsr 8 in
      match rem with
      | 0 -> Buffer.contents buff
      | x -> convert x
    end in
    let res = convert v in
    let buff' = Buffer.create @@ String.length res in
    for i = ((String.length res) - 1) downto 0 do
      Buffer.add_char buff' @@ String.get res i
    done;
    Buffer.contents buff'
  end

  let print_buffer f t = begin
    let buff = UTF8.Buffer.create 16 in
    f buff t;
    UTF8.Buffer.contents buff
  end

  let filter_float str = begin
    let l = String.length str in
    if l > 0 && String.get str (l - 1) = '.' then
      String.sub str 0 (l - 1)
    else
      str
  end

end

module List = struct

  (** fold_left over only the first element *)
  let fst f init = function
  | hd::tl -> f init hd
  | [] -> init

  let printb ?(first=(u"(")) ?(last=(u")")) ?(sep=(u",")) f buffer elems = begin

    let rec print = begin function
    | [] -> ()
    | hd::[] ->
        f buffer hd;
    | hd::tl ->
        f buffer hd;
        UTF8.Buffer.add_string buffer sep;
        print tl
    end in

    UTF8.Buffer.add_string buffer first;
    print elems;
    UTF8.Buffer.add_string buffer last
  end

  let rec find_map f = begin function
  | [] -> raise Not_found
  | hd::tl -> begin match f hd with
              | Some x -> x
              | None -> (find_map[@tailcall]) f tl
              end
  end

  let rec findOpt p = begin function
  | [] -> None
  | x::l ->
    if p x then
      Some(x)
    else
      findOpt p l
  end

  and find_map2 p = begin function
  | [] -> raise Not_found
  | x::l ->
    begin try find_map p x with
    Not_found -> find_map2 p l
    end
  end

  (** Convert the list [l] as an array *)
  let to_array l = begin
    let elems = ref l in
    let build = fun _ ->
      begin match (!elems) with
      | [] -> assert false
      | hd::tl ->
          elems := tl;
          hd
      end
    in Array.init (List.length l) build
  end

  let linearize elems = begin
    let rec _linearize acc (elems:'a list list) : 'a list = begin
      let split (hds, tls) = function
      | hd::tl -> hd::hds, tl::tls
      | [] -> hds, tls
      in
      match elems with
      | [] -> acc
      | elems ->
        let acc, tls = List.fold_left split (acc, []) elems in
        _linearize acc tls
    end in
    List.rev @@ _linearize [] elems
  end

end

module Tuple2 = struct

  let fst = Pervasives.fst

  let snd = Pervasives.snd

  let map1 f (a, b) = (f a, b)

  let map2 f (a, b) = (a, f b)

  let replace1 v (a, b) = (v, b)

  let replace2 v (a, b) = (a, v)

  let printb ?(first="(") ?(last=")") ?(sep=",") format1 format2 out (a, b) = begin
    UTF8.Printf.bprintf out "%s%a%s%a%s"
      first
      format1 a
      sep
      format2 b
      last
  end

end

module Tuple3 = struct

    let fst (a, b, c) = a

    let snd (a, b, c) = b

    let thd (a, b, c) = c

    let map f (a, b, c) = (f a, f b, f c)

    let map1 f (a, b, c) = (f a, b, c)

    let map2 f (a, b, c) = (a, f b, c)

    let map3 f (a, b, c) = (a, b, f c)

    let replace1 v (a, b, c) = (v, b, c)

    let replace2 v (a, b, c) = (a, v, c)

    let replace3 v (a, b, c) = (a, b, v)
end

module NCurses = struct

  type mouse_event =
  | BUTTON1_PRESSED
  | BUTTON1_RELEASED
  | BUTTON1_CLICKED
  | BUTTON1_DOUBLE_CLICKED
  | BUTTON1_TRIPLE_CLICKED
  | BUTTON2_PRESSED
  | BUTTON2_RELEASED
  | BUTTON2_CLICKED
  | BUTTON2_DOUBLE_CLICKED
  | BUTTON2_TRIPLE_CLICKED
  | BUTTON3_PRESSED
  | BUTTON3_RELEASED
  | BUTTON3_CLICKED
  | BUTTON3_DOUBLE_CLICKED
  | BUTTON3_TRIPLE_CLICKED
  | BUTTON4_PRESSED
  | BUTTON4_RELEASED
  | BUTTON4_CLICKED
  | BUTTON4_DOUBLE_CLICKED
  | BUTTON4_TRIPLE_CLICKED
  | BUTTON_SHIFT
  | BUTTON_CTRL
  | BUTTON_ALT
  | ALL_MOUSE_EVENTS
  | REPORT_MOUSE_POSITION

  type event_type

  external set_mouse_event: mouse_event list -> unit = "c_set_mouse_event"

  external get_mouse_event: unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event"

  external is_event_of_type: mouse_event -> event_type -> bool = "c_is_event_of_type"

end

let try_finally f except =
  try let res = f () in
    except ();
    res
  with e ->
    except ();
    raise e

type (_,_) cmp =
  | Eq : ('a,'a) cmp
  | Lt : ('a,'b) cmp
  | Gt : ('a,'b) cmp

(** Existencial type for comparing two types.
    This type has no utility, except for structural comparison between two
    values.
 *)
type existencial = Ex: 'a -> existencial

module type COMPARABLE_TYPE = sig

    type 'a t

    val comp: 'a t -> 'b t -> ('a, 'b) cmp

end

module ArrayMap(Ord: COMPARABLE_TYPE) = struct

  type 'a key = 'a Ord.t

  type t = Val : ('a key * 'a) array -> t

  let find: type a. a key -> t -> a = begin fun k (Val map) ->
    let rec find_ idx : a = begin
        let x, v = Array.get map idx in
        match Ord.comp x k with
        | Eq -> v
        | Lt -> find_ ((2 * idx) + 1)
        | Gt -> find_ ((2 * idx) + 2)
    end in
    find_ 0
  end

  let from_list l = begin
    let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with
    | Eq -> 0
    | Lt -> -1
    | Gt -> 1
    in
    let arr = List.to_array l in
    Array.sort compare arr;
    Val arr
  end

end

let fold_for f a b init =
  let rec _fold res i = begin
  if i >= b then res
  else
    _fold (f i res) (i + 1)
  end in
  (_fold[@tailcall]) init a