oplevel/oplevel.ml

open Lwt.Infix
module F = Fmt
open Tgles2
module Gv = Graphv_gles2_native

module GLFWExtras = struct
  open Ctypes
  open Foreign

  let glfwSetErrorCallback :
      (int -> string -> unit) -> int -> string -> unit =
    let errorfun = int @-> string @-> returning void in
    foreign "glfwSetErrorCallback"
      (funptr errorfun @-> returning (funptr errorfun))
end

let errorcb error desc =
  Printf.printf "GLFW error %d: %s\n%!" error desc

let load_data vg =
  let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
  let _ =
    Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"sans-bold"
      ~file:"./assets/Roboto-Bold.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"emoji"
      ~file:"./assets/NotoEmoji-Regular.ttf"
  in
  Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji";
  Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
  Gv.Text.set_font_face vg ~name:"mono"

let pp_glfw_key : GLFW.key F.t =
 fun ppf k ->
  F.pf ppf
    GLFW.(
      match k with
      | Unknown -> "Unknown"
      | Space -> "Space"
      | Apostrophe -> "Apostrophe"
      | Comma -> "Comma"
      | Minus -> "Minus"
      | Period -> "Period"
      | Slash -> "Slash"
      | Num0 -> "Num0"
      | Num1 -> "Num1"
      | Num2 -> "Num2"
      | Num3 -> "Num3"
      | Num4 -> "Num4"
      | Num5 -> "Num5"
      | Num6 -> "Num6"
      | Num7 -> "Num7"
      | Num8 -> "Num8"
      | Num9 -> "Num9"
      | Semicolon -> "Semicolon"
      | Equal -> "Equal"
      | A -> "A"
      | B -> "B"
      | C -> "C"
      | D -> "D"
      | E -> "E"
      | F -> "F"
      | G -> "G"
      | H -> "H"
      | I -> "I"
      | J -> "J"
      | K -> "K"
      | L -> "L"
      | M -> "M"
      | N -> "N"
      | O -> "O"
      | P -> "P"
      | Q -> "Q"
      | R -> "R"
      | S -> "S"
      | T -> "T"
      | U -> "U"
      | V -> "V"
      | W -> "W"
      | X -> "X"
      | Y -> "Y"
      | Z -> "Z"
      | LeftBracket -> "LeftBracket"
      | Backslash -> "Backslash"
      | RightBracket -> "RightBracket"
      | GraveAccent -> "GraveAccent"
      | World1 -> "World1"
      | World2 -> "World2"
      | Escape -> "Escape"
      | Enter -> "Enter"
      | Tab -> "Tab"
      | Backspace -> "Backspace"
      | Insert -> "Insert"
      | Delete -> "Delete"
      | Right -> "Right"
      | Left -> "Left"
      | Down -> "Down"
      | Up -> "Up"
      | PageUp -> "PageUp"
      | PageDown -> "PageDown"
      | Home -> "Home"
      | End -> "End"
      | CapsLock -> "CapsLock"
      | ScrollLock -> "ScrollLock"
      | NumLock -> "NumLock"
      | PrintScreen -> "PrintScreen"
      | Pause -> "Pause"
      | F1 -> "F1"
      | F2 -> "F2"
      | F3 -> "F3"
      | F4 -> "F4"
      | F5 -> "F5"
      | F6 -> "F6"
      | F7 -> "F7"
      | F8 -> "F8"
      | F9 -> "F9"
      | F10 -> "F10"
      | F11 -> "F11"
      | F12 -> "F12"
      | F13 -> "F13"
      | F14 -> "F14"
      | F15 -> "F15"
      | F16 -> "F16"
      | F17 -> "F17"
      | F18 -> "F18"
      | F19 -> "F19"
      | F20 -> "F20"
      | F21 -> "F21"
      | F22 -> "F22"
      | F23 -> "F23"
      | F24 -> "F24"
      | F25 -> "F25"
      | Kp0 -> "Kp0"
      | Kp1 -> "Kp1"
      | Kp2 -> "Kp2"
      | Kp3 -> "Kp3"
      | Kp4 -> "Kp4"
      | Kp5 -> "Kp5"
      | Kp6 -> "Kp6"
      | Kp7 -> "Kp7"
      | Kp8 -> "Kp8"
      | Kp9 -> "Kp9"
      | KpDecimal -> "KpDecimal"
      | KpDivide -> "KpDivide"
      | KpMultiply -> "KpMultiply"
      | KpSubtract -> "KpSubtract"
      | KpAdd -> "KpAdd"
      | KpEnter -> "KpEnter"
      | KpEqual -> "KpEqual"
      | LeftShift -> "LeftShift"
      | LeftControl -> "LeftControl"
      | LeftAlt -> "LeftAlt"
      | LeftSuper -> "LeftSuper"
      | RightShift -> "RightShift"
      | RightControl -> "RightControl"
      | RightAlt -> "RightAlt"
      | RightSuper -> "RightSuper"
      | Menu -> "Menu")

