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

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

Browse Source
This commit is contained in:
cqc
2022-02-06 18:34:17 -06:00
parent 481870e067
commit a82c9464f4
1 changed files with 123 additions and 169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

278
human.ml
View File

@ -1226,42 +1226,6 @@ module Panel = struct
; font= Font.merge a.font b.font } ; font= Font.merge a.font b.font }
end 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 module Pad = struct
type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1} type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1}
@ -1276,8 +1240,9 @@ module Panel = struct
type 'a t = type 'a t =
{t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor} {t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor}
and 'a region = 'a t
type cursor = Trope.cursor type cursor = Trope.cursor
type 'a region = 'a t
let create () = let create () =
let t = Trope.create () in let t = Trope.create () in
@ -1325,6 +1290,11 @@ module Panel = struct
~start:c' ~f () ~start:c' ~f ()
| None -> r | 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) let rec fold ~(t : 'a region) ?(start = t.left)
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b) ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b)
: 'b = : 'b =
@ -1350,19 +1320,25 @@ module Panel = struct
| Some x -> fold_lwt_opt ~t ~start:c ~f x | Some x -> fold_lwt_opt ~t ~start:c ~f x
| None -> Lwt.return acc ) | None -> Lwt.return acc )
| None -> Lwt.return acc | None -> Lwt.return acc
end 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 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 Gg
open Wall 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 node = {mutable parent: [`Node of node | `Region of node * Region.cursor]; mutable child: t}
and cursor = {root: node;
and parent = [ `Atom of atom | `Attr of (attr * node) | `Region of (dir * region * Region.cursor)] mutable sel: node option;
}
and atom = and atom =
[ `Image of image [ `Image of image
@ -1373,20 +1349,13 @@ module Panel = struct
[ `Style of style [ `Style of style
| `Pad of Pad.t | `Pad of Pad.t
| `Shift of dim | `Shift of dim
| `Focus of handle * Focus.handle
| `Handle of handle ] | `Handle of handle ]
and region = node Region.t and region = node Region.t
and dir = [`X | `Y | `Z] and dir = [`X | `Y | `Z]
and image = Wall.image * Size2.t and image = Wall.image * Size2.t
and dim = Gg.size2 and dim = Gg.size2
and style = Style.t and style = Style.t
and handle = node -> Event.t -> Event.t option Lwt.t and handle = node -> Event.t -> Event.t option Lwt.t
let empty_image = (Image.empty, V2.zero) let empty_image = (Image.empty, V2.zero)
@ -1395,44 +1364,31 @@ module Panel = struct
let rec parent = `Atom (`Image empty_image) in let rec parent = `Atom (`Image empty_image) in
parent parent
let empty_region dir = let empty_region dir : t = `Region (dir, Region.create ())
let rec parent =
`Region (dir, Region.create ()) in
parent
let set_parent_on_children parent = let set_parent_on_children parent =
match parent.child with match parent.child with
| `Atom _ -> () | `Atom _ -> ()
| `Attr (_, n) -> n.parent <- parent | `Attr (_, n) -> n.parent <- `Node parent
| `Region (_, r) -> | `Region (_, r) ->
Region.iter ~t:r ~f:(fun n -> n.parent <- parent) () Region.fold ~t:r ~f:(fun (_, c) n a -> n.parent <- `Region (parent, c); a) ()
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) ()
let node (child : t) = let node (child : t) =
let rec parent = {parent; child} in let rec parent = {parent=`Node parent; child} in
set_parent_on_children parent ; set_parent_on_children parent ;
parent parent
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) 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) let node_func ?(fnode = fun (x : node) -> x)
?(fregion = fun (x : node Region.t) -> x) ?(fregion = fun (x : node Region.t) -> x)
?(fatom = fun (x : atom) -> x) parent : node = ?(fatom = fun (x : atom) -> x) n : node =
parent.child <- n.child <-
( match parent.child with ( match n.child with
| `Attr (a, n) -> `Attr (a, {(fnode n) with parent}) | `Attr (a, n) -> `Attr (a, {(fnode n) with parent=`Node n})
| `Region (a, r) -> `Region (a, fregion r) | `Region (a, r) -> `Region (a, fregion r)
| `Atom a -> `Atom (fatom a) ) ; | `Atom a -> `Atom (fatom a) ) ;
parent n
let rec traverse_nodes ~(f : node -> node) (n : node) : node = let rec traverse_nodes ~(f : node -> node) (n : node) : node =
node_func node_func
@ -1443,7 +1399,7 @@ module Panel = struct
( { r with ( { r with
t= t=
Trope.put_right r.t c Trope.put_right r.t c
{(traverse_nodes ~f e) with parent= n} } {(traverse_nodes ~f e) with parent= `Region (n, c)} }
, c ) ) , c ) )
() ) () )
n n
@ -1463,20 +1419,17 @@ module Panel = struct
() ) () )
parent parent
let rec search_backward (node : node) (t : [`Atom of atom | `Attr of attr | `Region of dir] ) = let region_append (r : node) (c : t) : node =
match node.parent.child with match r.child with
| `Atom a when t <> `Atom a -> search_backward node.parent t `Atom _ | `Attr _ -> assert false
| `Attr (a, n) when t <> `Attr a -> search_backward node.parent t | `Region (d, r') ->
| `Region (d, r) when t <> `Region d -> let right = Trope.cursor_after r'.right in
let child = {parent=`Region (r, right); child=c} in
| `Region -> x where x = t -> x {r with child=`Region (d,{r' with t= Trope.put_right r'.t right child; right})}
let join_ d (a : node) (b : node) = let join_ d (a : node) (b : node) =
let rec parent = let rec parent =
{ parent { parent= `Node parent
; child= ; child=
`Region `Region
(d, Region.append (Region.append (Region.create ()) a) b) (d, Region.append (Region.append (Region.create ()) a) b)
@ -1487,46 +1440,33 @@ module Panel = struct
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 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_x : node Lwd_utils.monoid =
let pack_z : node Lwd_utils.monoid = (empty_region `Z, join_z) (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_x
let ( ^/^ ) = join_y let ( ^/^ ) = join_y
module Text = struct module Text = struct
(* let to_buffer t = let rec _of_string ~(ry : node) (str : string) : node =
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 uudec = Uutf.decoder (`String str) in 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 match Uutf.decode uudec with
| `Malformed b -> | `Malformed b ->
dec dec
(Region.append rl (Region.append rx'
(_of_string ~rl:(Region.create ()) (_of_string ~ry:(node (empty_region `Y))
(String.escaped b) ) ) (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 uuline = Uuseg.create `Line_break in
let rec line (rl : node Region.t) = let rec line (ry' : node) : node =
let rec char (x, t) (line : node Region.t) = let rec char (x, t) (line : node) =
match Uuseg.add uuline x with match Uuseg.add uuline x with
| `End as x -> (line, x) | `End as x -> (line, x)
| `Boundary as x when Uuseg.mandatory uuline -> (line, x) | `Boundary as x when Uuseg.mandatory uuline -> (line, x)
@ -1534,28 +1474,25 @@ module Panel = struct
| `Boundary -> | `Boundary ->
char char
(`Await, t) (`Await, t)
(Region.append line (region_append line (`Atom (`Boundary `Hint)))
{parent; child= `Atom (`Boundary `Hint)} )
| `Uchar c -> | `Uchar c ->
char char
(`Await, t) (`Await, t)
(Region.append line (region_append line (`Atom (`Uchar c) )) in
{parent; child= `Atom (`Uchar c)} ) in
match match
char char
(`Await, rl) (`Await, rl)
(Region.append (Region.create ()) (node (empty_region `X))
{parent; child= `Atom (`Boundary `Line)} )
with with
| l, `Boundary -> | l, `Boundary ->
line (Region.append rl {parent; child= `Region (`X, l)}) line (region_append ry' (`Atom (`Boundary `Line) ))
| l, `End -> | l, `End ->
Region.append rl {parent; child= `Region (`X, l)} in region_append ry' l in
parent.child <- `Region (`Y, line rl) ; parent.child <- `Region (`Y, line rl) ;
parent parent
let of_string ?(rl = Region.create ()) (str : string) = let of_string ?(ry = (empty_region `Y)) (str : string) =
_of_string ~rl str _of_string ~ry str
let segment ?(boundary = `Word) ?(label = `Word) (node : node) : let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node = node =
@ -1708,39 +1645,41 @@ module Panel = struct
| `Enter | `Enter
| `In | `In
| `Out ] | `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 end
type event_status = let rec search_backward (n : node) (f : node -> 'a option) : 'a option =
[ `Handled match f n with
| (*`Focus of [`Next | `Prev | `Up | `Down] | *) | None ->
`Event of (match n.parent.child with
Event.t ] | 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 = let handle_action (a : Action.t) (c : node) : node option =
match node.child with match a with
| `Atom _ -> Lwt.return (`Event ev) | `Move (`Beginning `Char) -> c
| `Attr (`Focus (f, _), n) -> ( | `Move (`Beginning `Word) ->
f n ev search_backward c (fun n -> match n.child with `Atom (`Boundary `Word) -> n | None -> None)
>>= function | `Move _ -> c
| None -> Lwt.return `Handled | Some e -> handle_event n e ) | `Yank _s -> c
| `Attr (`Handle f, n) -> ( | `Kill _s -> c
f n ev | `Custom _s -> c
>>= function
| None -> Lwt.return `Handled | Some e -> handle_event n e ) let rec handle_of_node (node : node) : handle option
| `Attr (_, n) -> handle_event n ev =
traverse_nodes ~f:(fun n ->
match n.child with
| `Atom _ -> None
| `Attr (`Handle f, _) -> Some f
| `Attr (_, n) -> handle_of_node n
| `Region (_, r) -> | `Region (_, r) ->
Region.fold_lwt_opt ~t:r traverse_ ~t:r
~f:(fun _ n (es : event_status) -> ~f:(fun _ n (es : event_status) ->
match es with match es with
| `Event e -> ( | `Event e -> (
@ -1751,6 +1690,13 @@ module Panel = struct
| `Handled -> Lwt.return None ) | `Handled -> Lwt.return None )
(`Event ev) (`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 textedit_bindings =
let open Key.Bind in let open Key.Bind in
empty empty
@ -1775,17 +1721,22 @@ module Panel = struct
[([Ctrl], C 'x'); ([], U `Backspace)] [([Ctrl], C 'x'); ([], U `Backspace)]
[`Kill (`Back `Phrase)] [`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 bind = Key.Bind.init bindings in
let fq = Stack.create () in let c = ref n in
Stack.push (`Down, node) fq ; `Handler ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
focus
( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
match Key.Bind.resolve_events bind [e] with match Key.Bind.resolve_events bind [e] with
| x :: _ -> Action.handle x | x :: _ -> handle_event x n c
| [] -> Lwt.return_some e ) | [] -> Lwt.return_some e )
, Focus.make () ) , Focus.make () )
n
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 panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t =
let rq = Lwd.make_release_queue () in let rq = Lwd.make_release_queue () in
@ -1794,7 +1745,7 @@ module Panel = struct
let r = Lwd.sample rq root in let r = Lwd.sample rq root in
Lwt_list.iter_s Lwt_list.iter_s
(fun e -> (fun e ->
handle_event r e handle_event r e c
>>= fun h -> >>= fun h ->
( match h with ( match h with
| `Handled -> () | `Handled -> ()
@ -1805,6 +1756,9 @@ module Panel = struct
ev ev
>|= fun () -> Draw.pane r ) >|= fun () -> Draw.pane r )
let new_cursor (root : node) : cursor =
{root; sel=root}
let test = let test =
panel panel
(Lwd.pure (Lwd.pure
@ -1813,7 +1767,7 @@ module Panel = struct
(join_y (join_y
(join_y (join_y
(Text.of_string (Text.of_string
"-- welcome to the land of idiots ---" ) "-- welcome to my land of idiocy ---" )
(join_x (join_x
(Text.of_string "hello bitch") (Text.of_string "hello bitch")
(Text.of_string "!\n sup dude") ) ) (Text.of_string "!\n sup dude") ) )