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

working on cursor contro

Browse Source
This commit is contained in:
cqc
2022-02-13 16:28:58 -06:00
parent a82c9464f4
commit ecf9983728
2 changed files with 242 additions and 313 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
dune
View File

@ -18,7 +18,6 @@
nottui nottui
nottui-pretty nottui-pretty
uuseg.string uuseg.string
grenier.trope
uutf uutf
uucp uucp
ocaml-compiler-libs.common ocaml-compiler-libs.common

484
human.ml
View File

@ -1236,109 +1236,20 @@ module Panel = struct
; r= Gg.Size1.zero } ; r= Gg.Size1.zero }
end end
module Region = struct
type 'a t =
{t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor}
and 'a region = 'a t
type cursor = Trope.cursor
let create () =
let t = Trope.create () in
let left = Trope.cursor_at_origin t in
{t; left; right= left}
let append (t : 'a region) (e : 'a) : 'a region =
let right = Trope.cursor_after t.right in
{t with t= Trope.put_right t.t right e; right}
let rec iter ~t ?(start = t.left) ~(f : 'a -> unit) () =
match Trope.seek_after t.t start with
| Some (c, e) -> f e ; iter ~start:c ~t ~f ()
| None -> ()
let rec trope_replace ~(t : 'a region) ?(start = t.left)
~(f :
'a Trope.t * Trope.cursor
-> 'a
-> 'a Trope.t * Trope.cursor ) () : 'a region =
match Trope.seek_after t.t start with
| Some (c, e) ->
let t', c' = f (t.t, c) e in
trope_replace
~t:
{ t with
t= t'
; right=
( if Trope.compare t.right c' < 0 then c'
else t.right ) }
~start:c' ~f ()
| None -> t
let rec replace ~(r : 'a region) ?(start = r.left)
~(f : 'a t * cursor -> 'a -> 'a t * cursor) () : 'a region =
match Trope.seek_after r.t start with
| Some (c, e) ->
let r', c' = f (r, c) e in
replace
~r:
{ r' with
right=
( if Trope.compare r.right c' < 0 then c'
else r.right ) }
~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 =
match Trope.seek_after t.t start with
| Some (c, e) -> fold ~t ~start:c ~f (f (t.t, c) e acc)
| None -> acc
let rec fold_lwt ~(t : 'a region) ?(start = t.left)
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b Lwt.t)
(acc : 'b) : 'b Lwt.t =
match Trope.seek_after t.t start with
| Some (c, e) ->
f (t.t, c) e acc >>= fun x -> fold_lwt ~t ~start:c ~f x
| None -> Lwt.return acc
let rec fold_lwt_opt ~(t : 'a region) ?(start = t.left)
~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b option Lwt.t)
(acc : 'b) : 'b Lwt.t =
match Trope.seek_after t.t start with
| Some (c, e) -> (
f (t.t, c) e acc
>>= function
| 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 module Ui = struct
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. (* 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 *) (* i think this is gonna end up being a binary tree?? *)
open Gg open Gg
open Wall open Wall
type t = type t =
[`Atom of atom | `Attr of attr * node | `Region of dir * region] [ `Atom of atom
| `Attr of attr * node
| `Join of dir * node * node ]
and node = {mutable parent: [`Node of node | `Region of node * Region.cursor]; mutable child: t} and node = {mutable parent: node option; mutable t: t}
and cursor = {root: node; and cursor = {root: node; mutable sel: node}
mutable sel: node option;
}
and atom = and atom =
[ `Image of image [ `Image of image
@ -1349,123 +1260,135 @@ module Panel = struct
[ `Style of style [ `Style of style
| `Pad of Pad.t | `Pad of Pad.t
| `Shift of dim | `Shift of dim
| `Handle of handle ] | `Cursor
| `Handler of handler ]
and region = node Region.t and dim = Size2.t
and dir = [`X | `Y | `Z] and image = Wall.image * dim
and image = Wall.image * Size2.t
and dim = Gg.size2
and style = Style.t and style = Style.t
and handle = node -> Event.t -> Event.t option Lwt.t and handler = node -> Event.t -> Event.t option Lwt.t
and dir = [`X | `Y | `Z]
let empty_image = (Image.empty, V2.zero) let set_parent_on_children n : node =
( match n.t with
let empty_node =
let rec parent = `Atom (`Image empty_image) in
parent
let empty_region dir : t = `Region (dir, Region.create ())
let set_parent_on_children parent =
match parent.child with
| `Atom _ -> () | `Atom _ -> ()
| `Attr (_, n) -> n.parent <- `Node parent | `Attr (_, a) -> a.parent <- Some n
| `Region (_, r) -> | `Join (_, a, b) ->
Region.fold ~t:r ~f:(fun (_, c) n a -> n.parent <- `Region (parent, c); a) () a.parent <- Some n ;
b.parent <- Some n ) ;
let node (child : t) = n
let rec parent = {parent=`Node parent; child} in
set_parent_on_children parent ;
parent
let node (t : t) = set_parent_on_children {parent= None; t}
let empty_image = (Image.empty, V2.zero)
let empty_node = node (`Atom (`Image empty_image))
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 node_func ?(fnode = fun (x : node) -> x) let rec traverse_nodes ~(f : node -> node option) (n : node) :
?(fregion = fun (x : node Region.t) -> x) unit =
?(fatom = fun (x : atom) -> x) n : node = match f n with
n.child <- | Some {t= `Atom _; _} -> ()
( match n.child with | Some {t= `Attr (_, n'); _} -> traverse_nodes ~f n'
| `Attr (a, n) -> `Attr (a, {(fnode n) with parent=`Node n}) | Some {t= `Join (_, a, b); _} ->
| `Region (a, r) -> `Region (a, fregion r) traverse_nodes ~f a ; traverse_nodes ~f b
| `Atom a -> `Atom (fatom a) ) ; | None -> ()
n
let rec traverse_nodes ~(f : node -> node) (n : node) : node = let insert_attr (a : attr) (n : node) : node =
node_func let p = n.parent in
~fnode:(fun n -> traverse_nodes ~f (f n)) let n' = node (`Attr (a, n)) in
~fregion:(fun r -> n'.parent <- p ;
Region.replace ~r ( match p with
~f:(fun (r, c) e -> | Some p ->
( { r with p.t <-
t= ( match p.t with
Trope.put_right r.t c | `Attr (a, _) -> `Attr (a, n')
{(traverse_nodes ~f e) with parent= `Region (n, c)} } | `Join (d, a, b) when n == a -> `Join (d, n', b)
, c ) ) | `Join (d, a, b) when n == b -> `Join (d, a, n')
() ) | _ -> assert false )
n | None -> () ) ;
n'
let rec traverse_regions let remove_attr (n : node) : node =
~(region : match n.t with
parent:node | `Attr (_, n') ->
-> node Region.t * Region.cursor ( match n.parent with
-> child:node | Some p ->
-> node Region.t * Region.cursor ) ~(node : node -> node) p.t <-
(parent : node) : node = ( match p.t with
node_func | `Attr (a, _) -> `Attr (a, n')
~fnode:(fun n -> traverse_regions ~region ~node (node n)) | `Join (d, a, b) when n == a -> `Join (d, n', b)
~fregion:(fun r -> | `Join (d, a, b) when n == b -> `Join (d, a, n')
Region.replace ~r | _ -> assert false )
~f:(fun (r, c) child -> region ~parent (r, c) ~child) | None -> () ) ;
() ) n'
parent | _ -> assert false
let region_append (r : node) (c : t) : node = let sub (n : node) : node =
match r.child with match n.t with
`Atom _ | `Attr _ -> assert false | `Atom _ -> n
| `Region (d, r') -> | `Attr (_, n) -> n
let right = Trope.cursor_after r'.right in | `Join (_, a, _) -> a
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 join_ d (a : node) (b : node) =
let rec parent = set_parent_on_children {parent= a.parent; t= `Join (d, a, b)}
{ parent= `Node parent
; child=
`Region
(d, Region.append (Region.append (Region.create ()) a) b)
} in
set_parent_on_children parent ;
parent
let empty_join d = node (`Join (d, empty_node, empty_node))
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_join `X, join_x)
let pack_x : node Lwd_utils.monoid = let pack_y : node Lwd_utils.monoid = (empty_join `Y, join_y)
(node (empty_region `X), join_x) let pack_z : node Lwd_utils.monoid = (empty_join `Z, join_z)
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
let rec pp_ui : node F.t =
fun ppf v ->
let atom a =
F.pf ppf "`Atom " ;
match a with
| `Image _ -> F.pf ppf "`Image"
| `Uchar c ->
F.pf ppf "`Uchar " ;
if Uchar.is_char c then F.pf ppf "%c" (Uchar.to_char c)
else F.pf ppf "0x%x" (Uchar.to_int c)
| `Boundary b ->
F.pf ppf "`Boundary " ;
F.pf ppf
( match b with
| `Word -> "`Word"
| `Line -> "`Line"
| `Sentance -> "`Sentance"
| `Hint -> "`Hint" ) in
let attr a =
F.pf ppf "`Attr " ;
F.pf ppf
( match a with
| `Style _ -> "`Style ..., "
| `Pad _ -> "`Pad ..., "
| `Shift _ -> "`Shift ..., "
| `Cursor -> "`Cursor "
| `Handler _ -> "`Handler ..., " ) in
let join (d, a, b) =
F.pf ppf "`Join " ;
( match d with
| `X -> F.pf ppf "`X "
| `Y -> F.pf ppf "`Y "
| `Z -> F.pf ppf "`Z " ) ;
F.parens pp_ui ppf b ; F.parens pp_ui ppf a in
match v.t with
| `Join x -> join x
| `Attr (x, n) -> attr x ; F.parens pp_ui ppf n
| `Atom x -> atom x
module Text = struct module Text = struct
let rec _of_string ~(ry : node) (str : string) : node = let rec insert_string (n : node) (str : string) : node =
let uudec = Uutf.decoder (`String str) in let uudec = Uutf.decoder (`String str) in
let rec dec (rx' : node Region.t) : 'a * node Region.t = let rec dec (n' : node) : 'a * node =
match Uutf.decode uudec with match Uutf.decode uudec with
| `Malformed b -> | `Malformed b -> dec (insert_string n' (String.escaped b))
dec | (`Await | `Uchar _ | `End) as x -> (x, n') in
(Region.append rx'
(_of_string ~ry:(node (empty_region `Y))
(String.escaped b) ) )
| (`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 (ry' : node) : node = let rec line (n' : node) : node =
let rec char (x, t) (line : node) = 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)
@ -1474,27 +1397,16 @@ module Panel = struct
| `Boundary -> | `Boundary ->
char char
(`Await, t) (`Await, t)
(region_append line (`Atom (`Boundary `Hint))) (line ^^ node (`Atom (`Boundary `Hint)))
| `Uchar c -> | `Uchar c ->
char char (`Await, t) (line ^^ node (`Atom (`Uchar c)))
(`Await, t) in
(region_append line (`Atom (`Uchar c) )) in match char (`Await, n') n' with
match | l, `Boundary -> line (l ^/^ node (`Atom (`Boundary `Line)))
char | l, `End -> l in
(`Await, rl) line n
(node (empty_region `X))
with
| l, `Boundary ->
line (region_append ry' (`Atom (`Boundary `Line) ))
| l, `End ->
region_append ry' l in
parent.child <- `Region (`Y, line rl) ;
parent
let of_string ?(ry = (empty_region `Y)) (str : string) = (* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
_of_string ~ry str
let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node = node =
let uuseg = Uuseg.create boundary in let uuseg = Uuseg.create boundary in
traverse_regions traverse_regions
@ -1529,14 +1441,23 @@ module Panel = struct
let sentances node : node = let sentances node : node =
segment ~boundary:`Sentence ~label:`Sentance node segment ~boundary:`Sentence ~label:`Sentance node
let text str : node = of_string str |> sentances |> words let text str : node = insert_string str |> sentances |> words *)
end end
let text = Text.text let text = Text.insert_string
module Draw = struct module Draw = struct
type d = [`X | `Y | `Z] type d = [`X | `Y | `Z]
let cursor ((i, v) : image) =
( I.stack
(I.paint (Paint.color Color.red)
( I.stroke_path (Outline.make ())
@@ fun t ->
P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) )
i
, v )
let vcat d a b = let vcat d a b =
match d with match d with
| `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b)) | `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b))
@ -1604,18 +1525,17 @@ module Panel = struct
| `Style s -> pane ~style:(Style.merge s style) node | `Style s -> pane ~style:(Style.merge s style) node
| `Pad p -> pad p (pane ~style node) | `Pad p -> pad p (pane ~style node)
| `Shift s -> shift s (pane ~style node) | `Shift s -> shift s (pane ~style node)
| `Cursor -> cursor (pane ~style node)
| _ -> pane ~style node | _ -> pane ~style node
and region ?(style = Style.empty) (dir, region) : image = and join ?(style = Style.empty) (d, a, b) : image =
Region.fold ~t:region cat d (pane ~style a) (pane ~style b)
~f:(fun _ n i -> cat dir i (pane ~style n))
empty_image
and pane ?(style = Style.empty) (node : node) : image = and pane ?(style = Style.empty) (node : node) : image =
match node.child with match node.t with
| `Atom a -> atom ~style a | `Atom a -> atom ~style a
| `Attr a -> attr ~style a | `Attr a -> attr ~style a
| `Region a -> region ~style a | `Join a -> join ~style a
end end
module Action = struct module Action = struct
@ -1632,6 +1552,8 @@ module Panel = struct
[ `Move of segment [ `Move of segment
| `Yank of segment | `Yank of segment
| `Kill of segment | `Kill of segment
| `Ascend
| `Descend
| `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ] | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
type dir = type dir =
@ -1647,54 +1569,44 @@ module Panel = struct
| `Out ] | `Out ]
end end
let rec search_backward (n : node) (f : node -> 'a option) : 'a option = let rec search_forward (n : node) (f : node -> 'a option) :
'a option =
match f n with match f n with
| None -> | None -> (
(match n.parent.child with match n.t with
| a when n = a -> None (* at root and didn't find anything *) | `Atom _ -> None
| (`Atom _) | (`Attr _) -> search_backward node.parent f | `Attr (_, n) -> search_forward n f
| (`Region (d, r)) -> ( | `Join (_, a, b) -> (
match Region.seek_before ~r with match search_forward a f with
| Some r' -> | Some n' -> Some n'
search_backward {node with child= `Region (d, r')} t | None -> search_forward b f ) )
| None -> search_backward node.parent t ) | Some a -> Some a
let rec search_backward (n : node) (f : node -> 'a option) :
'a option =
match f n with
| None -> (
match n.parent with
| None -> None (* at root and didn't find anything *)
| Some n -> search_backward n f )
| Some n' -> Some n' | Some n' -> Some n'
let perform_action (a : Action.t) (c : node) : node =
let handle_action (a : Action.t) (c : node) : node option =
match a with match a with
| `Move (`Beginning `Char) -> c | `Move (`Beginning `Char) -> c
| `Move (`Beginning `Word) -> | `Move (`Beginning `Word) ->
search_backward c (fun n -> match n.child with `Atom (`Boundary `Word) -> n | None -> None) Option.value ~default:c
(search_backward c (fun n ->
match n.t with
| `Atom (`Boundary `Word) -> Some n
| _ -> None ) )
| `Move _ -> c | `Move _ -> c
| `Yank _s -> c | `Yank _s -> c
| `Kill _s -> c | `Kill _s -> c
| `Descend -> sub c
| `Ascend -> ( match c.parent with Some n -> n | None -> c )
| `Custom _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
| `Handled -> Lwt.return None
| x -> Lwt.return (Some x) )
| `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] type event_status = [`Handled | `Event of Event.t]
let textedit_bindings = let textedit_bindings =
@ -1720,58 +1632,76 @@ module Panel = struct
|> add |> add
[([Ctrl], C 'x'); ([], U `Backspace)] [([Ctrl], C 'x'); ([], U `Backspace)]
[`Kill (`Back `Phrase)] [`Kill (`Back `Phrase)]
|> add [([Ctrl], C 'q')] [`Ascend]
|> add [([Ctrl], C 'e')] [`Descend]
let textedit_handler ?(bindings = textedit_bindings) (n : node) = let textedit_handler ?(bindings = textedit_bindings) (n : node) =
let bind = Key.Bind.init bindings in let bind = Key.Bind.init bindings in
let n' = insert_attr `Cursor n in
let c = ref n in let c = ref n in
`Handler ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t -> F.epr "%a@." pp_ui n' ;
node
(`Attr
( `Handler
(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 :: _ -> handle_event x n c | x :: _ ->
c :=
insert_attr `Cursor
(perform_action x (remove_attr !c)) ;
F.epr "%a@." pp_ui !c ;
Lwt.return_none
| [] -> Lwt.return_some e ) | [] -> Lwt.return_some e )
, Focus.make () ) , n ) )
let rec handle_event (n : cursor) (ev : Event.t) : let handler_of_node (n : node) : handler option =
event_status Lwt.t = search_forward n (fun n ->
match n.sel.child with match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
| Some a ->
c := handle_action a !c ; let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
Lwt.return `Handled match handler_of_node n with
| None -> `Event ev | Some f -> (
f n ev
>>= function
| Some ev -> Lwt.return (`Event ev)
| None -> Lwt.return `Handled )
| None -> Lwt.return (`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
let root = Lwd.observe t in let root = Lwd.observe t in
Lwt.return (fun ev -> Lwt.return (fun ev ->
let r = Lwd.sample rq root in let r = Lwd.sample rq root in
(* F.epr "Draw.pane: %a@." pp_ui r ; *)
Lwt_list.iter_s Lwt_list.iter_s
(fun e -> (fun e ->
handle_event r e c handle_event r e
>>= fun h -> >>= fun h ->
( match h with ( match h with
| `Handled -> () | `Handled -> F.epr "Handled %s@." (Event.to_string e)
| `Event e -> | `Event _e ->
F.epr "handle_event: Unhandled event: %s@." (* F.epr "Unhandled event: %s@."
(Event.to_string e) ) ; (Event.to_string _e)*)
() ) ;
Lwt.return_unit ) Lwt.return_unit )
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
(textedit_handler (textedit_handler
(style Style.dark (style Style.dark
(*(join_y
(join_y (join_y
(join_y (Text.insert_string empty_node
(Text.of_string
"-- welcome to my land of idiocy ---" ) "-- welcome to my land of idiocy ---" )
(join_x (join_x
(Text.of_string "hello bitch") (Text.insert_string empty_node "hello bitch")
(Text.of_string "!\n sup dude") ) ) (Text.insert_string empty_node
(Text.of_string "test 1 2 3 4 5 6") ) ) ) ) "!\n sup daddy" ) ) )*)
(Text.insert_string empty_node "test 1 2 3") ) ) )
(* ) *)
end end
end end