From a82c9464f4b2be444b5506441ba9bd6060a9b430 Mon Sep 17 00:00:00 2001 From: cqc Date: Sun, 6 Feb 2022 18:34:17 -0600 Subject: [PATCH] here i am going to abandon using the linear "Regions" which are "Trope"s from grenier.trope which were adopted while star-struck from a weird ui library i can't remember the name of at the moment, because using regions with nodes is just pure fucking premature optimization and makes the backward references really hard and i don't want to deal with it anymore --- human.ml | 292 +++++++++++++++++++++++-------------------------------- 1 file changed, 123 insertions(+), 169 deletions(-) diff --git a/human.ml b/human.ml index 0f04899..c935fd6 100644 --- a/human.ml +++ b/human.ml @@ -1226,42 +1226,6 @@ module Panel = struct ; font= Font.merge a.font b.font } end - module Focus = struct - (* Stolen from lwd/lib/nottui/nottui.ml *) - type var = int Lwd.var - type status = [`Empty | `Handle of int * var | `Conflict of int] - type handle = var * status Lwd.t - - let make () = - let v = Lwd.var 0 in - (v, Lwd.map ~f:(fun n -> `Handle (n, v)) (Lwd.get v)) - - let empty : status = `Empty - let status (h : handle) : status Lwd.t = snd h - - let has_focus = function - | `Empty -> false - | `Handle (i, _) | `Conflict i -> i > 0 - - let clock = ref 0 - let request_var (v : var) = incr clock ; Lwd.set v !clock - let request ((v, _) : handle) = request_var v - let release ((v, _) : handle) = incr clock ; Lwd.set v 0 - - let merge s1 s2 : status = - match (s1, s2) with - | s, (`Empty | `Handle (0, _)) | (`Empty | `Handle (0, _)), s -> - s - | (`Handle (i, _) as s), `Handle (j, _) when i = j -> s - | (`Handle (i, _) | `Conflict i), (`Conflict j as s) when i < j - -> - s - | (`Handle (i, _) | `Conflict i), `Handle (j, _) when i < j -> - `Conflict j - | (`Conflict _ as s), (`Handle (_, _) | `Conflict _) -> s - | `Handle (i, _), (`Handle (_, _) | `Conflict _) -> `Conflict i - end - module Pad = struct type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1} @@ -1276,8 +1240,9 @@ module Panel = struct type 'a t = {t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor} + and 'a region = 'a t + type cursor = Trope.cursor - type 'a region = 'a t let create () = let t = Trope.create () in @@ -1325,6 +1290,11 @@ module Panel = struct ~start:c' ~f () | None -> r + let seek_before ~(r : 'a region) : 'a region option = + match Trope.seek_before r.t r.left with + | Some (c, _e) -> Some {r with left= c} + | None -> None + let rec fold ~(t : 'a region) ?(start = t.left) ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b) : 'b = @@ -1350,19 +1320,25 @@ module Panel = struct | Some x -> fold_lwt_opt ~t ~start:c ~f x | None -> Lwt.return acc ) | None -> Lwt.return acc - - end + (* trying to construct a data type where "regions" as above are an internal + linear dimension inside a tree, or maybe even a dag *) + module Ui = struct + (* Tree-like structure of Ui elements, from the entire display down to individual glyphs. + Uses the linear Region.t as the collection of nodes on each branch *) + open Gg open Wall - type t = [`Atom of atom | `Attr of (attr * node) | `Region of (dir * region)] + type t = + [`Atom of atom | `Attr of attr * node | `Region of dir * region] - and node = {mutable parent: parent; mutable child: t} - - and parent = [ `Atom of atom | `Attr of (attr * node) | `Region of (dir * region * Region.cursor)] + and node = {mutable parent: [`Node of node | `Region of node * Region.cursor]; mutable child: t} + and cursor = {root: node; + mutable sel: node option; + } and atom = [ `Image of image @@ -1373,20 +1349,13 @@ module Panel = struct [ `Style of style | `Pad of Pad.t | `Shift of dim - | `Focus of handle * Focus.handle | `Handle of handle ] and region = node Region.t - - and dir = [`X | `Y | `Z] - and image = Wall.image * Size2.t - and dim = Gg.size2 - and style = Style.t - and handle = node -> Event.t -> Event.t option Lwt.t let empty_image = (Image.empty, V2.zero) @@ -1395,44 +1364,31 @@ module Panel = struct let rec parent = `Atom (`Image empty_image) in parent - let empty_region dir = - let rec parent = - `Region (dir, Region.create ()) in - parent + let empty_region dir : t = `Region (dir, Region.create ()) let set_parent_on_children parent = match parent.child with | `Atom _ -> () - | `Attr (_, n) -> n.parent <- parent + | `Attr (_, n) -> n.parent <- `Node parent | `Region (_, r) -> - Region.iter ~t:r ~f:(fun n -> n.parent <- parent) () - - let set_children_on_parent (t : t) = - match t with - | `Atom _ -> () - | `Attr (_, n) -> n.parent.child <- t - | `Region (_, r) -> - Region.iter ~t:r ~f:(fun n -> n.parent.child <- t) () + Region.fold ~t:r ~f:(fun (_, c) n a -> n.parent <- `Region (parent, c); a) () let node (child : t) = - let rec parent = {parent; child} in + let rec parent = {parent=`Node parent; child} in set_parent_on_children parent ; parent let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) - let focus ((f, h) : handle * Focus.handle) (n : node) = - node (`Attr (`Focus (f, h), n)) - let node_func ?(fnode = fun (x : node) -> x) ?(fregion = fun (x : node Region.t) -> x) - ?(fatom = fun (x : atom) -> x) parent : node = - parent.child <- - ( match parent.child with - | `Attr (a, n) -> `Attr (a, {(fnode n) with parent}) + ?(fatom = fun (x : atom) -> x) n : node = + n.child <- + ( match n.child with + | `Attr (a, n) -> `Attr (a, {(fnode n) with parent=`Node n}) | `Region (a, r) -> `Region (a, fregion r) | `Atom a -> `Atom (fatom a) ) ; - parent + n let rec traverse_nodes ~(f : node -> node) (n : node) : node = node_func @@ -1443,7 +1399,7 @@ module Panel = struct ( { r with t= Trope.put_right r.t c - {(traverse_nodes ~f e) with parent= n} } + {(traverse_nodes ~f e) with parent= `Region (n, c)} } , c ) ) () ) n @@ -1463,20 +1419,17 @@ module Panel = struct () ) parent - let rec search_backward (node : node) (t : [`Atom of atom | `Attr of attr | `Region of dir] ) = - match node.parent.child with - | `Atom a when t <> `Atom a -> search_backward node.parent t - | `Attr (a, n) when t <> `Attr a -> search_backward node.parent t - | `Region (d, r) when t <> `Region d -> - - | `Region -> x where x = t -> x - - - - + let region_append (r : node) (c : t) : node = + match r.child with + `Atom _ | `Attr _ -> assert false + | `Region (d, r') -> + let right = Trope.cursor_after r'.right in + let child = {parent=`Region (r, right); child=c} in + {r with child=`Region (d,{r' with t= Trope.put_right r'.t right child; right})} + let join_ d (a : node) (b : node) = let rec parent = - { parent + { parent= `Node parent ; child= `Region (d, Region.append (Region.append (Region.create ()) a) b) @@ -1487,46 +1440,33 @@ module Panel = struct let join_x = join_ `X let join_y = join_ `Y let join_z = join_ `Z - let pack_x : node Lwd_utils.monoid = (empty_region `X, join_x) - let pack_y : node Lwd_utils.monoid = (empty_region `Y, join_y) - let pack_z : node Lwd_utils.monoid = (empty_region `Z, join_z) + + let pack_x : node Lwd_utils.monoid = + (node (empty_region `X), join_x) + + let pack_y : node Lwd_utils.monoid = + (node (empty_region `Y), join_y) + + let pack_z : node Lwd_utils.monoid = + (node (empty_region `Z), join_z) + let ( ^^ ) = join_x let ( ^/^ ) = join_y module Text = struct - (* let to_buffer t = - let b = Buffer.create 0 in - let enc' = Uutf.encoder `UTF_8 (`Buffer b) in - let rec enc c = - match Uutf.encode enc' c with - | `Partial -> enc `Await - | `Ok -> () in - let rec aux c = - match Trope.seek_after t.t c with - | Some (c, Uchar char) -> - enc (`Uchar char) ; - aux c - | Some (c, _) -> aux c - | None -> () in - aux line.left ; b - - let to_string t = - Bytes.to_string (Buffer.to_bytes (to_buffer t)) *) - - let rec _of_string ~rl (str : string) : node = - let rec parent = {parent; child= `Region (`Y, rl)} in + let rec _of_string ~(ry : node) (str : string) : node = let uudec = Uutf.decoder (`String str) in - let rec dec (rl : node Region.t) : 'a * node Region.t = + let rec dec (rx' : node Region.t) : 'a * node Region.t = match Uutf.decode uudec with | `Malformed b -> dec - (Region.append rl - (_of_string ~rl:(Region.create ()) + (Region.append rx' + (_of_string ~ry:(node (empty_region `Y)) (String.escaped b) ) ) - | (`Await | `Uchar _ | `End) as x -> (x, rl) in + | (`Await | `Uchar _ | `End) as x -> (x, rx') in let uuline = Uuseg.create `Line_break in - let rec line (rl : node Region.t) = - let rec char (x, t) (line : node Region.t) = + let rec line (ry' : node) : node = + let rec char (x, t) (line : node) = match Uuseg.add uuline x with | `End as x -> (line, x) | `Boundary as x when Uuseg.mandatory uuline -> (line, x) @@ -1534,28 +1474,25 @@ module Panel = struct | `Boundary -> char (`Await, t) - (Region.append line - {parent; child= `Atom (`Boundary `Hint)} ) + (region_append line (`Atom (`Boundary `Hint))) | `Uchar c -> char (`Await, t) - (Region.append line - {parent; child= `Atom (`Uchar c)} ) in + (region_append line (`Atom (`Uchar c) )) in match char (`Await, rl) - (Region.append (Region.create ()) - {parent; child= `Atom (`Boundary `Line)} ) + (node (empty_region `X)) with | l, `Boundary -> - line (Region.append rl {parent; child= `Region (`X, l)}) + line (region_append ry' (`Atom (`Boundary `Line) )) | l, `End -> - Region.append rl {parent; child= `Region (`X, l)} in + region_append ry' l in parent.child <- `Region (`Y, line rl) ; parent - let of_string ?(rl = Region.create ()) (str : string) = - _of_string ~rl str + let of_string ?(ry = (empty_region `Y)) (str : string) = + _of_string ~ry str let segment ?(boundary = `Word) ?(label = `Word) (node : node) : node = @@ -1708,41 +1645,43 @@ module Panel = struct | `Enter | `In | `Out ] - - let handle (action : t) (node : node) : node option = - match action with - | `Move (`Beginning `Char) -> Some node - | `Move (`Beginning `Word) -> - Some (search_backward node (`Boundary `Word)) - | `Move _ -> None - | `Yank _s -> None - | `Kill _s -> None - | `Custom _s -> None end - type event_status = - [ `Handled - | (*`Focus of [`Next | `Prev | `Up | `Down] | *) - `Event of - Event.t ] + let rec search_backward (n : node) (f : node -> 'a option) : 'a option = + match f n with + | None -> + (match n.parent.child with + | a when n = a -> None (* at root and didn't find anything *) + | (`Atom _) | (`Attr _) -> search_backward node.parent f + | (`Region (d, r)) -> ( + match Region.seek_before ~r with + | Some r' -> + search_backward {node with child= `Region (d, r')} t + | None -> search_backward node.parent t ) + | Some n' -> Some n' - let rec handle_event (node : node) (ev : Event.t) : - event_status Lwt.t = - match node.child with - | `Atom _ -> Lwt.return (`Event ev) - | `Attr (`Focus (f, _), n) -> ( - f n ev - >>= function - | None -> Lwt.return `Handled | Some e -> handle_event n e ) - | `Attr (`Handle f, n) -> ( - f n ev - >>= function - | None -> Lwt.return `Handled | Some e -> handle_event n e ) - | `Attr (_, n) -> handle_event n ev - | `Region (_, r) -> - Region.fold_lwt_opt ~t:r - ~f:(fun _ n (es : event_status) -> - match es with + + let handle_action (a : Action.t) (c : node) : node option = + match a with + | `Move (`Beginning `Char) -> c + | `Move (`Beginning `Word) -> + search_backward c (fun n -> match n.child with `Atom (`Boundary `Word) -> n | None -> None) + | `Move _ -> c + | `Yank _s -> c + | `Kill _s -> c + | `Custom _s -> c + + let rec handle_of_node (node : node) : handle option + = + traverse_nodes ~f:(fun n -> + match n.child with + | `Atom _ -> None + | `Attr (`Handle f, _) -> Some f + | `Attr (_, n) -> handle_of_node n + | `Region (_, r) -> + traverse_ ~t:r + ~f:(fun _ n (es : event_status) -> + match es with | `Event e -> ( handle_event n e >>= function @@ -1751,6 +1690,13 @@ module Panel = struct | `Handled -> Lwt.return None ) (`Event ev) + let action_of_handler (e : Event.t) (h : handler) = Action.t option + f n ev + >>= function + | Some e -> Lwt.return `Handled | None -> Lwt.return_none ) + + type event_status = [`Handled | `Event of Event.t] + let textedit_bindings = let open Key.Bind in empty @@ -1775,17 +1721,22 @@ module Panel = struct [([Ctrl], C 'x'); ([], U `Backspace)] [`Kill (`Back `Phrase)] - let textedit_handler ?(bindings = textedit_bindings) n = + let textedit_handler ?(bindings = textedit_bindings) (n : node) = let bind = Key.Bind.init bindings in - let fq = Stack.create () in - Stack.push (`Down, node) fq ; - focus - ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t -> - match Key.Bind.resolve_events bind [e] with - | x :: _ -> Action.handle x - | [] -> Lwt.return_some e ) - , Focus.make () ) - n + let c = ref n in + `Handler ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t -> + match Key.Bind.resolve_events bind [e] with + | x :: _ -> handle_event x n c + | [] -> Lwt.return_some e ) + , Focus.make () ) + + let rec handle_event (n : cursor) (ev : Event.t) : + event_status Lwt.t = + match n.sel.child with + | Some a -> + c := handle_action a !c ; + Lwt.return `Handled + | None -> `Event ev let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t = let rq = Lwd.make_release_queue () in @@ -1794,7 +1745,7 @@ module Panel = struct let r = Lwd.sample rq root in Lwt_list.iter_s (fun e -> - handle_event r e + handle_event r e c >>= fun h -> ( match h with | `Handled -> () @@ -1805,6 +1756,9 @@ module Panel = struct ev >|= fun () -> Draw.pane r ) +let new_cursor (root : node) : cursor = + {root; sel=root} + let test = panel (Lwd.pure @@ -1813,7 +1767,7 @@ module Panel = struct (join_y (join_y (Text.of_string - "-- welcome to the land of idiots ---" ) + "-- welcome to my land of idiocy ---" ) (join_x (Text.of_string "hello bitch") (Text.of_string "!\n sup dude") ) )