console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

urgh... stuck with how to implement cursor/focus etc. Decided to try to integrate Nottui and Nottui_widgets directly istead of reinventing another wheel.

Browse Source
This commit is contained in:
cqc
2022-12-04 12:25:00 -06:00
parent b5d846b35d
commit 49bddb6365
2 changed files with 170 additions and 209 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
boot_js.ml
View File

@ -27,12 +27,8 @@ 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;
@ -43,7 +39,8 @@ let _ =
print_endline "Sorry your browser does not support WebGL";
raise Exit
| Some ctx -> ctx
in
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
in
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 _ -> render Human.Event.empty))
|> ignore;*)
let open Js_of_ocaml_lwt.Lwt_js_events in
async (fun () ->
buffered_loop (make_event Dom_html.Event.keydown)
Dom_html.document (fun ev _ ->
(Js.wrap_callback (fun (time : float) -> Lwt.wakeup s time))
in
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
begin_frame vg ~width:canvas##.width ~height:canvas##.height
NVG.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.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))
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 () ->
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) ->

188
human.ml
View File

@ -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
(* ignore
(path_box vg.vg
(NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
(Box2.of_pts b b'));
(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,12 +1440,11 @@ 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
(* let i = ref 0 in
ignore
(search_backward
(function
@ -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,26 +1559,12 @@ 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))
(join_y
(pad 5. (draw_path (Lwd.get path)))
(pad 5. (node_structure (Lwd.get doc))))
(* 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 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
@ -1594,68 +1573,48 @@ module Panel = struct
| `Key (`Press, (k : Key.keystate)) -> (
match k.code with
| `Uchar c ->
Some (`Insert (atom (`Uchar c)))
Some (`Insert (Page.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 x -> (
match perform_action x (Lwd.get path) root with
| Some n' ->
F.epr "textedit action @[%a@] Success@."
Action.pp_t x;
c.sel <- n'
| None ->
F.epr "textedit action @[%a@] Failure@."
Log.info (fun m ->
m "nav_handler action @[%a@] Success@."
Action.pp_t x);
c.sel <- insert_attr cursor_attr c.sel;
None
| None -> None
in
r),
n );
join_y (pad 5. c.root)
n'
| None ->
Log.warn (fun m ->
m "nav_handler action @[%a@] Failure@."
Action.pp_t x);
root)
| None -> root)
(join_y
(pad 5. (draw_cursor_sel c))
(pad 5. (draw_cursor_root c))) *)
(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 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' ->
~f:(fun t ->
let handlers =
Page.fold_preorder
(fun acc n' ->
match is_handler n' with
| Some f -> f n' ev'
| None -> None)
ev)
| 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