let pp_glfw_key_action : GLFW.key_action F.t =
 fun ppf s ->
  F.pf ppf
    GLFW.(
      match s with
      | Release -> "Release"
      | Press -> "Press"
      | Repeat -> "Repeat")

let pp_glfw_mods =
  F.(
    list (fun ppf s ->
        pf ppf
          GLFW.(
            match s with
            | Shift -> "Shift"
            | Control -> "Control"
            | Alt -> "Alt"
            | Super -> "Super")))

let () =
  GLFW.init ();
  at_exit GLFW.terminate;
  let _res = GLFWExtras.glfwSetErrorCallback errorcb in
  GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi;
  GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2;
  GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0;

  let window =
    GLFW.createWindow ~width:1000 ~height:600 ~title:"window" ()
  in
  (* Make the window's context current *)
  GLFW.makeContextCurrent ~window:(Some window);
  GLFW.swapInterval ~interval:0;

  Gl.clear_color 0.3 0.3 0.32 1.;

  Memtrace.trace_if_requested ();

  let ctx =
    Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
  in

  let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
  let _odata = load_data ctx in
  let continue = ref true in
  let min_fps = ref Float.max_float in
  let max_fps = ref Float.min_float in

  (* Thread which is woken up when the main window is closed. *)
  let _waiter, _wakener = Lwt.wait () in
  F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
  Toploop.initialize_toplevel_env ();

  let text =
    Lwt_main.run
      ((fun () ->
         Store.init_default
           (F.str "%s/console/rootstore.git" Secrets.giturl)
         >>= fun t ->
         Store.S.tree t >>= fun rootstore ->
         (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
         | Not_found | Invalid_argument _ ->
             Lwt.return
               "print_newline \"rootstore://.config/init.ml not \
                found\";;"
         | exc ->
             Lwt.return
               (F.str ".config/init.ml load exception: %s"
                  (Printexc.to_string exc)))
         >>= fun text -> Lwt.return text)
         ())
  in

  let ui =
    Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.))
  in

  GLFW.setKeyCallback ~window
    ~f:
      (Some
         (fun window key int state mods ->
           F.epr
             "GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \
              mods=%a@."
             pp_glfw_key key int pp_glfw_key_action state pp_glfw_mods
             mods;
           Ogui.Ui.keycallback ui window key int state mods))
  |> ignore;

  let t = GLFW.getTime () |> ref in

  while (not GLFW.(windowShouldClose ~window)) && !continue do
    Lwt_main.run
      ((fun () ->
         let now = GLFW.getTime () in
         let dt = now -. !t in
         t := now;

         Perfgraph.update graph dt;

         if now > 2. then (
           let avg = 1. /. Perfgraph.average graph in
           min_fps := Float.min avg !min_fps;
           max_fps := Float.max avg !max_fps);

         let _mx, _my = GLFW.getCursorPos ~window in
         let win_w, win_h = GLFW.getWindowSize ~window in

         Gl.viewport 0 0 win_w win_h;
         Gl.clear
           (Gl.color_buffer_bit lor Gl.depth_buffer_bit
          lor Gl.stencil_buffer_bit);

         Gl.enable Gl.blend;
         Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
         Gl.enable Gl.cull_face_enum;
         Gl.disable Gl.depth_test;

         let win_w, win_h = (float win_w, float win_h) in
         Gv.begin_frame ctx ~width:win_w ~height:win_h
           ~device_ratio:1.;

         Perfgraph.render graph ctx (win_w -. 205.) 5.;

         ignore Ogui.TextEdit.(show (multiline (String text)) ui);
         (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
         Gv.end_frame ctx;

         Gc.major_slice 0 |> ignore;

         GLFW.swapBuffers ~window;
         GLFW.pollEvents ();
         Lwt.return_unit)
         ())
  done;

  Printf.printf "MIN %.2f\n" !min_fps;
  Printf.printf "MAX %.2f\n%!" !max_fps;

  if Array.length Sys.argv = 1 then
    while not GLFW.(windowShouldClose ~window) do
      GLFW.pollEvents ();
      Unix.sleepf 0.25
    done

(* let out_ppf =
     Format.formatter_of_out_functions
       Format.
         {
           out_string = (fun s _ _ -> output_buffer#insert s);
           out_flush = (fun () -> ());
           out_indent =
             (fun n ->
               for _ = 0 to n do
                 output_buffer#insert "  "
               done);
           out_newline = (fun () -> output_buffer#insert "\n");
           out_spaces =
             (fun n -> output_buffer#insert (String.make n ' '));
         }
   in *)

(* ignore
   (Toploop.use_input out_ppf
      (String "#use \"topfind\";;\n#list;;")); *)
(* ignore (Toploop.use_input Format.std_formatter (String text)); *)
(* Wait for it to be closed. *)