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

irmin

Browse Source
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
Download Patch File Download Diff File Expand all files Collapse all files

4
dune
View File

@ -13,8 +13,8 @@
graphv_webgl
js_of_ocaml
lwt
; irmin-git
; irmin-indexeddb
irmin
irmin-git
zed
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!!
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 NVG = Graphv_webgl
(* module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)*)
(*module Istore =
Irmin_git.Generic
(Irmin_indexeddb.Content_store)
(Irmin_indexeddb.Branch_store)
(Irmin.Contents.String)
(Irmin.Path.String_list)
(Irmin.Branch.String)*)
module Nav = struct
open Lwt.Infix
module S = Irmin_mem.KV.Make(Irmin.Contents.String)
type t = S.tree
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
type special =
@ -325,11 +342,9 @@ module Event_js = struct
| None -> `Unknown "keypress .key is None?"
end
module Display = struct
module Panel = struct
open Gg
module I = NVG.Image
module P = NVG.Path
module Color = NVG.Color
open NVG
(* current window state to be passed to window renderer *)
type state =
@ -380,45 +395,6 @@ module Display = struct
NVG.stroke vg ;
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 Font = struct
type t =
@ -531,6 +507,8 @@ module Panel = struct
; b= Gg.Size1.zero
; l= Gg.Size1.zero
; r= Gg.Size1.zero }
let all v = {t= v; b= v; l= v; r= v}
end
module Ui = struct
@ -546,7 +524,8 @@ module Panel = struct
| `Attr of attr * 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 atom =
@ -556,12 +535,19 @@ module Panel = struct
| `Hint of [`Line | `Other]
| `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 image = NVG.Image.image
and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text]
and style = Style.t
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
@ -572,10 +558,10 @@ module Panel = struct
let set_parent_on_children n : node =
( match n.t with
| `Atom _ -> ()
| `Attr (_, a) -> a.parent <- Some n
| `Attr (_, a) -> a.parent <- `Left n
| `Join (_, a, b) ->
a.parent <- Some n ;
b.parent <- Some n ) ;
a.parent <- `Left n ;
b.parent <- `Right n ) ;
n
let sub (n : node) : node =
@ -585,23 +571,28 @@ module Panel = struct
| `Join (_, a, _) -> a
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 =
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 set_children_on_parent n =
match n.parent with
| `Left ({t= `Attr (a, _); _} as s)
|`Right ({t= `Attr (a, _); _} as s) ->
s.t <- `Attr (a, n) ;
n
| `Left ({t= `Join (d, _, b); _} as s) ->
s.t <- `Join (d, n, b) ;
n
| `Right ({t= `Join (d, a, _); _} as s) ->
s.t <- `Join (d, a, n) ;
n
| _ -> n
let option_of_parent = function
| `None -> None
| `Left a | `Right a -> Some a
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 attr (a : attr) (child : node) = node (`Attr (a, child))
@ -609,6 +600,159 @@ module Panel = struct
let empty_image = V2.zero
let empty_node () = node (`Atom `Empty)
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
let pp_uchar ppf v =
@ -650,7 +794,8 @@ module Panel = struct
| `Pad _ -> "`Pad ..."
| `Shift _ -> "`Shift ..."
| `Cursor -> "`Cursor"
| `Handler _ -> "`Handler ..." ) )
| `Handler _ -> "`Handler ..."
| `Draw _ -> "`Draw ..." ) )
ppf ()
let pp_dir ppf v =
@ -674,6 +819,13 @@ module Panel = struct
++ 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 =
let open Fmt in
pf ppf "@[<hov>%a@]"
@ -681,9 +833,7 @@ module Panel = struct
(record
[ field "n" (fun v -> v.n) int
; field "t" (fun v -> v.t) (_pp_t child)
; field "parent"
(fun v -> v.parent)
(option pp_node_n) ] ) )
; field "parent" (fun v -> v.parent) _pp_parent ] ) )
v
and pp_node_n_record =
@ -716,58 +866,6 @@ module Panel = struct
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
let rec decode dec (l : 'a) :
'a * [< `Await | `End | `Uchar of Uchar.t] =
@ -821,7 +919,7 @@ module Panel = struct
open NVG
type d = [`X | `Y | `Z]
type t = {vg: NVG.t; style: Style.t}
type t = draw_context
let vcat d a b =
match d with
@ -855,7 +953,7 @@ module Panel = struct
( P2.y t +. metrics.ascender +. metrics.descender
+. 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
match a with
| `Image image ->
@ -877,15 +975,16 @@ module Panel = struct
and attr t b ((a : attr), n) : P2.t =
match a with
| `Style s ->
Display.fill_box t.vg s.bg
path_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
| _ -> node t b n
| `Draw d -> d t b
| `Handler _ -> node t b 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
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 =
let av = node vg t a in
@ -985,80 +1084,7 @@ module Panel = struct
ppf ()
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 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
| `Move (`Forward `Line) -> (
let i = ref 0 in
@ -1069,13 +1095,13 @@ module Panel = struct
| {t= `Atom (`Uchar _); _} -> incr i ; None
| _ -> None )
c.sel ) ;
match search_forward (mb `Line) c.sel with
match search_forward (is_boundary `Line) c.sel with
| Some n' ->
Some
(tree_iter
(fun nn ->
Option.value
(search_forward (mb `Char) nn)
(search_forward (is_boundary `Char) nn)
~default:nn )
n' !i )
| None -> None )
@ -1090,34 +1116,32 @@ module Panel = struct
c.sel
with
| Some n' ->
Some
(tree_iter
(fun nn ->
Option.value
(search_forward (mb `Char) nn)
~default:nn )
(fst (search_ tree_prev (mb `Line) n'))
!i )
Option.map
(fun n -> tree_iter tree_uchar_back n !i)
(search_backward (is_boundary `Line) n')
| None -> None )
| `Move (`Forward b) ->
search_forward (mb ~f:tree_uchar_back b) c.sel
| `Move (`Backward b) ->
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)))
Option.map tree_uchar_fwd
(search_forward (is_boundary b) c.sel)
| `Move (`End b) ->
(* uses last searched node regardless of match *)
Some
(tree_uchar_back (fst (search_ tree_next (mb b) c.sel)))
Option.map tree_uchar_back
(search_forward (is_boundary 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 ->
ignore (insert_join_r `X (super c.sel) n) ;
ignore (insert_join_l `X (super c.sel) n) ;
Some c.sel
| `Overwrite _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
| `Descend -> Some (sub c.sel)
| `Ascend -> c.sel.parent
| `Ascend -> option_of_parent c.sel.parent
| `Custom _s -> None
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 'e')] [`Move (`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 [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
|> add
@ -1157,6 +1183,25 @@ module Panel = struct
let cursor_attr =
`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) =
Format.pp_set_max_boxes F.stderr 64 ;
(*full screen fynn *)
@ -1178,6 +1223,7 @@ module Panel = struct
| `Uchar c -> Some (`Insert (atom (`Uchar c)))
| _ -> None )
| _ -> None ) in
let r =
match a with
| Some x ->
c.sel <- remove_attr c.sel ;
@ -1190,11 +1236,14 @@ 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
| None -> None )
| None -> None in
r )
, 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 f n =
@ -1217,14 +1266,15 @@ module Panel = struct
Draw.node {vg; style= Style.dark} p t
let test =
textedit
(style Style.dark
style Style.dark
(pad 20.
(textedit
Text.(
(* text "--- welcome to my land of idiocy ---"
^/^ *)
text "hello bitch"
(*^^ text "! sup daddy" ^^ nl)
^/^ lines "123")*)) )
^/^ lines "123")*)) ) )
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)
*)
(* 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 *)