From b5d846b35d927ac3452855c723f0f90fe453aae8 Mon Sep 17 00:00:00 2001 From: cqc Date: Tue, 22 Nov 2022 23:38:53 -0600 Subject: [PATCH] re-arranged --- human.ml | 1116 ++++++++++++++++++++++++------------------------------ 1 file changed, 502 insertions(+), 614 deletions(-) diff --git a/human.ml b/human.ml index e0f21a1..4f160a6 100644 --- a/human.ml +++ b/human.ml @@ -976,523 +976,399 @@ 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 } + 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 atom = - [ `Image of image - | `Uchar of Uchar.t - | `Boundary of boundary - | `Hint of [ `Line | `Other ] - | `Empty ] + and step = [ `Next | `Left | `Right ] + and path = step list + and cursor = { path : path; root : t } - and attr = - [ `Style of style - | `Pad of Pad.t - | `Handler of handler - | `Draw of draw ] + and atom = + [ (*`Lwd of t + | *) + `Image of + image + | `Uchar of Uchar.t + | `Boundary of boundary + | `Hint of [ `Line | `Other ] + | `Empty ] - and p = P2.t - and dir = [ `X | `Y | `Z ] - and image = NVG.Image.image - 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 attr = + [ `Style of style + | `Pad of Pad.t + | `Handler of handler + | `Draw of draw ] - let node_count = ref 0 + and dir = [ `X | `Y | `Z ] + and image = NVG.Image.image - let node_n () = - node_count := !node_count + 1; - !node_count - 1 + and boundary = + [ `Char | `Word | `Phrase | `Line | `Page | `Text ] - 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 + and style = Style.t + and handler = t -> Event.t -> Event.t option - let sub (n : node) : node = - match n.t with - | `Atom _ -> n - | `Attr (_, n) -> n - | `Join (_, a, _) -> a + 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_right = function + | `Atom _ as n -> n + | `Attr (_, n) -> n + | `Join (_, _, b) -> b - 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 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 option_of_parent = function - | `None -> None - | `Left a | `Right a -> Some a + (* 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 (t : t) = - set_parent_on_children { parent = `None; t; n = node_n () } + (* 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 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 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 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 + let is_atom_uchar = function + | `Atom (`Uchar _) as n -> Some n + | _ -> None - 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 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) ) as x -> + Some x + | _ -> None - 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 join_x = join `X + let join_y = join `Y + let join_z = join `Z - 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 + module Text = struct + let append_ d (l : t -> t) (a : t) (b : t) : t = + l (join d a b) - 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 empty_append = Fun.id + let append_x = append_ `X + let append_y = append_ `Y + let append_z = append_ `Z - let rec tree_iter f n i = - if i <> 0 then tree_iter f (f n) (i - 1) else f n + let rec decode dec (l : 'a) : + 'a * [< `Await | `End | `Uchar of Uchar.t ] = + match Uutf.decode dec with + | `Malformed b -> + F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." + (String.escaped b); + decode dec (append_x l (of_string (String.escaped b))) + | (`Await | `End | `Uchar _) as s -> (l, s) - let search_forward f (n : node) = search_preorder f n - let search_backward f (n : node) = search_reverse_preorder f n + 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, _ -> _of_string dec l - let is_atom_uchar = function - | { t = `Atom (`Uchar _); _ } as n -> Some n - | _ -> None + and of_string str = + _of_string + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str)) + empty_append - let tree_uchar_fwd n = - Option.value (search_forward is_atom_uchar n) ~default:n + and _lines u d ly (lx, s) = + match Uuseg.add u s with + | `Boundary when Uuseg.mandatory u -> + _lines u d + (append_y ly (lx (atom (`Boundary `Line)))) + (empty_append, `Await) + | `Boundary -> + _lines u d ly (append_x lx (atom (`Hint `Line)), `Await) + | `End -> ly (lx (atom (`Boundary `Text))) + | `Await -> _lines u d ly (decode d lx) + | `Uchar c -> + _lines u d ly (append_x lx (atom (`Uchar c)), `Await) - let tree_uchar_back n = - Option.value (search_backward is_atom_uchar n) ~default:n + let lines str = + _lines + (Uuseg.create `Line_break) + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str)) + empty_append (empty_append, `Await) - let is_boundary b n = - match (b, n.t) with - | `Char, `Atom (`Uchar _) - | `Word, `Atom (`Boundary `Word) - | `Phrase, `Atom (`Boundary `Phrase) - | `Line, `Atom (`Boundary `Line) - | `Page, `Atom (`Boundary `Page) -> - Some n - | _ -> None + let text = of_string + let nl = atom (`Boundary `Line) + end - let search_back_opt (f : node -> node option) (n : node option) = - Option.bind n (search_backward f) + module Draw = struct + type p = P2.t + type d = [ `X | `Y | `Z ] - let search_back_uchar_opt = search_back_opt is_atom_uchar + 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)) + | `Y -> + V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b) + | `Z -> + V2.v + (Float.max_num (V2.x a) (V2.x b)) + (Float.max_num (V2.y a) (V2.y b)) - 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 uchar vg t (uc : Uchar.t) : P2.t = + let module Buffer = Stdlib.Buffer in + let b = Stdlib.Buffer.create 1 in + let enc = Uutf.encoder `UTF_8 (`Buffer b) in + let rec encode c = + match Uutf.encode enc c with + | `Ok -> () + | `Partial -> encode `Await + in + encode (`Uchar uc); + 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) + (P2.y t +. metrics.ascender +. metrics.descender + +. metrics.line_height) - 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 rec atom { vg; _ } b (a : atom) : P2.t = + match a with + | `Image image -> + let wi, hi = Image.size vg image in + let w, h = (float wi, float hi) in + Path.begin_ vg; + Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h; + let img_paint = + Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h + ~angle:0.0 ~image ~alpha:0. + in + set_fill_paint vg ~paint:img_paint; + fill vg; + P2.v (P2.x b +. w) (P2.y b +. h) + | `Uchar uc -> uchar vg b uc + | `Boundary _ -> b + | `Hint _ -> b + | `Empty -> b - 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 + and attr t b ((a : attr), n) : P2.t = + match a with + | `Style s -> + path_box t.vg s.bg + (Box2.of_pts b + (node { t with style = Style.merge t.style s } b n)) + | `Pad p -> pad t b p n + | `Draw d -> d t b + | `Handler _ -> node t b n - let kill_backward_char (n : node) : node option = - search_forward is_atom_uchar - (replace_parents_child (super (tree_uchar_back n)).parent n) + and pad vg t (p : Pad.t) n = + let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in + P2.(v (x nv +. p.r) (y nv +. p.b)) - 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' + and join vg t (d, a, b) : P2.t = + let av = node vg t a in + let bv = + node vg + (match d with + | `X -> P2.v (P2.x av) (P2.y t) + | `Y -> P2.v (P2.x t) (P2.y av) + | `Z -> t) + b + in + match d with + | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv)) + | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv) + | `Z -> + V2.v + (Float.max_num (V2.x av) (V2.x bv)) + (Float.max_num (V2.y av) (V2.y bv)) - 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 + and node vg b n : P2.t = + let b' = + match n with + | `Atom a -> atom vg b a + | `Attr a -> attr vg b a + | `Join a -> join vg b a + in + ignore + (path_box vg.vg + (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) + (Box2.of_pts b b')); + b' + end - let join_x = join `X - let join_y = join `Y - let join_z = join `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 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 "@[%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 + + let empty = Lwd.pure Page.empty + let pad v = Lwd.map ~f:(Page.pad v) + 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) - let append_ d (l : node -> node) (a : node) : node -> node = - fun n -> l (join d a n) - - 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 "@[%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 "@[%a@]" (_pp_t pp_node_n_record) - - let pp_n ppf n = - F.pf ppf "@[%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 - | `Malformed b -> - F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." - (String.escaped b); - decode dec (append_x l (of_string (String.escaped b))) - | (`Await | `End | `Uchar _) as s -> (l, s) - - 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, _ -> _of_string dec l - - and of_string str = - _of_string - (Uutf.decoder - ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str)) - empty_append - - and _lines u d ly (lx, s) = - match Uuseg.add u s with - | `Boundary when Uuseg.mandatory u -> - _lines u d - (append_y ly (lx (atom (`Boundary `Line)))) - (empty_append, `Await) - | `Boundary -> - _lines u d ly (append_x lx (atom (`Hint `Line)), `Await) - | `End -> ly (lx (atom (`Boundary `Text))) - | `Await -> _lines u d ly (decode d lx) - | `Uchar c -> - _lines u d ly (append_x lx (atom (`Uchar c)), `Await) - - let lines str = - _lines - (Uuseg.create `Line_break) - (Uutf.decoder - ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str)) - empty_append (empty_append, `Await) - - let text = of_string - let nl = atom (`Boundary `Line) - end - - module Draw = struct - open NVG - - 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)) - | `Y -> - V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b) - | `Z -> - V2.v - (Float.max_num (V2.x a) (V2.x b)) - (Float.max_num (V2.y a) (V2.y b)) - - let uchar vg t (uc : Uchar.t) : P2.t = - let module Buffer = Stdlib.Buffer in - let b = Stdlib.Buffer.create 1 in - let enc = Uutf.encoder `UTF_8 (`Buffer b) in - let rec encode c = - match Uutf.encode enc c with - | `Ok -> () - | `Partial -> encode `Await - in - encode (`Uchar uc); - 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) - (P2.y t +. metrics.ascender +. metrics.descender - +. metrics.line_height) - - let rec atom vg b (a : atom) : P2.t = - let vg = vg.vg in - match a with - | `Image image -> - let wi, hi = Image.size vg image in - let w, h = (float wi, float hi) in - Path.begin_ vg; - Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h; - let img_paint = - Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h - ~angle:0.0 ~image ~alpha:0. - in - set_fill_paint vg ~paint:img_paint; - fill vg; - P2.v (P2.x b +. w) (P2.y b +. h) - | `Uchar uc -> uchar vg b uc - | `Boundary _ -> b - | `Hint _ -> b - | `Empty -> b - - and attr t b ((a : attr), n) : P2.t = - match a with - | `Style s -> - path_box t.vg s.bg - (Box2.of_pts b - (node { t with style = Style.merge t.style s } b n)) - | `Pad p -> pad t b p n - | `Draw d -> d t b - | `Handler _ -> node t b n - - and pad vg t (p : Pad.t) n = - let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in - P2.(v (x nv +. p.r) (y nv +. p.b)) - - and join vg t (d, a, b) : P2.t = - let av = node vg t a in - let bv = - node vg - (match d with - | `X -> P2.v (P2.x av) (P2.y t) - | `Y -> P2.v (P2.x t) (P2.y av) - | `Z -> t) - b - in - match d with - | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv)) - | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv) - | `Z -> - V2.v - (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 = - let b' = - match n.t with - | `Atom a -> atom t b a - | `Attr a -> attr t b a - | `Join a -> join t 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') ) ; *) - b' - end + open Page.Pp module Action = struct + open Page + type segment = [ `Beginning of boundary | `Forward of boundary @@ -1501,8 +1377,8 @@ module Panel = struct and t = [ `Move of segment - | `Insert of node - | `Overwrite of node + | `Insert of t + | `Overwrite of t | `Yank of segment | `Kill of segment | `Ascend @@ -1560,9 +1436,11 @@ module Panel = struct ppf () end - let perform_action (a : Action.t) (c : cursor) : node option = + let perform_action (a : Action.t) ({ path; root } : Page.cursor) : + node option = match a with - | `Move (`Forward `Line) -> ( + | `Move (`Forward `Line) -> + (* let i = ref 0 in ignore (search_backward @@ -1572,8 +1450,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,46 +1460,48 @@ module Panel = struct (search_forward (is_boundary `Char) nn) ~default:nn) n' !i) - | None -> None) - | `Move (`Backward `Line) -> ( - let i = ref 0 in - match - search_backward - (function - | { t = `Atom (`Boundary `Line); _ } as n' -> Some n' - | { t = `Atom (`Uchar _); _ } -> - incr i; - None - | _ -> None) - c.sel - with - | Some n' -> - Option.map - (fun n -> tree_iter tree_uchar_back n !i) - (search_backward (is_boundary `Line) n') - | None -> None) - | `Move (`Forward b) -> - Option.map tree_uchar_fwd - (search_forward (is_boundary b) c.sel) - | `Move (`End b) -> - Option.map tree_uchar_back - (search_forward (is_boundary b) c.sel) - | `Move (`Backward b) -> - Option.map tree_uchar_back - (search_backward (is_boundary b) c.sel) - | `Move (`Beginning b) -> - Option.map tree_uchar_fwd - (search_backward (is_boundary b) c.sel) - | `Insert n -> - ignore (insert_join_l `X (super c.sel) n); - Some c.sel + | None -> *) + None + | `Move (`Backward `Line) -> + (* let i = ref 0 in + match + search_backward + (function + | { t = `Atom (`Boundary `Line); _ } as n' -> Some n' + | { t = `Atom (`Uchar _); _ } -> + incr i; + None + | _ -> None) + c.sel + with + | Some n' -> + Option.map + (fun n -> tree_iter tree_uchar_back n !i) + (search_backward (is_boundary `Line) n') + | None ->*) + None + (* | `Move (`Forward b) -> + Option.map tree_uchar_fwd + (search_forward (is_boundary b) c.sel) + | `Move (`End b) -> + Option.map tree_uchar_back + (search_forward (is_boundary b) c.sel) + | `Move (`Backward b) -> + Option.map tree_uchar_back + (search_backward (is_boundary b) c.sel) + | `Move (`Beginning b) -> + Option.map tree_uchar_fwd + (search_backward (is_boundary b) c.sel) + | `Insert n -> + ignore (insert_join_l `X (super c.sel) n); + 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 type event_status = [ `Handled | `Event of Event.t ] @@ -1663,90 +1543,106 @@ 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) + (* 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 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 node_structure root = + Lwd.map + ~f:(fun node -> + Page.Text.lines (Fmt.to_to_string pp_node_structure node)) + root - let textedit ?(bindings = textedit_bindings) (n : node) = + 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) + (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 bind = Key.Bind.init bindings in - let sel = insert_attr cursor_attr n in - let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in - c.root.t <- - `Attr - ( `Handler - (fun (_ : node) (e : Event.t) : Event.t option -> - let a = - match Key.Bind.resolve_events bind [ e ] with - | x :: _ -> Some x - | [] -> ( - match e with - | `Key (`Press, (k : Key.keystate)) -> ( - match k.code with - | `Uchar c -> - Some (`Insert (atom (`Uchar c))) - | _ -> None) - | _ -> None) - in - let r = - match a with - | Some x -> - c.sel <- remove_attr c.sel; - (match perform_action x c with - | Some n' -> - F.epr "textedit action @[%a@] Success@." - Action.pp_t x; - c.sel <- n' - | None -> - F.epr "textedit action @[%a@] Failure@." - Action.pp_t x); - c.sel <- insert_attr cursor_attr c.sel; - None - | None -> None - in - r), - n ); - join_y (pad 5. c.root) + 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_cursor_sel c)) - (pad 5. (draw_cursor_root c))) + (pad 5. (draw_path (Lwd.get path))) + (pad 5. (node_structure (Lwd.get doc)))) - let handler_of_node (n : node) : handler option = - let f n = - match n.t with `Attr (`Handler f, _) -> Some f | _ -> None - in - match f n with Some a -> Some a | None -> search_forward f n + (* let bind = Key.Bind.init bindings in + let sel = insert_attr cursor_attr n in + let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in + c.root.t <- + `Attr + ( `Handler + (fun (_ : node) (e : Event.t) : Event.t option -> + let a = + match Key.Bind.resolve_events bind [ e ] with + | x :: _ -> Some x + | [] -> ( + match e with + | `Key (`Press, (k : Key.keystate)) -> ( + match k.code with + | `Uchar c -> + Some (`Insert (atom (`Uchar c))) + | _ -> None) + | _ -> None) + in + let r = + match a with + | Some x -> + c.sel <- remove_attr c.sel; + (match perform_action x c with + | Some n' -> + F.epr "textedit action @[%a@] Success@." + Action.pp_t x; + c.sel <- n' + | None -> + F.epr "textedit action @[%a@] Failure@." + Action.pp_t x); + c.sel <- insert_attr cursor_attr c.sel; + None + | None -> None + in + r), + n ); + join_y (pad 5. c.root) + (join_y + (pad 5. (draw_cursor_sel c)) + (pad 5. (draw_cursor_root c))) *) - let 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 is_handler (n : node) : 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: + (fold_preorder + (fun ev' n' -> + match is_handler n' with + | Some f -> f n' ev' + | None -> None) + ev) + n - let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t - = + 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 @@ -1760,6 +1656,11 @@ module Panel = struct * *) + 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 +1673,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,39 +1689,41 @@ 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 - (Text.of_string - (Logs.level_to_string (Some level) ^ ": " ^ s)) - (Lwd.peek var))); + 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 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 - Lwt.return (Draw.node vg p (Lwd.quick_sample root)) + 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 render_lwt (vg : NVG.t) (p : Gg.p2) (_ev : Event.t) : + Gg.p2 Lwt.t = let t = { vg; style = Style.dark } in Nav.test_pull () >>= fun tree -> View.of_tree tree >>= fun doc -> View.draw (t, p) - (Lwd_utils.reduce View.pack_y + (Lwd_utils.reduce pack_y [ doc.doc; View.of_path (Lwd.peek doc.cursor);