diff --git a/boot_js.ml b/boot_js.ml index efafb9c..3688a3a 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -27,23 +27,20 @@ let scale_canvas (canvas : Dom_html.canvasElement Js.t) = canvas##.style##.width := width; canvas##.style##.height := height -let _ = - let canvas = - Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas") - in +let webgl_initialize canvas = scale_canvas canvas; - let webgl_ctx = - (* 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 - in + (* 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 @@ -53,55 +50,55 @@ let _ = (* 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 render ev = - 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 - begin_frame vg ~width:canvas##.width ~height:canvas##.height - ~device_ratio; - Transform.scale vg ~x:device_ratio ~y:device_ratio; - ignore Human.Panel.Ui.(panel vg Gg.P2.o test ev); - (* - Path.begin_ vg ; - Path.rect vg ~x:40. ~y:40. ~w:320. ~h:320. ; - set_fill_color vg ~color:Color.(rgba ~r:154 ~g:203 ~b:255 ~a:200) ; - fill vg ; - Transform.translate vg ~x:200. ~y:200. ; - Transform.rotate vg ~angle:(time *. 0.0005) ; - Text.set_font_face vg ~name:"sans" ; - Text.set_size vg ~size:48. ; - Text.set_align vg ~align:Align.(center lor middle) ; - set_fill_color vg ~color:Color.white ; - Text.text vg ~x:0. ~y:0. "Hello World!" ; *) - NVG.end_frame 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 - Dom_html.window##requestAnimationFrame - (Js.wrap_callback (fun _ -> render Human.Event.empty)) - |> ignore;*) + t + +let request_render canvas webgl_ctx vg + (render : NVG.t -> ?time:float -> Gg.p2 -> Gg.p2 Lwt.t) = + 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 >>= fun _p -> + (* Logs.debug (fun m -> m "Drawing finished at point: %a" Gg.V2.pp p); *) + NVG.end_frame vg; + Lwt.return_unit + +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 page_var = Lwd.var Human.Panel.Ui.empty in + async (fun () -> - buffered_loop (make_event Dom_html.Event.keydown) - Dom_html.document (fun ev _ -> - 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 - begin_frame vg ~width:canvas##.width ~height:canvas##.height - ~device_ratio; - Transform.scale vg ~x:device_ratio ~y:device_ratio; - Human.Panel.Ui.( - render_lwt vg Gg.P2.o - (Human.Event_js.evt_of_jskey `Press ev)) - >>= fun p -> - Logs.debug (fun m -> - m "Drawing finished at point: %a" Gg.V2.pp p); - NVG.end_frame vg; - Lwt.return_unit)) + Human.Panel.Ui.boot_page >>= fun page -> + Lwd.set page_var page; + let render = Human.Panel.Ui.renderer page_var in + request_render canvas webgl_ctx vg render >>= fun () -> + buffered_loop + (make_event Dom_html.Event.keydown) + Dom_html.document + Human.( + fun ev _ -> + Lwd.set page_var + (Panel.Ui.handle_event (Lwd.peek page_var) + (Event_js.evt_of_jskey `Press ev)); + request_render canvas webgl_ctx vg render)) (* Dom_html.document##.onkeydown := Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) -> diff --git a/human.ml b/human.ml index 4f160a6..fa0d512 100644 --- a/human.ml +++ b/human.ml @@ -1,10 +1,11 @@ (* + names?: - universal tool, unitool [was thinking about how this is trying to unify a lot of my "tools for thought"] * because it has always bothered me that it's easier to use google search as a calculator than the purpose built app!!!!!!!! - universal console, unicon (UNICOrN) [unicon is nice ;3] - - + - non-magical systems (NMS) un-magical + - console is an interface to allow you to program your computer more easily. describe exactly every case you can think of that you want this drawing and layout system to handle: @@ -984,7 +985,7 @@ module Panel = struct open Gg - type draw_context = { vg : NVG.t; style : Style.t } + type draw_context = { vg : NVG.t; style : Style.t; time : float } and draw = draw_context -> Gg.p2 -> Gg.p2 module Page = struct @@ -994,7 +995,6 @@ module Panel = struct and step = [ `Next | `Left | `Right ] and path = step list - and cursor = { path : path; root : t } and atom = [ (*`Lwd of t @@ -1019,13 +1019,15 @@ module Panel = struct [ `Char | `Word | `Phrase | `Line | `Page | `Text ] and style = Style.t - and handler = t -> Event.t -> Event.t option + and handler = t -> Event.t -> t let sub_left = function | `Atom _ as n -> n | `Attr (_, n) -> n | `Join (_, a, _) -> a + let sub = sub_left + let sub_right = function | `Atom _ as n -> n | `Attr (_, n) -> n @@ -1178,12 +1180,10 @@ module Panel = struct encode `End; let text = Bytes.to_string (Buffer.to_bytes b) in let open NVG in - let bounds = Text.bounds vg ~x:(V2.x t) ~y:(V2.y t) text in let metrics = Text.metrics vg in let x, y = (V2.x t, V2.y t +. metrics.ascender) in - Text.text vg ~x ~y text; - P2.v - (P2.x t +. bounds.advance) + let twidth = Text.text_w vg ~x ~y text in + P2.v twidth (P2.y t +. metrics.ascender +. metrics.descender +. metrics.line_height) @@ -1245,10 +1245,10 @@ module Panel = struct | `Attr a -> attr vg b a | `Join a -> join vg b a in - ignore - (path_box vg.vg - (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) - (Box2.of_pts b b')); + (* ignore + (path_box vg.vg + (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) + (Box2.of_pts b b')); *) b' end @@ -1292,7 +1292,6 @@ module Panel = struct | `Style _ -> "`Style" | `Pad _ -> "`Pad" | `Shift _ -> "`Shift" - | `Cursor -> "`Cursor" | `Handler _ -> "`Handler" | `Draw _ -> "`Draw")) ppf () @@ -1351,9 +1350,14 @@ module Panel = struct type node = Page.t type t = node Lwd.t + type path = Page.path Lwd.t + type cursor = { path : Page.path Lwd.var; root : node Lwd.var } let empty = Lwd.pure Page.empty let pad v = Lwd.map ~f:(Page.pad v) + let attr a n = Lwd.map ~f:(Page.attr a) n + let handler f (n : t) : t = attr (`Handler f) n + let atom a = Lwd.map ~f:Page.atom a let join d = Lwd.map2 ~f:(Page.join d) let join_x, join_y, join_z = (join `X, join `Y, join `Z) let ( ^^ ) = join_x @@ -1377,8 +1381,8 @@ module Panel = struct and t = [ `Move of segment - | `Insert of t - | `Overwrite of t + | `Insert of node + | `Overwrite of node | `Yank of segment | `Kill of segment | `Ascend @@ -1436,31 +1440,30 @@ module Panel = struct ppf () end - let perform_action (a : Action.t) ({ path; root } : Page.cursor) : + let perform_action (a : Action.t) (path : path) (node : node) : node option = match a with | `Move (`Forward `Line) -> - (* - let i = ref 0 in - ignore - (search_backward - (function - | { t = `Atom (`Boundary `Line); _ } -> Some () - | { t = `Atom (`Uchar _); _ } -> - incr i; - None - | _ -> None) - path); - match search_forward (is_boundary `Line) path with - | Some n' -> - Some - (tree_iter - (fun nn -> - Option.value - (search_forward (is_boundary `Char) nn) - ~default:nn) - n' !i) - | None -> *) + (* let i = ref 0 in + ignore + (search_backward + (function + | { t = `Atom (`Boundary `Line); _ } -> Some () + | { t = `Atom (`Uchar _); _ } -> + incr i; + None + | _ -> None) + path); + match search_forward (is_boundary `Line) path with + | Some n' -> + Some + (tree_iter + (fun nn -> + Option.value + (search_forward (is_boundary `Char) nn) + ~default:nn) + n' !i) + | None -> *) None | `Move (`Backward `Line) -> (* let i = ref 0 in @@ -1503,10 +1506,11 @@ module Panel = struct (* | `Descend -> Some (sub c.sel) *) (* | `Ascend -> option_of_parent c.sel.parent*) | `Custom _s -> None + | _ -> None type event_status = [ `Handled | `Event of Event.t ] - let textedit_bindings = + let default_bindings = let open Key.Bind in empty |> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ] @@ -1543,17 +1547,6 @@ module Panel = struct let cursor_attr = `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.)) - (* this was a hack? - let draw_node_structure (doc : node Lwd.var) : node = - let open Gg in - attr - (`Draw - (fun (t : draw_context) (b : P2.t) -> - Draw.node t b - (Text.lines - (Fmt.to_to_string pp_node_structure (Lwd.peek doc))))) - (atom `Empty) *) - let node_structure root = Lwd.map ~f:(fun node -> @@ -1566,96 +1559,62 @@ module Panel = struct Page.Text.lines (Fmt.to_to_string pp_path path)) path - let textedit ?(bindings = textedit_bindings) - (initial : node * Page.path) = - Format.pp_set_max_boxes F.stderr 64; - (*full screen fynn *) - Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230; - let doc = Lwd.var (fst initial) in - let path = Lwd.var (snd initial) in - join_y - (pad 5. (Lwd.get doc)) + let nav_handler ?(bindings = default_bindings) + ((page, path) : node Lwd.t * Page.path) = + let page, path = (Lwd.var page, Lwd.var path) in + let bind = Key.Bind.init bindings in + handler + (fun (root : node) (e : Event.t) : node -> + let a = + match Key.Bind.resolve_events bind [ e ] with + | x :: _ -> Some x + | [] -> ( + match e with + | `Key (`Press, (k : Key.keystate)) -> ( + match k.code with + | `Uchar c -> + Some (`Insert (Page.atom (`Uchar c))) + | _ -> None) + | _ -> None) + in + match a with + | Some x -> ( + match perform_action x (Lwd.get path) root with + | Some n' -> + Log.info (fun m -> + m "nav_handler action @[%a@] Success@." + Action.pp_t x); + n' + | None -> + Log.warn (fun m -> + m "nav_handler action @[%a@] Failure@." + Action.pp_t x); + root) + | None -> root) (join_y - (pad 5. (draw_path (Lwd.get path))) - (pad 5. (node_structure (Lwd.get doc)))) + (pad 5. (Lwd.join @@ Lwd.get page)) + (join_y + (pad 5. (draw_path (Lwd.get path))) + (pad 5. (node_structure (Lwd.join @@ Lwd.get page))))) - (* let bind = Key.Bind.init bindings in - let sel = insert_attr cursor_attr n in - let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in - c.root.t <- - `Attr - ( `Handler - (fun (_ : node) (e : Event.t) : Event.t option -> - let a = - match Key.Bind.resolve_events bind [ e ] with - | x :: _ -> Some x - | [] -> ( - match e with - | `Key (`Press, (k : Key.keystate)) -> ( - match k.code with - | `Uchar c -> - Some (`Insert (atom (`Uchar c))) - | _ -> None) - | _ -> None) - in - let r = - match a with - | Some x -> - c.sel <- remove_attr c.sel; - (match perform_action x c with - | Some n' -> - F.epr "textedit action @[%a@] Success@." - Action.pp_t x; - c.sel <- n' - | None -> - F.epr "textedit action @[%a@] Failure@." - Action.pp_t x); - c.sel <- insert_attr cursor_attr c.sel; - None - | None -> None - in - r), - n ); - join_y (pad 5. c.root) - (join_y - (pad 5. (draw_cursor_sel c)) - (pad 5. (draw_cursor_root c))) *) - - (* - let is_handler (n : node) : handler option = + let is_handler (n : node) : Page.handler option = match n with `Attr (`Handler f, _) -> Some f | _ -> None - (** receives a node document and event and returns a node document where that event is handled *) + + (* * receives a node document and event and returns a node document where that event is handled *) let handle_event (n : t) (ev : Event.t) : t = Lwd.map - ~f: - (fold_preorder - (fun ev' n' -> - match is_handler n' with - | Some f -> f n' ev' - | None -> None) - ev) + ~f:(fun t -> + let handlers = + Page.fold_preorder + (fun acc n' -> + match is_handler n' with + | Some f -> Some (f :: acc) + | None -> Some acc) + [] t + in + List.fold_left (fun acc f -> f acc ev) t handlers) n - let panel (vg : NVG.t) (p : P2.t) (t : t) (ev : Event.t) : P2.t = - (match handle_event t ev with - | `Handled -> F.epr "Handled %s@." (Event.to_string ev) - | `Event _e -> - F.epr "Unhandled event: %s@." (Event.to_string _e)); - Draw.node { vg; style = Style.dark } p t - *) - (* I feel like the Wall module from github.com/let-def/wall includes another layer on top - of the drawing functions, missing from graphv, that - specificall allows the composability and cache-ability i want, so instead of writing in from - scratch i will try to steal it. - *) - - (* we need to determine how "document types" should be implemented: - * as a module that implements a common interface which allows - production of a Ui.t which is then rendered. - * this will require exposing the Ui and all drawing related functions. - * - *) - module Text = struct let lines = Lwd.map ~f:Page.Text.lines let of_string = Lwd.map ~f:Page.Text.of_string @@ -1705,28 +1664,33 @@ module Panel = struct (Lwd.peek var))); Lwd.get var - let draw (vg, p) (t : node Lwd.t) : Page.Draw.p Lwt.t = - let root = - Lwd.observe - ~on_invalidate:(fun _ -> - Log.warn (fun m -> m "View.draw doc_root on_invalidate")) - t - in + let draw (vg, p) (root : node Lwd.root) : Page.Draw.p Lwt.t = Lwt.return (Page.Draw.node vg p (Lwd.quick_sample root)) end open Lwt.Infix - let render_lwt (vg : NVG.t) (p : Gg.p2) (_ev : Event.t) : - Gg.p2 Lwt.t = - let t = { vg; style = Style.dark } in + (* event handler just needs to result in a Lwd.set on some portion of the doc root + and then trigger a request animation frame *) + let renderer (root : t Lwd.var) : + NVG.t -> ?time:float -> Gg.p2 -> Gg.p2 Lwt.t = + let root = + Lwd.observe + ~on_invalidate:(fun _ -> + Log.warn (fun m -> m "View.draw doc_root on_invalidate")) + (Lwd.join (Lwd.get root)) + in + fun vg ?(time = 0.) p -> + View.draw ({ vg; style = Style.dark; time }, p) root + + let boot_page : node Lwd.t Lwt.t = Nav.test_pull () >>= fun tree -> - View.of_tree tree >>= fun doc -> - View.draw (t, p) - (Lwd_utils.reduce pack_y + View.of_tree tree >>= fun tv -> + Lwt.return + (vcat [ - doc.doc; - View.of_path (Lwd.peek doc.cursor); + nav_handler (tv.doc, []); + View.of_path (Lwd.peek tv.cursor); View.list_logs Logs_reporter.hook; ]) end