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 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

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

module Date = struct

  type t = Num.num

  let get_julian_day year month day = begin
    let y, m =
      if month > 2 then
        year, month
      else
        year - 1, month + 12
    in
    let b =
      if (year > 1582) || (year = 1582 && month > 10) || (year = 1582 && month = 10 && day >= 15) then
        let s = y / 100 in
        2 - s + (s / 4)
      else
        0
      in
      365 * y + y / 4
    + (int_of_float (30.6001 *. (float_of_int (m + 1))))
    + day
    + b
    + 1720995
    - 2415019         (* Shift to 30/12/1899 *)
    |> Num.num_of_int

  end

  let date_from_julian_day day = begin

    let shift_day = Num.floor_num day
      |> Num.add_num (Num.num_of_int 2415019) in

    let z = Num.int_of_num shift_day in
    let f =
      if z >= 2299161 then
        (* We use the Num module here to prevent overflow *)
        let day' = Num.(((num_of_int 4) */ shift_day +/ (num_of_int 274277)) // (num_of_int 146097))
                |> Num.floor_num
                |> Num.int_of_num in
        z + 1401 + ((day' * 3) / 4) - 38
      else
        z + 1401
      in
    let e = (4 * f) + 3 in
    let h = 5 * ((e mod 1461) / 4) + 2 in (* 1461 is 365.25 * 4 *)
    let d = ((h mod 153) / 5) + 1
    and m = (((h / 153) + 2) mod 12) + 1 in
    let y = (e / 1461) - 4716 + (14 - m) / 12 in (* 4716 is day 2 *)
    (y, m, d)

  end

  let time_from_julian_day j = begin Num.(
    let day = floor_num j in
    let time = j -/ day in

    let h = floor_num @@ time */ (num_of_int 24) in
    let h_24 = (h // (num_of_int 24)) in
    let m = floor_num @@ (num_of_int 1440) */ (time -/ h_24 ) in
    let s = (num_of_int 86400) */ (time -/ h_24 -/ (m // (num_of_int 1440))) in
    (h, m, s)
  ) end

  (** Compute the julian for a given date.

      Integer return number of days since November 24, 4714 BC.
      Fractionnal part return the time since midnight.
  *)
  let from_string str = begin
    let n = Num.num_of_int in
    let date_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+"
    and time_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+T[0-9]+:[0-9]+:[0-9]" in
    if Str.string_match time_regex str 0 then
      Scanf.sscanf str "%d-%d-%dT%d:%d:%d" (fun year month day hour min sec ->
      Num.(
        let nhour = n hour // (n 24)
        and nmin  = n min // (n 1440)
        and nsec  = n sec // (n 86400) in
        (get_julian_day year month day) +/ nhour +/ nmin +/ nsec
      )
    ) else if Str.string_match date_regex str 0 then
      Scanf.sscanf str "%d-%d-%d" get_julian_day
    else (
      Num.num_of_int 0
    )
  end

  let to_string date = begin
    let y, m, d = date_from_julian_day date
    and h, n, s = time_from_julian_day date in

    Printf.sprintf "%d-%02d-%02dT%02d:%02d:%02g"
      y
      m
      d
      (Num.int_of_num h)
      (Num.int_of_num n)
      (Num.float_of_num s)

  end


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 eq: '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.eq 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.eq 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 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.eq 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.eq 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.eq x k with
        | Eq -> true
        | Lt -> mem x l
        | Gt -> mem x r
  end

end