(*
This file is part of licht.

licht is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

licht is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with licht.  If not, see <http://www.gnu.org/licenses/>.
*)

module D = DataType
module T = Tools

type _ typ =
  | Unit: unit typ
  | Bool: D.Bool.t typ
  | Num: D.Num.t typ
  | String: UTF8.t typ
  | List: 'a typ -> 'a list typ

let t_unit = Unit
let t_bool: DataType.Bool.t typ = Bool
let t_int:  DataType.Num.t  typ = Num
let t_string: UTF8.t typ = String
let t_list (t: 'a typ): 'a list typ = List t

let typ_of_format: type a. a ScTypes.DataFormat.t -> a typ = function
  | ScTypes.DataFormat.Date -> Num
  | ScTypes.DataFormat.Number -> Num
  | ScTypes.DataFormat.String -> String
  | ScTypes.DataFormat.Bool -> Bool


let rec repr:
type a. Format.formatter -> a typ -> unit =
fun printer typ -> match typ with
  | Unit ->   Format.fprintf printer "Unit"
  | Bool ->   Format.fprintf printer "Bool"
  | Num  ->   Format.fprintf printer "Num"
  | String -> Format.fprintf printer "String"
  | List t -> Format.fprintf printer "List[%a]"
      (repr[@tailcall]) t

module C = Catalog.Make(struct

  let repr = repr

  let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp =
  begin fun a b ->
    match a, b with
    | Unit, Unit     -> T.Eq
    | Bool, Bool     -> T.Eq
    | Num, Num       -> T.Eq
    | String, String -> T.Eq
    | List l1, List l2 ->
        begin match compare_typ l1 l2 with
        | T.Lt -> T.Lt
        | T.Eq -> T.Eq
        | T.Gt -> T.Gt
        end
    | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
  end

  type 'a t = 'a typ

  type 'a returnType = 'a ScTypes.ReturnType.t

end)

let f_num = ScTypes.ReturnType.f_num
let f_date = ScTypes.ReturnType.f_date
let f_number = ScTypes.ReturnType.f_number
let f_string = ScTypes.ReturnType.f_string
let f_bool = ScTypes.ReturnType.f_bool

module Make_Compare(Comp: D.COMPARABLE) = struct

  let register t catalog  = begin catalog
    |> C.register2 "="  (t, t) f_bool Comp.eq
    |> C.register2 "<>" (t, t) f_bool Comp.neq
    |> C.register2 ">"  (t, t) f_bool Comp.gt
    |> C.register2 ">=" (t, t) f_bool Comp.ge
    |> C.register2 "<"  (t, t) f_bool Comp.lt
    |> C.register2 "<=" (t, t) f_bool Comp.le
  end

end

let built_in catalog = begin

  let module CompareNum = Make_Compare(D.Num) in
  let module CompareString = Make_Compare(D.String) in
  let module CompareBool = Make_Compare(D.Bool) in

  (* Helper for list functions : reduce over a list of elements *)
  let reduce name typ res f c = begin
    C.register1 name (t_list typ) res (fun x ->
      List.fold_left f (List.hd x) x) c
  |> C.register1 name (t_list (t_list typ)) res (fun x ->
      List.fold_left (List.fold_left f) (List.hd (List.hd x)) x);
  end in

  (* Helper for list functions : fold over a list of elements *)
  let fold name t_in t_out f init c = begin
    C.register1 name (t_list t_in) t_out (fun x ->
      List.fold_left f init x) c
  |> C.register1 name (t_list (t_list t_in)) t_out (fun x ->
      List.fold_left (List.fold_left f) init x)
  end in


  let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c in

  (* Build a date *)
  C.register3 "date"  (t_int, t_int, t_int) f_date (
    fun year month day ->
      D.Date.get_julian_day
        (D.Num.to_int year)
        (D.Num.to_int month)
        (D.Num.to_int day)
  ) catalog
  |> CompareNum.register t_int

  |> C.register1 "rand" t_unit       f_number  D.Num.rnd

  |> C.register1 "pi"   t_unit       f_number (fun () -> D.Num.of_float (4. *. atan 1.))
  |> C.register1 "sin"  t_int        f_number (fun x  -> D.Num.of_float (sin  (D.Num.to_float x)))
  |> C.register1 "cos"  t_int        f_number (fun x  -> D.Num.of_float (cos  (D.Num.to_float x)))
  |> C.register1 "tan"  t_int        f_number (fun x  -> D.Num.of_float (tan  (D.Num.to_float x)))
  |> C.register1 "atan" t_int        f_number (fun x  -> D.Num.of_float (atan (D.Num.to_float x)))
  |> C.register1 "asin" t_int        f_number (fun x  -> D.Num.of_float (asin (D.Num.to_float x)))
  |> C.register1 "acos" t_int        f_number (fun x  -> D.Num.of_float (acos (D.Num.to_float x)))
  |> C.register1 "sinh" t_int        f_number (fun x  -> D.Num.of_float (sinh (D.Num.to_float x)))
  |> C.register1 "cosh" t_int        f_number (fun x  -> D.Num.of_float (cosh (D.Num.to_float x)))
  |> C.register1 "tanh" t_int        f_number (fun x  -> D.Num.of_float (tanh (D.Num.to_float x)))
  |> C.register2 "atan2" (t_int, t_int)f_number (fun x y ->
    D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y))
  )

  |> C.register1 "sqrt" t_int        f_number (fun x  -> D.Num.of_float (sqrt(D.Num.to_float x)))
  |> C.register1 "exp"  t_int        f_number (fun x  -> D.Num.of_float (exp (D.Num.to_float x)))
  |> C.register1 "ln"   t_int        f_number (fun x  -> D.Num.of_float (log (D.Num.to_float x)))

  |> C.register3 "if" (t_bool, t_int, t_int) f_number if_
  |> C.register3 "if" (t_bool, t_bool, t_bool) f_bool if_
  |> C.register3 "if" (t_bool, t_string, t_string) f_string if_

  |> C.register1 "abs"   t_int       f_number  D.Num.abs
  |> C.register1 "int"   t_int       f_number  D.Num.floor
  |> C.register1 "rounddown" t_int   f_number  D.Num.round_down
  |> C.register1 "round" t_int       f_number  D.Num.round

  |> C.register1 "trim"  t_string    f_string  UTF8.trim
  |> C.register1 "right" t_string    f_string  (fun x -> UTF8.get x (-1))
  |> C.register2 "right" (t_string, t_int) f_string (
    fun t n ->
      let n' = D.Num.to_int n in
      UTF8.sub t (-(n')) n'
  )
  |> C.register1 "left"  t_string    f_string  (fun x -> UTF8.get x 0)
  |> C.register2 "left"  (t_string, t_int) f_string (
    fun t n ->
      let n' = D.Num.to_int n in
      UTF8.sub t 0 n'
  )
  |> C.register1 "len"   t_string    f_number  (fun x -> D.Num.of_int (UTF8.length x))
  |> C.register1 "lenb"  t_string    f_number  (fun x -> D.Num.of_int (String.length (UTF8.to_utf8string x)))
  |> C.register1 "lower" t_string    f_string  UTF8.lower
  |> C.register1 "unicode" t_string  f_number (fun x -> D.Num.of_int (UTF8.code x))
  |> C.register1 "unichar" t_int     f_string (fun x -> UTF8.char (D.Num.to_int x))
  |> C.register1 "upper" t_string    f_string  UTF8.upper
  |> C.register3 "substitute" (t_string, t_string, t_string)  f_string  UTF8.replace
  |> C.register2 "rept"  (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t)

  |> CompareBool.register t_bool
  |> C.register1 "true"  t_unit            f_bool (fun () -> D.Bool.true_)
  |> C.register1 "false" t_unit            f_bool (fun () -> D.Bool.false_)
  |> C.register1 "not"   t_bool            f_bool D.Bool.not
  |> C.register2 "and"   (t_bool, t_bool)  f_bool D.Bool.and_
  |> C.register2 "or"    (t_bool, t_bool)  f_bool D.Bool.or_
  |> C.register2 "xor"   (t_bool, t_bool)  f_bool D.Bool.neq

  |> CompareString.register t_string

  |> reduce "min" t_int f_num D.Num.min (* Minimum value from a list *)
  |> reduce "max" t_int f_num D.Num.max (* Maximum value from a list *)

  |> fold "sum"     t_int f_number D.Num.add  (D.Num.zero)
  |> fold "product" t_int f_number D.Num.mult (D.Num.one)

  |> C.register2 "^"     (t_int, t_int) f_number  D.Num.pow
  |> C.register2 "power" (t_int, t_int) f_number  D.Num.pow

  |> C.register2 "gcd"(t_int, t_int) f_number  D.Num.gcd
  |> C.register2 "lcm"(t_int, t_int) f_number  D.Num.lcm
  |> C.register1 "+"  t_int          f_num     (fun x -> x)
  |> C.register1 "-"  t_int          f_num     D.Num.neg    (* Unary negation *)
  |> C.register2 "+"  (t_int, t_int) f_num     D.Num.add
  |> C.register2 "-"  (t_int, t_int) f_num     D.Num.sub
  |> C.register2 "*"  (t_int, t_int) f_number  D.Num.mult
  |> C.register2 "/"  (t_int, t_int) f_number  D.Num.div

end