124 lines
3.9 KiB
OCaml
124 lines
3.9 KiB
OCaml
open Js_of_ocaml
|
|
open Lwt.Infix
|
|
module NVG = Graphv_webgl
|
|
|
|
let _ =
|
|
Logs.set_reporter (Human.Logs_reporter.console_reporter ());
|
|
Logs.set_level (Some Debug)
|
|
|
|
module Log = (val Logs.src_log Logs.default : Logs.LOG)
|
|
|
|
(* This scales the canvas to match the DPI of the window,
|
|
it prevents blurriness when rendering to the canvas *)
|
|
let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
|
|
let dpr = Dom_html.window##.devicePixelRatio in
|
|
let rect = canvas##getBoundingClientRect in
|
|
let width = rect##.right -. rect##.left in
|
|
let height = rect##.bottom -. rect##.top in
|
|
canvas##.width := width *. dpr |> int_of_float;
|
|
canvas##.height := height *. dpr |> int_of_float;
|
|
let width =
|
|
Printf.sprintf "%dpx" (int_of_float width) |> Js.string
|
|
in
|
|
let height =
|
|
Printf.sprintf "%dpx" (int_of_float height) |> Js.string
|
|
in
|
|
canvas##.style##.width := width;
|
|
canvas##.style##.height := height
|
|
|
|
let webgl_initialize canvas =
|
|
scale_canvas canvas;
|
|
(* Graphv requires a stencil buffer to work properly *)
|
|
let attrs = WebGL.defaultContextAttributes in
|
|
attrs##.stencil := Js._true;
|
|
match
|
|
WebGL.getContextWithAttributes canvas attrs |> Js.Opt.to_option
|
|
with
|
|
| None ->
|
|
print_endline "Sorry your browser does not support WebGL";
|
|
raise Exit
|
|
| Some ctx -> ctx
|
|
|
|
let graphv_initialize webgl_ctx =
|
|
let open NVG in
|
|
let vg =
|
|
create
|
|
~flags:CreateFlags.(antialias lor stencil_strokes)
|
|
webgl_ctx
|
|
in
|
|
(* File in this case is actually the CSS font name *)
|
|
Text.create vg ~name:"sans" ~file:"sans" |> ignore;
|
|
webgl_ctx##clearColor 0.3 0.3 0.32 1.;
|
|
vg
|
|
|
|
let request_animation_frame () =
|
|
let t, s = Lwt.wait () in
|
|
let (_ : Dom_html.animation_frame_request_id) =
|
|
Dom_html.window##requestAnimationFrame
|
|
(Js.wrap_callback (fun (time : float) -> Lwt.wakeup s time))
|
|
in
|
|
t
|
|
|
|
let render_stream canvas webgl_ctx vg
|
|
(render : NVG.t -> ?time:float -> Gg.p2 -> Human.I.t -> unit) :
|
|
Human.I.t Lwt_stream.t -> unit Lwt.t =
|
|
Lwt_stream.iter_n (fun i ->
|
|
request_animation_frame () >>= fun time ->
|
|
webgl_ctx##clear
|
|
(webgl_ctx##._COLOR_BUFFER_BIT_
|
|
lor webgl_ctx##._DEPTH_BUFFER_BIT_
|
|
lor webgl_ctx##._STENCIL_BUFFER_BIT_);
|
|
let device_ratio = Dom_html.window##.devicePixelRatio in
|
|
NVG.begin_frame vg ~width:canvas##.width ~height:canvas##.height
|
|
~device_ratio;
|
|
NVG.Transform.scale vg ~x:device_ratio ~y:device_ratio;
|
|
render vg ~time Gg.P2.o i;
|
|
NVG.end_frame vg;
|
|
Lwt.return_unit)
|
|
|
|
open Human
|
|
|
|
let _ =
|
|
let canvas =
|
|
Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
|
|
in
|
|
let webgl_ctx = webgl_initialize canvas in
|
|
let vg = graphv_initialize webgl_ctx in
|
|
let open Js_of_ocaml_lwt.Lwt_js_events in
|
|
let open Nottui in
|
|
let gravity_pad = Gravity.make ~h:`Negative ~v:`Negative in
|
|
let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in
|
|
let body = Lwd.var (Lwd.pure Ui.empty) in
|
|
let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in
|
|
Nav.test_populate () >>= fun test_store ->
|
|
let ui = Widgets.(h_node_area (test_store, [ [] ])) in
|
|
let root =
|
|
Lwd.set body
|
|
(Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);
|
|
Widgets.window_manager_view wm
|
|
in
|
|
|
|
let events, push_event = Lwt_stream.create () in
|
|
let images =
|
|
Human.Nottui_lwt.render vg
|
|
~size:(Gg.P2.v canvas##.width canvas##.height)
|
|
events root
|
|
in
|
|
async (fun () ->
|
|
render_stream canvas webgl_ctx vg
|
|
(fun vg ?(time = 0.) p i ->
|
|
let _ = time in
|
|
Log.debug (fun m ->
|
|
m "Drawing image: p=%a n=%a" Gg.V2.pp p
|
|
(I.Draw.pp ~attr:A.dark)
|
|
i);
|
|
let p' = I.Draw.node vg A.dark p i in
|
|
Logs.debug (fun m ->
|
|
m "Drawing finished: p'=%a" Gg.V2.pp p'))
|
|
images);
|
|
buffered_loop (make_event Dom_html.Event.keydown) Dom_html.document
|
|
(fun ev _ ->
|
|
Dom.preventDefault ev;
|
|
Lwt.return
|
|
@@ push_event (Some (`Keys [ Event_js.evt_of_jskey ev ])))
|