This commit is contained in:
cqc
2022-10-04 23:36:25 -05:00
parent 65aa7ff901
commit fec4249d9f
2 changed files with 307 additions and 255 deletions

4
dune
View File

@ -13,8 +13,8 @@
graphv_webgl graphv_webgl
js_of_ocaml js_of_ocaml
lwt lwt
; irmin-git irmin
; irmin-indexeddb irmin-git
zed zed
gg gg

516
human.ml
View File

@ -1,5 +1,14 @@
(* (*
describe exactly every case you can think of that you want this drawing and layout system to handle:
* draw text on variously coloured backgrounds that can be defined locally or globally
* TODO
*)
(*
ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!! ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2 Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2
@ -20,18 +29,26 @@ some options:
*) *)
open Lwt.Infix
module F = Fmt module F = Fmt
module NVG = Graphv_webgl module NVG = Graphv_webgl
(* module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)*) module Nav = struct
(*module Istore = open Lwt.Infix
Irmin_git.Generic
(Irmin_indexeddb.Content_store) module S = Irmin_mem.KV.Make(Irmin.Contents.String)
(Irmin_indexeddb.Branch_store)
(Irmin.Contents.String) type t = S.tree
(Irmin.Path.String_list)
(Irmin.Branch.String)*) let init () : t Lwt.t =
S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
let test_populate () : t Lwt.t =
let add p s t = S.Tree.add t p s in
add ["hello"] "world" (S.Tree.empty ()) >>=
add ["hello";"daddy"] "ily" >>=
add ["beep";"beep"] "motherfucker"
end
module Key = struct module Key = struct
type special = type special =
@ -325,11 +342,9 @@ module Event_js = struct
| None -> `Unknown "keypress .key is None?" | None -> `Unknown "keypress .key is None?"
end end
module Display = struct module Panel = struct
open Gg open Gg
module I = NVG.Image open NVG
module P = NVG.Path
module Color = NVG.Color
(* current window state to be passed to window renderer *) (* current window state to be passed to window renderer *)
type state = type state =
@ -380,45 +395,6 @@ module Display = struct
NVG.stroke vg ; NVG.stroke vg ;
Box2.max b Box2.max b
(* Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
This way basic widgets will just expand to the full area of a box, while other widgets can have
the express purpose of limiting the size of an object in a larger system of limitations.
Panes return a tuple: (state, (box, image))
state is the updated state, where state.box is always
- the top left corner of the box the pane drew in, and
- the bottom right corner of the state.box that was passed in
box is the area the widget actually drew in (or wants to sort of "use")
image is the Wall.image to compose with other panes and draw to the display
*)
end
module Panel = struct
open Gg
open NVG
type t =
{ mutable act: t -> Event.events -> Display.pane Lwt.t
; mutable subpanels: t Lwt.t list
; mutable tag: string }
type panel = t
let blank =
{ act= (fun _panel _events -> Lwt.return Display.pane_empty)
; subpanels= []
; tag= "blank pane" }
let draw (pane : Display.pane) =
Lwt.return
{ act= (fun _panel _events -> Lwt.return pane)
; subpanels= []
; tag= "draw-pane" }
let actor (panel : t) : Event.events -> Display.pane Lwt.t =
fun events ->
panel.act panel events >>= fun pane -> Lwt.return pane
module Style = struct module Style = struct
module Font = struct module Font = struct
type t = type t =
@ -531,6 +507,8 @@ module Panel = struct
; b= Gg.Size1.zero ; b= Gg.Size1.zero
; l= Gg.Size1.zero ; l= Gg.Size1.zero
; r= Gg.Size1.zero } ; r= Gg.Size1.zero }
let all v = {t= v; b= v; l= v; r= v}
end end
module Ui = struct module Ui = struct
@ -546,7 +524,8 @@ module Panel = struct
| `Attr of attr * node | `Attr of attr * node
| `Join of dir * node * node ] | `Join of dir * node * node ]
and node = {mutable parent: node option; mutable t: t; n: int} 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} and cursor = {root: node; mutable sel: node}
and atom = and atom =
@ -556,12 +535,19 @@ module Panel = struct
| `Hint of [`Line | `Other] | `Hint of [`Line | `Other]
| `Empty ] | `Empty ]
and attr = [`Style of style | `Pad of Pad.t | `Handler of handler] and attr =
[ `Style of style
| `Pad of Pad.t
| `Handler of handler
| `Draw of draw ]
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 = node -> Event.t -> Event.t option and handler = node -> Event.t -> Event.t option
and draw_context = {vg: NVG.t; style: Style.t}
and draw = draw_context -> P2.t -> P2.t
let node_count = ref 0 let node_count = ref 0
@ -572,10 +558,10 @@ module Panel = struct
let set_parent_on_children n : node = let set_parent_on_children n : node =
( match n.t with ( match n.t with
| `Atom _ -> () | `Atom _ -> ()
| `Attr (_, a) -> a.parent <- Some n | `Attr (_, a) -> a.parent <- `Left n
| `Join (_, a, b) -> | `Join (_, a, b) ->
a.parent <- Some n ; a.parent <- `Left n ;
b.parent <- Some n ) ; b.parent <- `Right n ) ;
n n
let sub (n : node) : node = let sub (n : node) : node =
@ -585,23 +571,28 @@ module Panel = struct
| `Join (_, a, _) -> a | `Join (_, a, _) -> a
let super (n : node) : node = let super (n : node) : node =
match n.parent with Some n' -> n' | None -> n match n.parent with `Left n' | `Right n' -> n' | `None -> n
let set_children_on_parent ~oldc ~newc = let set_children_on_parent n =
match newc.parent with match n.parent with
| Some ({t= `Attr (a, _); _} as s) -> | `Left ({t= `Attr (a, _); _} as s)
s.t <- `Attr (a, newc) ; |`Right ({t= `Attr (a, _); _} as s) ->
newc s.t <- `Attr (a, n) ;
| Some ({t= `Join (d, a, b); _} as s) when oldc == a -> n
s.t <- `Join (d, newc, b) ; | `Left ({t= `Join (d, _, b); _} as s) ->
newc s.t <- `Join (d, n, b) ;
| Some ({t= `Join (d, a, b); _} as s) when oldc == b -> n
s.t <- `Join (d, a, newc) ; | `Right ({t= `Join (d, a, _); _} as s) ->
newc s.t <- `Join (d, a, n) ;
| _ -> newc n
| _ -> n
let option_of_parent = function
| `None -> None
| `Left a | `Right a -> Some a
let node (t : t) = let node (t : t) =
set_parent_on_children {parent= None; t; n= node_n ()} set_parent_on_children {parent= `None; t; n= node_n ()}
let atom (a : atom) = node (`Atom a) let atom (a : atom) = node (`Atom a)
let attr (a : attr) (child : node) = node (`Attr (a, child)) let attr (a : attr) (child : node) = node (`Attr (a, child))
@ -609,6 +600,159 @@ module Panel = struct
let empty_image = V2.zero let empty_image = V2.zero
let empty_node () = node (`Atom `Empty) let empty_node () = node (`Atom `Empty)
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 pad v n = attr (`Pad (Pad.all v)) 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 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 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 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
| {t= `Atom (`Uchar _); _} as n -> Some n
| _ -> None
let tree_uchar_fwd n =
Option.value (search_forward is_atom_uchar n) ~default:n
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)
|`Phrase, `Atom (`Boundary `Phrase)
|`Line, `Atom (`Boundary `Line)
|`Page, `Atom (`Boundary `Page) ->
Some n
| _ -> 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_y = join `Y
let join_z = join `Z
let ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_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 module Pp = struct
let pp_uchar ppf v = let pp_uchar ppf v =
@ -650,7 +794,8 @@ module Panel = struct
| `Pad _ -> "`Pad ..." | `Pad _ -> "`Pad ..."
| `Shift _ -> "`Shift ..." | `Shift _ -> "`Shift ..."
| `Cursor -> "`Cursor" | `Cursor -> "`Cursor"
| `Handler _ -> "`Handler ..." ) ) | `Handler _ -> "`Handler ..."
| `Draw _ -> "`Draw ..." ) )
ppf () ppf ()
let pp_dir ppf v = let pp_dir ppf v =
@ -674,6 +819,13 @@ module Panel = struct
++ const child b ) ) ++ 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 = and _pp_node child ppf v =
let open Fmt in let open Fmt in
pf ppf "@[<hov>%a@]" pf ppf "@[<hov>%a@]"
@ -681,9 +833,7 @@ module Panel = struct
(record (record
[ field "n" (fun v -> v.n) int [ field "n" (fun v -> v.n) int
; field "t" (fun v -> v.t) (_pp_t child) ; field "t" (fun v -> v.t) (_pp_t child)
; field "parent" ; field "parent" (fun v -> v.parent) _pp_parent ] ) )
(fun v -> v.parent)
(option pp_node_n) ] ) )
v v
and pp_node_n_record = and pp_node_n_record =
@ -716,58 +866,6 @@ module Panel = struct
open Pp open Pp
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_r (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 ~oldc:n ~newc: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 ~oldc:n ~newc:n'
let remove_attr (n : node) : node =
match n.t with
| `Attr (_, n') ->
( match n.parent with
| Some p ->
p.t <-
( match p.t with
| `Attr (a, _) -> `Attr (a, n')
| `Join (d, a, b) when n == a -> `Join (d, n', b)
| `Join (d, a, b) when n == b -> `Join (d, a, n')
| _ -> assert false ) ;
ignore (set_parent_on_children p)
| None -> () ) ;
n'
| _ -> assert false
let join_x = join `X
let join_y = join `Y
let join_z = join `Z
let ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_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 Text = struct 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] =
@ -821,7 +919,7 @@ module Panel = struct
open NVG open NVG
type d = [`X | `Y | `Z] type d = [`X | `Y | `Z]
type t = {vg: NVG.t; style: Style.t} type t = draw_context
let vcat d a b = let vcat d a b =
match d with match d with
@ -855,7 +953,7 @@ module Panel = struct
( 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 : P2.t = let rec atom vg b (a : atom) : P2.t =
let vg = vg.vg in let vg = vg.vg in
match a with match a with
| `Image image -> | `Image image ->
@ -877,15 +975,16 @@ module Panel = struct
and attr t b ((a : attr), n) : P2.t = and attr t b ((a : attr), n) : P2.t =
match a with match a with
| `Style s -> | `Style s ->
Display.fill_box t.vg s.bg path_box t.vg s.bg
(Box2.of_pts b (Box2.of_pts b
(node {t with style= Style.merge t.style s} b n) ) (node {t with style= Style.merge t.style s} b n) )
| `Pad p -> pad t b p n | `Pad p -> pad t b p n
| _ -> node t b n | `Draw d -> d t b
| `Handler _ -> node t b n
and pad vg t (p : Pad.t) 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 let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in
P2.(v (x nv +. p.r) (y t +. p.b)) P2.(v (x nv +. p.r) (y nv +. p.b))
and join vg t (d, a, b) : P2.t = and join vg t (d, a, b) : P2.t =
let av = node vg t a in let av = node vg t a in
@ -985,80 +1084,7 @@ module Panel = struct
ppf () ppf ()
end end
let tree_next (n : node) =
let rec next_right n' =
match n'.parent with
| None -> None
| Some ({t= `Attr _; _} as p) -> next_right p
| Some {t= `Join (_, a, b); _} when n' == a -> Some b
| Some ({t= `Join (_, _, b); _} as p) when n' == b ->
next_right p
| Some {t= `Join _; _} -> assert false
| Some {t= `Atom _; _} -> assert false in
match n.t with
| `Atom _ -> next_right n
| `Attr (_, n') -> Some n'
| `Join (_, a, _) -> Some a
let tree_prev (n : node) =
let rec prev_right n' =
match n'.t with
| `Attr (_, nn) -> prev_right nn
| `Join (_, _, b) -> prev_right b
| `Atom _ -> Some n' in
match n.parent with
| None -> None
| Some {t= `Atom _; _} ->
assert false
(* shouldn't happen TODO is there no way to type constrain these? *)
| Some {t= `Attr _; _} -> n.parent
| Some {t= `Join (_, a, b); _} when b == n -> prev_right a
| Some {t= `Join (_, a, _); _} when a == n -> n.parent
| Some {t= `Join _; _} -> assert false
(* shouldn't happen *)
let rec tree_iter f n i =
if i <> 0 then tree_iter f (f n) (i - 1) else f n
let rec search_ next f n =
(* F.epr "search_ " ; *)
match next n with
| Some n' -> (
(* F.epr "%a@." pp_n n' ; *)
match f n' with
| Some a -> (n', Some a)
| None -> search_ next f n' )
| None -> (*F.epr "None@." ; *) (n, None)
let search_forward f (n : node) = snd (search_ tree_next f n)
let search_backward f (n : node) = snd (search_ tree_prev f n)
let is_atom_uchar = function
| {t= `Atom (`Uchar _); _} as n -> Some n
| _ -> None
let tree_uchar_fwd n =
match is_atom_uchar n with
| Some a -> a
| None ->
Option.value (search_forward is_atom_uchar n) ~default:n
let tree_uchar_back n =
match is_atom_uchar n with
| Some a -> a
| None ->
Option.value (search_backward is_atom_uchar n) ~default:n
let perform_action (a : Action.t) (c : cursor) : node option = let perform_action (a : Action.t) (c : cursor) : node option =
let mb ?(f = fun a -> a) 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 (f n)
| _ -> None in
match a with match a with
| `Move (`Forward `Line) -> ( | `Move (`Forward `Line) -> (
let i = ref 0 in let i = ref 0 in
@ -1069,13 +1095,13 @@ module Panel = struct
| {t= `Atom (`Uchar _); _} -> incr i ; None | {t= `Atom (`Uchar _); _} -> incr i ; None
| _ -> None ) | _ -> None )
c.sel ) ; c.sel ) ;
match search_forward (mb `Line) c.sel with match search_forward (is_boundary `Line) c.sel with
| Some n' -> | Some n' ->
Some Some
(tree_iter (tree_iter
(fun nn -> (fun nn ->
Option.value Option.value
(search_forward (mb `Char) nn) (search_forward (is_boundary `Char) nn)
~default:nn ) ~default:nn )
n' !i ) n' !i )
| None -> None ) | None -> None )
@ -1090,34 +1116,32 @@ module Panel = struct
c.sel c.sel
with with
| Some n' -> | Some n' ->
Some Option.map
(tree_iter (fun n -> tree_iter tree_uchar_back n !i)
(fun nn -> (search_backward (is_boundary `Line) n')
Option.value
(search_forward (mb `Char) nn)
~default:nn )
(fst (search_ tree_prev (mb `Line) n'))
!i )
| None -> None ) | None -> None )
| `Move (`Forward b) -> | `Move (`Forward b) ->
search_forward (mb ~f:tree_uchar_back b) c.sel Option.map tree_uchar_fwd
| `Move (`Backward b) -> (search_forward (is_boundary b) c.sel)
search_backward (mb ~f:tree_uchar_fwd b) c.sel
| `Move (`Beginning b) ->
(* uses last searched node regardless of match *)
Some (tree_uchar_fwd (fst (search_ tree_prev (mb b) c.sel)))
| `Move (`End b) -> | `Move (`End b) ->
(* uses last searched node regardless of match *) Option.map tree_uchar_back
Some (search_forward (is_boundary b) c.sel)
(tree_uchar_back (fst (search_ tree_next (mb 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 -> | `Insert n ->
ignore (insert_join_r `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 (`Backward `Char) -> kill_backward_char c.sel
| `Kill _s -> None | `Kill _s -> None
| `Descend -> Some (sub c.sel) | `Descend -> Some (sub c.sel)
| `Ascend -> c.sel.parent | `Ascend -> option_of_parent c.sel.parent
| `Custom _s -> None | `Custom _s -> None
type event_status = [`Handled | `Event of Event.t] type event_status = [`Handled | `Event of Event.t]
@ -1146,6 +1170,8 @@ module Panel = struct
|> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)] |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)]
|> add [([Ctrl], C 'e')] [`Move (`End `Line)] |> add [([Ctrl], C 'e')] [`Move (`End `Line)]
|> add [([Ctrl], C 'k')] [`Kill (`End `Line)] |> add [([Ctrl], C 'k')] [`Kill (`End `Line)]
|> add [([], U `Backspace)] [`Kill (`Backward `Char)]
|> add [([], U `Delete)] [`Kill (`Forward `Char)]
|> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)] |> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)]
|> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)] |> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
|> add |> add
@ -1157,6 +1183,25 @@ 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 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)
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 textedit ?(bindings = textedit_bindings) (n : node) = let textedit ?(bindings = textedit_bindings) (n : node) =
Format.pp_set_max_boxes F.stderr 64 ; Format.pp_set_max_boxes F.stderr 64 ;
(*full screen fynn *) (*full screen fynn *)
@ -1178,6 +1223,7 @@ module Panel = struct
| `Uchar c -> Some (`Insert (atom (`Uchar c))) | `Uchar c -> Some (`Insert (atom (`Uchar c)))
| _ -> None ) | _ -> None )
| _ -> None ) in | _ -> None ) in
let r =
match a with match a with
| Some x -> | Some x ->
c.sel <- remove_attr c.sel ; c.sel <- remove_attr c.sel ;
@ -1190,11 +1236,14 @@ module Panel = struct
F.epr "textedit action @[%a@] Failure@." F.epr "textedit action @[%a@] Failure@."
Action.pp_t x ) ; Action.pp_t x ) ;
c.sel <- insert_attr cursor_attr c.sel ; c.sel <- insert_attr cursor_attr c.sel ;
F.epr "tree: @[%a@]@." Pp.pp_node_structure c.root ;
None None
| None -> None ) | None -> None in
r )
, n ) ; , n ) ;
set_parent_on_children c.root join_y (pad 5. c.root)
(join_y
(pad 5. (draw_cursor_sel c))
(pad 5. (draw_cursor_root c)) )
let handler_of_node (n : node) : handler option = let handler_of_node (n : node) : handler option =
let f n = let f n =
@ -1217,14 +1266,15 @@ module Panel = struct
Draw.node {vg; style= Style.dark} p t Draw.node {vg; style= Style.dark} p t
let test = let test =
textedit style Style.dark
(style Style.dark (pad 20.
(textedit
Text.( Text.(
(* text "--- welcome to my land of idiocy ---" (* text "--- welcome to my land of idiocy ---"
^/^ *) ^/^ *)
text "hello bitch" text "hello bitch"
(*^^ text "! sup daddy" ^^ nl) (*^^ text "! sup daddy" ^^ nl)
^/^ lines "123")*)) ) ^/^ lines "123")*)) ) )
end end
end end
@ -1256,3 +1306,5 @@ end
If the Irmin Tree is better implemented than the garbage i am trying to make ad hoc, (i.e. we can implement all our cursor movement and editing mechanisms with the Irmin.Tree interface easily, then yea lol) If the Irmin Tree is better implemented than the garbage i am trying to make ad hoc, (i.e. we can implement all our cursor movement and editing mechanisms with the Irmin.Tree interface easily, then yea lol)
*) *)
(* would be nice to be able to switch arbitrary nodes between their drawn representation and the sort of node structure representation. This might be a more general philsophy to apply to the entire system, where you want to be able to switch between representations (i.e. "view-source" but with further higher level analysis views built on top as well *)