Compare commits
1 Commits
49bddb6365
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
| ee550301e9 |
87
boot_js.ml
87
boot_js.ml
@ -27,8 +27,12 @@ let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
|
|||||||
canvas##.style##.width := width;
|
canvas##.style##.width := width;
|
||||||
canvas##.style##.height := height
|
canvas##.style##.height := height
|
||||||
|
|
||||||
let webgl_initialize canvas =
|
let _ =
|
||||||
|
let canvas =
|
||||||
|
Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
|
||||||
|
in
|
||||||
scale_canvas canvas;
|
scale_canvas canvas;
|
||||||
|
let webgl_ctx =
|
||||||
(* Graphv requires a stencil buffer to work properly *)
|
(* Graphv requires a stencil buffer to work properly *)
|
||||||
let attrs = WebGL.defaultContextAttributes in
|
let attrs = WebGL.defaultContextAttributes in
|
||||||
attrs##.stencil := Js._true;
|
attrs##.stencil := Js._true;
|
||||||
@ -39,8 +43,7 @@ let webgl_initialize canvas =
|
|||||||
print_endline "Sorry your browser does not support WebGL";
|
print_endline "Sorry your browser does not support WebGL";
|
||||||
raise Exit
|
raise Exit
|
||||||
| Some ctx -> ctx
|
| Some ctx -> ctx
|
||||||
|
in
|
||||||
let graphv_initialize webgl_ctx =
|
|
||||||
let open NVG in
|
let open NVG in
|
||||||
let vg =
|
let vg =
|
||||||
create
|
create
|
||||||
@ -50,55 +53,55 @@ let graphv_initialize webgl_ctx =
|
|||||||
(* File in this case is actually the CSS font name *)
|
(* File in this case is actually the CSS font name *)
|
||||||
Text.create vg ~name:"sans" ~file:"sans" |> ignore;
|
Text.create vg ~name:"sans" ~file:"sans" |> ignore;
|
||||||
webgl_ctx##clearColor 0.3 0.3 0.32 1.;
|
webgl_ctx##clearColor 0.3 0.3 0.32 1.;
|
||||||
vg
|
|
||||||
|
|
||||||
let request_animation_frame () =
|
(*
|
||||||
let t, s = Lwt.wait () in
|
let render ev =
|
||||||
let (_ : Dom_html.animation_frame_request_id) =
|
|
||||||
Dom_html.window##requestAnimationFrame
|
|
||||||
(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##clear
|
||||||
(webgl_ctx##._COLOR_BUFFER_BIT_
|
(webgl_ctx##._COLOR_BUFFER_BIT_
|
||||||
lor webgl_ctx##._DEPTH_BUFFER_BIT_
|
lor webgl_ctx##._DEPTH_BUFFER_BIT_
|
||||||
lor webgl_ctx##._STENCIL_BUFFER_BIT_);
|
lor webgl_ctx##._STENCIL_BUFFER_BIT_);
|
||||||
let device_ratio = Dom_html.window##.devicePixelRatio in
|
let device_ratio = Dom_html.window##.devicePixelRatio in
|
||||||
NVG.begin_frame vg ~width:canvas##.width ~height:canvas##.height
|
begin_frame vg ~width:canvas##.width ~height:canvas##.height
|
||||||
~device_ratio;
|
~device_ratio;
|
||||||
NVG.Transform.scale vg ~x:device_ratio ~y:device_ratio;
|
Transform.scale vg ~x:device_ratio ~y:device_ratio;
|
||||||
render vg ~time Gg.P2.o >>= fun _p ->
|
ignore Human.Panel.Ui.(panel vg Gg.P2.o test ev);
|
||||||
(* Logs.debug (fun m -> m "Drawing finished at point: %a" Gg.V2.pp p); *)
|
(*
|
||||||
NVG.end_frame vg;
|
Path.begin_ vg ;
|
||||||
Lwt.return_unit
|
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) ;
|
||||||
let _ =
|
fill vg ;
|
||||||
let canvas =
|
Transform.translate vg ~x:200. ~y:200. ;
|
||||||
Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
|
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
|
in
|
||||||
let webgl_ctx = webgl_initialize canvas in
|
Dom_html.window##requestAnimationFrame
|
||||||
let vg = graphv_initialize webgl_ctx in
|
(Js.wrap_callback (fun _ -> render Human.Event.empty))
|
||||||
|
|> ignore;*)
|
||||||
let open Js_of_ocaml_lwt.Lwt_js_events in
|
let open Js_of_ocaml_lwt.Lwt_js_events in
|
||||||
let page_var = Lwd.var Human.Panel.Ui.empty in
|
|
||||||
|
|
||||||
async (fun () ->
|
async (fun () ->
|
||||||
Human.Panel.Ui.boot_page >>= fun page ->
|
buffered_loop (make_event Dom_html.Event.keydown)
|
||||||
Lwd.set page_var page;
|
Dom_html.document (fun ev _ ->
|
||||||
let render = Human.Panel.Ui.renderer page_var in
|
webgl_ctx##clear
|
||||||
request_render canvas webgl_ctx vg render >>= fun () ->
|
(webgl_ctx##._COLOR_BUFFER_BIT_
|
||||||
buffered_loop
|
lor webgl_ctx##._DEPTH_BUFFER_BIT_
|
||||||
(make_event Dom_html.Event.keydown)
|
lor webgl_ctx##._STENCIL_BUFFER_BIT_);
|
||||||
Dom_html.document
|
let device_ratio = Dom_html.window##.devicePixelRatio in
|
||||||
Human.(
|
begin_frame vg ~width:canvas##.width ~height:canvas##.height
|
||||||
fun ev _ ->
|
~device_ratio;
|
||||||
Lwd.set page_var
|
Transform.scale vg ~x:device_ratio ~y:device_ratio;
|
||||||
(Panel.Ui.handle_event (Lwd.peek page_var)
|
Human.Panel.Ui.(
|
||||||
(Event_js.evt_of_jskey `Press ev));
|
render_lwt vg Gg.P2.o
|
||||||
request_render canvas webgl_ctx vg render))
|
(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))
|
||||||
|
|
||||||
(* Dom_html.document##.onkeydown
|
(* Dom_html.document##.onkeydown
|
||||||
:= Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) ->
|
:= Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) ->
|
||||||
|
|||||||
1
doc/console.drawio
Normal file
1
doc/console.drawio
Normal file
@ -0,0 +1 @@
|
|||||||
|
<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>
|
||||||
BIN
doc/console.drawio.png
Normal file
BIN
doc/console.drawio.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 17 KiB |
BIN
doc/console.odp
Normal file
BIN
doc/console.odp
Normal file
Binary file not shown.
BIN
doc/console.pptx
Normal file
BIN
doc/console.pptx
Normal file
Binary file not shown.
17
doc/deck_example.ml
Normal file
17
doc/deck_example.ml
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
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
doc/factorial.drawio
Normal file
1
doc/factorial.drawio
Normal file
@ -0,0 +1 @@
|
|||||||
|
<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>
|
||||||
BIN
doc/factorial.drawio.png
Normal file
BIN
doc/factorial.drawio.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 32 KiB |
772
human.ml
772
human.ml
@ -1,11 +1,10 @@
|
|||||||
(*
|
(*
|
||||||
|
|
||||||
names?:
|
names?:
|
||||||
- universal tool, unitool [was thinking about how this is trying to unify a lot of my "tools for thought"]
|
- 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!!!!!!!!
|
* 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]
|
- 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:
|
describe exactly every case you can think of that you want this drawing and layout system to handle:
|
||||||
|
|
||||||
@ -977,30 +976,24 @@ module Panel = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
module Ui = struct
|
module Ui = struct
|
||||||
(* Tree-like document structure of Ui elements, from the top level window down
|
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
|
||||||
to individual glyphs, and built with Lwd.
|
(* i think this is gonna end up being a binary tree?? *)
|
||||||
|
|
||||||
Probably an LCRS binary tree.
|
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
|
||||||
*)
|
|
||||||
|
|
||||||
open Gg
|
open Gg
|
||||||
|
|
||||||
type draw_context = { vg : NVG.t; style : Style.t; time : float }
|
|
||||||
and draw = draw_context -> Gg.p2 -> Gg.p2
|
|
||||||
|
|
||||||
module Page = struct
|
|
||||||
type t =
|
type t =
|
||||||
(* TODO figure out how to allow extending `node` with custom document tree combinators *)
|
[ `Atom of atom
|
||||||
[ `Atom of atom | `Attr of attr * t | `Join of dir * t * t ]
|
| `Attr of attr * node
|
||||||
|
| `Join of dir * node * node ]
|
||||||
|
|
||||||
and step = [ `Next | `Left | `Right ]
|
and node = { mutable parent : parent; mutable t : t; n : int }
|
||||||
and path = step list
|
and parent = [ `Left of node | `Right of node | `None ]
|
||||||
|
and cursor = { root : node; mutable sel : node }
|
||||||
|
|
||||||
and atom =
|
and atom =
|
||||||
[ (*`Lwd of t
|
[ `Image of image
|
||||||
| *)
|
|
||||||
`Image of
|
|
||||||
image
|
|
||||||
| `Uchar of Uchar.t
|
| `Uchar of Uchar.t
|
||||||
| `Boundary of boundary
|
| `Boundary of boundary
|
||||||
| `Hint of [ `Line | `Other ]
|
| `Hint of [ `Line | `Other ]
|
||||||
@ -1012,96 +1005,341 @@ module Panel = struct
|
|||||||
| `Handler of handler
|
| `Handler of handler
|
||||||
| `Draw of draw ]
|
| `Draw of draw ]
|
||||||
|
|
||||||
|
and p = P2.t
|
||||||
and dir = [ `X | `Y | `Z ]
|
and dir = [ `X | `Y | `Z ]
|
||||||
and image = NVG.Image.image
|
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 style = Style.t
|
||||||
and handler = t -> Event.t -> t
|
and handler = node -> Event.t -> Event.t option
|
||||||
|
and draw_context = { vg : NVG.t; style : Style.t }
|
||||||
|
and draw = draw_context -> p -> p
|
||||||
|
|
||||||
let sub_left = function
|
let node_count = ref 0
|
||||||
| `Atom _ as n -> n
|
|
||||||
|
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
|
||||||
| `Attr (_, n) -> n
|
| `Attr (_, n) -> n
|
||||||
| `Join (_, a, _) -> a
|
| `Join (_, a, _) -> a
|
||||||
|
|
||||||
let sub = sub_left
|
let super (n : node) : node =
|
||||||
|
match n.parent with `Left n' | `Right n' -> n' | `None -> n
|
||||||
|
|
||||||
let sub_right = function
|
let set_children_on_parent n =
|
||||||
| `Atom _ as n -> n
|
match n.parent with
|
||||||
| `Attr (_, n) -> n
|
| `Left ({ t = `Attr (a, _); _ } as s)
|
||||||
| `Join (_, _, b) -> b
|
| `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 atom (a : atom) : t = `Atom a
|
let option_of_parent = function
|
||||||
let attr (a : attr) (child : t) : t = `Attr (a, child)
|
| `None -> None
|
||||||
let join (d : dir) (a : t) (b : t) : t = `Join (d, a, b)
|
| `Left a | `Right a -> Some a
|
||||||
let empty = `Atom `Empty
|
|
||||||
let style (s : Style.t) t = attr (`Style s) t
|
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 pad v n = attr (`Pad (Pad.all v)) n
|
let pad v n = attr (`Pad (Pad.all v)) n
|
||||||
|
|
||||||
(* left child, right sibiling *)
|
let rec node_up_ (d : [ `Left | `Right ]) n' =
|
||||||
let rec fold_preorder : ('a -> t -> 'a option) -> 'a -> t -> 'a
|
match (d, n'.parent) with
|
||||||
=
|
| _, `None -> None
|
||||||
fun f acc n ->
|
| ( _,
|
||||||
match f acc n with
|
( `Left ({ t = `Attr _; _ } as p)
|
||||||
| Some acc' -> (
|
| `Right ({ t = `Attr _; _ } as p) ) ) ->
|
||||||
match n with
|
node_up_ d p
|
||||||
| `Atom _ -> acc'
|
| `Right, `Right ({ t = `Join _; _ } as p)
|
||||||
| `Attr (_, n'') -> fold_preorder f acc' n''
|
| `Left, `Left ({ t = `Join _; _ } as p) ->
|
||||||
| `Join (_, a, b) ->
|
node_up_ d p
|
||||||
fold_preorder f (fold_preorder f acc' a) b)
|
| `Left, `Right { t = `Join (_, l, _); _ } -> Some l
|
||||||
| None -> acc
|
| `Right, `Left { t = `Join (_, _, r); _ } -> Some r
|
||||||
|
| _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) ->
|
||||||
|
assert false
|
||||||
|
|
||||||
(* let rec fold_inorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
|
let node_next_ (d : [ `Left | `Right ]) (n : node) =
|
||||||
fun f acc n ->
|
match (d, n.t) with
|
||||||
match n with
|
| _, `Atom _ -> node_up_ d n
|
||||||
| `Atom _ -> (match f acc n with
|
| _, `Attr (_, n') -> Some n'
|
||||||
Some acc' -> acc'
|
| `Right, `Join (_, _, r) -> Some r
|
||||||
| None -> acc)
|
| `Left, `Join (_, l, _) -> Some l
|
||||||
| `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 fold_postorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
|
let rec search_preorder (f : node -> 'a option) (n : node) :
|
||||||
fun f acc n ->
|
'a option =
|
||||||
match n with
|
match f n with
|
||||||
| `Atom _ -> f (Some acc) n
|
| None -> (
|
||||||
| `Attr (_, n') -> f (fold_postorder f (Some acc) n') n
|
match node_next_ `Left n with
|
||||||
| `Join (_, a, b) ->
|
| Some n -> search_preorder f n
|
||||||
f (fold_postorder f (fold_postorder f (Some acc) a) b) 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 is_atom_uchar = function
|
let is_atom_uchar = function
|
||||||
| `Atom (`Uchar _) as n -> Some n
|
| { t = `Atom (`Uchar _); _ } as n -> Some n
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
let is_boundary b t =
|
let tree_uchar_fwd n =
|
||||||
match (b, t) with
|
Option.value (search_forward is_atom_uchar n) ~default:n
|
||||||
| ( `Char, `Atom (`Uchar _)
|
|
||||||
|
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 _)
|
||||||
| `Word, `Atom (`Boundary `Word)
|
| `Word, `Atom (`Boundary `Word)
|
||||||
| `Phrase, `Atom (`Boundary `Phrase)
|
| `Phrase, `Atom (`Boundary `Phrase)
|
||||||
| `Line, `Atom (`Boundary `Line)
|
| `Line, `Atom (`Boundary `Line)
|
||||||
| `Page, `Atom (`Boundary `Page) ) as x ->
|
| `Page, `Atom (`Boundary `Page) ->
|
||||||
Some x
|
Some n
|
||||||
| _ -> None
|
| _ -> 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_x = join `X
|
||||||
let join_y = join `Y
|
let join_y = join `Y
|
||||||
let join_z = join `Z
|
let join_z = join `Z
|
||||||
|
let ( ^^ ) = join_x
|
||||||
|
let ( ^/^ ) = join_y
|
||||||
|
let ( ^*^ ) = join_z
|
||||||
|
|
||||||
module Text = struct
|
let append_ d (l : node -> node) (a : node) : node -> node =
|
||||||
let append_ d (l : t -> t) (a : t) (b : t) : t =
|
fun n -> l (join d a n)
|
||||||
l (join d a b)
|
|
||||||
|
|
||||||
let empty_append = Fun.id
|
let empty_append = Fun.id
|
||||||
let append_x = append_ `X
|
let append_x = append_ `X
|
||||||
let append_y = append_ `Y
|
let append_y = append_ `Y
|
||||||
let append_z = append_ `Z
|
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) :
|
let rec decode dec (l : 'a) :
|
||||||
'a * [< `Await | `End | `Uchar of Uchar.t ] =
|
'a * [< `Await | `End | `Uchar of Uchar.t ] =
|
||||||
match Uutf.decode dec with
|
match Uutf.decode dec with
|
||||||
@ -1114,8 +1352,7 @@ module Panel = struct
|
|||||||
and _of_string dec l =
|
and _of_string dec l =
|
||||||
match decode dec l with
|
match decode dec l with
|
||||||
| l, `End -> l (atom (`Boundary `Text))
|
| l, `End -> l (atom (`Boundary `Text))
|
||||||
| l, `Uchar c ->
|
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
|
||||||
_of_string dec (append_x l (atom (`Uchar c)))
|
|
||||||
| l, _ -> _of_string dec l
|
| l, _ -> _of_string dec l
|
||||||
|
|
||||||
and of_string str =
|
and of_string str =
|
||||||
@ -1151,15 +1388,15 @@ module Panel = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
module Draw = struct
|
module Draw = struct
|
||||||
type p = P2.t
|
open NVG
|
||||||
|
|
||||||
type d = [ `X | `Y | `Z ]
|
type d = [ `X | `Y | `Z ]
|
||||||
|
type t = draw_context
|
||||||
|
|
||||||
let vcat d a b =
|
let vcat d a b =
|
||||||
match d with
|
match d with
|
||||||
| `X ->
|
| `X ->
|
||||||
V2.v
|
V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b))
|
||||||
(V2.x a +. V2.x b)
|
|
||||||
(Float.max_num (V2.y a) (V2.y b))
|
|
||||||
| `Y ->
|
| `Y ->
|
||||||
V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
|
V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
|
||||||
| `Z ->
|
| `Z ->
|
||||||
@ -1180,14 +1417,17 @@ module Panel = struct
|
|||||||
encode `End;
|
encode `End;
|
||||||
let text = Bytes.to_string (Buffer.to_bytes b) in
|
let text = Bytes.to_string (Buffer.to_bytes b) in
|
||||||
let open NVG 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 metrics = Text.metrics vg in
|
||||||
let x, y = (V2.x t, V2.y t +. metrics.ascender) in
|
let x, y = (V2.x t, V2.y t +. metrics.ascender) in
|
||||||
let twidth = Text.text_w vg ~x ~y text in
|
Text.text vg ~x ~y text;
|
||||||
P2.v twidth
|
P2.v
|
||||||
|
(P2.x t +. bounds.advance)
|
||||||
(P2.y t +. metrics.ascender +. metrics.descender
|
(P2.y t +. metrics.ascender +. metrics.descender
|
||||||
+. metrics.line_height)
|
+. metrics.line_height)
|
||||||
|
|
||||||
let rec atom { vg; _ } b (a : atom) : P2.t =
|
let rec atom vg b (a : atom) : P2.t =
|
||||||
|
let vg = vg.vg in
|
||||||
match a with
|
match a with
|
||||||
| `Image image ->
|
| `Image image ->
|
||||||
let wi, hi = Image.size vg image in
|
let wi, hi = Image.size vg image in
|
||||||
@ -1238,141 +1478,21 @@ module Panel = struct
|
|||||||
(Float.max_num (V2.x av) (V2.x bv))
|
(Float.max_num (V2.x av) (V2.x bv))
|
||||||
(Float.max_num (V2.y av) (V2.y bv))
|
(Float.max_num (V2.y av) (V2.y bv))
|
||||||
|
|
||||||
and node vg b n : P2.t =
|
and node t b (n : node) : P2.t =
|
||||||
let b' =
|
let b' =
|
||||||
match n with
|
match n.t with
|
||||||
| `Atom a -> atom vg b a
|
| `Atom a -> atom t b a
|
||||||
| `Attr a -> attr vg b a
|
| `Attr a -> attr t b a
|
||||||
| `Join a -> join vg b a
|
| `Join a -> join t b a
|
||||||
in
|
in
|
||||||
(* ignore
|
(*ignore
|
||||||
(path_box vg.vg
|
(Display.path_box t.vg
|
||||||
(NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
|
(Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
|
||||||
(Box2.of_pts b b')); *)
|
(Box2.of_pts b b') ) ; *)
|
||||||
b'
|
b'
|
||||||
end
|
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
|
module Action = struct
|
||||||
open Page
|
|
||||||
|
|
||||||
type segment =
|
type segment =
|
||||||
[ `Beginning of boundary
|
[ `Beginning of boundary
|
||||||
| `Forward of boundary
|
| `Forward of boundary
|
||||||
@ -1440,11 +1560,10 @@ module Panel = struct
|
|||||||
ppf ()
|
ppf ()
|
||||||
end
|
end
|
||||||
|
|
||||||
let perform_action (a : Action.t) (path : path) (node : node) :
|
let perform_action (a : Action.t) (c : cursor) : node option =
|
||||||
node option =
|
|
||||||
match a with
|
match a with
|
||||||
| `Move (`Forward `Line) ->
|
| `Move (`Forward `Line) -> (
|
||||||
(* let i = ref 0 in
|
let i = ref 0 in
|
||||||
ignore
|
ignore
|
||||||
(search_backward
|
(search_backward
|
||||||
(function
|
(function
|
||||||
@ -1453,8 +1572,8 @@ module Panel = struct
|
|||||||
incr i;
|
incr i;
|
||||||
None
|
None
|
||||||
| _ -> None)
|
| _ -> None)
|
||||||
path);
|
c.sel);
|
||||||
match search_forward (is_boundary `Line) path with
|
match search_forward (is_boundary `Line) c.sel with
|
||||||
| Some n' ->
|
| Some n' ->
|
||||||
Some
|
Some
|
||||||
(tree_iter
|
(tree_iter
|
||||||
@ -1463,10 +1582,9 @@ module Panel = struct
|
|||||||
(search_forward (is_boundary `Char) nn)
|
(search_forward (is_boundary `Char) nn)
|
||||||
~default:nn)
|
~default:nn)
|
||||||
n' !i)
|
n' !i)
|
||||||
| None -> *)
|
| None -> None)
|
||||||
None
|
| `Move (`Backward `Line) -> (
|
||||||
| `Move (`Backward `Line) ->
|
let i = ref 0 in
|
||||||
(* let i = ref 0 in
|
|
||||||
match
|
match
|
||||||
search_backward
|
search_backward
|
||||||
(function
|
(function
|
||||||
@ -1481,9 +1599,8 @@ module Panel = struct
|
|||||||
Option.map
|
Option.map
|
||||||
(fun n -> tree_iter tree_uchar_back n !i)
|
(fun n -> tree_iter tree_uchar_back n !i)
|
||||||
(search_backward (is_boundary `Line) n')
|
(search_backward (is_boundary `Line) n')
|
||||||
| None ->*)
|
| None -> None)
|
||||||
None
|
| `Move (`Forward b) ->
|
||||||
(* | `Move (`Forward b) ->
|
|
||||||
Option.map tree_uchar_fwd
|
Option.map tree_uchar_fwd
|
||||||
(search_forward (is_boundary b) c.sel)
|
(search_forward (is_boundary b) c.sel)
|
||||||
| `Move (`End b) ->
|
| `Move (`End b) ->
|
||||||
@ -1497,20 +1614,19 @@ module Panel = struct
|
|||||||
(search_backward (is_boundary b) c.sel)
|
(search_backward (is_boundary b) c.sel)
|
||||||
| `Insert n ->
|
| `Insert n ->
|
||||||
ignore (insert_join_l `X (super c.sel) n);
|
ignore (insert_join_l `X (super c.sel) n);
|
||||||
Some c.sel *)
|
Some c.sel
|
||||||
| `Overwrite _s -> None
|
| `Overwrite _s -> None
|
||||||
| `Yank _s -> None
|
| `Yank _s -> None
|
||||||
| `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
|
| `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
|
| `Kill _s -> None
|
||||||
(* | `Descend -> Some (sub c.sel) *)
|
| `Descend -> Some (sub c.sel)
|
||||||
(* | `Ascend -> option_of_parent c.sel.parent*)
|
| `Ascend -> option_of_parent c.sel.parent
|
||||||
| `Custom _s -> None
|
| `Custom _s -> None
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
type event_status = [ `Handled | `Event of Event.t ]
|
type event_status = [ `Handled | `Event of Event.t ]
|
||||||
|
|
||||||
let default_bindings =
|
let textedit_bindings =
|
||||||
let open Key.Bind in
|
let open Key.Bind in
|
||||||
empty
|
empty
|
||||||
|> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ]
|
|> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ]
|
||||||
@ -1547,24 +1663,35 @@ module Panel = struct
|
|||||||
let cursor_attr =
|
let cursor_attr =
|
||||||
`Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))
|
`Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))
|
||||||
|
|
||||||
let node_structure root =
|
let draw_cursor_root (c : cursor) : node =
|
||||||
Lwd.map
|
let open Gg in
|
||||||
~f:(fun node ->
|
attr
|
||||||
Page.Text.lines (Fmt.to_to_string pp_node_structure node))
|
(`Draw
|
||||||
root
|
(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 draw_path path =
|
let draw_cursor_sel (c : cursor) : node =
|
||||||
Lwd.map
|
let open Gg in
|
||||||
~f:(fun path ->
|
attr
|
||||||
Page.Text.lines (Fmt.to_to_string pp_path path))
|
(`Draw
|
||||||
path
|
(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 nav_handler ?(bindings = default_bindings)
|
let textedit ?(bindings = textedit_bindings) (n : node) =
|
||||||
((page, path) : node Lwd.t * Page.path) =
|
Format.pp_set_max_boxes F.stderr 64;
|
||||||
let page, path = (Lwd.var page, Lwd.var path) in
|
(*full screen fynn *)
|
||||||
|
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
|
||||||
let bind = Key.Bind.init bindings in
|
let bind = Key.Bind.init bindings in
|
||||||
handler
|
let sel = insert_attr cursor_attr n in
|
||||||
(fun (root : node) (e : Event.t) : node ->
|
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 =
|
let a =
|
||||||
match Key.Bind.resolve_events bind [ e ] with
|
match Key.Bind.resolve_events bind [ e ] with
|
||||||
| x :: _ -> Some x
|
| x :: _ -> Some x
|
||||||
@ -1573,52 +1700,65 @@ module Panel = struct
|
|||||||
| `Key (`Press, (k : Key.keystate)) -> (
|
| `Key (`Press, (k : Key.keystate)) -> (
|
||||||
match k.code with
|
match k.code with
|
||||||
| `Uchar c ->
|
| `Uchar c ->
|
||||||
Some (`Insert (Page.atom (`Uchar c)))
|
Some (`Insert (atom (`Uchar c)))
|
||||||
| _ -> None)
|
| _ -> None)
|
||||||
| _ -> None)
|
| _ -> None)
|
||||||
in
|
in
|
||||||
|
let r =
|
||||||
match a with
|
match a with
|
||||||
| Some x -> (
|
| Some x ->
|
||||||
match perform_action x (Lwd.get path) root with
|
c.sel <- remove_attr c.sel;
|
||||||
|
(match perform_action x c with
|
||||||
| Some n' ->
|
| Some n' ->
|
||||||
Log.info (fun m ->
|
F.epr "textedit action @[%a@] Success@."
|
||||||
m "nav_handler action @[%a@] Success@."
|
Action.pp_t x;
|
||||||
Action.pp_t x);
|
c.sel <- n'
|
||||||
n'
|
|
||||||
| None ->
|
| None ->
|
||||||
Log.warn (fun m ->
|
F.epr "textedit action @[%a@] Failure@."
|
||||||
m "nav_handler action @[%a@] Failure@."
|
|
||||||
Action.pp_t x);
|
Action.pp_t x);
|
||||||
root)
|
c.sel <- insert_attr cursor_attr c.sel;
|
||||||
| None -> root)
|
None
|
||||||
(join_y
|
| None -> None
|
||||||
(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) : 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
|
in
|
||||||
List.fold_left (fun acc f -> f acc ev) t handlers)
|
r),
|
||||||
n
|
n );
|
||||||
|
join_y (pad 5. c.root)
|
||||||
|
(join_y
|
||||||
|
(pad 5. (draw_cursor_sel c))
|
||||||
|
(pad 5. (draw_cursor_root c)))
|
||||||
|
|
||||||
module Text = struct
|
let handler_of_node (n : node) : handler option =
|
||||||
let lines = Lwd.map ~f:Page.Text.lines
|
let f n =
|
||||||
let of_string = Lwd.map ~f:Page.Text.of_string
|
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
|
||||||
end
|
in
|
||||||
|
match f n with Some a -> Some a | None -> search_forward f 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 View = struct
|
module View = struct
|
||||||
type path = Nav.path
|
type path = Nav.path
|
||||||
@ -1632,11 +1772,26 @@ module Panel = struct
|
|||||||
|
|
||||||
open Lwt.Infix
|
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 =
|
let of_path path =
|
||||||
join_x
|
Lwd.map2 ~f:join_x
|
||||||
(Text.of_string (Lwd.pure "/"))
|
(DText.of_string (Lwd.pure "/"))
|
||||||
(Lwd_utils.map_reduce
|
(Lwd_utils.map_reduce
|
||||||
(fun step -> Lwd.pure (Page.Text.of_string ("/" ^ step)))
|
(fun step ->
|
||||||
|
Lwd_utils.pack
|
||||||
|
(empty_node (), join_x)
|
||||||
|
[
|
||||||
|
DText.of_string (Lwd.pure "/");
|
||||||
|
DText.of_string (Lwd.pure step);
|
||||||
|
])
|
||||||
pack_x path)
|
pack_x path)
|
||||||
|
|
||||||
let of_tree ?(path = []) tree =
|
let of_tree ?(path = []) tree =
|
||||||
@ -1648,49 +1803,42 @@ module Panel = struct
|
|||||||
cursor = Lwd.var path;
|
cursor = Lwd.var path;
|
||||||
doc =
|
doc =
|
||||||
Lwd_utils.map_reduce
|
Lwd_utils.map_reduce
|
||||||
(fun (step, _t') -> Text.of_string (Lwd.pure step))
|
(fun (step, _t') -> DText.of_string (Lwd.pure step))
|
||||||
pack_y l;
|
pack_y l;
|
||||||
}
|
}
|
||||||
|
|
||||||
let list_logs hook =
|
let list_logs hook =
|
||||||
let var = Lwd.var Page.empty in
|
let var = Lwd.var (empty_node ()) in
|
||||||
(hook :=
|
(hook :=
|
||||||
fun level s ->
|
fun level s ->
|
||||||
Lwd.set var
|
Lwd.set var
|
||||||
Page.(
|
(join_y
|
||||||
join_y
|
|
||||||
(Text.of_string
|
(Text.of_string
|
||||||
(Logs.level_to_string (Some level) ^ ": " ^ s))
|
(Logs.level_to_string (Some level) ^ ": " ^ s))
|
||||||
(Lwd.peek var)));
|
(Lwd.peek var)));
|
||||||
Lwd.get var
|
Lwd.get var
|
||||||
|
|
||||||
let draw (vg, p) (root : node Lwd.root) : Page.Draw.p Lwt.t =
|
let draw (vg, p) (t : node Lwd.t) : p Lwt.t =
|
||||||
Lwt.return (Page.Draw.node vg p (Lwd.quick_sample root))
|
|
||||||
end
|
|
||||||
|
|
||||||
open Lwt.Infix
|
|
||||||
|
|
||||||
(* 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 =
|
let root =
|
||||||
Lwd.observe
|
Lwd.observe
|
||||||
~on_invalidate:(fun _ ->
|
~on_invalidate:(fun _ ->
|
||||||
Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
|
Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
|
||||||
(Lwd.join (Lwd.get root))
|
t
|
||||||
in
|
in
|
||||||
fun vg ?(time = 0.) p ->
|
Lwt.return (Draw.node vg p (Lwd.quick_sample root))
|
||||||
View.draw ({ vg; style = Style.dark; time }, p) root
|
end
|
||||||
|
|
||||||
let boot_page : node Lwd.t Lwt.t =
|
open Lwt.Infix
|
||||||
|
|
||||||
|
let render_lwt (vg : NVG.t) (p : p) (_ev : Event.t) : p Lwt.t =
|
||||||
|
let t = { vg; style = Style.dark } in
|
||||||
Nav.test_pull () >>= fun tree ->
|
Nav.test_pull () >>= fun tree ->
|
||||||
View.of_tree tree >>= fun tv ->
|
View.of_tree tree >>= fun doc ->
|
||||||
Lwt.return
|
View.draw (t, p)
|
||||||
(vcat
|
(Lwd_utils.reduce View.pack_y
|
||||||
[
|
[
|
||||||
nav_handler (tv.doc, []);
|
doc.doc;
|
||||||
View.of_path (Lwd.peek tv.cursor);
|
View.of_path (Lwd.peek doc.cursor);
|
||||||
View.list_logs Logs_reporter.hook;
|
View.list_logs Logs_reporter.hook;
|
||||||
])
|
])
|
||||||
end
|
end
|
||||||
|
|||||||
Reference in New Issue
Block a user