Source file misc.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program 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, version 3 of the License.       *)
(*                                                                               *)
(*    This program 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 this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Utilities.

 Not useful for library's user. *)

open Tsdl

module IMap = Map.Make(Int)
module ISet = Set.Make(Int)

module type Idset = sig
    type id
    type t
    val empty : t
    val add : t -> id -> t
    val remove : t -> id -> t
    val compare : t -> t -> int
    val to_list : t -> id list
    val of_list : id list -> t
    val iter : (id -> unit) -> t -> unit
  end

module type Id =
  sig
    type t
    val gen : unit -> t
    val compare : t -> t -> int
    val to_string : t -> string
    val pp : Format.formatter -> t -> unit
    val equal : t -> t -> bool
    val to_int : t -> int
    val of_int : int -> t
    module Map : Map.S with type key = t
    val wrapper : t Ocf.wrapper
  end

module Id () : Id =
  struct
    type t = int
    let gen = let i = ref 0 in fun () -> let id = !i in incr i; id
    let compare = Stdlib.compare
    let to_string = string_of_int
    let pp ppf t = Format.pp_print_string ppf (to_string t)
    let equal x y = x = y
    let to_int t = t
    let of_int t = t
    module Map = Map.Make(struct type nonrec t = t let compare = compare end)
    let wrapper =
      let w = Ocf.Wrapper.int in
      let to_json ?with_doc id = w.to_json ?with_doc (to_int id) in
      let from_json ?def json = of_int (w.from_json ?def json) in
      Ocf.Wrapper.make to_json from_json
  end

module type Base_id = sig
    type t
    val to_int : t -> int
    val of_int : int -> t
  end
module Idset (I:Base_id) : Idset with type id = I.t = struct
    type id = I.t
    type t = int64 array

    let create () = Array.make 1 Int64.zero
    let empty = create ()
    let len = Array.length

    let extend t n =
      let t' = Array.make n Int64.zero in
      Array.blit t 0 t' 0 (len t) ;
      t'

    let add t id =
      let n = I.to_int id in
      let i = n / 64 in
      let t = if len t <= i then extend t (i+1) else Array.copy t in
      let j = n mod 64 in
      let mask = Int64.(shift_left one j) in
      let v = Int64.logor t.(i) mask in
      t.(i) <- v;
      t

    let remove t id =
      let n = I.to_int id in
      let i = n / 64 in
      if len t > i then
        (
         let j = n mod 64 in
         let mask = Int64.(lognot (shift_left one j)) in
         let t = Array.copy t in
         let v = Int64.logand t.(i) mask in
         t.(i) <- v;
         t
        )
      else
        t

    let compare t1 t2 = Stdlib.compare t1 t2

    let to_list t =
      let res = ref [] in
      let f i n =
        for j = 0 to 63 do
          let mask = Int64.(shift_left one j) in
          let v = Int64.logand n mask in
          if not Int64.(equal v zero) then
            res := (I.of_int (i + j)) :: !res
        done
      in
      Array.iteri
        (fun i n -> f (64 * i) n)
        t;
      !res

    let of_list l = List.fold_left add (create ()) l

    let iter f t = List.iter f (to_list t)
  end

(*
module Memoizer (P:sig
     type t
     val compare : t -> t -> int
     val dup : t -> t
   end) =
  struct
    module M = Map.Make(P)
    type t = { mutable map : P.t M.t }
    let create () = { map = M.empty }
    let clear t = t.map <- M.empty
    let get t x =
      match M.find_opt x t.map with
      | Some s -> s
      | None ->
          t.map <- M.add x (P.dup x) t.map;
          x
  end
*)

type error =
    | SDL_error of string
    | Missing_prop of string * string
    | Font_not_found of string
    | Could_not_load_font of string
exception Error of error

let error e = raise (Error e)
let sdl_error msg = error (SDL_error msg)
let missing_prop p props = error (Missing_prop (p, props))
let font_not_found str = error (Font_not_found str)
let could_not_load_font str = error (Could_not_load_font str)

let string_of_error = function
| SDL_error msg -> Printf.sprintf "SDL error: %s" msg
| Missing_prop (p, str_props) ->
    Printf.sprintf "Missing property %S; properties set: %s" p str_props
| Font_not_found str ->
    Printf.sprintf "Font not found: %s" str
| Could_not_load_font str ->
    Printf.sprintf "Could not load font: %s" str

let pp_error fmt e = Format.pp_print_string fmt (string_of_error e)

let () = Printexc.register_printer
  (function Error e -> Some (string_of_error e) | _ -> None)

let (let>) v f =
  match v with
  | Result.Error (`Msg msg) -> sdl_error msg
  | Ok x -> f x

let event_typ_and_window_id e =
  let t = Sdl.Event.(enum (get e typ)) in
  let id = match t with
    | `App_did_enter_background
    | `App_did_enter_foreground
    | `App_low_memory
    | `App_terminating
    | `App_will_enter_background
    | `App_will_enter_foreground
    | `Clipboard_update
    | `Controller_axis_motion
    | `Controller_button_down
    | `Controller_button_up
    | `Controller_device_added
    | `Controller_device_remapped
    | `Controller_device_removed
    | `Dollar_gesture
    | `Dollar_record -> None
    | `Drop_file
    | `Drop_text
    | `Drop_begin
    | `Drop_complete -> Some (Sdl.Event.(get e drop_window_id))
    | `Finger_down
    | `Finger_motion
    | `Finger_up
    | `Joy_axis_motion
    | `Joy_ball_motion
    | `Joy_button_down
    | `Joy_button_up
    | `Joy_device_added
    | `Joy_device_removed
    | `Joy_hat_motion -> None
    | `Key_down
    | `Key_up -> Some (Sdl.Event.(get e keyboard_window_id))
    | `Mouse_button_down
    | `Mouse_button_up -> Some (Sdl.Event.(get e mouse_button_window_id))
    | `Mouse_motion -> Some (Sdl.Event.(get e mouse_motion_window_id))
    | `Mouse_wheel -> Some (Sdl.Event.(get e mouse_wheel_window_id))
    | `Multi_gesture
    | `Quit
    | `Sys_wm_event -> None
    | `Text_editing -> Some (Sdl.Event.(get e text_editing_window_id))
    | `Text_input -> Some (Sdl.Event.(get e text_input_window_id))
    | `Unknown _ -> None
    | `User_event -> Some (Sdl.Event.(get e user_window_id))
    | `Window_event -> Some (Sdl.Event.(get e window_window_id))
    | `Display_event
    | `Sensor_update
    | `Render_targets_reset
    | `Audio_device_removed
    | `Audio_device_added
    | `Render_device_reset
    | `Keymap_changed -> None
  in
  (t, id)

let mouse_event_position win e =
  let open Sdl.Event in
  match enum (get e typ) with
  | `Mouse_button_down
  | `Mouse_button_up ->
    let x = get e mouse_button_x in
    let y = get e mouse_button_y in
    Some (x, y)
  | `Mouse_motion ->
      let x = get e mouse_motion_x in
      let y = get e mouse_motion_y in
      Some (x, y)
  | `Mouse_wheel
  | `Drop_file
  | `Drop_text
  | `Drop_begin
  | `Drop_complete ->
      (* mouse_wheel_x, mouse_wheel_y and drop events do not
         contain mouse coords; we have to retrieve them *)
      let (_,(x,y)) = Sdl.get_global_mouse_state () in
      let (wx, wy) = Sdl.get_window_position win in
      let pos = (x - wx, y - wy) in
      Some pos
  | _ -> None

(*
let render_with_int32 color f =
  fun renderer ->
    let> () =
      let (r,g,b,a) = Color.to_int8s color in
      Sdl.set_render_draw_color renderer r g b a in
    f renderer

let render_fill_rect_with_int32 renderer color =
  render_with_int32 color Sdl.render_fill_rect renderer

let render_draw_rect renderer ~x ~y ~w ~h =
  (* renderer with flag accelerated seems to not render rectangles
     properly, with one side broken; works well in software mode.
     By not let's draw lines ourselves. The important point seems to
     draw lines with points sorted on x and y *)
  if w = 0 || h = 0 then
    Ok ()
  else
    let x1 = x and y1 = y in
    let x2 = x1 + w - 1 and y2 = y1 + h - 1 in
    let> () = Sdl.(render_draw_line renderer x1 y1 x2 y1) in
    let> () = Sdl.(render_draw_line renderer x2 y1 x2 y2) in
    let> () = Sdl.(render_draw_line renderer x1 y2 x2 y2) in
    Sdl.(render_draw_line renderer x1 y1 x1 y2)

let render_draw_rect_with_int32 :
  Sdl.renderer -> int32 -> x:int -> y:int -> w:int -> h:int -> unit Sdl.result =
  fun renderer color ->
      render_with_int32 color render_draw_rect renderer
*)

let compare_points p1 p2 =
  let open Sdl.Point in
  match Stdlib.compare (x p1) (x p2) with
  | 0 -> Stdlib.compare (y p1) (y p2)
  | n -> n

let pp_point fmt (p:Sdl.point) =
  Format.fprintf fmt "{x=%d, y=%d}" (Sdl.Point.x p) (Sdl.Point.y p)

let lwt_reporter () =
  let buf_fmt ~like =
    let b = Buffer.create 512 in
    Fmt.with_buffer ~like b,
    fun () -> let m = Buffer.contents b in Buffer.reset b; m
  in
  let app, app_flush = buf_fmt ~like:Fmt.stdout in
  let dst, dst_flush = buf_fmt ~like:Fmt.stderr in
  let reporter = Logs_fmt.reporter ~app ~dst () in
  let report src level ~over k msgf =
    let k () =
      let write () = match level with
      | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ())
      | _ -> Lwt_io.write Lwt_io.stderr (dst_flush ())
      in
      let unblock () = over (); Lwt.return_unit in
      Lwt.finalize write unblock |> Lwt.ignore_result;
      k ()
    in
    reporter.Logs.report src level ~over:(fun () -> ()) k msgf;
  in
  { Logs.report = report }


type 'a state_machine = {
    state : unit -> 'a ;
    set_state : 'a -> unit ;
    f : (int*int) option -> Sdl.event -> bool
  }
let empty_state_machine = {
    state = (fun () -> failwith "State machine not initialized");
    set_state = (fun _ -> ()) ;
    f = (fun _ _ -> false) ;
  }
let mk_state_machine start_state f =
  let state = ref start_state in
  let f pos ev =
    match f !state pos ev with
    | None -> false
    | Some (st,ret) -> state := st; ret
  in
  { state = (fun () -> !state) ;
    set_state = (fun x -> state := x) ;
    f ;
  }

let list_insert =
  let rec iter ~rev elt ~pos acc i = function
  | [] -> if rev then elt :: acc else List.rev (elt :: acc)
  | l when pos <= i ->
      if rev then
        (List.rev l @ elt :: acc)
      else
        (List.rev acc) @ elt :: l
  | h :: q -> iter ~rev elt ~pos (h::acc) (i+1) q
  in
  fun list ~pos elt ->
    let rev = pos < 0 in
    iter ~rev elt ~pos:(abs pos) [] 0
      (if rev then List.rev list else list)

let list_add ?pos list elt =
  match pos with
  | None -> list @ [elt]
  | Some pos -> list_insert list ~pos elt

let lwt_option_iter f = function
| None -> Lwt.return_unit
| Some x -> f x

let array_array_find_opt =
  let rec iter pred t len i =
     if i >= len then
      None
    else
      match Array.find_opt pred t.(i) with
      | None -> iter pred t len (i+1)
      | Some x -> Some x
  in
  fun pred t -> iter pred t (Array.length t) 0

let array_array_find_index =
  let rec iter pred t len i =
     if i >= len then
      None
    else
      match Array.find_index pred t.(i) with
      | None -> iter pred t len (i+1)
      | Some j -> Some (i,j)
  in
  fun pred t -> iter pred t (Array.length t) 0

let array_array_fold_right f t acc =
  Array.fold_right (fun t2 acc -> Array.fold_right f t2 acc) t acc

let array_array_fold_left f acc t =
  Array.fold_left (fun acc t2 -> Array.fold_left f acc t2) acc t

let array_array_map f t = Array.map (fun t -> Array.map f t) t

let array_array_to_list t = array_array_fold_right List.cons t []

let split_string ?(keep_empty=false) s chars =
  let len = String.length s in
  let rec iter acc pos =
    if pos >= len then
      match acc with
        "" -> if keep_empty then [""] else []
      | _ -> [acc]
    else
      if List.mem s.[pos] chars then
        match acc with
          "" ->
            if keep_empty then
              "" :: iter "" (pos + 1)
            else
              iter "" (pos + 1)
        | _ -> acc :: (iter "" (pos + 1))
      else
        iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
  in
  iter "" 0

let strip_string s =
  let len = String.length s in
  let rec iter_first n =
    if n >= len then
      None
    else
      match s.[n] with
        ' ' | '\t' | '\n' | '\r' -> iter_first (n+1)
      | _ -> Some n
  in
  match iter_first 0 with
    None -> ""
  | Some first ->
      let rec iter_last n =
        if n <= first then
          None
        else
          match s.[n] with
            ' ' | '\t' | '\n' | '\r' -> iter_last (n-1)
          |     _ -> Some n
      in
      match iter_last (len-1) with
        None -> String.sub s first 1
      | Some last -> String.sub s first ((last-first)+1)

let is_prefix ~s ~pref =
      let len_s = String.length s in
      let len_pref = String.length pref in
      (len_pref <= len_s) &&
        (String.sub s 0 len_pref) = pref

let is_suffix ~s ~suff =
  let len_s = String.length s in
  let len_suff = String.length suff in
  (len_suff <= len_s) &&
    (String.sub s (len_s - len_suff - 1) len_suff) = suff

let string_contains =
  let rec iter s pat ls lp i =
    if i > ls - lp then false
    else
     String.sub s i lp = pat
        || iter s pat ls lp (i+1)
  in
  fun ~s ~pat ->
  let len_s = String.length s in
  let len_pat = String.length pat in
  len_pat <= len_s && iter s pat len_s len_pat 0