character insertion

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
+    fill vg ;
-
+    Box2.max b
-  let draw_filled_box c (s : state) =
-    fill_box s.renderer c s.box ;
-    (s, s.box)
 
   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 () =
+    let super (n : node) : node =
-      node_count := !node_count + 1 ;
+      match n.parent with Some n' -> n' | None -> n
-      !node_count - 1
+
+    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
+      set_children_on_parent ~oldc:n ~newc:n'
-      | 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'
 
     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
+        (* ignore
            (Display.path_box t.vg
               (Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
-             (Box2.of_pts b b') ) ;
+              (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' ;
+        (*          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)
+      | 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@." ;
+                let a =
                   match Key.Bind.resolve_events bind [e] with
-                | x :: _ ->
+                  | 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 "--- welcome to my land of idiocy ---"
-             ^/^ (text "hello bitch" ^^ text "! sup daddy" ^^ nl)
+                ^/^ *)
-             ^/^ lines "hello bitch" ^/^ lines "! sup daddy"
+             text "hello bitch"
-             ^/^ lines "123") )
+             (*^^ text "! sup daddy" ^^ nl)
+               ^/^ lines "123")*)) )
   end
 end