(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_tai64.ml

  Copyright (c) 2003-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type t

exception Range_error
exception Label_error

external compare: t -> t -> int = "cf_tai64_compare"
external now: unit -> t = "cf_tai64_now"
external epoch_: unit -> t = "cf_tai64_epoch"
external first_: unit -> t = "cf_tai64_first"
external last_: unit -> t = "cf_tai64_last"
external mjd_epoch_: unit -> t = "cf_tai64_mjd_epoch"
external set_current_offset_: int -> unit = "cf_tai64_set_current_offset"
external to_unix_time: t -> float = "cf_tai64_to_unix_time"
external of_unix_time: float -> t = "cf_tai64_of_unix_time"
external to_label: t -> string = "cf_tai64_to_label"
external of_label: string -> t = "cf_tai64_of_label"
external add: t -> int -> t = "cf_tai64_add_int"
external add_int32: t -> int32 -> t = "cf_tai64_add_int32"
external add_int64: t -> int64 -> t = "cf_tai64_add_int64"
external sub: t -> t -> int64 = "cf_tai64_sub"

;;
external init_: unit -> unit = "cf_tai64_init";;
let _ = Callback.register_exception "Cf_tai64.Range_error" Range_error;;
init_ ();;

let epoch = epoch_ ()
let first = first_ ()
let last = last_ ()
let mjd_epoch = mjd_epoch_ ()

type archive_t = {
    a_current_: int;
    a_history_: (t * int) list;
    a_expires_: t;
}

(*---
  This data is copied manually copied from the NIST leap seconds archive.
  <ftp://time.nist.gov/pub/leap-seconds.3331497600>
  
  Yes, this really shouldn't be hard-coded.  Perhaps, there is a way to
  retrieve this information from an NTP client application.
  ---*)
let embedded_ = "3360441600", [
    "2272060800", 10;    (* 1 Jan 1972 *)
    "2287785600", 11;    (* 1 Jul 1972 *)
    "2303683200", 12;    (* 1 Jan 1973 *)
    "2335219200", 13;    (* 1 Jan 1974 *)
    "2366755200", 14;    (* 1 Jan 1975 *)
    "2398291200", 15;    (* 1 Jan 1976 *)
    "2429913600", 16;    (* 1 Jan 1977 *)
    "2461449600", 17;    (* 1 Jan 1978 *)
    "2492985600", 18;    (* 1 Jan 1979 *)
    "2524521600", 19;    (* 1 Jan 1980 *)
    "2571782400", 20;    (* 1 Jul 1981 *)
    "2603318400", 21;    (* 1 Jul 1982 *)
    "2634854400", 22;    (* 1 Jul 1983 *)
    "2698012800", 23;    (* 1 Jul 1985 *)
    "2776982400", 24;    (* 1 Jan 1988 *)
    "2840140800", 25;    (* 1 Jan 1990 *)
    "2871676800", 26;    (* 1 Jan 1991 *)
    "2918937600", 27;    (* 1 Jul 1992 *)
    "2950473600", 28;    (* 1 Jul 1993 *)
    "2982009600", 29;    (* 1 Jul 1994 *)
    "3029443200", 30;    (* 1 Jan 1996 *)
    "3076704000", 31;    (* 1 Jul 1997 *)
    "3124137600", 32;    (* 1 Jan 1999 *)
    "3345062400", 33;    (* 1 Jan 2006 *)
]

let archive_ =
    let tai64_1900 = Int64.of_string "0x3fffffff7c55818a" in
    let tai64_1900 = add_int64 first tai64_1900 in
    let rec loop dt0 adj acc = function
        | (_, dt) :: tl when dt0 = dt ->
            loop dt0 adj acc tl
        | (secs, dt) :: tl ->
            let secs = Int64.of_string secs in
            let tai64 = add_int64 tai64_1900 secs in
            let tai64 = add tai64 adj in
            loop dt (adj + (dt - dt0)) ((tai64, dt0) :: acc) tl
        | [] ->
            dt0, acc
    in
    let expires, history = embedded_ in
    let current, history = loop 10 0 [] history in
    let expires = add_int64 tai64_1900 (Int64.of_string expires) in
    let expires = add expires current in
    set_current_offset_ current;
    ref {
        a_current_ = current;
        a_history_ = history;
        a_expires_ = expires;
    }

let leapsec_add =
    let rec loop mark hit dt = function
        | (tai, dt') :: tl ->
            let mark' = add mark (10 - dt') in
            let cmp = compare tai mark' in
            if cmp < 0 || hit && cmp = 0 then
                loop mark hit dt' tl
            else
                dt
        | _ ->
            dt
    in
    fun mark hit ->
        let a = !archive_ in
        let dt = loop mark hit a.a_current_ a.a_history_ in
        add mark (dt - 10)

let leapsec_sub =
    let rec loop mark dt = function
        | (tai, dt) :: tl when (compare tai mark < 0) ->
            loop mark dt tl
        | (tai, _) :: _ when (compare tai mark = 0) ->
            true, dt
        | _ ->
            false, dt
    in
    fun mark ->
        let a = !archive_ in
        let leap, dt = loop mark a.a_current_ a.a_history_ in
        leap, add mark (10 - dt)

(*--- End of File [ cf_tai64.ml ] ---*)
