oplevel/oplevel.ml

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

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_fonts 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 main =
  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.1 0.2 0.2 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 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 rootrepo =
    Store.init_default
      (F.str "%s/console/rootstore.git" Secrets.giturl)
  in

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

  load_fonts ui.gv;
  GLFW.setKeyCallback ~window
    ~f:
      (Some
         (fun _window key _int state mods ->
           Lwt.async (fun () ->
               Ogui.Ui.keycallback ui state key mods >>= fun _ ->
               Lwt.return_unit)))
  |> ignore;

  GLFW.setCharCallback ~window
    ~f:
      (Some
         (fun _window ch ->
           Lwt.async (fun () ->
               Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
  |> ignore;

  GLFW.setWindowSizeCallback ~window
    ~f:
      (Some
         Gg.(
           fun _window x y ->
             Lwd.set ui.rect
               (Box2.v V2.zero (V2.v (float x) (float y)))))
  |> ignore;

  F.pr "oplevel.ml: building initial page@.";
  let initial_path = [ ".config"; "init.ml" ] in
  TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init ->
  TextBuffer.of_string ~repo:rootrepo
    ~path:
      (List.fold_right
         (fun a (acc : string list) ->
           match acc with
           | [] -> [ F.str "%s.output" a ]
           | a' -> a :: a')
         [] initial_path)
    (F.str "(* --- output:%s --- *)\n\n"
       (String.concat "/" initial_path))
  |> Lwt.return
  >>= fun to_init ->
  let out_ppf =
    let insert s =
      Lwt.async (fun () ->
          TextBuffer.length to_init >>= fun len ->
          (* TKTK if buffer is modified here during yield from >>= it could be weird *)
          TextBuffer.insert to_init len s)
    in
    Format.formatter_of_out_functions
      Format.
        {
          out_string = (fun s _ _ -> insert s);
          out_flush = (fun () -> ());
          out_indent = (fun n -> insert (String.make (n * 2) ' '));
          out_newline = (fun () -> insert "\n");
          out_spaces = (fun n -> insert (String.make n ' '));
        }
  in

  ignore
    (Toploop.use_input out_ppf (String "#use \"topfind\";;\n#list;;"));
  (* toplevel execution binding *)
  Ui.(
    update_bindings ui
      Event.(
        fun a ->
          a
          |> adds
               [
                 [
                   Key (Press, X, [ Control ]);
                   Key (Release, X, [ Control ]);
                   Key (Press, E, [ Control ]);
                 ];
               ]
               [
                 Custom
                   (fun () ->
                     F.epr "Ctrl-X Ctrl-E@.";
                     TextBuffer.peek tb_init >>= fun str ->
                     Toploop.use_input out_ppf (String str)
                     |> F.epr "Toploop.use_input=%b@.";
                     Lwt.return_unit);
               ]));

  Layout.(
    tiling ui `Y
      ~style:
        Style.{ default with margin = Margin.symmetric 10.0 10.0 }
      [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ])
  >>= fun page ->
  let page_root = Lwd.observe page in

  let open GLFW in
  let open Event in
  Ui.update_bindings ui
    Ui.(
      adds
        [
          [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
        ]
        [ Custom (fun () -> Lwt.return ()) ]);
  F.pr "oplevel.ml: entering drawing loop@.";
  let period_min = 1.0 /. 30. in
  let t = GLFW.getTime () |> ref in

  let render root =
    let page = Lwd.quick_sample root in
    let win_w, win_h = GLFW.getWindowSize ~window in
    let width, height = (float win_w, float win_h) in
    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
    Perfgraph.render graph ctx (width -. 205.) 5.;
    (* F.epr "box=%a@." Gg.Box2.pp box;
       F.epr "Painter.layout=%a@." Gg.Box2.pp *)
    Painter.layout box ui page >>= fun _ ->
    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
    Gv.end_frame ctx;

    Lwt.return_unit
  in

  while not GLFW.(windowShouldClose ~window) do
    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 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;
    Lwt.async (fun () -> render page_root);
    Gc.major_slice 0 |> ignore;
    GLFW.swapBuffers ~window;
    GLFW.pollEvents ();
    Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t))
  done;

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

let () = Lwt_main.run main