functional text display

dune

@@ -15,17 +15,22 @@
 
 (executables
  (names oplevel)
- (modules oplevel secrets)
+ (modules oplevel secrets perfgraph ogui)
  (libraries
    lwt
    store
-   lablgtk3
-   lablgtk3-sourceview3
-   lwt_glib
+   memtrace
+   tgls
+   tgls.tgles2
+   graphv_gles2_native
+   stb_image
+   glfw-ocaml
+   gg
    irmin-git
    compiler-libs.toplevel
  )
  (link_flags (-linkall))
+ (ocamlopt_flags (:standard -O3 -unboxed-types))
  (modes byte)
  (preprocess
   (pps ppx_irmin))

oplevel.ml

@@ -1,40 +1,77 @@
 open Lwt.Infix
 module F = Fmt
+open Tgles2
+module Gv = Graphv_gles2_native
 
-let lang_mime_type = "text/x-ocaml"
-let lang_name = "ocaml"
-let use_mime_type = true
-let font_name = "Monospace 12"
+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 () =
+  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
+  let blowup = ref false in
+
+  (* Thread which is woken up when the main window is closed. *)
+  let _waiter, _wakener = Lwt.wait () in
+
   Lwt_main.run
-    ((* Initializes GTK. *)
-     ignore (GMain.init ());
-
-     (* Install Lwt<->Glib integration. *)
-     Lwt_glib.install ();
-
-     (* Thread which is wakeup when the main window is closed. *)
-     let waiter, wakener = Lwt.wait () in
-
-     let language_manager =
-       GSourceView3.source_language_manager ~default:true
-     in
-
-     let lang =
-       if use_mime_type then
-         match
-           language_manager#guess_language
-             ~content_type:lang_mime_type ()
-         with
-         | Some x -> x
-         | None ->
-             failwith (F.str "no language for %s" lang_mime_type)
-       else
-         match language_manager#language lang_name with
-         | Some x -> x
-         | None -> failwith (F.str "can't load %s" lang_name)
-     in
+    ((fun () ->
        Store.init_default
          (F.str "%s/console/rootstore.git" Secrets.giturl)
        >>= fun t ->
@@ -42,58 +79,80 @@ let () =
        (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
        | Not_found | Invalid_argument _ ->
            Lwt.return
-           "print_newline \"rootstore://.config/init.ml not found\";;"
+             "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 ->
-     let source_buffer =
-       GSourceView3.source_buffer ~language:lang ~text
-         ?style_scheme:
-           ((GSourceView3.source_style_scheme_manager ~default:true)
-              #style_scheme "solarized-dark")
-         ~highlight_matching_brackets:true ~highlight_syntax:true ()
-     in
+       GLFW.setKeyCallback ~window
+         ~f:
+           (Some
+              (fun _ key _ state _ ->
+                match (key, state) with
+                | GLFW.Space, GLFW.Release -> blowup := not !blowup
+                | _ -> ()))
+       |> ignore;
 
-     let win = GWindow.window ~title:"oplevel main" () in
-     (* Quit when the window is closed. *)
-     ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener));
-     (* Show the window. *)
-     win#show ();
+       let t = GLFW.getTime () |> ref in
+       while (not GLFW.(windowShouldClose ~window)) && !continue do
+         let now = GLFW.getTime () in
+         let dt = now -. !t in
+         t := now;
 
-     let vbox =
-       GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add ()
-     in
-     let scroll_edit =
-       GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
-         ~packing:vbox#add ()
-     in
-     let edit =
-       GSourceView3.source_view ~source_buffer ~auto_indent:true
-         ~insert_spaces_instead_of_tabs:true ~tab_width:2
-         ~show_line_numbers:true ~right_margin_position:80
-         ~show_right_margin:true (* ~smart_home_end:true *)
-         ~packing:scroll_edit#add ~height:500 ~width:650 ()
-     in
-     edit#misc#modify_font_by_name font_name;
-     edit#set_smart_home_end `AFTER;
-     if edit#smart_home_end <> `AFTER then failwith "regret";
-     ignore
-       (edit#connect#undo ~callback:(fun _ -> prerr_endline "undo"));
+         Perfgraph.update graph dt;
 
-     let scroll_output =
-       GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
-         ~packing:vbox#add ()
-     in
-     let output_buffer = GText.buffer ~text:"loading..." () in
-     let _output_win =
-       GText.view ~buffer:output_buffer ~editable:false
-         ~cursor_visible:true ~packing:scroll_output#add ()
+         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.;
+
+         let ui =
+           Ogui.Ui.window ctx Gg.(Box2.v P2.o (P2.v 500. 500.))
          in
+         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 ()
+         (*continue := false;*)
+       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;
        F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
        Toploop.initialize_toplevel_env ();
-     let out_ppf =
+
+       (* let out_ppf =
             Format.formatter_of_out_functions
               Format.
                 {
@@ -108,94 +167,12 @@ let () =
                   out_spaces =
                     (fun n -> output_buffer#insert (String.make n ' '));
                 }
-     in
-
-     ignore (GtkMain.BindingSet.make "execute");
-
-     let module GToolbox = struct
-       include GToolbox
-
-       (* mk_keys turns keys from a key_combination into a format which can be used in
-          * a GTK+ RC file. *)
-       let mk_keys (mods, c) =
-         let mods =
-           List.map
-             (function
-               | `A -> "<alt>" | `C -> "<control>" | `S -> "<shift>")
-             mods
-         in
-         String.concat "" mods
-         ^ String.make 1 (Char.lowercase_ascii c)
-
-       (* Signal creation for shortcuts unfortunately requires us to create an
-        * in-memory gtkrc file which this function do. *)
-       let make_gtkrc_string g_type shortcuts =
-         let sp = Printf.sprintf in
-         let b = Buffer.create 4000 in
-         Buffer.add_string b "binding \"Shortcuts\" {";
-         StdLabels.List.iter shortcuts ~f:(fun t ->
-             ListLabels.iter t.keys ~f:(fun keys ->
-                 let keys = mk_keys keys in
-                 Buffer.add_string b
-                   (sp " bind \"%s\" { \"%s\" () }" keys t.name)));
-         Buffer.add_string b "}";
-         let classname = Gobject.Type.name g_type in
-         Buffer.add_string b
-           (sp "\nclass \"%s\" binding \"Shortcuts\"" classname);
-         Buffer.contents b
-
-       let create_shortcuts ~window:(win : #GWindow.window_skel)
-           ~shortcuts ~callback =
-         let win = win#as_window in
-         let g_type = Gobject.get_type win in
-         F.pr "gtkrc_string: %s@.@."
-           (make_gtkrc_string g_type shortcuts);
-         GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts);
-         ListLabels.iter shortcuts ~f:(fun t ->
-             let sgn =
-               {
-                 GtkSignal.name = t.name;
-                 classe = `window;
-                 marshaller = GtkSignal.marshal_unit;
-               }
-             in
-             GtkSignal.signal_new t.name g_type
-               [ `ACTION; `RUN_FIRST ];
-             ignore
-               (GtkSignal.connect ~sgn
-                  ~callback:(fun () -> callback t.message)
-                  win))
-     end in
-     GToolbox.create_shortcuts ~window:win
-       ~shortcuts:
-         [
-           {
-             name = "Quit";
-             keys = [ ([ `C ], 'q') ];
-             message = `Quit;
-           };
-           {
-             name = "Execute";
-             keys = [ ([ `C ], 'e') ];
-             message = `Execute;
-           };
-         ]
-       ~callback:(function
-         | `Quit ->
-             F.pr "`Quit@.";
-             F.pf out_ppf "`Quit@.";
-             Lwt.wakeup wakener ()
-         | `Execute ->
-             F.pr "`Execute@.";
-             F.pf out_ppf "`Execute@.";
-             ignore
-               (Toploop.use_input out_ppf
-                  (String (source_buffer#get_text ()))));
+          in *)
 
        (* ignore
           (Toploop.use_input out_ppf
              (String "#use \"topfind\";;\n#list;;")); *)
-     output_buffer#set_text "";
-     ignore (Toploop.use_input out_ppf (String text));
+       (* ignore (Toploop.use_input Format.std_formatter (String text)); *)
        (* Wait for it to be closed. *)
-     waiter)
+       Lwt.return ())
+       ())

perfgraph.ml

@@ -0,0 +1,87 @@
+module NVG = Graphv_gles2_native
+
+type style = FPS | Ms | Percent
+
+type t = {
+  style : style;
+  name : string;
+  values : float array;
+  mutable head : int;
+  mutable last : float;
+}
+
+let init style name =
+  { name; style; values = Array.make 100 0.; head = 0; last = 0. }
+
+let average t =
+  let avg = ref 0. in
+  for i = 0 to Array.length t.values - 1 do
+    avg := !avg +. t.values.(i)
+  done;
+  !avg /. float (Array.length t.values)
+
+let update t dt =
+  t.head <- (t.head + 1) mod Array.length t.values;
+  t.values.(t.head) <- dt
+(*
+    t.last <- t.last +. dt;
+    if t.last > 1. then (
+        t.last <- 0.;
+        Printf.printf "FPS %.2f\n%!" (1. /. average t);
+    )
+    *)
+
+let render t (vg : NVG.t) x y =
+  let avg = average t in
+  let w = 200. in
+  let h = 35. in
+
+  let open NVG in
+  let open FloatOps in
+  Path.begin_ vg;
+  Path.rect vg ~x ~y ~w ~h;
+  set_fill_color vg ~color:(Color.rgba ~r:0 ~g:0 ~b:0 ~a:128);
+  fill vg;
+
+  Path.begin_ vg;
+  Path.move_to vg ~x ~y:(y + h);
+  let len = Array.length t.values in
+  (match t.style with
+  | FPS ->
+      for i = 0 to len -. 1 do
+        let v = 1. / (0.00001 + t.values.((t.head +. i) mod len)) in
+        let v = if v > 80. then 80. else v in
+        let vx = x + (float i / (float len - 1.) * w) in
+        let vy = y + h - (v / 80. * h) in
+        Path.line_to vg ~x:vx ~y:vy
+      done
+  | Percent -> ()
+  | Ms -> ());
+  Path.line_to vg ~x:(x + w) ~y:(y + h);
+  set_fill_color vg ~color:(Color.rgba ~r:255 ~g:192 ~b:0 ~a:128);
+  fill vg;
+
+  Text.set_font_face vg ~name:"mono";
+
+  Text.set_size vg ~size:12.;
+  Text.set_align vg ~align:Align.(left lor top);
+  set_fill_color vg ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:192);
+  Text.text vg ~x:(x + 3.) ~y:(y + 3.) t.name;
+
+  match t.style with
+  | FPS ->
+      Text.set_size vg ~size:15.;
+      Text.set_align vg ~align:Align.(right lor top);
+      set_fill_color vg
+        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:255);
+      let s = Printf.sprintf "%.2f FPS" (1. / avg) in
+      Text.text vg ~x:(x + w - 3.) ~y:(y + 3.) s;
+
+      Text.set_size vg ~size:13.;
+      Text.set_align vg ~align:Align.(right lor baseline);
+      set_fill_color vg
+        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:160);
+      let s = Printf.sprintf "%.2f ms" (avg * 1000.) in
+      Text.text vg ~x:(x + w - 3.) ~y:(y + h - 3.) s
+  | Percent -> ()
+  | Ms -> ()