1 files changed, 231 insertions, 26 deletions

diff --git a/tools.ml b/tools.ml
index 1e0e1c4..0cf8fe6 100755
--- a/tools.ml
+++ b/tools.ml
@@ -75,6 +75,30 @@ module Num = struct
     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
@@ -101,6 +125,36 @@ module List = struct
     UTF8.Buffer.add_string buffer last
   end
 
+  let rec findOpt p = begin function
+  | [] -> None
+  | x::l ->
+      if p x then
+        Some(x)
+      else
+        findOpt p l
+  end
+
+  and find2 p = begin function
+  | [] -> raise Not_found
+  | x::l ->
+      begin match findOpt p x with
+      | None -> find2 p l
+      | Some x -> x
+      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
 
@@ -152,25 +206,6 @@ module Tuple3 = struct
     let replace3 v (a, b, c) = (a, b, v)
 end
 
-(*
-module Locale = struct
-
-  type locale =
-    | LC_ALL
-    | LC_COLLATE
-    | LC_CTYPE
-    | LC_MONETARY
-    | LC_NUMERIC
-    | LC_TIME
-    | LC_MESSAGES
-
-  external set: locale -> string -> string = "c_set_locale"
-
-  external length: string -> int = "c_length"
-
-end
-*)
-
 module NCurses = struct
 
   type mouse_event =
@@ -215,16 +250,50 @@ module Date = struct
   type t = Num.num
 
   let get_julian_day year month day = begin
-    CalendarLib.Date.make year month day
-    |> CalendarLib.Date.to_jd
+    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 j = begin
-    let date = CalendarLib.Date.from_jd (Num.int_of_num @@ Num.floor_num j) in
-    (CalendarLib.Date.year date),
-    (CalendarLib.Date.int_of_month @@ CalendarLib.Date.month date),
-    (CalendarLib.Date.day_of_month date)
+  let date_from_julian_day day = begin
+
+
+    let z = Num.int_of_num (Num.floor_num day) in
+    let f =
+      if z >= 2299161 then
+        (* We use the Num module here to prevent overflow *)
+        let day' = Num.(((num_of_int 4) */ 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.(
@@ -286,3 +355,139 @@ let try_finally f except =
   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