path: root/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


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 Num = struct

  include Num

  let of_float_string a = begin
    try
      let ipart_s,fpart_s = String.split a ~by:'.' in
      let ipart = if ipart_s = "" then Num.Int 0 else Num.num_of_string ipart_s in
      let fpart =
        if fpart_s = "" then Num.Int 0
        else
          let fpart = Num.num_of_string fpart_s in
          let num10 = Num.num_of_int 10 in
          let frac = Num.power_num num10 (Num.num_of_int (String.length fpart_s)) in
          Num.div_num fpart frac
      in
      Num.add_num ipart fpart
    with Not_found -> Num.num_of_string a
  end

  let of_float f = begin
    match classify_float f with
    | FP_normal
    | FP_subnormal ->
      let x,e = frexp f in
      let n,e =
        Big_int.big_int_of_int64 (Int64.of_float (ldexp x 52)),
        (e-52)
      in
      if e >= 0 then
        Big_int (Big_int.shift_left_big_int n e)
      else
        Num.div_num
          (Big_int n)
          (Big_int Big_int.(shift_left_big_int unit_big_int ~-e))
    | FP_zero -> Num.num_of_int 0
    | FP_nan -> Num.div_num (Num.num_of_int 0) (Num.num_of_int 0)
    | FP_infinite ->
      if f >= 0. then
        Num.div_num (Num.num_of_int 1) (Num.num_of_int 0)
      else
        Num.div_num (Num.num_of_int (-1)) (Num.num_of_int 0)
    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[@tailrec]) 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

(** Map for any comparable value.
    This map can bind 'a key -> 'a value as long as the key are comparable.
 *)
module Map(Ord: COMPARABLE_TYPE) = struct

  type 'a key = 'a Ord.t

  type wrapper = Ex: 'a key * 'a -> wrapper

  type t =
    | Empty : t
    | Node : t * 'a key * 'a * t * int -> t

  let singleton x d = Node(Empty, x, d, Empty, 1)

  let empty = Empty

  let is_empty = function
    | Empty -> true
    | _ -> false

  let height = function
    | Empty -> 0
    | Node(_,_,_,_,h) -> h

  let create l x d r =
    let hl = height l and hr = height r in
    Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

  let bal l x d r =
    let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
    let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
    if hl > hr + 2 then begin
      match l with
        Empty -> invalid_arg "Map.bal"
      | Node(ll, lv, ld, lr, _) ->
          if height ll >= height lr then
            create ll lv ld (create lr x d r)
          else begin
            match lr with
              Empty -> invalid_arg "Map.bal"
            | Node(lrl, lrv, lrd, lrr, _)->
                create (create ll lv ld lrl) lrv lrd (create lrr x d r)
          end
    end else if hr > hl + 2 then begin
      match r with
        Empty -> invalid_arg "Map.bal"
      | Node(rl, rv, rd, rr, _) ->
          if height rr >= height rl then
            create (create l x d rl) rv rd rr
          else begin
            match rl with
              Empty -> invalid_arg "Map.bal"
            | Node(rll, rlv, rld, rlr, _) ->
                create (create l x d rll) rlv rld (create rlr rv rd rr)
          end
    end else
      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))


  let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with
    | Empty -> Node(Empty, x, data, Empty, 1)
    | Node(l, v, d, r, h) ->
        match Ord.comp x v with
        | Eq -> Node(l, x, data, r, h)
        | Lt -> bal (add x data l) v d r
        | Gt -> bal l v d (add x data r)
  end

  let rec find: type a. a key -> t -> a = begin fun x t -> match t with
    | Empty -> raise Not_found
    | Node(l, k, v, r, _) ->
        match Ord.comp x k with
        | Eq -> v
        | Lt -> find x l
        | Gt -> find x r
  end

  let rec mem: type a. a key -> t -> bool = begin fun  x t -> match t with
    | Empty -> false
    | Node(l, k, v, r, _) ->
        match Ord.comp x k with
        | Eq -> true
        | Lt -> mem x l
        | Gt -> mem x r
  end

  (*
  let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a =
  begin fun f init t -> match t with
  | Empty -> init
  | Node(l, k, v, r, _) ->
      let res_left = fold f init l in
      let result = f res_left @@ Ex (k, v) in
      fold f result r
  end
  *)
end