1 files changed, 392 insertions, 0 deletions

diff --git a/src/tools.ml b/src/tools.ml
new file mode 100755
index 0000000..6dfe564
--- /dev/null
+++ b/src/tools.ml
@@ -0,0 +1,392 @@
+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 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