character insertion
This commit is contained in:
cqc
127
human.ml
127
human.ml
@ -361,16 +361,14 @@ module Display = struct
|
||||
(Box2.oy b) (Box2.maxx b) (Box2.maxy b)
|
||||
|
||||
let fill_box vg color b =
|
||||
let module Path = NVG.Path in
|
||||
let open NVG in
|
||||
Path.begin_ vg ;
|
||||
Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
|
||||
~h:(Box2.h b) ;
|
||||
set_fill_color vg ~color ;
|
||||
fill vg
|
||||
|
||||
let draw_filled_box c (s : state) =
|
||||
fill_box s.renderer c s.box ;
|
||||
(s, s.box)
|
||||
fill vg ;
|
||||
Box2.max b
|
||||
|
||||
let path_box vg color ?(width = 0.) b =
|
||||
let module Path = NVG.Path in
|
||||
@ -565,6 +563,12 @@ module Panel = struct
|
||||
and style = Style.t
|
||||
and handler = node -> Event.t -> Event.t option
|
||||
|
||||
let node_count = ref 0
|
||||
|
||||
let node_n () =
|
||||
node_count := !node_count + 1 ;
|
||||
!node_count - 1
|
||||
|
||||
let set_parent_on_children n : node =
|
||||
( match n.t with
|
||||
| `Atom _ -> ()
|
||||
@ -574,11 +578,27 @@ module Panel = struct
|
||||
b.parent <- Some n ) ;
|
||||
n
|
||||
|
||||
let node_count = ref 0
|
||||
let sub (n : node) : node =
|
||||
match n.t with
|
||||
| `Atom _ -> n
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, a, _) -> a
|
||||
|
||||
let node_n () =
|
||||
node_count := !node_count + 1 ;
|
||||
!node_count - 1
|
||||
let super (n : node) : node =
|
||||
match n.parent with Some n' -> n' | None -> n
|
||||
|
||||
let set_children_on_parent ~oldc ~newc =
|
||||
match newc.parent with
|
||||
| Some ({t= `Attr (a, _); _} as s) ->
|
||||
s.t <- `Attr (a, newc) ;
|
||||
newc
|
||||
| Some ({t= `Join (d, a, b); _} as s) when oldc == a ->
|
||||
s.t <- `Join (d, newc, b) ;
|
||||
newc
|
||||
| Some ({t= `Join (d, a, b); _} as s) when oldc == b ->
|
||||
s.t <- `Join (d, a, newc) ;
|
||||
newc
|
||||
| _ -> newc
|
||||
|
||||
let node (t : t) =
|
||||
set_parent_on_children {parent= None; t; n= node_n ()}
|
||||
@ -705,20 +725,17 @@ module Panel = struct
|
||||
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 ;
|
||||
( match p 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 )
|
||||
| None -> () ) ;
|
||||
n'
|
||||
set_children_on_parent ~oldc:n ~newc:n'
|
||||
|
||||
let remove_attr (n : node) : node =
|
||||
match n.t with
|
||||
@ -736,12 +753,6 @@ module Panel = struct
|
||||
n'
|
||||
| _ -> assert false
|
||||
|
||||
let sub (n : node) : node =
|
||||
match n.t with
|
||||
| `Atom _ -> n
|
||||
| `Attr (_, n) -> n
|
||||
| `Join (_, a, _) -> a
|
||||
|
||||
let join_x = join `X
|
||||
let join_y = join `Y
|
||||
let join_z = join `Z
|
||||
@ -757,14 +768,6 @@ module Panel = struct
|
||||
let append_y = append_ `Y
|
||||
let append_z = append_ `Z
|
||||
|
||||
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
||||
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
||||
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
||||
I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
|
||||
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
|
||||
The main problem with this thought is that you can't do anything but append with the datastructure.
|
||||
*)
|
||||
|
||||
module Text = struct
|
||||
let rec decode dec (l : 'a) :
|
||||
'a * [< `Await | `End | `Uchar of Uchar.t] =
|
||||
@ -874,7 +877,7 @@ module Panel = struct
|
||||
and attr t b ((a : attr), n) : P2.t =
|
||||
match a with
|
||||
| `Style s ->
|
||||
Display.path_box t.vg s.bg
|
||||
Display.fill_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
|
||||
@ -907,10 +910,10 @@ module Panel = struct
|
||||
| `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') ) ;
|
||||
(* ignore
|
||||
(Display.path_box t.vg
|
||||
(Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
|
||||
(Box2.of_pts b b') ) ;*)
|
||||
b'
|
||||
end
|
||||
|
||||
@ -923,6 +926,8 @@ module Panel = struct
|
||||
|
||||
and t =
|
||||
[ `Move of segment
|
||||
| `Insert of node
|
||||
| `Overwrite of node
|
||||
| `Yank of segment
|
||||
| `Kill of segment
|
||||
| `Ascend
|
||||
@ -969,6 +974,8 @@ module Panel = struct
|
||||
let pp_t ppf v =
|
||||
( match v with
|
||||
| `Move s -> any "`Move " ++ const pp_segment s
|
||||
| `Insert n -> any "`Insert " ++ const pp_node n
|
||||
| `Overwrite n -> any "`Overwrite " ++ const pp_node n
|
||||
| `Yank s -> any "`Yank " ++ const pp_segment s
|
||||
| `Kill s -> any "`Kill " ++ const pp_segment s
|
||||
| `Ascend -> any "`Ascend"
|
||||
@ -1014,14 +1021,14 @@ module Panel = struct
|
||||
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
||||
|
||||
let rec search_ next f n =
|
||||
F.epr "search_ " ;
|
||||
(* 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)
|
||||
(* 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)
|
||||
@ -1103,6 +1110,10 @@ module Panel = struct
|
||||
(* uses last searched node regardless of match *)
|
||||
Some
|
||||
(tree_uchar_back (fst (search_ tree_next (mb b) c.sel)))
|
||||
| `Insert n ->
|
||||
ignore (insert_join_r `X (super c.sel) n) ;
|
||||
Some c.sel
|
||||
| `Overwrite _s -> None
|
||||
| `Yank _s -> None
|
||||
| `Kill _s -> None
|
||||
| `Descend -> Some (sub c.sel)
|
||||
@ -1157,9 +1168,18 @@ module Panel = struct
|
||||
`Attr
|
||||
( `Handler
|
||||
(fun (_ : node) (e : Event.t) : Event.t option ->
|
||||
Fmt.epr "textedit_handler@." ;
|
||||
match Key.Bind.resolve_events bind [e] with
|
||||
| x :: _ ->
|
||||
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
|
||||
match a with
|
||||
| Some x ->
|
||||
c.sel <- remove_attr c.sel ;
|
||||
( match perform_action x c with
|
||||
| Some n' ->
|
||||
@ -1170,8 +1190,9 @@ module Panel = struct
|
||||
F.epr "textedit action @[%a@] Failure@."
|
||||
Action.pp_t x ) ;
|
||||
c.sel <- insert_attr cursor_attr c.sel ;
|
||||
F.epr "tree: @[%a@]@." Pp.pp_node_structure c.root ;
|
||||
None
|
||||
| [] -> Some e )
|
||||
| None -> None )
|
||||
, n ) ;
|
||||
set_parent_on_children c.root
|
||||
|
||||
@ -1182,7 +1203,6 @@ module Panel = struct
|
||||
match f n with Some a -> Some a | None -> search_forward f n
|
||||
|
||||
let handle_event (n : node) (ev : Event.t) : event_status =
|
||||
Fmt.epr "handle_event@." ;
|
||||
match handler_of_node n with
|
||||
| Some f -> (
|
||||
match f n ev with Some ev -> `Event ev | None -> `Handled )
|
||||
@ -1200,10 +1220,11 @@ module Panel = struct
|
||||
textedit
|
||||
(style Style.dark
|
||||
Text.(
|
||||
text "--- welcome to my land of idiocy ---"
|
||||
^/^ (text "hello bitch" ^^ text "! sup daddy" ^^ nl)
|
||||
^/^ lines "hello bitch" ^/^ lines "! sup daddy"
|
||||
^/^ lines "123") )
|
||||
(* text "--- welcome to my land of idiocy ---"
|
||||
^/^ *)
|
||||
text "hello bitch"
|
||||
(*^^ text "! sup daddy" ^^ nl)
|
||||
^/^ lines "123")*)) )
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
Reference in New Issue
Block a user