1 files changed, 120 insertions, 0 deletions
diff --git a/src/date.ml b/src/date.ml
new file mode 100644
index 0000000..92cb9f6
--- /dev/null
+++ b/src/date.ml
@@ -0,0 +1,120 @@
+module type CALCULABLE = sig
+
+  type t
+
+  val add: t -> t -> t
+
+  val sub: t -> t -> t
+
+  val mult: t -> t -> t
+
+  val div: t -> t -> t
+
+  val floor: t -> t
+
+  val of_int: int -> t
+
+  val to_int: t -> int
+
+  val to_float: t -> float
+
+end
+
+
+module Make(C : CALCULABLE) = struct
+
+  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 *)
+    |> C.of_int
+
+  end
+
+  let date_from_julian_day day = begin
+
+    let shift_day = C.add (C.floor day) (C.of_int 2415019) in
+
+    let z = C.to_int shift_day in
+    let f =
+      if z >= 2299161 then
+        (* We use the Num module here to prevent overflow *)
+        let product = C.mult (C.of_int 4) shift_day in
+        let shifted = C.add product (C.of_int 274277) in
+        let div = C.div shifted (C.of_int 146097) in
+        let day' = C.to_int @@ C.floor div 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
+
+    let day = C.floor j in
+    let time = C.sub j day in
+
+    let h = C.floor @@ C.mult time  (C.of_int 24) in
+    let h_24 = C.div h (C.of_int 24) in
+    let m = C.floor @@ C.mult (C.of_int 1440) (C.sub time h_24) in
+    let s = C.mult (C.of_int 86400) (C.sub (C.sub time h_24) (C.div m (C.of_int 1440))) in
+    (C.to_int h, C.to_int 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 = C.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 ->
+      let nhour = C.div (n hour) (n 24)
+      and nmin  = C.div (n min)  (n 1440)
+      and nsec  = C.div (n sec)  (n 86400) in
+      C.add (C.add (C.add (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 (
+      C.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
+
+      h n (C.to_float s)
+
+  end
+
+end