Compare commits
2 Commits
main
...
49bddb6365
| Author | SHA1 | Date | |
|---|---|---|---|
| 49bddb6365 | |||
| b5d846b35d |
89
boot_js.ml
89
boot_js.ml
@ -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) ->
|
||||
|
||||
@ -1 +0,0 @@
|
||||
<mxfile host="Electron" modified="2023-03-13T23:21:20.375Z" agent="5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) draw.io/20.8.16 Chrome/106.0.5249.199 Electron/21.3.5 Safari/537.36" etag="Z2Mfk2ZBbl7WkBZ1-Pcz" version="20.8.16" type="device"><diagram name="Page-1" id="LQ51MIGZ5u8MJkVY-xBH">7Vttc9o4EP41zPQ6k4xlY2M+BpJcP+RuOpOZa/PpRtgyqJUtzogA/fUn2TK2LBFIwC9tmkyItdabtc8+u1qLgTONt3+mcLn4i4aIDGwr3A6c24FtD32bfwrBLhfYo3EumKc4zEWgFDziH0gKLSld4xCtlIqMUsLwUhUGNElQwBQZTFO6UatFlKijLuEcaYLHABJd+gWHbJFLfdcq5Z8Qni+KkYEl78SwqCwFqwUM6aYicu4GzjSllOVX8XaKiFi7Yl3ydvcH7u4nlqKEndIA3aL7+bd/bD8ef/nu3D7cpA/0SvbyDMlaPjBBjAtSFIjVgoEoJPwvu2nhSClaQhsLJATgmn8gskKiGaGwaPfxuuznQ3IF/pCLwXbFCjO05fOfLFhMuADwyxVL6Xc0pYSmXJLQhNecRJiQmggSPE94MeArgLh88oxShrnubuSNGIehGGayWWCGHpcwEGNuOFC5LKXrJERicfjTTAicIfKZrjDD1NjnQ63Cvu8FTfEPmjBYTD/ihXsYYyIgP6XrFPOObOtvxJU/kevNO0Xbg4oEe3hws0I0Rizd8So71TQ2JR7dAnWLChYdKYPSBOb7nkqU8AsJlFeAxvY01AxsjwgtrpYwUdTr/bcWAM8W5WojZ3cjwEHTWCzZpKzDr+byPynaGDurXnHLz0FRFTrAGjljpHctkMj1xQeWY/AFyIcphrYuMHrozTzX00fnuLnB2WAwFhBMZqvlftDfoiZEZiXvxTlejbAzahZ6vjXzdc1e7UcvYCRJ8MAEahy42uCYwOQQVVW48UVyETelCwWgQpAERWJY/kQELld4lg1rnclGW5VlJDl5OjkNgYGcwLAxdhqb2KkGjV76oLr6znckL9D3QYV6nqpQTZ9GdTamTV2ZUqVV/anreJYJVVQsmBwiPwo0PPA7XuCjWdSkIuyho2jCcTRV2G26fV9bdhTyWFkWacoWdE4TSO5KaQ3gZZ0HSpdSHd8QYzsJe7hmVFUW2mL2VTS/dmXpqXLndit7zgq7opDwx/1aLTxlPYzcoly2y0pFw9cgI4oiOzAiQ3r/Ahlikd6CC77SfAYBeqmipDoG0zl6sUcz0FJEIMPP6vRMuJFNP9Msetkzha/g060BL5++bFPD3n4Sb4ej1wkcD0DL/tWg5baErLMYydWcg6WBojHXELni1+gash/ZXUWe/zTpMoBfcxl6NOYYXIbdmPfu1GcU10+K/zD7jFfF1fUgwUV+ODQhwbdnToaEkjeu3SpzgCO00bidn+pBnGZcyNBWAVvvIZ9XYz5E3yqIDFe+Z5ulhxMZqwwMIo0BwHI7MCUx8rzYRbrK02r1LUuKYTI/uLM4ldRqW8RjSO8wHHYsFSquHg57Bm7zmuI2YNiadEB2DRNX4wQEiqz+MQYadxlpAD1RLjLe7znWsG01/B/p9thqrAEcTUWM/ivTcO8hXwAclSAB0DUyalUjejTe0+ivlW3dydhoMmPwU5Ctvq/L3yC2ZcUzEIaRZdKUfK/UpBW7NVr1NSMeum0a8bBLI75E2u88G345gupDqubkLGDuD36xNKAh5dNTJ/MqnL0ZzP3DJ/BOxafbCD7B+EBc1FKSAejHJa7eSURqj45tEVp9gwW6SUc2E1z23zGB0amGfwBGLYWbI80+QXv22cet/Ug9AjDq+i2C+7O4+IbePPc/i1fkPvu9sSxmWbH0jy1m8fp0mARYoGNfPO6TL76sgb5l99pD/336xvJc/20O3F0VsvU3OU1vLLtJfLxXD1Jsyo6fOLE7dSF6aNjTWOQi6Ybje5QeIunks0vnIslMW3b9PYzVbr7B0aOc3wegX3PQoHaIqrET0LxYfv0r1375HTrn7n8=</diagram></mxfile>
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 17 KiB |
BIN
doc/console.odp
BIN
doc/console.odp
Binary file not shown.
BIN
doc/console.pptx
BIN
doc/console.pptx
Binary file not shown.
@ -1,17 +0,0 @@
|
||||
let rec copy_blocks buffer r w =
|
||||
match%lwt Lwt_io.read_into r buffer 0 (Bytes.length buffer) with
|
||||
| 0 -> Lwt.return_unit
|
||||
| bytes_read ->
|
||||
let%lwt () = Lwt_io.write_from_exactly w buffer 0 bytes_read in
|
||||
copy_blocks buffer r w
|
||||
|
||||
let run () =
|
||||
((let%lwt server =
|
||||
Lwt_io.establish_server (Lwt_unix.ADDR_INET (Unix.inet_addr_any, 8765))
|
||||
(fun (r, w) ->
|
||||
let buffer = Bytes.create (16 * 1024) in
|
||||
copy_blocks buffer r w)
|
||||
in
|
||||
Lwt.return server) : Lwt_io.server Lwt.t) |> ignore
|
||||
|
||||
let () = Lwt_main.run run ();
|
||||
@ -1 +0,0 @@
|
||||
<mxfile host="Electron" modified="2023-03-14T02:21:12.395Z" agent="5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) draw.io/20.8.16 Chrome/106.0.5249.199 Electron/21.3.5 Safari/537.36" etag="kySTQQLOUsgllAWFhiTX" version="20.8.16" type="device"><diagram name="Page-1" id="LQ51MIGZ5u8MJkVY-xBH">7Vtbb6M4FP41kdKRWmEIhDy2Tbv70F2NNNLO9GnlgEk8dXCWOE06v35tMOFik9AkXGY6rVrhg318Od+5+BgPrPvl7o8IrhZ/UR+RgWn4u4E1HZimMwH8vyC8JQRrMkkI8wj7CQlkhC/4B5JEQ1I32EfrQkVGKWF4VSR6NAyRxwo0GEV0W6wWUFLsdQXnSCF88SBRqV+xzxYJ1bWNjP4nwvNF2jMw5JslTCtLwnoBfbrNkayHgXUfUcqSp+XuHhGxdum6JO0eK97uBxahkNVpgKbocf79H9NdTr6+WNOn2+iJXksur5Bs5IQJYpwQIU+sFvQYjTAUbEL+F9dwCO/ubhbxp7l4Sik+fhWzZG9y6Zz/NlS+z54KLdYrGGqbzKD3Mo/oJvSvPUpoNLBuxURCzMRYKljC5Yo/hLP1Ki4bOMiPWojFYAskCOCG/0NkjWIw/RsQCpms++mmNO1heA2u0gHzxU3GXJwHJ8eTT6lmYVImQztBX7AlH/sUiImziL6g+2Rq05CGvOZdgAkpkSDB85AXCQoEh1cUMcyheSvJjIqpbheYoS8r6InutlwJOS1eOyQEz2d/R+AMkc90zZePinYeRwyKcgyfShWW2PfF6O8WfBl+0JDBdOQBLzzCJSZCne/pJsKckWn8jbb7mQumaFcJUrCHPjcZiC4Ri954lbSBVJZtpmv2SNIWOT1LaVCq93zPKdMA/iCV4B0KYTqKRhyFq1iU660cnUBqSKNlNVBJ2uaouhgS/YXXFjDG1gSprHOw3eMy6Sbt2rhA774zc2xH7Z3j5hbHnZUV8TepAZJS1kv8oN2SKNCKGTquMXM1+I0BLk1mRacl+7fe4iWBsUHT2aqcXTxoXcRLGR8AoBpHPgsCV2s8i7s1LmuOZPCiM08joDFPoDn7NNHZpxIYLu6AFI+RuqC9pzjuhcryO9+VHDDglRJ1nIJEHUWeWnE2Jk1VmFKkefkV1/EsHcqJWNhyiNzAU/DA3ziei2ZBk4IwR1ZBEpaliMLUiMJqShSusuzI5zsBWaQRW9A5DSF5yKglgGd1nqiIzGJxfEeMvUnYww2jRWGhHWbfRPMbW5aec2+mO8k5LrylhZBP91u+8BxzGNtpOWsXl9KG70FGEASmp0WG9P8pMsQinYILvtJ8BB46VFGaOgajOTrIUQ+0CBHI8GtxeDrcyKafaRy/7C2FW8CnXQJeMnzZpoS9/SBOh6PTCRwroGX+atCyW0LWWRbJVpyDoYCiMdcQ2OJX6xriH8kuR09+mnQZwC25DDUaszQuw2zMe3fqM9Ln54L/0PuMdwXW5SDBRq4/0iHBNWdWjITMbtzYecsBjpiNxvW8rgexmnEhI7MI2DKHZFyN+RB1qyByYln+riqVsY7BIPZ5AKx2A10aI8mkXYRVkogrb1kiDMN55c6irlEr7RGPIb3DcNgyilCx1XDY0dg2pynbBjRbkw6MXcOGq3EDBNIzi2MWaNJlpAHUYwCRI//IsYZpFsP/saqPrcYawFJElB1dfIR8ASgZSABUiYxblYgajfc0+mtlW1cbG01mDH4KY6vu63InN22p8gz4fmDoxCWPl5pU5bJtdVVNNtvU5FGXmnyJ3N95inw4jOpDvqZ2KjBxCr9YLlCT9+mpp3kXzk4Gc//wCZy6+LQbwSdwKoKjljINQP1q4vpjhKWT8bFtQqunWKCblGQzAWb//RIY19X7ChS1FHKOFfUE7alnL7f3xc8Axl2fJNg/i4dv6PS5/5m8NP/Z781lOsqcpn9qMZPXpw9KgAE69sWTPvniyyroKZvXHvrv+vvKc/23Pm63i5Atn+Y0va/sJu/xUT1Iuic7/tWJ2akLUUPDnsYiF8k2HN+j9BBJtb9fOhdJerNlls9ijHbTDZYa5fz+CPo9Hxu4xe/aO/4K2lLPNqtuoQ2TC13JdTB2tS+kd7ji1pobauULFcP4dtgwdz0s5lWnaZkkL5UNwc3JLORdtOEwfxvtZG4nk+LLb+12OVTu2l01O4B67K8aMB8f7xJfKarN3+kzdPblhJ0YL2Y3aBP3kl1Dth7+Bw==</diagram></mxfile>
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 32 KiB |
776
human.ml
776
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:
|
||||
|
||||
@ -976,24 +977,30 @@ module Panel = struct
|
||||
end
|
||||
|
||||
module Ui = struct
|
||||
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
|
||||
(* i think this is gonna end up being a binary tree?? *)
|
||||
(* Tree-like document structure of Ui elements, from the top level window down
|
||||
to individual glyphs, and built with Lwd.
|
||||
|
||||
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
|
||||
Probably an LCRS binary tree.
|
||||
*)
|
||||
|
||||
open Gg
|
||||
|
||||
type t =
|
||||
[ `Atom of atom
|
||||
| `Attr of attr * node
|
||||
| `Join of dir * node * node ]
|
||||
type draw_context = { vg : NVG.t; style : Style.t; time : float }
|
||||
and draw = draw_context -> Gg.p2 -> Gg.p2
|
||||
|
||||
and node = { mutable parent : parent; mutable t : t; n : int }
|
||||
and parent = [ `Left of node | `Right of node | `None ]
|
||||
and cursor = { root : node; mutable sel : node }
|
||||
module Page = struct
|
||||
type t =
|
||||
(* TODO figure out how to allow extending `node` with custom document tree combinators *)
|
||||
[ `Atom of atom | `Attr of attr * t | `Join of dir * t * t ]
|
||||
|
||||
and step = [ `Next | `Left | `Right ]
|
||||
and path = step list
|
||||
|
||||
and atom =
|
||||
[ `Image of image
|
||||
[ (*`Lwd of t
|
||||
| *)
|
||||
`Image of
|
||||
image
|
||||
| `Uchar of Uchar.t
|
||||
| `Boundary of boundary
|
||||
| `Hint of [ `Line | `Other ]
|
||||
@ -1005,341 +1012,96 @@ module Panel = struct
|
||||
| `Handler of handler
|
||||
| `Draw of draw ]
|
||||
|
||||
and p = P2.t
|
||||
and dir = [ `X | `Y | `Z ]
|
||||
and image = NVG.Image.image
|
||||
and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ]
|
||||
|
||||
and boundary =
|
||||
[ `Char | `Word | `Phrase | `Line | `Page | `Text ]
|
||||
|
||||
and style = Style.t
|
||||
and handler = node -> Event.t -> Event.t option
|
||||
and draw_context = { vg : NVG.t; style : Style.t }
|
||||
and draw = draw_context -> p -> p
|
||||
and handler = t -> Event.t -> t
|
||||
|
||||
let node_count = ref 0
|
||||
|
||||
let node_n () =
|
||||
node_count := !node_count + 1;
|
||||
!node_count - 1
|
||||
|
||||
let set_parent_on_children n : node =
|
||||
(match n.t with
|
||||
| `Atom _ -> ()
|
||||
| `Attr (_, a) -> a.parent <- `Left n
|
||||
| `Join (_, a, b) ->
|
||||
a.parent <- `Left n;
|
||||
b.parent <- `Right n);
|
||||
n
|
||||
|
||||
let sub (n : node) : node =
|
||||
match n.t with
|
||||
| `Atom _ -> n
|
||||
let sub_left = function
|
||||
| `Atom _ as n -> n
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, a, _) -> a
|
||||
|
||||
let super (n : node) : node =
|
||||
match n.parent with `Left n' | `Right n' -> n' | `None -> n
|
||||
let sub = sub_left
|
||||
|
||||
let set_children_on_parent n =
|
||||
match n.parent with
|
||||
| `Left ({ t = `Attr (a, _); _ } as s)
|
||||
| `Right ({ t = `Attr (a, _); _ } as s) ->
|
||||
s.t <- `Attr (a, n);
|
||||
n
|
||||
| `Left ({ t = `Join (d, _, b); _ } as s) ->
|
||||
s.t <- `Join (d, n, b);
|
||||
n
|
||||
| `Right ({ t = `Join (d, a, _); _ } as s) ->
|
||||
s.t <- `Join (d, a, n);
|
||||
n
|
||||
| _ -> n
|
||||
let sub_right = function
|
||||
| `Atom _ as n -> n
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, _, b) -> b
|
||||
|
||||
let option_of_parent = function
|
||||
| `None -> None
|
||||
| `Left a | `Right a -> Some a
|
||||
|
||||
let node (t : t) =
|
||||
set_parent_on_children { parent = `None; t; n = node_n () }
|
||||
|
||||
let atom (a : atom) = node (`Atom a)
|
||||
let attr (a : attr) (child : node) = node (`Attr (a, child))
|
||||
let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b))
|
||||
let empty_image = V2.zero
|
||||
let empty_node () = node (`Atom `Empty)
|
||||
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
||||
let atom (a : atom) : t = `Atom a
|
||||
let attr (a : attr) (child : t) : t = `Attr (a, child)
|
||||
let join (d : dir) (a : t) (b : t) : t = `Join (d, a, b)
|
||||
let empty = `Atom `Empty
|
||||
let style (s : Style.t) t = attr (`Style s) t
|
||||
let pad v n = attr (`Pad (Pad.all v)) n
|
||||
|
||||
let rec node_up_ (d : [ `Left | `Right ]) n' =
|
||||
match (d, n'.parent) with
|
||||
| _, `None -> None
|
||||
| ( _,
|
||||
( `Left ({ t = `Attr _; _ } as p)
|
||||
| `Right ({ t = `Attr _; _ } as p) ) ) ->
|
||||
node_up_ d p
|
||||
| `Right, `Right ({ t = `Join _; _ } as p)
|
||||
| `Left, `Left ({ t = `Join _; _ } as p) ->
|
||||
node_up_ d p
|
||||
| `Left, `Right { t = `Join (_, l, _); _ } -> Some l
|
||||
| `Right, `Left { t = `Join (_, _, r); _ } -> Some r
|
||||
| _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) ->
|
||||
assert false
|
||||
(* left child, right sibiling *)
|
||||
let rec fold_preorder : ('a -> t -> 'a option) -> 'a -> t -> 'a
|
||||
=
|
||||
fun f acc n ->
|
||||
match f acc n with
|
||||
| Some acc' -> (
|
||||
match n with
|
||||
| `Atom _ -> acc'
|
||||
| `Attr (_, n'') -> fold_preorder f acc' n''
|
||||
| `Join (_, a, b) ->
|
||||
fold_preorder f (fold_preorder f acc' a) b)
|
||||
| None -> acc
|
||||
|
||||
let node_next_ (d : [ `Left | `Right ]) (n : node) =
|
||||
match (d, n.t) with
|
||||
| _, `Atom _ -> node_up_ d n
|
||||
| _, `Attr (_, n') -> Some n'
|
||||
| `Right, `Join (_, _, r) -> Some r
|
||||
| `Left, `Join (_, l, _) -> Some l
|
||||
(* let rec fold_inorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
|
||||
fun f acc n ->
|
||||
match n with
|
||||
| `Atom _ -> (match f acc n with
|
||||
Some acc' -> acc'
|
||||
| None -> acc)
|
||||
| `Attr (_, n') ->
|
||||
let acc' = (fold_inorder f acc n') in
|
||||
(match f acc' n with
|
||||
| Some acc'' -> acc''
|
||||
| None -> acc')
|
||||
| `Join (_, a, b) ->
|
||||
fold_inorder f (f (fold_inorder f acc a) n) b
|
||||
|
||||
let rec search_preorder (f : node -> 'a option) (n : node) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
match node_next_ `Left n with
|
||||
| Some n -> search_preorder f n
|
||||
| None -> None)
|
||||
| x -> x
|
||||
|
||||
let rec search_reverse_preorder (f : node -> 'a option) (n : node)
|
||||
: 'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
match node_next_ `Right n with
|
||||
| Some n -> search_reverse_preorder f n
|
||||
| None -> None)
|
||||
| x -> x
|
||||
|
||||
let replace_parents_child parent n : node =
|
||||
match parent with
|
||||
| `Left ({ t = `Attr (a, _); _ } as p)
|
||||
| `Right ({ t = `Attr (a, _); _ } as p) ->
|
||||
p.t <- `Attr (a, n);
|
||||
n
|
||||
| `Left ({ t = `Join (d, _, r); _ } as p) ->
|
||||
p.t <- `Join (d, n, r);
|
||||
n
|
||||
| `Right ({ t = `Join (d, l, _); _ } as p) ->
|
||||
p.t <- `Join (d, l, n);
|
||||
n
|
||||
| _ -> n
|
||||
|
||||
let rec tree_iter f n i =
|
||||
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
||||
|
||||
let search_forward f (n : node) = search_preorder f n
|
||||
let search_backward f (n : node) = search_reverse_preorder f n
|
||||
let rec fold_postorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
|
||||
fun f acc n ->
|
||||
match n with
|
||||
| `Atom _ -> f (Some acc) n
|
||||
| `Attr (_, n') -> f (fold_postorder f (Some acc) n') n
|
||||
| `Join (_, a, b) ->
|
||||
f (fold_postorder f (fold_postorder f (Some acc) a) b) n*)
|
||||
|
||||
let is_atom_uchar = function
|
||||
| { t = `Atom (`Uchar _); _ } as n -> Some n
|
||||
| `Atom (`Uchar _) as n -> Some n
|
||||
| _ -> None
|
||||
|
||||
let tree_uchar_fwd n =
|
||||
Option.value (search_forward is_atom_uchar n) ~default:n
|
||||
|
||||
let tree_uchar_back n =
|
||||
Option.value (search_backward is_atom_uchar n) ~default:n
|
||||
|
||||
let is_boundary b n =
|
||||
match (b, n.t) with
|
||||
| `Char, `Atom (`Uchar _)
|
||||
let is_boundary b t =
|
||||
match (b, t) with
|
||||
| ( `Char, `Atom (`Uchar _)
|
||||
| `Word, `Atom (`Boundary `Word)
|
||||
| `Phrase, `Atom (`Boundary `Phrase)
|
||||
| `Line, `Atom (`Boundary `Line)
|
||||
| `Page, `Atom (`Boundary `Page) ->
|
||||
Some n
|
||||
| `Page, `Atom (`Boundary `Page) ) as x ->
|
||||
Some x
|
||||
| _ -> None
|
||||
|
||||
let search_back_opt (f : node -> node option) (n : node option) =
|
||||
Option.bind n (search_backward f)
|
||||
|
||||
let search_back_uchar_opt = search_back_opt is_atom_uchar
|
||||
|
||||
let rec traverse_nodes ~(f : node -> node option) (n : node) :
|
||||
unit =
|
||||
match f n with
|
||||
| Some { t = `Atom _; _ } -> ()
|
||||
| Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n'
|
||||
| Some { t = `Join (_, a, b); _ } ->
|
||||
traverse_nodes ~f a;
|
||||
traverse_nodes ~f b
|
||||
| None -> ()
|
||||
|
||||
let insert_join_l (d : dir) (n : node) (n' : node) : node =
|
||||
let p = n.parent in
|
||||
let n'' = join d n' n in
|
||||
n''.parent <- p;
|
||||
set_children_on_parent n''
|
||||
|
||||
let remove_join_l (n : node) : node =
|
||||
match n.parent with
|
||||
| `Left ({ t = `Attr (_, n'); _ } as s)
|
||||
| `Right ({ t = `Attr (_, n'); _ } as s)
|
||||
| `Left ({ t = `Join (_, _, n'); _ } as s) ->
|
||||
s.t <- n'.t;
|
||||
n'
|
||||
| _ -> n
|
||||
|
||||
let kill_backward_char (n : node) : node option =
|
||||
search_forward is_atom_uchar
|
||||
(replace_parents_child (super (tree_uchar_back n)).parent n)
|
||||
|
||||
let insert_attr (a : attr) (n : node) : node =
|
||||
let p = n.parent in
|
||||
let n' = node (`Attr (a, n)) in
|
||||
n'.parent <- p;
|
||||
set_children_on_parent n'
|
||||
|
||||
let remove_attr (n : node) : node =
|
||||
match n.t with
|
||||
| `Attr (_, n') ->
|
||||
(match n.parent with
|
||||
| `Left ({ t = `Join (d, _, b); _ } as p) ->
|
||||
p.t <- `Join (d, n', b);
|
||||
ignore (set_parent_on_children p)
|
||||
| `Right ({ t = `Join (d, a, _); _ } as p) ->
|
||||
p.t <- `Join (d, a, n');
|
||||
ignore (set_parent_on_children p)
|
||||
| `Left ({ t = `Attr (a, _); _ } as p)
|
||||
| `Right ({ t = `Attr (a, _); _ } as p) ->
|
||||
p.t <- `Attr (a, n');
|
||||
ignore (set_parent_on_children p)
|
||||
| _ -> ());
|
||||
n'
|
||||
| _ -> assert false
|
||||
|
||||
let join_x = join `X
|
||||
let join_y = join `Y
|
||||
let join_z = join `Z
|
||||
let ( ^^ ) = join_x
|
||||
let ( ^/^ ) = join_y
|
||||
let ( ^*^ ) = join_z
|
||||
|
||||
let append_ d (l : node -> node) (a : node) : node -> node =
|
||||
fun n -> l (join d a n)
|
||||
module Text = struct
|
||||
let append_ d (l : t -> t) (a : t) (b : t) : t =
|
||||
l (join d a b)
|
||||
|
||||
let empty_append = Fun.id
|
||||
let append_x = append_ `X
|
||||
let append_y = append_ `Y
|
||||
let append_z = append_ `Z
|
||||
|
||||
module Pp = struct
|
||||
let pp_uchar ppf v =
|
||||
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
|
||||
else Fmt.Dump.uchar ppf v
|
||||
|
||||
let pp_boundary ppf v =
|
||||
F.any
|
||||
(match v with
|
||||
| `Char -> "`Char"
|
||||
| `Word -> "`Word"
|
||||
| `Phrase -> "`Phrase"
|
||||
| `Line -> "`Line"
|
||||
| `Page -> "`Page"
|
||||
| `Text ->
|
||||
"`Text"
|
||||
(* text is like a file (unicode calls it End Of Text) *))
|
||||
ppf ()
|
||||
|
||||
let pp_atom ppf v =
|
||||
let open Fmt in
|
||||
(match v with
|
||||
| `Image _ -> any "`Image"
|
||||
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
|
||||
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
|
||||
| `Hint h ->
|
||||
any "`Hint "
|
||||
++ any
|
||||
(match h with
|
||||
| `Line -> "`Line"
|
||||
| `Other -> "`Other")
|
||||
| `Empty -> any "`Empty")
|
||||
ppf ()
|
||||
|
||||
let pp_attr ppf v =
|
||||
let open Fmt in
|
||||
(any
|
||||
(match v with
|
||||
| `Style _ -> "`Style ..."
|
||||
| `Pad _ -> "`Pad ..."
|
||||
| `Shift _ -> "`Shift ..."
|
||||
| `Cursor -> "`Cursor"
|
||||
| `Handler _ -> "`Handler ..."
|
||||
| `Draw _ -> "`Draw ..."))
|
||||
ppf ()
|
||||
|
||||
let pp_dir ppf v =
|
||||
F.pf ppf "%s"
|
||||
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
||||
|
||||
let pp_node_n ppf v = F.(pf ppf "%a" int v.n)
|
||||
|
||||
let rec _pp_t child ppf v =
|
||||
let open Fmt in
|
||||
match v with
|
||||
| `Atom x -> pf ppf "`Atom %a" pp_atom x
|
||||
| `Attr (a, n) ->
|
||||
pf ppf "`Attr %a"
|
||||
(parens (const pp_attr a ++ comma ++ const child n))
|
||||
()
|
||||
| `Join (d, a, b) ->
|
||||
pf ppf "`Join %a"
|
||||
(parens
|
||||
(const pp_dir d ++ comma ++ const child a ++ comma
|
||||
++ const child b))
|
||||
()
|
||||
|
||||
and _pp_parent ppf v =
|
||||
let open Fmt in
|
||||
match v with
|
||||
| `None -> pf ppf "`None"
|
||||
| `Left n -> pf ppf "`Left %a" pp_node_n n
|
||||
| `Right n -> pf ppf "`Right %a" pp_node_n n
|
||||
|
||||
and _pp_node child ppf v =
|
||||
let open Fmt in
|
||||
pf ppf "@[<hov>%a@]"
|
||||
(braces
|
||||
(record
|
||||
[
|
||||
field "n" (fun v -> v.n) int;
|
||||
field "t" (fun v -> v.t) (_pp_t child);
|
||||
field "parent" (fun v -> v.parent) _pp_parent;
|
||||
]))
|
||||
v
|
||||
|
||||
and pp_node_n_record =
|
||||
F.(
|
||||
braces
|
||||
(record ~sep:semi
|
||||
[ field "n" Fun.id pp_node_n; any "..." ]))
|
||||
|
||||
and pp_node ppf = _pp_node pp_node_n ppf
|
||||
and pp_dump_node ppf = _pp_node pp_dump_node ppf
|
||||
|
||||
let pp_t ppf = F.pf ppf "@[<hov>%a@]" (_pp_t pp_node_n_record)
|
||||
|
||||
let pp_n ppf n =
|
||||
F.pf ppf "@[<h>%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t
|
||||
|
||||
let rec pp_node_structure ppf v =
|
||||
F.(
|
||||
const int v.n
|
||||
++ parens
|
||||
(concat ~sep:comma
|
||||
(match v.t with
|
||||
| `Atom a -> [ const pp_atom a ]
|
||||
| `Attr (a, n) ->
|
||||
[ const pp_attr a; const pp_node_structure n ]
|
||||
| `Join (d, l, r) ->
|
||||
[
|
||||
const pp_dir d;
|
||||
const pp_node_structure l;
|
||||
const pp_node_structure r;
|
||||
])))
|
||||
ppf ()
|
||||
end
|
||||
|
||||
open Pp
|
||||
|
||||
module Text = struct
|
||||
let rec decode dec (l : 'a) :
|
||||
'a * [< `Await | `End | `Uchar of Uchar.t ] =
|
||||
match Uutf.decode dec with
|
||||
@ -1352,7 +1114,8 @@ module Panel = struct
|
||||
and _of_string dec l =
|
||||
match decode dec l with
|
||||
| l, `End -> l (atom (`Boundary `Text))
|
||||
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
|
||||
| l, `Uchar c ->
|
||||
_of_string dec (append_x l (atom (`Uchar c)))
|
||||
| l, _ -> _of_string dec l
|
||||
|
||||
and of_string str =
|
||||
@ -1388,15 +1151,15 @@ module Panel = struct
|
||||
end
|
||||
|
||||
module Draw = struct
|
||||
open NVG
|
||||
|
||||
type p = P2.t
|
||||
type d = [ `X | `Y | `Z ]
|
||||
type t = draw_context
|
||||
|
||||
let vcat d a b =
|
||||
match d with
|
||||
| `X ->
|
||||
V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b))
|
||||
V2.v
|
||||
(V2.x a +. V2.x b)
|
||||
(Float.max_num (V2.y a) (V2.y b))
|
||||
| `Y ->
|
||||
V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
|
||||
| `Z ->
|
||||
@ -1417,17 +1180,14 @@ 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)
|
||||
|
||||
let rec atom vg b (a : atom) : P2.t =
|
||||
let vg = vg.vg in
|
||||
let rec atom { vg; _ } b (a : atom) : P2.t =
|
||||
match a with
|
||||
| `Image image ->
|
||||
let wi, hi = Image.size vg image in
|
||||
@ -1478,21 +1238,141 @@ module Panel = struct
|
||||
(Float.max_num (V2.x av) (V2.x bv))
|
||||
(Float.max_num (V2.y av) (V2.y bv))
|
||||
|
||||
and node t b (n : node) : P2.t =
|
||||
and node vg b n : P2.t =
|
||||
let b' =
|
||||
match n.t with
|
||||
| `Atom a -> atom t b a
|
||||
| `Attr a -> attr t b a
|
||||
| `Join a -> join t b a
|
||||
match n with
|
||||
| `Atom a -> atom vg b a
|
||||
| `Attr a -> attr vg b a
|
||||
| `Join a -> join vg b a
|
||||
in
|
||||
(*ignore
|
||||
(Display.path_box t.vg
|
||||
(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
|
||||
|
||||
module Pp = struct
|
||||
let pp_uchar ppf v =
|
||||
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
|
||||
else Fmt.Dump.uchar ppf v
|
||||
|
||||
let pp_boundary ppf v =
|
||||
F.any
|
||||
(match v with
|
||||
| `Char -> "`Char"
|
||||
| `Word -> "`Word"
|
||||
| `Phrase -> "`Phrase"
|
||||
| `Line -> "`Line"
|
||||
| `Page -> "`Page"
|
||||
| `Text ->
|
||||
"`Text"
|
||||
(* text is like a file (unicode calls it End Of Text) *))
|
||||
ppf ()
|
||||
|
||||
let pp_atom ppf v =
|
||||
let open Fmt in
|
||||
(match v with
|
||||
| `Image _ -> any "`Image"
|
||||
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
|
||||
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
|
||||
| `Hint h ->
|
||||
any "`Hint "
|
||||
++ any
|
||||
(match h with
|
||||
| `Line -> "`Line"
|
||||
| `Other -> "`Other")
|
||||
| `Empty -> any "`Empty")
|
||||
ppf ()
|
||||
|
||||
let pp_attr ppf v =
|
||||
let open Fmt in
|
||||
(any
|
||||
(match v with
|
||||
| `Style _ -> "`Style"
|
||||
| `Pad _ -> "`Pad"
|
||||
| `Shift _ -> "`Shift"
|
||||
| `Handler _ -> "`Handler"
|
||||
| `Draw _ -> "`Draw"))
|
||||
ppf ()
|
||||
|
||||
let pp_dir ppf v =
|
||||
F.pf ppf "%s"
|
||||
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
||||
|
||||
let rec _pp_t child ppf v =
|
||||
let open Fmt in
|
||||
match v with
|
||||
| `Atom x -> pf ppf "`Atom %a" pp_atom x
|
||||
| `Attr (a, n) ->
|
||||
pf ppf "`Attr %a"
|
||||
(F.pair (const pp_attr a) (const child n))
|
||||
(a, n)
|
||||
| `Join (d, a, b) ->
|
||||
pf ppf "`Join %a"
|
||||
(parens
|
||||
(const pp_dir d ++ comma ++ const child a ++ comma
|
||||
++ const child b))
|
||||
()
|
||||
|
||||
and pp_node ppf = _pp_t pp_node ppf
|
||||
and pp_dump_node ppf = _pp_t pp_dump_node ppf
|
||||
|
||||
let pp_t ppf = F.pf ppf "@[<hov>%a@]" pp_node
|
||||
|
||||
let rec pp_node_structure ppf t =
|
||||
F.(
|
||||
parens
|
||||
(concat ~sep:comma
|
||||
(match t with
|
||||
| `Atom a -> [ const pp_atom a ]
|
||||
| `Attr (a, n) ->
|
||||
[ const pp_attr a; const pp_node_structure n ]
|
||||
| `Join (d, l, r) ->
|
||||
[
|
||||
const pp_dir d;
|
||||
const pp_node_structure l;
|
||||
const pp_node_structure r;
|
||||
])))
|
||||
ppf ()
|
||||
|
||||
let pp_step ppf s =
|
||||
F.any
|
||||
(match s with
|
||||
| `Next -> "`Next"
|
||||
| `Left -> "`Left"
|
||||
| `Right -> "`Right")
|
||||
ppf ()
|
||||
|
||||
let rec pp_path ppf (p : path) = F.list pp_step ppf p
|
||||
end
|
||||
end
|
||||
|
||||
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
|
||||
let ( ^/^ ) = join_y
|
||||
let ( ^*^ ) = join_z
|
||||
let pack d = Lwd_utils.lift_monoid Page.(empty, join d)
|
||||
let pack_x, pack_y, pack_z = (pack `X, pack `Y, pack `Z)
|
||||
let cat d = Lwd_utils.reduce (pack d)
|
||||
let hcat, vcat, zcat = (cat `X, cat `Y, cat `Z)
|
||||
|
||||
open Page.Pp
|
||||
|
||||
module Action = struct
|
||||
open Page
|
||||
|
||||
type segment =
|
||||
[ `Beginning of boundary
|
||||
| `Forward of boundary
|
||||
@ -1560,10 +1440,11 @@ module Panel = struct
|
||||
ppf ()
|
||||
end
|
||||
|
||||
let perform_action (a : Action.t) (c : cursor) : node option =
|
||||
let perform_action (a : Action.t) (path : path) (node : node) :
|
||||
node option =
|
||||
match a with
|
||||
| `Move (`Forward `Line) -> (
|
||||
let i = ref 0 in
|
||||
| `Move (`Forward `Line) ->
|
||||
(* let i = ref 0 in
|
||||
ignore
|
||||
(search_backward
|
||||
(function
|
||||
@ -1572,8 +1453,8 @@ module Panel = struct
|
||||
incr i;
|
||||
None
|
||||
| _ -> None)
|
||||
c.sel);
|
||||
match search_forward (is_boundary `Line) c.sel with
|
||||
path);
|
||||
match search_forward (is_boundary `Line) path with
|
||||
| Some n' ->
|
||||
Some
|
||||
(tree_iter
|
||||
@ -1582,9 +1463,10 @@ module Panel = struct
|
||||
(search_forward (is_boundary `Char) nn)
|
||||
~default:nn)
|
||||
n' !i)
|
||||
| None -> None)
|
||||
| `Move (`Backward `Line) -> (
|
||||
let i = ref 0 in
|
||||
| None -> *)
|
||||
None
|
||||
| `Move (`Backward `Line) ->
|
||||
(* let i = ref 0 in
|
||||
match
|
||||
search_backward
|
||||
(function
|
||||
@ -1599,8 +1481,9 @@ module Panel = struct
|
||||
Option.map
|
||||
(fun n -> tree_iter tree_uchar_back n !i)
|
||||
(search_backward (is_boundary `Line) n')
|
||||
| None -> None)
|
||||
| `Move (`Forward b) ->
|
||||
| None ->*)
|
||||
None
|
||||
(* | `Move (`Forward b) ->
|
||||
Option.map tree_uchar_fwd
|
||||
(search_forward (is_boundary b) c.sel)
|
||||
| `Move (`End b) ->
|
||||
@ -1614,19 +1497,20 @@ module Panel = struct
|
||||
(search_backward (is_boundary b) c.sel)
|
||||
| `Insert n ->
|
||||
ignore (insert_join_l `X (super c.sel) n);
|
||||
Some c.sel
|
||||
Some c.sel *)
|
||||
| `Overwrite _s -> None
|
||||
| `Yank _s -> None
|
||||
| `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
|
||||
| `Kill (`Backward `Char) -> kill_backward_char c.sel
|
||||
(* | `Kill (`Backward `Char) -> kill_backward_char c.sel *)
|
||||
| `Kill _s -> None
|
||||
| `Descend -> Some (sub c.sel)
|
||||
| `Ascend -> option_of_parent c.sel.parent
|
||||
(* | `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) ]
|
||||
@ -1663,35 +1547,24 @@ module Panel = struct
|
||||
let cursor_attr =
|
||||
`Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))
|
||||
|
||||
let draw_cursor_root (c : cursor) : 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 c.root))))
|
||||
(atom `Empty)
|
||||
let node_structure root =
|
||||
Lwd.map
|
||||
~f:(fun node ->
|
||||
Page.Text.lines (Fmt.to_to_string pp_node_structure node))
|
||||
root
|
||||
|
||||
let draw_cursor_sel (c : cursor) : 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 (sub c.sel)))))
|
||||
(atom `Empty)
|
||||
let draw_path path =
|
||||
Lwd.map
|
||||
~f:(fun path ->
|
||||
Page.Text.lines (Fmt.to_to_string pp_path path))
|
||||
path
|
||||
|
||||
let textedit ?(bindings = textedit_bindings) (n : node) =
|
||||
Format.pp_set_max_boxes F.stderr 64;
|
||||
(*full screen fynn *)
|
||||
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
|
||||
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
|
||||
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 ->
|
||||
handler
|
||||
(fun (root : node) (e : Event.t) : node ->
|
||||
let a =
|
||||
match Key.Bind.resolve_events bind [ e ] with
|
||||
| x :: _ -> Some x
|
||||
@ -1700,65 +1573,52 @@ 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 handler_of_node (n : node) : handler option =
|
||||
let f n =
|
||||
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
|
||||
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 *)
|
||||
let handle_event (n : t) (ev : Event.t) : t =
|
||||
Lwd.map
|
||||
~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
|
||||
match f n with Some a -> Some a | None -> search_forward f n
|
||||
List.fold_left (fun acc f -> f acc ev) t handlers)
|
||||
n
|
||||
|
||||
let handle_event (n : node) (ev : Event.t) : event_status =
|
||||
match handler_of_node n with
|
||||
| Some f -> (
|
||||
match f n ev with Some ev -> `Event ev | None -> `Handled)
|
||||
| None -> `Event ev
|
||||
|
||||
let panel (vg : NVG.t) (p : P2.t) (t : node) (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
|
||||
end
|
||||
|
||||
module View = struct
|
||||
type path = Nav.path
|
||||
@ -1772,26 +1632,11 @@ module Panel = struct
|
||||
|
||||
open Lwt.Infix
|
||||
|
||||
let pack_x = Lwd_utils.lift_monoid (empty_node (), join_x)
|
||||
let pack_y = Lwd_utils.lift_monoid (empty_node (), join_y)
|
||||
let pack_z = Lwd_utils.lift_monoid (empty_node (), join_z)
|
||||
|
||||
module DText = struct
|
||||
let lines = Lwd.map ~f:Text.lines
|
||||
let of_string = Lwd.map ~f:Text.of_string
|
||||
end
|
||||
|
||||
let of_path path =
|
||||
Lwd.map2 ~f:join_x
|
||||
(DText.of_string (Lwd.pure "/"))
|
||||
join_x
|
||||
(Text.of_string (Lwd.pure "/"))
|
||||
(Lwd_utils.map_reduce
|
||||
(fun step ->
|
||||
Lwd_utils.pack
|
||||
(empty_node (), join_x)
|
||||
[
|
||||
DText.of_string (Lwd.pure "/");
|
||||
DText.of_string (Lwd.pure step);
|
||||
])
|
||||
(fun step -> Lwd.pure (Page.Text.of_string ("/" ^ step)))
|
||||
pack_x path)
|
||||
|
||||
let of_tree ?(path = []) tree =
|
||||
@ -1803,42 +1648,49 @@ module Panel = struct
|
||||
cursor = Lwd.var path;
|
||||
doc =
|
||||
Lwd_utils.map_reduce
|
||||
(fun (step, _t') -> DText.of_string (Lwd.pure step))
|
||||
(fun (step, _t') -> Text.of_string (Lwd.pure step))
|
||||
pack_y l;
|
||||
}
|
||||
|
||||
let list_logs hook =
|
||||
let var = Lwd.var (empty_node ()) in
|
||||
let var = Lwd.var Page.empty in
|
||||
(hook :=
|
||||
fun level s ->
|
||||
Lwd.set var
|
||||
(join_y
|
||||
Page.(
|
||||
join_y
|
||||
(Text.of_string
|
||||
(Logs.level_to_string (Some level) ^ ": " ^ s))
|
||||
(Lwd.peek var)));
|
||||
Lwd.get var
|
||||
|
||||
let draw (vg, p) (t : node Lwd.t) : p Lwt.t =
|
||||
let root =
|
||||
Lwd.observe
|
||||
~on_invalidate:(fun _ ->
|
||||
Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
|
||||
t
|
||||
in
|
||||
Lwt.return (Draw.node vg p (Lwd.quick_sample root))
|
||||
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 : p) (_ev : Event.t) : p 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 View.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
|
||||
|
||||
Reference in New Issue
Block a user