(*
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/>.
*)

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
  let test f v = match f v with Some x -> x | None -> v
end

module String = struct
  include String

  let split str ~by:sep =
    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))

  let string_of_ints v =
    let buff = Buffer.create 1 in
    let rec convert value =
      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 [@tailcall]) x
    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'

  let print_buffer f t =
    let buff = UTF8.Buffer.create 16 in
    f buff t;
    UTF8.Buffer.contents buff

  let filter_float str =
    let l = String.length str in
    if l > 0 && String.get str (l - 1) = '.' then String.sub str 0 (l - 1)
    else str
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 =
    let rec print = function
      | [] -> ()
      | [ hd ] -> f buffer hd
      | hd :: tl ->
          f buffer hd;
          UTF8.Buffer.add_string buffer sep;
          (print [@tailcall]) tl
    in

    UTF8.Buffer.add_string buffer first;
    print elems;
    UTF8.Buffer.add_string buffer last

  let rec find_map f = function
    | [] -> raise Not_found
    | hd :: tl -> (
        match f hd with Some x -> x | None -> (find_map [@tailcall]) f tl)

  and find_map2 p = function
    | [] -> raise Not_found
    | x :: l -> (
        try find_map p x with Not_found -> (find_map2 [@tailcall]) p l)
end

module Tuple2 = struct
  let fst = Stdlib.fst
  let snd = Stdlib.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)
      =
    UTF8.Printf.bprintf out "%s%a%s%a%s" first format1 a sep format2 b last
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

let fold_for f a b init =
  let rec _fold res i = if i >= b then res else _fold (f i res) (i + 1) in
  (_fold [@tailcall]) init a