From 44879eb94712f085927c16c2ad8ec7a9a04a95f8 Mon Sep 17 00:00:00 2001 From: cqc Date: Wed, 7 Dec 2022 12:47:56 -0600 Subject: [PATCH] another barely working text rendering scheme --- boot_js.ml | 73 +- human.ml | 3601 +++++++++++++++++++++++++++++++++++----------------- 2 files changed, 2467 insertions(+), 1207 deletions(-) diff --git a/boot_js.ml b/boot_js.ml index 3688a3a..0e4aacc 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -60,21 +60,24 @@ let request_animation_frame () = in t -let request_render canvas webgl_ctx vg - (render : NVG.t -> ?time:float -> Gg.p2 -> Gg.p2 Lwt.t) = - request_animation_frame () >>= fun time -> - webgl_ctx##clear - (webgl_ctx##._COLOR_BUFFER_BIT_ - lor webgl_ctx##._DEPTH_BUFFER_BIT_ - lor webgl_ctx##._STENCIL_BUFFER_BIT_); - let device_ratio = Dom_html.window##.devicePixelRatio in - NVG.begin_frame vg ~width:canvas##.width ~height:canvas##.height - ~device_ratio; - NVG.Transform.scale vg ~x:device_ratio ~y:device_ratio; - render vg ~time Gg.P2.o >>= fun _p -> - (* Logs.debug (fun m -> m "Drawing finished at point: %a" Gg.V2.pp p); *) - NVG.end_frame vg; - Lwt.return_unit +let render_stream canvas webgl_ctx vg + (render : NVG.t -> ?time:float -> Gg.p2 -> Human.I.t -> unit) : + Human.I.t Lwt_stream.t -> unit Lwt.t = + Lwt_stream.iter_n (fun i -> + request_animation_frame () >>= fun time -> + webgl_ctx##clear + (webgl_ctx##._COLOR_BUFFER_BIT_ + lor webgl_ctx##._DEPTH_BUFFER_BIT_ + lor webgl_ctx##._STENCIL_BUFFER_BIT_); + let device_ratio = Dom_html.window##.devicePixelRatio in + NVG.begin_frame vg ~width:canvas##.width ~height:canvas##.height + ~device_ratio; + NVG.Transform.scale vg ~x:device_ratio ~y:device_ratio; + render vg ~time Gg.P2.o i; + NVG.end_frame vg; + Lwt.return_unit) + +open Human let _ = let canvas = @@ -83,24 +86,28 @@ let _ = let webgl_ctx = webgl_initialize canvas in let vg = graphv_initialize webgl_ctx in let open Js_of_ocaml_lwt.Lwt_js_events in - let page_var = Lwd.var Human.Panel.Ui.empty in + let root = + Lwd_utils.pack Nottui.Ui.pack_x + [ Lwd.pure @@ Nottui_widgets.string "hello daddy" ] + in + let events, push_event = Lwt_stream.create () in + let images = + Human.Nottui_lwt.render vg + ~size:(Gg.P2.v canvas##.width canvas##.height) + events root + in async (fun () -> - Human.Panel.Ui.boot_page >>= fun page -> - Lwd.set page_var page; - let render = Human.Panel.Ui.renderer page_var in - request_render canvas webgl_ctx vg render >>= fun () -> - buffered_loop - (make_event Dom_html.Event.keydown) - Dom_html.document - Human.( - fun ev _ -> - Lwd.set page_var - (Panel.Ui.handle_event (Lwd.peek page_var) - (Event_js.evt_of_jskey `Press ev)); - request_render canvas webgl_ctx vg render)) + render_stream canvas webgl_ctx vg + (fun vg ?(time = 0.) p i -> + Log.debug (fun m -> + m "Drawing image: p=%a n=%a" Gg.V2.pp p I.Draw.pp i); -(* Dom_html.document##.onkeydown - := Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) -> - render (Human.Event_js.evt_of_jskey `Press evt) ; - Js._false ) *) + let p' = I.Draw.node vg A.dark p i in + Logs.debug (fun m -> + m "Drawing finished: p'=%a" Gg.V2.pp p')) + images); + buffered_loop (make_event Dom_html.Event.keydown) Dom_html.document + (fun ev _ -> + Lwt.return + @@ push_event (Some (`Key (Event_js.evt_of_jskey ev)))) diff --git a/human.ml b/human.ml index fa0d512..359e1bb 100644 --- a/human.ml +++ b/human.ml @@ -37,7 +37,6 @@ some options: *) open Js_of_ocaml module F = Fmt -module NVG = Graphv_webgl module Logs_reporter = struct (* Console reporter *) @@ -469,7 +468,10 @@ module Nav = struct (* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *) end -module Key = struct +module Input = struct + type button = + [ `Left | `Middle | `Right | `Scroll of [ `Up | `Down ] ] + type special = [ `Enter | `Escape @@ -488,144 +490,14 @@ module Key = struct type code = [ `Uchar of Uchar.t (* A unicode character. *) | special ] + type mods = [ `Super | `Meta | `Ctrl | `Shift ] list + + type mouse = + [ `Press of button | `Drag | `Release ] * (float * float) * mods + + type paste = [ `Start | `End ] type keyaction = [ `Press | `Release | `Repeat ] - type keystate = { - ctrl : bool; - meta : bool; - shift : bool; - super : bool; - code : code; - } - - module KeyS = struct - type t = keystate - - let compare = compare - end - - module Bind = struct - (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) - module S = Zed_input.Make (KeyS) - - type 'a t = 'a list S.t - type 'a resolver = 'a list S.resolver - type 'a result = 'a list S.result - - type 'a state = { - mutable bindings : 'a t; - mutable state : 'a result; - mutable last_keyseq : keystate list; - mutable last_actions : 'a list; - } - - type mods = Ctrl | Meta | Super | Shift - type key = C of char | U of code - - let keystate_of_mods ks m = - List.fold_left - (fun ks m -> - match m with - | Meta -> { ks with meta = true } - | Ctrl -> { ks with ctrl = true } - | Super -> { ks with super = true } - | Shift -> { ks with shift = true }) - ks m - - let add events action bindings = - let events = - List.map - (fun (m, k) -> - keystate_of_mods - { - meta = false; - ctrl = false; - super = false; - shift = false; - code = - (match k with - | C c -> `Uchar (Uchar.of_char c) - | U c -> c); - } - m) - events - in - S.add events action bindings - - let default_resolver b = S.resolver [ S.pack (fun x -> x) b ] - - let get_resolver result default = - match result with S.Continue r -> r | _ -> default - - let init bindings = - { - bindings; - state = S.Rejected; - last_keyseq = []; - last_actions = []; - } - - let resolve = S.resolve - let empty = S.empty - - type action = Custom of (unit -> unit) | Zed of Zed_edit.action - - let resolve_events (state : 'a state) events = - List.flatten - (List.filter_map - (fun e -> - match e with - | `Key (`Press, (k : keystate)) -> ( - (match state.state with - | Continue _ -> () - | _ -> state.last_keyseq <- []); - state.state <- - resolve k - (get_resolver state.state - (default_resolver state.bindings)); - state.last_keyseq <- k :: state.last_keyseq; - match state.state with - | Accepted a -> - state.last_actions <- a; - Some a - | Rejected -> - state.last_actions <- []; - None - | _ -> None) - | _ -> None) - events) - - let actions_of_events (state : action state) events = - List.flatten - (List.filter_map - (fun e -> - match e with - | `Key (`Press, (k : keystate)) -> ( - (match state.state with - | Continue _ -> () - | _ -> state.last_keyseq <- []); - state.state <- - resolve k - (get_resolver state.state - (default_resolver state.bindings)); - state.last_keyseq <- k :: state.last_keyseq; - match state.state with - | Accepted a -> - state.last_actions <- a; - Some a - | Rejected -> - state.last_actions <- []; - None - | _ -> None) - | _ -> None) - events) - - let process bindstate events = - List.iter - (function Custom f -> f () | Zed _ -> ()) - (actions_of_events bindstate events) - end - (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function | `Uchar ch -> @@ -647,1082 +519,2463 @@ module Key = struct | `Delete -> "Delete" | `Backspace -> "Backspace" | `Unknown s -> String.concat "Unknown " [ "\""; s; "\"" ] - - let to_string key = - Printf.sprintf - "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" - key.ctrl key.meta key.shift key.super - (string_of_code key.code) - - let to_string_compact key = - let buffer = Buffer.create 32 in - if key.ctrl then Buffer.add_string buffer "Ctrl-"; - if key.meta then Buffer.add_string buffer "Meta-"; - if key.shift then Buffer.add_string buffer "Shift-"; - if key.super then Buffer.add_string buffer "Super-"; - (match key.code with - | `Uchar ch -> - let code = Uchar.to_int ch in - if Uchar.is_char ch then - match Uchar.to_char ch with - | ( 'a' .. 'z' - | 'A' .. 'Z' - | '0' .. '9' - | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' - | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' - | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch -> - Buffer.add_char buffer ch - | ' ' -> Buffer.add_string buffer "space" - | _ -> Printf.bprintf buffer "U+%02x" code - else if code <= 0xffff then - Printf.bprintf buffer "U+%04x" code - else Printf.bprintf buffer "U+%06x" code - | `Page `Down -> Buffer.add_string buffer "pgup" - | `Page `Up -> Buffer.add_string buffer "pgdn" - | code -> - Buffer.add_string buffer - (String.lowercase_ascii (string_of_code code))); - Buffer.contents buffer -end - -module Event = struct - open Gg - - type mouse = V2.t - type keystate = Key.keystate - type keyaction = Key.keyaction - - type t = - [ `Key of keyaction * keystate - | `Mouse of mouse - | `Quit - | `Fullscreen of bool - | `Unknown of string ] - - type events = t list - - let to_string : t -> string = function - | `Key (x, k) -> - "`Key " - ^ (match x with - | `Press -> "`Press " - | `Release -> "`Release " - | `Repeat -> "`Repeat ") - ^ Key.to_string k - | `Mouse m -> F.str "`Mouse %a" V2.pp m - | `Quit -> "`Quit" - | `Fullscreen b -> F.str "`Fullscreen %b" b - | `Unknown s -> F.str "`Unknown %s" s - - let handle_keyevents (el : events) f = List.iter f el - let empty = `Unknown "empty" end module Event_js = struct - include Event open Js_of_ocaml - type t = Dom_html.Keyboard_code.t - - let decode_single_uchar (str : string) = - (* yea we return None if there is more than one Uchar bitch **) - let rec decode dec (d : Uchar.t option) : Uchar.t option = - match Uutf.decode dec with - | `Malformed b -> - F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@." - (String.escaped b); - None - | `Await -> decode dec d - | `End -> d - | `Uchar u -> - if Option.is_none d then decode dec (Some u) else None - in - decode - (Uutf.decoder - ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str)) - None - - let of_jskey = function - | "Enter" -> `Enter - | "Escape" -> `Escape - | "Tab" -> `Tab - | "ArrowUp" -> `Arrow `Up - | "ArrowDown" -> `Arrow `Down - | "ArrowLeft" -> `Arrow `Left - | "ArrowRight" -> `Arrow `Right - | "PageUp" -> `Page `Up - | "PageDown" -> `Page `Down - | "Home" -> `Home - | "End" -> `End - | "Insert" -> `Insert - | "Delete" -> `Delete - | "Backspace" -> `Backspace - | s -> ( - match decode_single_uchar s with - | Some s -> `Uchar s - | None -> `Unknown s) - - let evt_of_jskey (p : Key.keyaction) - (evt : Dom_html.keyboardEvent Js.t) : Event.t = - match Js.Optdef.to_option evt##.key with - | Some s -> - `Key - ( p, - Key. - { - meta = Js.to_bool evt##.altKey; - shift = Js.to_bool evt##.shiftKey; - ctrl = Js.to_bool evt##.ctrlKey; - super = Js.to_bool evt##.metaKey; - code = of_jskey (Js.to_string s); - } ) - | None -> `Unknown "keypress .key is None?" + let evt_of_jskey (evt : Dom_html.keyboardEvent Js.t) = + ( (match Js.Optdef.to_option evt##.key with + | Some s -> ( + match Js.to_string s with + | "Enter" -> `Enter + | "Escape" -> `Escape + | "Tab" -> `Tab + | "ArrowUp" -> `Arrow `Up + | "ArrowDown" -> `Arrow `Down + | "ArrowLeft" -> `Arrow `Left + | "ArrowRight" -> `Arrow `Right + | "PageUp" -> `Page `Up + | "PageDown" -> `Page `Down + | "Home" -> `Home + | "End" -> `End + | "Insert" -> `Insert + | "Delete" -> `Delete + | "Backspace" -> `Backspace + | s -> ( + match Dom_html.Keyboard_key.of_event evt with + | Some s' -> `Uchar s' + | None -> `Unknown s)) + | None -> `Unknown "keypress .key is None?"), + (if Js.to_bool evt##.altKey then [ `Meta ] else []) + @ (if Js.to_bool evt##.shiftKey then [ `Shift ] else []) + @ (if Js.to_bool evt##.ctrlKey then [ `Ctrl ] else []) + @ if Js.to_bool evt##.metaKey then [ `Super ] else [] ) end -module Panel = struct - open Gg - open NVG +open Gg - (* current window state to be passed to window renderer *) - type state = { - box : box2; - (* This is cannonically box within which the next element should draw *) - renderer : NVG.t; - } +module NVG = struct + include Graphv_webgl - (* the box2 here is cannonically the place the returner drew - (the Wall.image extents) *) - type pane = state -> state * box2 - type actor = (Event.t -> P2.t) ref + module Color = struct + include Graphv_webgl.Color - let pane_empty s = (s, Box2.of_pts (Box2.o s.box) (Box2.o s.box)) + let none = Color.transparent + let rgbf = Color.rgbf + let gray a = rgbf ~r:a ~g:a ~b:a + let light = gray 0.2 + let dark = gray 0.8 - let on_failure ~cleanup result = - (match result with Ok _ -> () | Error _ -> cleanup ()); - result + let black = gray 0. + and red = rgbf ~r:1. ~g:0. ~b:0. + and green = rgbf ~r:0. ~g:1. ~b:0. + and yellow = rgbf ~r:1. ~g:1. ~b:0. + and blue = rgbf ~r:0. ~g:0. ~b:1. + and magenta = rgbf ~r:1. ~g:0. ~b:1. + and cyan = rgbf ~r:0. ~g:1. ~b:1. + and white = rgbf ~r:1. ~g:1. ~b:1. + and lightblack = gray 0.5 + and lightred = rgbf ~r:1.0 ~g:0.5 ~b:0.5 + and lightgreen = rgbf ~r:0.5 ~g:1.0 ~b:0.5 + and lightyellow = rgbf ~r:1.0 ~g:1.0 ~b:0.5 + and lightblue = rgbf ~r:0.5 ~g:0.5 ~b:1.0 + and lightmagenta = rgbf ~r:1.0 ~g:0.5 ~b:1.0 + and lightcyan = rgbf ~r:0.5 ~g:1.0 ~b:1.0 + and lightwhite = rgbf ~r:1.0 ~g:1.0 ~b:1.0 - let draw_pane vg pane width height = - let _, _ = - pane - { - box = Box2.v (P2.v 0. 0.) (P2.v width height); - renderer = vg; - } - in - Ok () - - let gray ?(a = 1.0) v = Color.rgbaf ~r:v ~g:v ~b:v ~a - - let str_of_box b = - Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) - (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; - Box2.max b - - let path_box vg color ?(width = 0.) b = - let module Path = NVG.Path in - Path.begin_ vg; - Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) - ~h:(Box2.h b); - if width != 0. then NVG.set_stroke_width vg ~width; - NVG.set_stroke_color vg ~color; - NVG.stroke vg; - Box2.max b - - module Style = struct - module Font = struct - type t = { - size : float option; - font : [ `Sans | `Serif | `Mono | `None ]; - weight : [ `Bold | `Regular | `Light | `None ]; - italic : [ `Italic | `None ]; - underline : [ `Underline | `None ]; - } - - let empty = - { - size = None; - font = `None; - weight = `None; - italic = `None; - underline = `None; - } - - let default = - ref - { - size = Some 20.; - font = `Sans; - weight = `Regular; - italic = `None; - underline = `None; - } - - let size { size; _ } = - match (size, !default.size) with - | None, None -> 20. - | None, Some s | Some s, _ -> s - - let merge a b = - { - size = - (match (a.size, b.size) with - | None, None -> None - | Some s, None | None, Some s -> Some s - | Some s1, Some s2 -> Some (Float.max_num s1 s2)); - font = - (match (a.font, b.font) with - | `Sans, _ | _, `Sans -> `Sans - | `Serif, (`Serif | `Mono | `None) - | (`Mono | `None), `Serif -> - `Serif - | `Mono, (`Mono | `None) | `None, `Mono -> `Mono - | `None, `None -> `None); - weight = - (match (a.weight, b.weight) with - | `Bold, _ | _, `Bold -> `Bold - | `Regular, (`Regular | `Light | `None) - | (`Light | `None), `Regular -> - `Regular - | `Light, (`Light | `None) | `None, `Light -> `Light - | `None, `None -> `None); - italic = - (match (a.italic, b.italic) with - | `Italic, _ | _, `Italic -> `Italic - | _ -> `None); - underline = - (match (a.underline, b.underline) with - | `Underline, _ | _, `Underline -> `Underline - | _ -> `None); - } - - let set vg t = - (match t.size with - | Some size -> Text.set_size vg ~size - | None -> ()); - match t.font with - | `Sans -> Text.set_font_face vg ~name:"sans" - | _ -> () - end - - type t = { fg : Color.t; bg : Color.t; font : Font.t } - type attr = t - - let gray a = Color.rgbf ~r:a ~g:a ~b:a - - let empty = - { - fg = Color.transparent; - bg = Color.transparent; - font = Font.empty; - } - - let light = { empty with fg = gray 0.2 } - let dark = { empty with fg = gray 0.8 } - let equal = ( == ) - - let ( ++ ) a1 a2 = - if a1 == empty then a2 - else if a2 == empty then a1 - else - { - a1 with - fg = Color.lerp a1.fg a2.fg ~a:0.5; - bg = Color.lerp a1.bg a2.bg ~a:0.5; - } - - let fg fg = { empty with fg } - let bg bg = { empty with bg } - - let merge a b = - { - fg = Color.lerp a.fg b.fg ~a:0.5; - bg = Color.lerp a.bg b.bg ~a:0.5; - font = Font.merge a.font b.font; - } - - let set vg s = - F.epr "Style.set @."; - NVG.set_fill_color vg ~color:s.bg; - NVG.set_stroke_color vg ~color:s.fg; - Font.set vg s.font + let pp ppf t : unit = + F.( + fmt "%a" ppf + (record + [ + field "r" (fun t -> t.r) F.float; + field "g" (fun t -> t.g) F.float; + field "b" (fun t -> t.b) F.float; + field "a" (fun t -> t.a) F.float; + ]) + t) end +end - module Pad = struct +open NVG + +let str_of_box b = + Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) + (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; + Box2.max b + +let path_box vg color ?(width = 0.) b = + let module Path = NVG.Path in + Path.begin_ vg; + Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) + ~h:(Box2.h b); + if width != 0. then NVG.set_stroke_width vg ~width; + NVG.set_stroke_color vg ~color; + NVG.stroke vg; + Box2.max b + +module Style = struct + module Font = struct type t = { - t : Gg.size1; - b : Gg.size1; - l : Gg.size1; - r : Gg.size1; + size : float option; + font : [ `Sans | `Serif | `Mono | `None ]; + weight : [ `Bold | `Regular | `Light | `None ]; + italic : [ `Italic | `None ]; + underline : [ `Underline | `None ]; } let empty = { - t = Gg.Size1.zero; - b = Gg.Size1.zero; - l = Gg.Size1.zero; - r = Gg.Size1.zero; + size = None; + font = `None; + weight = `None; + italic = `None; + underline = `None; } - let all v = { t = v; b = v; l = v; r = v } + let default = + ref + { + size = Some 20.; + font = `Sans; + weight = `Regular; + italic = `None; + underline = `None; + } + + let size { size; _ } = + match (size, !default.size) with + | None, None -> 20. + | None, Some s | Some s, _ -> s + + let merge a b = + { + size = + (match (a.size, b.size) with + | None, None -> None + | Some s, None | None, Some s -> Some s + | Some s1, Some s2 -> Some (Float.max_num s1 s2)); + font = + (match (a.font, b.font) with + | `Sans, _ | _, `Sans -> `Sans + | `Serif, (`Serif | `Mono | `None) | (`Mono | `None), `Serif + -> + `Serif + | `Mono, (`Mono | `None) | `None, `Mono -> `Mono + | `None, `None -> `None); + weight = + (match (a.weight, b.weight) with + | `Bold, _ | _, `Bold -> `Bold + | `Regular, (`Regular | `Light | `None) + | (`Light | `None), `Regular -> + `Regular + | `Light, (`Light | `None) | `None, `Light -> `Light + | `None, `None -> `None); + italic = + (match (a.italic, b.italic) with + | `Italic, _ | _, `Italic -> `Italic + | _ -> `None); + underline = + (match (a.underline, b.underline) with + | `Underline, _ | _, `Underline -> `Underline + | _ -> `None); + } + + let set vg t = + (match t.size with + | Some size -> Text.set_size vg ~size + | None -> ()); + match t.font with + | `Sans -> Text.set_font_face vg ~name:"sans" + | _ -> () end - module Ui = struct - (* Tree-like document structure of Ui elements, from the top level window down - to individual glyphs, and built with Lwd. - - Probably an LCRS binary tree. - *) - - open Gg - - type draw_context = { vg : NVG.t; style : Style.t; time : float } - and draw = draw_context -> Gg.p2 -> Gg.p2 - - module Page = struct - type t = - (* TODO figure out how to allow extending `node` with custom document tree combinators *) - [ `Atom of atom | `Attr of attr * t | `Join of dir * t * t ] - - and step = [ `Next | `Left | `Right ] - and path = step list - - and atom = - [ (*`Lwd of t - | *) - `Image of - image - | `Uchar of Uchar.t - | `Boundary of boundary - | `Hint of [ `Line | `Other ] - | `Empty ] - - 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 = t -> Event.t -> t - - let sub_left = function - | `Atom _ as n -> n - | `Attr (_, n) -> n - | `Join (_, a, _) -> a - - let sub = sub_left - - let sub_right = function - | `Atom _ as n -> n - | `Attr (_, n) -> n - | `Join (_, _, b) -> b - - let atom (a : atom) : t = `Atom a - let attr (a : attr) (child : t) : t = `Attr (a, child) - let join (d : dir) (a : t) (b : t) : t = `Join (d, a, b) - let empty = `Atom `Empty - let style (s : Style.t) t = attr (`Style s) t - let pad v n = attr (`Pad (Pad.all v)) n - - (* left child, right sibiling *) - let rec fold_preorder : ('a -> t -> 'a option) -> 'a -> t -> 'a - = - fun f acc n -> - match f acc n with - | Some acc' -> ( - match n with - | `Atom _ -> acc' - | `Attr (_, n'') -> fold_preorder f acc' n'' - | `Join (_, a, b) -> - fold_preorder f (fold_preorder f acc' a) b) - | None -> acc - - (* let rec fold_inorder : ('a -> node -> 'a option) -> 'a -> node -> 'a = - fun f acc n -> - match n with - | `Atom _ -> (match f acc n with - Some acc' -> acc' - | None -> acc) - | `Attr (_, n') -> - let acc' = (fold_inorder f acc n') in - (match f acc' n with - | Some acc'' -> acc'' - | None -> acc') - | `Join (_, a, b) -> - fold_inorder f (f (fold_inorder f acc a) n) b - - let rec fold_postorder : ('a -> node -> 'a option) -> 'a -> node -> 'a = - fun f acc n -> - match n with - | `Atom _ -> f (Some acc) n - | `Attr (_, n') -> f (fold_postorder f (Some acc) n') n - | `Join (_, a, b) -> - f (fold_postorder f (fold_postorder f (Some acc) a) b) n*) - - let is_atom_uchar = function - | `Atom (`Uchar _) as n -> Some n - | _ -> None - - let is_boundary b t = - match (b, t) with - | ( `Char, `Atom (`Uchar _) - | `Word, `Atom (`Boundary `Word) - | `Phrase, `Atom (`Boundary `Phrase) - | `Line, `Atom (`Boundary `Line) - | `Page, `Atom (`Boundary `Page) ) as x -> - Some x - | _ -> None - - let join_x = join `X - let join_y = join `Y - let join_z = join `Z - - module Text = struct - let append_ d (l : t -> t) (a : t) (b : t) : t = - l (join d a b) - - let empty_append = Fun.id - let append_x = append_ `X - let append_y = append_ `Y - let append_z = append_ `Z - - let rec decode dec (l : 'a) : - 'a * [< `Await | `End | `Uchar of Uchar.t ] = - match Uutf.decode dec with - | `Malformed b -> - F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." - (String.escaped b); - decode dec (append_x l (of_string (String.escaped b))) - | (`Await | `End | `Uchar _) as s -> (l, s) - - and _of_string dec l = - match decode dec l with - | l, `End -> l (atom (`Boundary `Text)) - | l, `Uchar c -> - _of_string dec (append_x l (atom (`Uchar c))) - | l, _ -> _of_string dec l - - and of_string str = - _of_string - (Uutf.decoder - ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str)) - empty_append - - and _lines u d ly (lx, s) = - match Uuseg.add u s with - | `Boundary when Uuseg.mandatory u -> - _lines u d - (append_y ly (lx (atom (`Boundary `Line)))) - (empty_append, `Await) - | `Boundary -> - _lines u d ly (append_x lx (atom (`Hint `Line)), `Await) - | `End -> ly (lx (atom (`Boundary `Text))) - | `Await -> _lines u d ly (decode d lx) - | `Uchar c -> - _lines u d ly (append_x lx (atom (`Uchar c)), `Await) - - let lines str = - _lines - (Uuseg.create `Line_break) - (Uutf.decoder - ~nln:(`Readline (Uchar.of_int 0x000A)) - (`String str)) - empty_append (empty_append, `Await) - - let text = of_string - let nl = atom (`Boundary `Line) - end - - module Draw = struct - type p = P2.t - type d = [ `X | `Y | `Z ] - - let vcat d a b = - match d with - | `X -> - V2.v - (V2.x a +. V2.x b) - (Float.max_num (V2.y a) (V2.y b)) - | `Y -> - V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b) - | `Z -> - V2.v - (Float.max_num (V2.x a) (V2.x b)) - (Float.max_num (V2.y a) (V2.y b)) - - let uchar vg t (uc : Uchar.t) : P2.t = - let module Buffer = Stdlib.Buffer in - let b = Stdlib.Buffer.create 1 in - let enc = Uutf.encoder `UTF_8 (`Buffer b) in - let rec encode c = - match Uutf.encode enc c with - | `Ok -> () - | `Partial -> encode `Await - in - encode (`Uchar uc); - encode `End; - let text = Bytes.to_string (Buffer.to_bytes b) in - let open NVG in - let metrics = Text.metrics vg in - let x, y = (V2.x t, V2.y t +. metrics.ascender) in - let twidth = Text.text_w vg ~x ~y text in - P2.v twidth - (P2.y t +. metrics.ascender +. metrics.descender - +. metrics.line_height) - - let rec atom { vg; _ } b (a : atom) : P2.t = - match a with - | `Image image -> - let wi, hi = Image.size vg image in - let w, h = (float wi, float hi) in - Path.begin_ vg; - Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h; - let img_paint = - Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h - ~angle:0.0 ~image ~alpha:0. - in - set_fill_paint vg ~paint:img_paint; - fill vg; - P2.v (P2.x b +. w) (P2.y b +. h) - | `Uchar uc -> uchar vg b uc - | `Boundary _ -> b - | `Hint _ -> b - | `Empty -> b - - and attr t b ((a : attr), n) : P2.t = - match a with - | `Style s -> - 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 - | `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 nv +. p.b)) - - and join vg t (d, a, b) : P2.t = - let av = node vg t a in - let bv = - node vg - (match d with - | `X -> P2.v (P2.x av) (P2.y t) - | `Y -> P2.v (P2.x t) (P2.y av) - | `Z -> t) - b - in - match d with - | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv)) - | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv) - | `Z -> - V2.v - (Float.max_num (V2.x av) (V2.x bv)) - (Float.max_num (V2.y av) (V2.y bv)) - - and node vg b n : P2.t = - let b' = - match n with - | `Atom a -> atom vg b a - | `Attr a -> attr vg b a - | `Join a -> join vg b a - in - (* ignore - (path_box vg.vg - (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) - (Box2.of_pts b b')); *) - b' - end - - module Pp = struct - let pp_uchar ppf v = - if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v) - else Fmt.Dump.uchar ppf v - - let pp_boundary ppf v = - F.any - (match v with - | `Char -> "`Char" - | `Word -> "`Word" - | `Phrase -> "`Phrase" - | `Line -> "`Line" - | `Page -> "`Page" - | `Text -> - "`Text" - (* text is like a file (unicode calls it End Of Text) *)) - ppf () - - let pp_atom ppf v = - let open Fmt in - (match v with - | `Image _ -> any "`Image" - | `Uchar c -> any "`Uchar " ++ const pp_uchar c - | `Boundary b -> any "`Boundary " ++ const pp_boundary b - | `Hint h -> - any "`Hint " - ++ any - (match h with - | `Line -> "`Line" - | `Other -> "`Other") - | `Empty -> any "`Empty") - ppf () - - let pp_attr ppf v = - let open Fmt in - (any - (match v with - | `Style _ -> "`Style" - | `Pad _ -> "`Pad" - | `Shift _ -> "`Shift" - | `Handler _ -> "`Handler" - | `Draw _ -> "`Draw")) - ppf () - - let pp_dir ppf v = - F.pf ppf "%s" - (match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z") - - let rec _pp_t child ppf v = - let open Fmt in - match v with - | `Atom x -> pf ppf "`Atom %a" pp_atom x - | `Attr (a, n) -> - pf ppf "`Attr %a" - (F.pair (const pp_attr a) (const child n)) - (a, n) - | `Join (d, a, b) -> - pf ppf "`Join %a" - (parens - (const pp_dir d ++ comma ++ const child a ++ comma - ++ const child b)) - () - - and pp_node ppf = _pp_t pp_node ppf - and pp_dump_node ppf = _pp_t pp_dump_node ppf - - let pp_t ppf = F.pf ppf "@[%a@]" pp_node - - let rec pp_node_structure ppf t = - F.( - parens - (concat ~sep:comma - (match t with - | `Atom a -> [ const pp_atom a ] - | `Attr (a, n) -> - [ const pp_attr a; const pp_node_structure n ] - | `Join (d, l, r) -> - [ - const pp_dir d; - const pp_node_structure l; - const pp_node_structure r; - ]))) - ppf () - - let pp_step ppf s = - F.any - (match s with - | `Next -> "`Next" - | `Left -> "`Left" - | `Right -> "`Right") - ppf () - - let rec pp_path ppf (p : path) = F.list pp_step ppf p - end - end - - type node = Page.t - type t = node Lwd.t - type path = Page.path Lwd.t - type cursor = { path : Page.path Lwd.var; root : node Lwd.var } - - let empty = Lwd.pure Page.empty - let pad v = Lwd.map ~f:(Page.pad v) - let attr a n = Lwd.map ~f:(Page.attr a) n - let handler f (n : t) : t = attr (`Handler f) n - let atom a = Lwd.map ~f:Page.atom a - let join d = Lwd.map2 ~f:(Page.join d) - let join_x, join_y, join_z = (join `X, join `Y, join `Z) - let ( ^^ ) = join_x - let ( ^/^ ) = join_y - let ( ^*^ ) = join_z - let pack d = Lwd_utils.lift_monoid Page.(empty, join d) - let pack_x, pack_y, pack_z = (pack `X, pack `Y, pack `Z) - let cat d = Lwd_utils.reduce (pack d) - let hcat, vcat, zcat = (cat `X, cat `Y, cat `Z) - - open Page.Pp - - module Action = struct - open Page - - type segment = - [ `Beginning of boundary - | `Forward of boundary - | `Backward of boundary - | `End of boundary ] - - and t = - [ `Move of segment - | `Insert of node - | `Overwrite of node - | `Yank of segment - | `Kill of segment - | `Ascend - | `Descend - | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ] - - and dir = - [ `Next - | `Prev - | `Up - | `Down - | `Left - | `Right - | `Fwd - | `Enter - | `In - | `Out ] - - open Fmt - - let pp_dir ppf v = - any - (match v with - | `Next -> "`Next" - | `Prev -> "`Prev" - | `Up -> "`Up" - | `Down -> "`Down" - | `Left -> "`Left" - | `Right -> "`Right" - | `Fwd -> "`Fwd" - | `Enter -> "`Enter" - | `In -> "`In" - | `Out -> "`Out") - ppf () - - let pp_segment ppf v = - (match v with - | `Beginning s -> any "`Beginning " ++ const pp_boundary s - | `Forward s -> any "`Forward " ++ const pp_boundary s - | `Backward s -> any "`Backward " ++ const pp_boundary s - | `End s -> any "`End " ++ const pp_boundary s) - ppf () - - 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" - | `Descend -> any "`Descend" - | `Custom (s, _) -> - fun ppf () -> pf ppf "`Custom \"%a\"" string s) - ppf () - end - - let perform_action (a : Action.t) (path : path) (node : node) : - node option = - match a with - | `Move (`Forward `Line) -> - (* let i = ref 0 in - ignore - (search_backward - (function - | { t = `Atom (`Boundary `Line); _ } -> Some () - | { t = `Atom (`Uchar _); _ } -> - incr i; - None - | _ -> None) - path); - match search_forward (is_boundary `Line) path with - | Some n' -> - Some - (tree_iter - (fun nn -> - Option.value - (search_forward (is_boundary `Char) nn) - ~default:nn) - n' !i) - | None -> *) - None - | `Move (`Backward `Line) -> - (* let i = ref 0 in - match - search_backward - (function - | { t = `Atom (`Boundary `Line); _ } as n' -> Some n' - | { t = `Atom (`Uchar _); _ } -> - incr i; - None - | _ -> None) - c.sel - with - | Some n' -> - Option.map - (fun n -> tree_iter tree_uchar_back n !i) - (search_backward (is_boundary `Line) n') - | None ->*) - None - (* | `Move (`Forward b) -> - Option.map tree_uchar_fwd - (search_forward (is_boundary b) c.sel) - | `Move (`End b) -> - 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_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 -> option_of_parent c.sel.parent*) - | `Custom _s -> None - | _ -> None - - type event_status = [ `Handled | `Event of Event.t ] - - let default_bindings = - let open Key.Bind in - empty - |> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ] - |> add [ ([], U (`Arrow `Right)) ] [ `Move (`Forward `Char) ] - |> add [ ([ Ctrl ], C 'b') ] [ `Move (`Backward `Char) ] - |> add [ ([], U (`Arrow `Left)) ] [ `Move (`Backward `Char) ] - |> add [ ([ Meta ], C 'f') ] [ `Move (`Forward `Word) ] - |> add [ ([ Meta ], C 'b') ] [ `Move (`Backward `Word) ] - |> add - [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'n') ] - [ `Move (`Forward `Phrase) ] - |> add - [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'p') ] - [ `Move (`Backward `Phrase) ] - |> add [ ([ Ctrl ], C 'n') ] [ `Move (`Forward `Line) ] - |> add [ ([], U (`Arrow `Down)) ] [ `Move (`Forward `Line) ] - |> add [ ([ Ctrl ], C 'p') ] [ `Move (`Backward `Line) ] - |> add [ ([], U (`Arrow `Up)) ] [ `Move (`Backward `Line) ] - |> add [ ([ Ctrl ], C 'v') ] [ `Move (`Forward `Page) ] - |> add [ ([ Meta ], C 'v') ] [ `Move (`Backward `Page) ] - |> 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 - [ ([ Ctrl ], C 'x'); ([], U `Backspace) ] - [ `Kill (`Backward `Phrase) ] - |> add [ ([ Ctrl ], C 'q') ] [ `Ascend ] - |> add [ ([ Ctrl ], C 'z') ] [ `Descend ] - - let cursor_attr = - `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.)) - - let node_structure root = - Lwd.map - ~f:(fun node -> - Page.Text.lines (Fmt.to_to_string pp_node_structure node)) - root - - let draw_path path = - Lwd.map - ~f:(fun path -> - Page.Text.lines (Fmt.to_to_string pp_path path)) - path - - let nav_handler ?(bindings = default_bindings) - ((page, path) : node Lwd.t * Page.path) = - let page, path = (Lwd.var page, Lwd.var path) in - let bind = Key.Bind.init bindings in - handler - (fun (root : node) (e : Event.t) : node -> - 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 (Page.atom (`Uchar c))) - | _ -> None) - | _ -> None) - in - match a with - | Some x -> ( - match perform_action x (Lwd.get path) root with - | Some n' -> - Log.info (fun m -> - m "nav_handler action @[%a@] Success@." - Action.pp_t x); - n' - | None -> - Log.warn (fun m -> - m "nav_handler action @[%a@] Failure@." - Action.pp_t x); - root) - | None -> root) - (join_y - (pad 5. (Lwd.join @@ Lwd.get page)) - (join_y - (pad 5. (draw_path (Lwd.get path))) - (pad 5. (node_structure (Lwd.join @@ Lwd.get page))))) - - let is_handler (n : node) : Page.handler option = - match n with `Attr (`Handler f, _) -> Some f | _ -> None - - (* * receives a node document and event and returns a node document where that event is handled *) - let handle_event (n : t) (ev : Event.t) : t = - Lwd.map - ~f:(fun t -> - let handlers = - Page.fold_preorder - (fun acc n' -> - match is_handler n' with - | Some f -> Some (f :: acc) - | None -> Some acc) - [] t - in - List.fold_left (fun acc f -> f acc ev) t handlers) - n - - module Text = struct - let lines = Lwd.map ~f:Page.Text.lines - let of_string = Lwd.map ~f:Page.Text.of_string - end - - module View = struct - type path = Nav.path - - type t = { - tree : Nav.tree; - view : path list Lwd.var; - cursor : Nav.path Lwd.var; - doc : node Lwd.t; + type t = { fg : Color.t; bg : Color.t; font : Font.t } + type attr = t + + let equal = ( == ) + + let empty = + { + fg = Color.transparent; + bg = Color.transparent; + font = Font.empty; + } + + let dark = { empty with fg = Color.light; bg = Color.dark } + + let ( ++ ) a1 a2 = + if a1 == empty then a2 + else if a2 == empty then a1 + else + { + a1 with + fg = Color.lerp a1.fg a2.fg ~a:0.5; + bg = Color.lerp a1.bg a2.bg ~a:0.5; } - open Lwt.Infix + let fg c = { empty with fg = c } + let bg c = { empty with bg = c } - let of_path path = - join_x - (Text.of_string (Lwd.pure "/")) - (Lwd_utils.map_reduce - (fun step -> Lwd.pure (Page.Text.of_string ("/" ^ step))) - pack_x path) + let merge a b = + { + fg = Color.lerp a.fg b.fg ~a:0.5; + bg = Color.lerp a.bg b.bg ~a:0.5; + font = Font.merge a.font b.font; + } - let of_tree ?(path = []) tree = - Nav.S.Tree.list tree path >>= fun l -> - Lwt.return - { - tree; - view = Lwd.var [ path ]; - cursor = Lwd.var path; - doc = - Lwd_utils.map_reduce - (fun (step, _t') -> Text.of_string (Lwd.pure step)) - pack_y l; - } + let set vg s = + F.epr "Style.set @."; + NVG.set_fill_color vg ~color:s.bg; + NVG.set_stroke_color vg ~color:s.fg; + Font.set vg s.font +end - let list_logs hook = - let var = Lwd.var Page.empty in - (hook := - fun level s -> - Lwd.set var - Page.( - join_y - (Text.of_string - (Logs.level_to_string (Some level) ^ ": " ^ s)) - (Lwd.peek var))); - Lwd.get var +module Pad = struct + open Gg - let draw (vg, p) (root : node Lwd.root) : Page.Draw.p Lwt.t = - Lwt.return (Page.Draw.node vg p (Lwd.quick_sample root)) - end + type t = { t : size1; b : size1; l : size1; r : size1 } - open Lwt.Infix + let empty = + { t = Size1.zero; b = Size1.zero; l = Size1.zero; r = Size1.zero } - (* event handler just needs to result in a Lwd.set on some portion of the doc root - and then trigger a request animation frame *) - let renderer (root : t Lwd.var) : - NVG.t -> ?time:float -> Gg.p2 -> Gg.p2 Lwt.t = - let root = - Lwd.observe - ~on_invalidate:(fun _ -> - Log.warn (fun m -> m "View.draw doc_root on_invalidate")) - (Lwd.join (Lwd.get root)) + let all v = { t = v; b = v; l = v; r = v } +end + +(* from notty.ml *) +let btw (x : int) a b = a <= x && x <= b + +module Buffer = struct + include Stdlib.Buffer + + let buf = create 1024 + + let mkstring f = + f buf; + let res = contents buf in + reset buf; + res + + let add_decimal b = function + | x when btw x 0 999 -> + let d1 = x / 100 and d2 = x mod 100 / 10 and d3 = x mod 10 in + if d1 > 0 then 0x30 + d1 |> Char.unsafe_chr |> add_char b; + if d1 + d2 > 0 then 0x30 + d2 |> Char.unsafe_chr |> add_char b; + 0x30 + d3 |> Char.unsafe_chr |> add_char b + | x -> string_of_int x |> add_string b + + let add_chars b c n = + for _ = 1 to n do + add_char b c + done +end + +module String = struct + include String + + let sub0cp s i len = + if i > 0 || len < length s then sub s i len else s + + let of_chars_rev = function + | [] -> "" + | [ c ] -> String.make 1 c + | cs -> + let n = List.length cs in + let rec go bs i = + Bytes.( + function + | [] -> unsafe_to_string bs + | x :: xs -> + unsafe_set bs i x; + go bs (pred i) xs) + in + go (Bytes.create n) (n - 1) cs +end + +module Text = struct + type t = String of string (* | Uchars of Uchar.t list*) + + let empty = String "" + + let equal = function + | String a -> ( function String b -> String.equal a b) + + let of_string s = String s + let to_string = function String s -> s + + let of_uchars ucs = + of_string @@ Buffer.mkstring + @@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs + + let replicatec w c = String (String.make (int_of_float w) c) + + let pp ppf : t -> unit = function + | String s -> F.(fmt "String %s" ppf s) +end + +module A = Style + +module I = struct + open Gg + + type dim = p2 + + type t = + | Empty + | Segment of Text.t + | Attr of (t * A.t) + | Hcompose of (t * t) + | Vcompose of (t * t) + | Zcompose of (t * t) + | Hcrop of (t * float * float) + | Vcrop of (t * float * float) + | Void of dim + + let p2_max p1 p2 : p2 = + V2.(v (Float.max (x p1) (x p2)) (Float.max (y p1) (y p2))) + [@@inline] + + let rec size vg p = function + | Empty -> V2.zero + | Segment s -> + let NVG.Bounds.{ xmin; ymin; xmax; ymax } = + (NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p) + (Text.to_string s)) + .box + in + V2.v (xmax -. xmin) (ymax -. ymin) + | Attr (t, _a) -> size vg p t + | Hcompose (t1, t2) -> + let p1 = size vg p t1 in + let p2 = size vg V2.(p + v (x p1) 0.) t2 in + p2_max p1 p2 + | Vcompose (t1, t2) -> + let p1 = size vg p t1 in + let p2 = size vg V2.(p + v 0. (y p1)) t2 in + p2_max p1 p2 + | Zcompose (t1, t2) -> p2_max (size vg p t1) (size vg p t2) + | Hcrop (t, left, right) -> + V2.(size vg (p - v left 0.) t - v right 0.) + | Vcrop (t, top, bottom) -> + V2.(size vg (p - v 0. top) t - v 0. bottom) + | Void p' -> V2.(p + p') + + let empty = Empty + let void w h = Void (P2.v w h) + + let attr a = function + | Attr (t, a0) -> Attr (t, A.(a ++ a0)) + | t -> Attr (t, a) + + let ( <|> ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> Hcompose (t1, t2) + + let ( <-> ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> Vcompose (t1, t2) + + let ( ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> Zcompose (t1, t2) + + let hcrop left right img = Hcrop (img, left, right) + let vcrop top bottom img = Vcrop (img, top, bottom) + + let crop ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img = + let img = if l <> 0. || r <> 0. then hcrop l r img else img in + if t <> 0. || b <> 0. then vcrop t b img else img + + let hpad left right img = hcrop (-.left) (-.right) img + let vpad top bottom img = vcrop (-.top) (-.bottom) img + + let pad ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img = + crop ~l:(-.l) ~r:(-.r) ~t:(-.t) ~b:(-.b) img + + let rec concatm z ( @ ) xs = + let rec accum ( @ ) = function + | ([] | [ _ ]) as xs -> xs + | a :: b :: xs -> (a @ b) :: accum ( @ ) xs + in + match xs with + | [] -> z + | [ x ] -> x + | xs -> concatm z ( @ ) (accum ( @ ) xs) + + let hcat = concatm empty ( <|> ) + let vcat = concatm empty ( <-> ) + let zcat xs = List.fold_right ( ) xs empty + + let text attr tx = + match attr with Some a -> Attr (Segment tx, a) | _ -> Segment tx + + let string ?attr s = text attr (Text.of_string s) + let uchars ?attr a = text attr (Text.of_uchars a) + + let rec linspcm z ( @ ) x n f = + match n with + | 0. -> z + | 1. -> f x + | _ -> + let m = n /. 2. in + linspcm z ( @ ) x m f @ linspcm z ( @ ) (x +. m) (n -. m) f + + let tabulate m n f = + let m = max m 0. and n = max n 0. in + linspcm empty ( <-> ) 0. n (fun y -> + linspcm empty ( <|> ) 0. m (fun x -> f x y)) + + let chars ctor ?attr c w h = + let w = max 0. w and h = max 0. h in + if w < 1. || h < 1. then void w h + else + let line = text attr (ctor w c) in + tabulate 1. h (fun _ _ -> line) + + let char = chars Text.replicatec + (* let uchar = chars Text.replicateu *) + + (* module Fmt = struct + open Format + + type stag += Attr of A.t + + let push r x = r := x :: !r + let pop r = r := match !r with _ :: xs -> xs | _ -> [] + let top_a r = match !r with a :: _ -> a | _ -> A.empty + + let create () = + let img, line, attr = (ref empty, ref empty, ref []) in + let fmt = + formatter_of_out_functions + { + out_flush = + (fun () -> + img := !img <-> !line; + line := empty; + attr := []); + out_newline = + (fun () -> + img := !img <-> !line; + line := void 0. 1.); + out_string = + (fun s i n -> + line := + !line + <|> string ~attr:(top_a attr) + String.(sub0cp s i n)) + (* Not entirely clear; either or both could be void: *); + out_spaces = + (fun w -> + line := !line <|> char ~attr:(top_a attr) ' ' w 1); + out_indent = + (fun w -> + line := !line <|> char ~attr:(top_a attr) ' ' w 1); + } + in + pp_set_formatter_stag_functions fmt + { + (pp_get_formatter_stag_functions fmt ()) with + mark_open_stag = + (function + | Attr a -> + push attr A.(top_a attr ++ a); + "" + | _ -> ""); + mark_close_stag = + (fun _ -> + pop attr; + ""); + }; + pp_set_mark_tags fmt true; + ( fmt, + fun () -> + let i = !img in + img := empty; + line := empty; + attr := []; + i ) + + let ppf, reset = create () + + let kstrf ?(attr = A.empty) ?(w = 1000000) k format = + let m = ref 0 in + let f1 _ () = + m := pp_get_margin ppf (); + pp_set_margin ppf w; + pp_open_stag ppf (Attr attr) + and k _ = + pp_print_flush ppf (); + pp_set_margin ppf !m; + reset () |> k + in + kfprintf k ppf ("%a" ^^ format) f1 () + + let strf ?attr ?w format = kstrf ?attr ?w (fun i -> i) format + + let attr attr f fmt x = + pp_open_stag fmt (Attr attr); + f fmt x; + pp_close_stag fmt () + end + + let kstrf, strf, pp_attr = Fmt.(kstrf, strf, attr) *) + + module Draw = struct + type attr = Style.t + type p = P2.t + type d = [ `X | `Y | `Z ] + + let vcat d a b = + match d with + | `X -> + V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b)) + | `Y -> V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b) + | `Z -> + V2.v + (Float.max_num (V2.x a) (V2.x b)) + (Float.max_num (V2.y a) (V2.y b)) + + let rec pp ppf : t -> unit = function + | Empty -> F.(fmt "Empty" ppf) + | Segment v -> F.(fmt "Segment %a" ppf (parens Text.pp) v) + | Attr v -> + F.(fmt "Attr %a" ppf (pair (parens pp) (any "...")) v) + | Hcompose a -> + F.(fmt "Hcompose %a" ppf (pair (parens pp) (parens pp)) a) + | Vcompose a -> + F.(fmt "Vcompose %a" ppf (pair (parens pp) (parens pp)) a) + | Zcompose a -> + F.(fmt "Zcompose %a" ppf (pair (parens pp) (parens pp)) a) + | Hcrop (t, h, w) -> F.(fmt "Hcrop (%a,%f,%f)" ppf pp t h w) + | Vcrop (t, h, w) -> F.(fmt "Vcrop (%a,%f,%f)" ppf pp t h w) + | Void dim -> F.(fmt "Void %a" ppf (parens V2.pp) dim) + + let rec segment vg p : Text.t -> P2.t = function + | String s -> + Log.debug (fun m -> m "I.Draw.segment p=%a %s" Gg.V2.pp p s); + let metrics = NVG.Text.metrics vg in + let twidth = + NVG.Text.text_w vg ~x:(V2.x p) + ~y:(V2.y p +. metrics.ascender) + s + in + V2.( + p + + v twidth + (P2.y p +. metrics.ascender +. metrics.descender + +. metrics.line_height)) + + and node vg attr p n : p2 = + let b' = + match n with + | Empty | Void _ -> p + | Segment text -> segment vg p text + | Attr (i, a0) -> + let p1 = node vg A.(attr ++ a0) p i in + (* TODO need to set that weird "draw under" thing here *) + if Style.(attr.fg) != a0.fg then + NVG.set_stroke_color vg ~color:Style.(attr.fg); + if Style.(attr.bg) != a0.bg then + NVG.set_fill_color vg ~color:Style.(attr.bg); + p1 + | Hcompose (i1, i2) -> + let p1 = node vg attr p i1 in + let p2 = node vg attr V2.(p + v (V2.x p1) 0.) i2 in + p2_max p1 p2 + | Vcompose (i1, i2) -> + let p1 = node vg attr p i1 in + let p2 = node vg attr V2.(p + v 0. (V2.y p1)) i2 in + p2_max p1 p2 + | Zcompose (i1, i2) -> + let p1 = node vg attr p i1 in + let p2 = node vg attr p i2 in + p2_max p1 p2 + | Hcrop (i, left, right) -> node vg attr p i + | Vcrop (i, top, bottom) -> node vg attr p i in - fun vg ?(time = 0.) p -> - View.draw ({ vg; style = Style.dark; time }, p) root - - let boot_page : node Lwd.t Lwt.t = - Nav.test_pull () >>= fun tree -> - View.of_tree tree >>= fun tv -> - Lwt.return - (vcat - [ - nav_handler (tv.doc, []); - View.of_path (Lwd.peek tv.cursor); - View.list_logs Logs_reporter.hook; - ]) + (* ignore + (path_box vg.vg + (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) + (Box2.of_pts b b')); *) + b' end end -(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) +module Nottui = struct + let maxi x y : int = if x > y then x else y + let mini x y : int = if x < y then x else y -(* FUTURE: (thinking now this should be based on react for that sweet incremental compuation) + module Focus : sig + type var = int Lwd.var + type handle - type panetree - type eventree - type imagetree + val make : unit -> handle + val request : handle -> unit + val request_var : var -> unit + val release : handle -> unit - Display.run should be: - Init: setup initial panetree and compute eventree and imagetree from it.last_actions - New events trigger parsing the eventree, the results of which update the imagetree - which is then parsed and displayed. *) + type status = Empty | Handle of int * var | Conflict of int -(* 220805: This is fundamentally trying to: - - display lines of text in a variety of ways - - allow manipulation of the display of the document - - display and manipulate history of the document - - turn the document into a tree - the + val empty : status - your previous idea around the binary tree display layout is ok but is it really trying to shove documents into trees when you can't then de-encode them into a file? That seems rough... + (*val is_empty : status -> bool*) + val status : handle -> status Lwd.t + val has_focus : status -> bool + val merge : status -> status -> status + end = struct + type var = int Lwd.var + type status = Empty | Handle of int * var | Conflict of int + type handle = var * status Lwd.t - you have an in-memory irmin store, and you really just want to be able to navigate it - but it's going to be lots of linear things (the internet, lol), so you still need linear document navigation - but what if you can rethink linear document navigation but switching the tree structure around while still making the layout a tree (Irmin.Tree), but now the history is a tree (Irmin.History) which just encodes the state of the display. This would require an in-memory Irmin store that + let make () = + let v = Lwd.var 0 in + (v, Lwd.map ~f:(fun i -> Handle (i, v)) (Lwd.get v)) - 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) -*) + let empty : status = Empty + let status (h : handle) : status Lwd.t = snd h -(* 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 *) + let has_focus = function + | Empty -> false + | Handle (i, _) | Conflict i -> i > 0 + + let clock = ref 0 + + let request_var (v : var) = + incr clock; + Lwd.set v !clock + + let request ((v, _) : handle) = request_var v + + let release ((v, _) : handle) = + incr clock; + Lwd.set v 0 + + let merge s1 s2 : status = + match (s1, s2) with + | Empty, x | x, Empty -> x + | _, Handle (0, _) -> s1 + | Handle (0, _), _ -> s2 + | Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1 + | (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2 + | (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 -> + Conflict i2 + | Conflict _, (Handle (_, _) | Conflict _) -> s1 + | Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1 + end + + module Gravity : sig + type direction = [ `Negative | `Neutral | `Positive ] + + val pp_direction : Format.formatter -> direction -> unit + + type t + + val pp : Format.formatter -> t -> unit + val make : h:direction -> v:direction -> t + val default : t + val h : t -> direction + val v : t -> direction + + type t2 + + val pair : t -> t -> t2 + val p1 : t2 -> t + val p2 : t2 -> t + end = struct + type direction = [ `Negative | `Neutral | `Positive ] + type t = int + type t2 = int + + let default = 0 + + let pack = function + | `Negative -> 0 + | `Neutral -> 1 + | `Positive -> 2 + + let unpack = function + | 0 -> `Negative + | 1 -> `Neutral + | _ -> `Positive + + let make ~h ~v = (pack h lsl 2) lor pack v + let h x = unpack (x lsr 2) + let v x = unpack (x land 3) + + let pp_direction ppf dir = + let text = + match dir with + | `Negative -> "`Negative" + | `Neutral -> "`Neutral" + | `Positive -> "`Positive" + in + Format.pp_print_string ppf text + + let pp ppf g = + Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g) + pp_direction (v g) + + let pair t1 t2 = (t1 lsl 4) lor t2 + let p1 t = (t lsr 4) land 15 + let p2 t = t land 15 + end + + type gravity = Gravity.t + + module Interval : sig + type t + + val make : float -> float -> t + val shift : t -> float -> t + val fst : t -> float + val snd : t -> float + + (*val size : t -> int*) + val zero : t + end = struct + type t = float * float + + let make x y = (x, y) + let shift (x, y) d = (x +. d, y +. d) + let fst (x, _) = x + let size (x, y) = y -. x + let snd (_, y) = y + let zero = (0., 0.) + end + + module Ui = struct + type may_handle = [ `Unhandled | `Handled ] + + type mouse_handler = + x:float -> + y:float -> + Input.button -> + [ `Unhandled + | `Handled + | `Grab of + (x:float -> y:float -> unit) * (x:float -> y:float -> unit) + ] + + type semantic_key = + [ (* Clipboard *) + `Copy + | `Paste + | (* Focus management *) + `Focus of + [ `Next | `Prev | `Left | `Right | `Up | `Down ] ] + + type key = + [ Input.special + | `Uchar of Uchar.t + | `ASCII of char + | semantic_key ] + * Input.mods + + type mouse = Input.mouse + + type event = + [ `Key of key | `Mouse of mouse | `Paste of Input.paste ] + + type layout_spec = { + w : float; + h : float; + sw : float; + sh : float; + } + + let pp_layout_spec ppf { w; h; sw; sh } = + Format.fprintf ppf "{ w = %f; h = %f; sw = %f; sh = %f }" w h sw + sh + + type flags = int + + let flags_none = 0 + let flag_transient_sensor = 1 + let flag_permanent_sensor = 2 + + type size_sensor = w:float -> h:float -> unit + + type frame_sensor = + x:float -> y:float -> w:float -> h:float -> unit -> unit + + type t = { + w : float; + sw : float; + h : float; + sh : float; + mutable desc : desc; + focus : Focus.status; + mutable flags : flags; + mutable sensor_cache : (float * float * float * float) option; + mutable cache : cache; + } + + and image = I.t + and cache = { vx : Interval.t; vy : Interval.t; image : image } + + and desc = + | Atom of image + | Size_sensor of t * size_sensor + | Transient_sensor of t * frame_sensor + | Permanent_sensor of t * frame_sensor + | Resize of t * Gravity.t2 * A.t + | Mouse_handler of t * mouse_handler + | Focus_area of t * (key -> may_handle) + | Shift_area of t * float * float + | Event_filter of + t * ([ `Key of key | `Mouse of mouse ] -> may_handle) + | X of t * t + | Y of t * t + | Z of t * t + + let layout_spec t : layout_spec = + { w = t.w; h = t.h; sw = t.sw; sh = t.sh } + + let layout_width t = t.w + let layout_stretch_width t = t.sw + let layout_height t = t.h + let layout_stretch_height t = t.sh + + let cache : cache = + { vx = Interval.zero; vy = Interval.zero; image = I.empty } + + let empty : t = + { + w = 0.; + sw = 0.; + h = 0.; + sh = 0.; + flags = flags_none; + focus = Focus.empty; + desc = Atom I.empty; + sensor_cache = None; + cache; + } + + let atom img : t = + { + w = 0.; + sw = 0.; + h = 0.; + sh = 0.; + focus = Focus.empty; + flags = flags_none; + desc = Atom img; + sensor_cache = None; + cache; + } + + (* let space_1_0 = atom (I.void 1 0) + let space_0_1 = atom (I.void 0 1) + let space_1_1 = atom (I.void 1 1) + + let space x y = + match (x, y) with + | 0, 0 -> empty + | 1, 0 -> space_1_0 + | 0, 1 -> space_0_1 + | 1, 1 -> space_1_1 + | _ -> atom (I.void x y) *) + + let space x y = atom (I.void x y) + let mouse_area f t : t = { t with desc = Mouse_handler (t, f) } + + let keyboard_area ?focus f t : t = + let focus = + match focus with + | None -> t.focus + | Some focus -> Focus.merge focus t.focus + in + { t with desc = Focus_area (t, f); focus } + + let shift_area x y t : t = { t with desc = Shift_area (t, x, y) } + + let size_sensor handler t : t = + { t with desc = Size_sensor (t, handler) } + + let transient_sensor frame_sensor t = + { + t with + desc = Transient_sensor (t, frame_sensor); + flags = t.flags lor flag_transient_sensor; + } + + let permanent_sensor frame_sensor t = + { + t with + desc = Permanent_sensor (t, frame_sensor); + flags = t.flags lor flag_permanent_sensor; + } + + let prepare_gravity = function + | None, None -> Gravity.(pair default default) + | Some g, None | None, Some g -> Gravity.(pair g g) + | Some pad, Some crop -> Gravity.(pair pad crop) + + let resize ?w ?h ?sw ?sh ?pad ?crop ?(bg = A.empty) t : t = + let g = prepare_gravity (pad, crop) in + match ((w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh)) with + | ( (Some w, _ | None, w), + (Some h, _ | None, h), + (Some sw, _ | None, sw), + (Some sh, _ | None, sh) ) -> + { t with w; h; sw; sh; desc = Resize (t, g, bg) } + + let resize_to ({ w; h; sw; sh } : layout_spec) ?pad ?crop + ?(bg = A.empty) t : t = + let g = prepare_gravity (pad, crop) in + { t with w; h; sw; sh; desc = Resize (t, g, bg) } + + let event_filter ?focus f t : t = + let focus = + match focus with None -> t.focus | Some focus -> focus + in + { t with desc = Event_filter (t, f); focus } + + let join_x a b = + { + w = a.w +. b.w; + sw = a.sw +. b.sw; + h = max a.h b.h; + sh = max a.sh b.sh; + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; + desc = X (a, b); + sensor_cache = None; + cache; + } + + let join_y a b = + { + w = max a.w b.w; + sw = max a.sw b.sw; + h = a.h +. b.h; + sh = a.sh +. b.sh; + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; + desc = Y (a, b); + sensor_cache = None; + cache; + } + + let join_z a b = + { + w = max a.w b.w; + sw = max a.sw b.sw; + h = max a.h b.h; + sh = max a.sh b.sh; + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; + desc = Z (a, b); + sensor_cache = None; + cache; + } + + let pack_x = (empty, join_x) + let pack_y = (empty, join_y) + let pack_z = (empty, join_z) + let hcat xs = Lwd_utils.reduce pack_x xs + let vcat xs = Lwd_utils.reduce pack_y xs + let zcat xs = Lwd_utils.reduce pack_z xs + let has_focus t = Focus.has_focus t.focus + + let rec pp ppf t = + Format.fprintf ppf + "@[{@ w = %f;@ h = %f;@ sw = %f;@ sh = %f;@ desc = \ + @[%a@];@ }@]" + t.w t.h t.sw t.sh pp_desc t.desc + + and pp_desc ppf = function + | Atom _ -> Format.fprintf ppf "Atom _" + | Size_sensor (desc, _) -> + Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc + | Transient_sensor (desc, _) -> + Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc + | Permanent_sensor (desc, _) -> + Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc + | Resize (desc, gravity, _bg) -> + Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc + Gravity.pp (Gravity.p1 gravity) Gravity.pp + (Gravity.p2 gravity) + | Mouse_handler (n, _) -> + Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n + | Focus_area (n, _) -> + Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n + | Shift_area (n, _, _) -> + Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n + | Event_filter (n, _) -> + Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n + | X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b + | Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b + | Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b + + let iter f ui = + match ui.desc with + | Atom _ -> () + | Size_sensor (u, _) + | Transient_sensor (u, _) + | Permanent_sensor (u, _) + | Resize (u, _, _) + | Mouse_handler (u, _) + | Focus_area (u, _) + | Shift_area (u, _, _) + | Event_filter (u, _) -> + f u + | X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> + f u1; + f u2 + end + + type ui = Ui.t + + module Renderer = struct + open Ui + + type size = Gg.p2 + + type grab_function = + (x:float -> y:float -> unit) * (x:float -> y:float -> unit) + + type t = { + mutable size : size; + mutable view : ui; + mutable mouse_grab : grab_function option; + } + + let make () = { mouse_grab = None; size = P2.o; view = Ui.empty } + let size t = t.size + + let solve_focus ui i = + let rec aux ui = + match ui.focus with + | Focus.Empty | Focus.Handle (0, _) -> () + | Focus.Handle (i', _) when i = i' -> () + | Focus.Handle (_, v) -> Lwd.set v 0 + | Focus.Conflict _ -> Ui.iter aux ui + in + aux ui + + let split ~a ~sa ~b ~sb total = + let stretch = sa +. sb in + let flex = total -. a -. b in + if stretch > 0. && flex > 0. then + let ratio = + if sa > sb then flex *. sa /. stretch + else flex -. (flex *. sb /. stretch) + in + (a +. ratio, b +. flex -. ratio) + else (a, b) + + let pack ~fixed ~stretch total g1 g2 = + let flex = total -. fixed in + if stretch > 0. && flex > 0. then (0., total) + else + let gravity = if flex >= 0. then g1 else g2 in + match gravity with + | `Negative -> (0., fixed) + | `Neutral -> (flex /. 2., fixed) + | `Positive -> (flex, fixed) + + let has_transient_sensor flags = + flags land flag_transient_sensor <> 0 + + let has_permanent_sensor flags = + flags land flag_permanent_sensor <> 0 + + let rec update_sensors ox oy sw sh ui = + if + has_transient_sensor ui.flags + || has_permanent_sensor ui.flags + && + match ui.sensor_cache with + | None -> false + | Some (ox', oy', sw', sh') -> + ox = ox' && oy = oy' && sw = sw' && sh = sh' + then ( + ui.flags <- ui.flags land lnot flag_transient_sensor; + if has_permanent_sensor ui.flags then + ui.sensor_cache <- Some (ox, oy, sw, sh); + match ui.desc with + | Atom _ -> () + | Size_sensor (t, _) + | Mouse_handler (t, _) + | Focus_area (t, _) + | Event_filter (t, _) -> + update_sensors ox oy sw sh t + | Transient_sensor (t, sensor) -> + ui.desc <- t.desc; + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Permanent_sensor (t, sensor) -> + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Resize (t, g, _) -> + let open Gravity in + let dx, rw = + pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) + in + let dy, rh = + pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) + in + update_sensors (ox +. dx) (oy +. dy) rw rh t + | Shift_area (t, sx, sy) -> + update_sensors (ox -. sx) (oy -. sy) sw sh t + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + update_sensors ox oy aw sh a; + update_sensors (ox +. aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + update_sensors ox oy sw ah a; + update_sensors ox (oy +. ah) sw bh b + | Z (a, b) -> + update_sensors ox oy sw sh a; + update_sensors ox oy sw sh b) + + let update_focus ui = + match ui.focus with + | Focus.Empty | Focus.Handle _ -> () + | Focus.Conflict i -> solve_focus ui i + + let update t size ui = + t.size <- size; + t.view <- ui; + update_sensors 0. 0. (P2.x size) (P2.y size) ui; + update_focus ui + + let dispatch_mouse st x y btn w h t = + let handle ox oy f = + match f ~x:(x -. ox) ~y:(y -. oy) btn with + | `Unhandled -> false + | `Handled -> true + | `Grab f -> + st.mouse_grab <- Some f; + true + in + let rec aux ox oy sw sh t = + match t.desc with + | Atom _ -> false + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + if x -. ox < aw then aux ox oy aw sh a + else aux (ox +. aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + if y -. oy < ah then aux ox oy sw ah a + else aux ox (oy +. ah) sw bh b + | Z (a, b) -> aux ox oy sw sh b || aux ox oy sw sh a + | Mouse_handler (t, f) -> + let _offsetx, rw = + pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative + and _offsety, rh = + pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative + in + assert (_offsetx = 0. && _offsety = 0.); + (x -. ox >= 0. + && x -. ox <= rw + && y -. oy >= 0. + && y -. oy <= rh) + && (aux ox oy sw sh t || handle ox oy f) + | Size_sensor (desc, _) + | Transient_sensor (desc, _) + | Permanent_sensor (desc, _) + | Focus_area (desc, _) -> + aux ox oy sw sh desc + | Shift_area (desc, sx, sy) -> + aux (ox -. sx) (oy -. sy) sw sh desc + | Resize (t, g, _bg) -> + let open Gravity in + let dx, rw = + pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) + in + let dy, rh = + pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) + in + aux (ox +. dx) (oy +. dy) rw rh t + | Event_filter (n, f) -> ( + match f (`Mouse (`Press btn, (x, y), [])) with + | `Handled -> true + | `Unhandled -> aux ox oy sw sh n) + in + aux 0. 0. w h t + + let release_grab st x y = + match st.mouse_grab with + | None -> () + | Some (_, release) -> + st.mouse_grab <- None; + release ~x ~y + + let resize_canvas vg rw rh image = + let w, h = V2.to_tuple @@ I.size vg V2.zero image in + if w <> rw || h <> rh then I.pad ~r:(rw -. w) ~b:(rh -. h) image + else image + + let resize_canvas2 vg ox oy rw rh image = + let w, h = V2.to_tuple @@ I.size vg V2.zero image in + I.pad ~l:ox ~t:oy ~r:(rw -. w -. ox) ~b:(rh -. h -. oy) image + + let same_size vg w h image = + V2.(equal (of_tuple (w, h)) (I.size vg V2.zero image)) + + let dispatch_mouse t (event, (x, y), _mods) = + if + match event with + | `Press btn -> + release_grab t x y; + let w, h = V2.to_tuple t.size in + dispatch_mouse t x y btn w h t.view + | `Drag -> ( + match t.mouse_grab with + | None -> false + | Some (drag, _) -> + drag ~x ~y; + true) + | `Release -> + release_grab t x y; + true + then `Handled + else `Unhandled + + let rec render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1) + (vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache = + if + let cache = t.cache in + vx1 >= Interval.fst cache.vx + && vy1 >= Interval.fst cache.vy + && vx2 <= Interval.snd cache.vx + && vy2 <= Interval.snd cache.vy + then t.cache + else if vx2 < 0. || vy2 < 0. || sw < vx1 || sh < vy1 then + { + vx = Interval.make vx1 vx2; + vy = Interval.make vy1 vy2; + image = I.void sw sh; + } + else + let cache = + match t.desc with + | Atom image -> + { + vx = Interval.make 0. sw; + vy = Interval.make 0. sh; + image = resize_canvas vg sw sh image; + } + | Size_sensor (desc, handler) -> + handler ~w:sw ~h:sh; + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) -> + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Focus_area (desc, _) | Mouse_handler (desc, _) -> + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Shift_area (t', sx, sy) -> + let cache = + render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx) + (vy2 +. sy) (sx +. sw) (sy +. sh) t' + in + let vx = Interval.make vx1 vx2 + and vy = Interval.make vy1 vy2 in + let image = + resize_canvas vg sw sh + (I.crop ~l:sx ~t:sy cache.image) + in + { vx; vy; image } + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in + let cb = + render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b + in + let vx = + Interval.make + (max (Interval.fst ca.vx) + (Interval.fst cb.vx +. aw)) + (min (Interval.snd ca.vx) + (Interval.snd cb.vx +. aw)) + and vy = + Interval.make + (max (Interval.fst ca.vy) (Interval.fst cb.vy)) + (min (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = + resize_canvas vg sw sh (I.( <|> ) ca.image cb.image) + in + { vx; vy; image } + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in + let cb = + render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b + in + let vx = + Interval.make + (max (Interval.fst ca.vx) (Interval.fst cb.vx)) + (min (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = + Interval.make + (max (Interval.fst ca.vy) + (Interval.fst cb.vy +. ah)) + (min (Interval.snd ca.vy) + (Interval.snd cb.vy +. ah)) + and image = + resize_canvas vg sw sh (I.( <-> ) ca.image cb.image) + in + { vx; vy; image } + | Z (a, b) -> + let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in + let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in + let vx = + Interval.make + (max (Interval.fst ca.vx) (Interval.fst cb.vx)) + (min (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = + Interval.make + (max (Interval.fst ca.vy) (Interval.fst cb.vy)) + (min (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = + resize_canvas vg sw sh (I.( ) cb.image ca.image) + in + { vx; vy; image } + | Resize (t, g, a) -> + let open Gravity in + let dx, rw = + pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) + in + let dy, rh = + pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) + in + let c = + render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx) + (vy2 -. dy) rw rh t + in + let image = resize_canvas2 vg dx dy sw sh c.image in + let image = + if a.bg != Color.none then + I.(image char ~attr:a ' ' sw sh) + else image + in + let vx = Interval.shift c.vx dx in + let vy = Interval.shift c.vy dy in + { vx; vy; image } + | Event_filter (t, _f) -> + render_node vg vx1 vy1 vx2 vy2 sw sh t + in + t.cache <- cache; + cache + + let image vg { size; view; _ } = + let w, h = V2.to_tuple size in + (render_node vg 0. 0. w h w h view).image + + let dispatch_raw_key st key = + let rec iter (st : ui list) : [> `Unhandled ] = + match st with + | [] -> `Unhandled + | ui :: tl -> ( + match ui.desc with + | Atom _ -> iter tl + | X (a, b) | Y (a, b) | Z (a, b) -> + (* Try left/top most branch first *) + let st' = + if Focus.has_focus b.focus then b :: tl + else a :: b :: tl + in + iter st' + | Focus_area (t, f) -> ( + match iter [ t ] with + | `Handled -> `Handled + | `Unhandled -> ( + match f key with + | `Handled -> `Handled + | `Unhandled -> iter tl)) + | Mouse_handler (t, _) + | Size_sensor (t, _) + | Transient_sensor (t, _) + | Permanent_sensor (t, _) + | Shift_area (t, _, _) + | Resize (t, _, _) -> + iter (t :: tl) + | Event_filter (t, f) -> ( + match f (`Key key) with + | `Unhandled -> iter (t :: tl) + | `Handled -> `Handled)) + in + iter [ st.view ] + + exception Acquired_focus + + let grab_focus ui = + let rec aux ui = + match ui.focus with + | Focus.Empty -> () + | Focus.Handle (_, v) -> + Focus.request_var v; + raise Acquired_focus + | Focus.Conflict _ -> iter aux ui + in + try + aux ui; + false + with Acquired_focus -> true + + let rec dispatch_focus t dir = + match t.desc with + | Atom _ -> false + | Mouse_handler (t, _) + | Size_sensor (t, _) + | Transient_sensor (t, _) + | Permanent_sensor (t, _) + | Shift_area (t, _, _) + | Resize (t, _, _) + | Event_filter (t, _) -> + dispatch_focus t dir + | Focus_area (t', _) -> + if Focus.has_focus t'.focus then + dispatch_focus t' dir || grab_focus t + else if Focus.has_focus t.focus then false + else grab_focus t + | X (a, b) -> ( + if Focus.has_focus a.focus then + dispatch_focus a dir + || + match dir with + | `Next | `Right -> dispatch_focus b dir + | _ -> false + else if Focus.has_focus b.focus then + dispatch_focus b dir + || + match dir with + | `Prev | `Left -> dispatch_focus a dir + | _ -> false + else + match dir with + | `Prev | `Left | `Up -> + dispatch_focus b dir || dispatch_focus a dir + | `Next | `Down | `Right -> + dispatch_focus a dir || dispatch_focus b dir) + | Y (a, b) -> ( + if Focus.has_focus a.focus then + dispatch_focus a dir + || + match dir with + | `Next | `Down -> dispatch_focus b dir + | _ -> false + else if Focus.has_focus b.focus then + dispatch_focus b dir + || + match dir with + | `Prev | `Up -> dispatch_focus a dir + | _ -> false + else + match dir with + | `Prev | `Up -> + dispatch_focus b dir || dispatch_focus a dir + | `Next | `Left | `Down | `Right -> + dispatch_focus a dir || dispatch_focus b dir) + | Z (a, b) -> + if Focus.has_focus a.focus then dispatch_focus a dir + else dispatch_focus b dir || dispatch_focus a dir + + let rec dispatch_key st key = + match (dispatch_raw_key st key, key) with + | `Handled, _ -> `Handled + | `Unhandled, (`Arrow dir, [ `Meta ]) -> + let dir : [ `Down | `Left | `Right | `Up ] :> + [ `Down | `Left | `Right | `Up | `Next | `Prev ] = + dir + in + dispatch_key st (`Focus dir, [ `Meta ]) + | `Unhandled, (`Tab, mods) -> + let dir = if List.mem `Shift mods then `Prev else `Next in + dispatch_key st (`Focus dir, mods) + | `Unhandled, (`Focus dir, _) -> + if dispatch_focus st.view dir then `Handled else `Unhandled + | `Unhandled, _ -> `Unhandled + + let dispatch_event t = function + | `Key key -> dispatch_key t key + | `Mouse mouse -> dispatch_mouse t mouse + | `Paste _ -> `Unhandled + end +end + +module Nottui_lwt = struct + open Nottui + + (* stolen from let-def/lwd/lib/nottui/nottui.ml* etc... *) + let copy_until quit ~f input = + let quit = Lwt.map (fun () -> None) quit in + let stream, push = Lwt_stream.create () in + let rec aux () = + Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ]) + @@ fun result -> + match result with + | None -> + push None; + Lwt.return_unit + | Some x -> + push (Some (f x)); + Lwt.bind (Lwt_stream.junk input) aux + in + Lwt.async aux; + stream + + let render vg ?quit ~size events doc = + let renderer = Renderer.make () in + let refresh_stream, push_refresh = Lwt_stream.create () in + let root = + Lwd.observe + ~on_invalidate:(fun _ -> + if not (Lwt_stream.is_closed refresh_stream) then + push_refresh (Some ())) + doc + in + let quit, do_quit = + match quit with + | Some quit -> (quit, None) + | None -> + let t, u = Lwt.wait () in + (t, Some u) + in + let events = + copy_until quit events ~f:(fun e -> + (e + : [ `Resize of _ | Ui.event ] + :> [ `Resize of _ | Ui.event ])) + in + let size = ref size in + let result, push = Lwt_stream.create () in + let refresh () = + (* FIXME This should use [Lwd.sample] with proper release management. *) + let ui = Lwd.quick_sample root in + Renderer.update renderer !size ui; + push (Some (Renderer.image vg renderer)) + in + refresh (); + let process_event = function + | `Key (`ASCII 'q', [ `Meta ]) as event -> ( + match do_quit with + | Some u -> Lwt.wakeup u () + | None -> ignore (Renderer.dispatch_event renderer event)) + | #Ui.event as event -> + ignore (Renderer.dispatch_event renderer event) + | `Resize size' -> + size := size'; + refresh () + in + Lwt.async (fun () -> + Lwt.finalize + (fun () -> Lwt_stream.iter process_event events) + (fun () -> + push None; + Lwt.return_unit)); + Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream); + result + + (* let run ?quit doc = + let term = Term.create () in + let images = + render ?quit ~size:(Term.size term) (Term.events term) doc + in + Lwt.finalize + (fun () -> Lwt_stream.iter_s (Term.image term) images) + (fun () -> Term.release term) *) +end + +module Nottui_widgets = struct + open Nottui + + let string ?(attr = A.empty) str = Ui.atom (I.string ~attr str) + let int ?attr x = string ?attr (string_of_int x) + let bool ?attr x = string ?attr (string_of_bool x) + let float_ ?attr x = string ?attr (string_of_float x) + let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt + let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt + + let kprintf k ?attr fmt = + Printf.ksprintf (fun str -> k (string ?attr str)) fmt + + let kfmt k ?attr fmt = + Format.kasprintf (fun str -> k (string ?attr str)) fmt + + let attr_menu_main = A.(bg Color.green ++ fg Color.black) + let attr_menu_sub = A.(bg Color.lightgreen ++ fg Color.black) + let attr_clickable = A.(bg Color.lightblue) + + type window_manager = { + overlays : ui Lwd.t Lwd_table.t; + view : ui Lwd.t; + } + + let window_manager base = + let overlays = Lwd_table.make () in + let composition = + Lwd.join + (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays) + in + let view = + Lwd.map2 base composition ~f:(fun base composite -> + Ui.join_z base + (Ui.resize_to (Ui.layout_spec base) composite)) + in + { overlays; view } + + let window_manager_view wm = wm.view + let window_manager_overlays wm = wm.overlays + + (* let menu_overlay wm g ?(dx = 0) ?(dy = 0) body around = + let sensor ~x ~y ~w ~h () = + let row = Lwd_table.append (window_manager_overlays wm) in + let h_pad = + match Gravity.h g with + | `Negative -> Ui.space (x + dx) 0 + | `Neutral -> Ui.space (x + dx + (w / 2)) 0 + | `Positive -> Ui.space (x + dx + w) 0 + in + let v_pad = + match Gravity.v g with + | `Negative -> Ui.space 0 (y + dy) + | `Neutral -> Ui.space 0 (y + dy + (h / 2)) + | `Positive -> Ui.space 0 (y + dy + h) + in + let view = + Lwd.map body ~f:(fun body -> + let body = + let pad = Ui.space 1 0 in + Ui.join_x pad (Ui.join_x body pad) + in + let bg = + Ui.resize_to (Ui.layout_spec body) + ~bg:A.(bg lightgreen) + Ui.empty + in + let catchall = + Ui.mouse_area + (fun ~x:_ ~y:_ -> function + | `Left -> + Lwd_table.remove row; + `Handled + | _ -> `Handled) + (Ui.resize ~sw:1 ~sh:1 Ui.empty) + in + Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad + @@ Ui.join_z bg body) + in + Lwd_table.set row view + in + Ui.transient_sensor sensor around + + (*let menu_overlay wm ?(dx=0) ?(dy=0) handler body = + let refresh = Lwd.var () in + let clicked = ref false in + Lwd.map' body @@ fun body -> + let body = let pad = Ui.space 1 0 in Ui.join_x pad (Ui.join_x body pad) in + let bg = + Ui.resize_to (Ui.layout_spec body) ~bg:A.(bg lightgreen) Ui.empty + in + let click_handler ~x:_ ~y:_ = function + | `Left -> clicked := true; Lwd.set refresh (); `Handled + | _ -> `Unhandled + in + let ui = Ui.mouse_area click_handler (Ui.join_z bg body) in + if !clicked then ( + clicked := false; + let sensor ~x ~y ~w:_ ~h () = + let row = Lwd_table.append (window_manager_overlays wm) in + let h_pad = Ui.space (x + dx) 0 in + let v_pad = Ui.space 0 (y + h + dy) in + let view = Lwd.map' (handler ()) @@ fun view -> + let catchall = + Ui.mouse_area + (fun ~x:_ ~y:_ -> function + | `Left -> Lwd_table.remove row; `Handled + | _ -> `Handled) + (Ui.resize ~sw:1 ~sh:1 Ui.empty) + in + Ui.join_z catchall (Ui.join_y v_pad (Ui.join_x h_pad view)) + in + Lwd_table.set row view + in + Ui.transient_sensor sensor ui + ) else ui*) + + let scroll_step = 1 + + type scroll_state = { + position : int; + bound : int; + visible : int; + total : int; + } + + let default_scroll_state = + { position = 0; bound = 0; visible = 0; total = 0 } + + let vscroll_area ~state ~change t = + let visible = ref (-1) in + let total = ref (-1) in + let scroll state delta = + let position = state.position + delta in + let position = max 0 (min state.bound position) in + if position <> state.position then + change `Action { state with position }; + `Handled + in + let focus_handler state = function + (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*) + (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*) + | `Arrow `Up, [] -> scroll state (-scroll_step) + | `Arrow `Down, [] -> scroll state (+scroll_step) + | `Page `Up, [] -> scroll state (-scroll_step * 8) + | `Page `Down, [] -> scroll state (+scroll_step * 8) + | _ -> `Unhandled + in + let scroll_handler state ~x:_ ~y:_ = function + | `Scroll `Up -> scroll state (-scroll_step) + | `Scroll `Down -> scroll state (+scroll_step) + | _ -> `Unhandled + in + Lwd.map2 t state ~f:(fun t state -> + t + |> Ui.shift_area 0 state.position + |> Ui.resize ~h:0 ~sh:1 + |> Ui.size_sensor (fun ~w:_ ~h -> + let tchange = + if !total <> (Ui.layout_spec t).Ui.h then ( + total := (Ui.layout_spec t).Ui.h; + true) + else false + in + let vchange = + if !visible <> h then ( + visible := h; + true) + else false + in + if tchange || vchange then + change `Content + { + state with + visible = !visible; + total = !total; + bound = max 0 (!total - !visible); + }) + |> Ui.mouse_area (scroll_handler state) + |> Ui.keyboard_area (focus_handler state)) + + let scroll_area ?(offset = (0, 0)) t = + let offset = Lwd.var offset in + let scroll d_x d_y = + let s_x, s_y = Lwd.peek offset in + let s_x = max 0 (s_x + d_x) in + let s_y = max 0 (s_y + d_y) in + Lwd.set offset (s_x, s_y); + `Handled + in + let focus_handler = function + | `Arrow `Left, [] -> scroll (-scroll_step) 0 + | `Arrow `Right, [] -> scroll (+scroll_step) 0 + | `Arrow `Up, [] -> scroll 0 (-scroll_step) + | `Arrow `Down, [] -> scroll 0 (+scroll_step) + | `Page `Up, [] -> scroll 0 (-scroll_step * 8) + | `Page `Down, [] -> scroll 0 (+scroll_step * 8) + | _ -> `Unhandled + in + let scroll_handler ~x:_ ~y:_ = function + | `Scroll `Up -> scroll 0 (-scroll_step) + | `Scroll `Down -> scroll 0 (+scroll_step) + | _ -> `Unhandled + in + Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) -> + t |> Ui.shift_area s_x s_y + |> Ui.mouse_area scroll_handler + |> Ui.keyboard_area focus_handler) + + let main_menu_item wm text f = + let text = string ~attr:attr_menu_main (" " ^ text ^ " ") in + let refresh = Lwd.var () in + let overlay = ref false in + let on_click ~x:_ ~y:_ = function + | `Left -> + overlay := true; + Lwd.set refresh (); + `Handled + | _ -> `Unhandled + in + Lwd.map (Lwd.get refresh) ~f:(fun () -> + let ui = Ui.mouse_area on_click text in + if !overlay then ( + overlay := false; + menu_overlay wm + (Gravity.make ~h:`Negative ~v:`Positive) + (f ()) ui) + else ui) + + let sub_menu_item wm text f = + let text = string ~attr:attr_menu_sub text in + let refresh = Lwd.var () in + let overlay = ref false in + let on_click ~x:_ ~y:_ = function + | `Left -> + overlay := true; + Lwd.set refresh (); + `Handled + | _ -> `Unhandled + in + Lwd.map (Lwd.get refresh) ~f:(fun () -> + let ui = Ui.mouse_area on_click text in + if !overlay then ( + overlay := false; + menu_overlay wm + (Gravity.make ~h:`Positive ~v:`Negative) + (f ()) ui) + else ui) + + let sub_entry text f = + let text = string ~attr:attr_menu_sub text in + let on_click ~x:_ ~y:_ = function + | `Left -> + f (); + `Handled + | _ -> `Unhandled + in + Ui.mouse_area on_click text + + type pane_state = + | Split of { pos : int; max : int } + | Re_split of { pos : int; max : int; at : int } + + let h_pane left right = + let state_var = Lwd.var (Split { pos = 5; max = 10 }) in + let render state (l, r) = + let (Split { pos; max } | Re_split { pos; max; _ }) = state in + let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos l in + let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) r in + let splitter = + Ui.resize + ~bg:Notty.A.(bg lightyellow) + ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty + in + let splitter = + Ui.mouse_area + (fun ~x:_ ~y:_ -> function + | `Left -> + `Grab + ( (fun ~x ~y:_ -> + match Lwd.peek state_var with + | Split { pos; max } -> + Lwd.set state_var + (Re_split { pos; max; at = x }) + | Re_split { pos; max; at } -> + if at <> x then + Lwd.set state_var + (Re_split { pos; max; at = x })), + fun ~x:_ ~y:_ -> () ) + | _ -> `Unhandled) + splitter + in + let ui = Ui.join_x l (Ui.join_x splitter r) in + let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in + let ui = + match state with + | Split _ -> ui + | Re_split { at; _ } -> + Ui.transient_sensor + (fun ~x ~y:_ ~w ~h:_ () -> + Lwd.set state_var (Split { pos = at - x; max = w })) + ui + in + ui + in + Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair left right) + + let v_pane top bot = + let state_var = Lwd.var (Split { pos = 5; max = 10 }) in + let render state (top, bot) = + let (Split { pos; max } | Re_split { pos; max; _ }) = state in + let top = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:pos top in + let bot = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:(max - pos) bot in + let splitter = + Ui.resize + ~bg:Notty.A.(bg lightyellow) + ~w:0 ~h:1 ~sw:1 ~sh:0 Ui.empty + in + let splitter = + Ui.mouse_area + (fun ~x:_ ~y:_ -> function + | `Left -> + `Grab + ( (fun ~x:_ ~y -> + match Lwd.peek state_var with + | Split { pos; max } -> + Lwd.set state_var + (Re_split { pos; max; at = y }) + | Re_split { pos; max; at } -> + if at <> y then + Lwd.set state_var + (Re_split { pos; max; at = y })), + fun ~x:_ ~y:_ -> () ) + | _ -> `Unhandled) + splitter + in + let ui = Ui.join_y top (Ui.join_y splitter bot) in + let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in + let ui = + match state with + | Split _ -> ui + | Re_split { at; _ } -> + Ui.transient_sensor + (fun ~x:_ ~y ~w:_ ~h () -> + Lwd.set state_var (Split { pos = at - y; max = h })) + ui + in + ui + in + Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot) + + let sub' str p l = + if p = 0 && l = String.length str then str else String.sub str p l + + let edit_field ?(focus = Focus.make ()) state ~on_change ~on_submit + = + let update focus_h focus (text, pos) = + let pos = min (max 0 pos) (String.length text) in + let content = + Ui.atom @@ I.hcat + @@ + if Focus.has_focus focus then + let attr = attr_clickable in + let len = String.length text in + (if pos >= len then [ I.string attr text ] + else [ I.string attr (sub' text 0 pos) ]) + @ + if pos < String.length text then + [ + I.string A.(bg lightred) (sub' text pos 1); + I.string attr (sub' text (pos + 1) (len - pos - 1)); + ] + else [ I.string A.(bg lightred) " " ] + else + [ + I.string + A.(st underline) + (if text = "" then " " else text); + ] + in + let handler = function + | `ASCII 'U', [ `Ctrl ] -> + on_change ("", 0); + `Handled (* clear *) + | `Escape, [] -> + Focus.release focus_h; + `Handled + | `ASCII k, _ -> + let text = + if pos < String.length text then + String.sub text 0 pos ^ String.make 1 k + ^ String.sub text pos (String.length text - pos) + else text ^ String.make 1 k + in + on_change (text, pos + 1); + `Handled + | `Backspace, _ -> + let text = + if pos > 0 then + if pos < String.length text then + String.sub text 0 (pos - 1) + ^ String.sub text pos (String.length text - pos) + else if String.length text > 0 then + String.sub text 0 (String.length text - 1) + else text + else text + in + let pos = max 0 (pos - 1) in + on_change (text, pos); + `Handled + | `Enter, _ -> + on_submit (text, pos); + `Handled + | `Arrow `Left, [] -> + let pos = min (String.length text) pos in + if pos > 0 then ( + on_change (text, pos - 1); + `Handled) + else `Unhandled + | `Arrow `Right, [] -> + let pos = pos + 1 in + if pos <= String.length text then ( + on_change (text, pos); + `Handled) + else `Unhandled + | _ -> `Unhandled + in + Ui.keyboard_area ~focus handler content + in + let node = + Lwd.map2 ~f:(update focus) (Focus.status focus) state + in + let mouse_grab (text, pos) ~x ~y:_ = function + | `Left -> + if x <> pos then on_change (text, x); + Nottui.Focus.request focus; + `Handled + | _ -> `Unhandled + in + Lwd.map2 state node ~f:(fun state content -> + Ui.mouse_area (mouse_grab state) content) + + (** Tab view, where exactly one element of [l] is shown at a time. *) + let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t + = + match tabs with + | [] -> Lwd.return Ui.empty + | _ -> + let cur = Lwd.var 0 in + Lwd.get cur >>= fun idx_sel -> + let _, f = List.nth tabs idx_sel in + let tab_bar = + tabs + |> List.mapi (fun i (s, _) -> + let attr = + if i = idx_sel then A.(st underline) else A.empty + in + let tab_annot = printf ~attr "[%s]" s in + Ui.mouse_area + (fun ~x:_ ~y:_ l -> + if l = `Left then ( + Lwd.set cur i; + `Handled) + else `Unhandled) + tab_annot) + |> Ui.hcat + in + f () >|= Ui.join_y tab_bar + + (** Horizontal/vertical box. We fill lines until there is no room, + and then go to the next ligne. All widgets in a line are considered to + have the same height. + @param width dynamic width (default 80) + *) + let flex_box ?(w = Lwd.return 80) (l : Ui.t Lwd.t list) : Ui.t Lwd.t + = + Lwd_utils.flatten_l l >>= fun l -> + w >|= fun w_limit -> + let rec box_render (acc : Ui.t) (i : int) l : Ui.t = + match l with + | [] -> acc + | ui0 :: tl -> + let w0 = (Ui.layout_spec ui0).Ui.w in + if i + w0 >= w_limit then + (* newline starting with ui0 *) + Ui.join_y acc (box_render ui0 w0 tl) + else + (* same line *) + box_render (Ui.join_x acc ui0) (i + w0) tl + in + box_render Ui.empty 0 l + + (** Prints the summary, but calls [f()] to compute a sub-widget + when clicked on. Useful for displaying deep trees. *) + let unfoldable ?(folded_by_default = true) summary + (f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t = + let open Lwd.Infix in + let opened = Lwd.var (not folded_by_default) in + let fold_content = + Lwd.get opened >>= function + | true -> + (* call [f] and pad a bit *) + f () |> Lwd.map ~f:(Ui.join_x (string " ")) + | false -> empty_lwd + in + (* pad summary with a "> " when it's opened *) + let summary = + Lwd.get opened >>= fun op -> + summary >|= fun s -> + Ui.hcat + [ + string ~attr:attr_clickable (if op then "v" else ">"); + string " "; + s; + ] + in + let cursor ~x:_ ~y:_ = function + | `Left when Lwd.peek opened -> + Lwd.set opened false; + `Handled + | `Left -> + Lwd.set opened true; + `Handled + | _ -> `Unhandled + in + let mouse = + Lwd.map ~f:(fun m -> Ui.mouse_area cursor m) summary + in + Lwd.map2 mouse fold_content ~f:(fun summary fold -> + (* TODO: make this configurable/optional *) + (* newline if it's too big to fit on one line nicely *) + let spec_sum = Ui.layout_spec summary in + let spec_fold = Ui.layout_spec fold in + (* TODO: somehow, probe for available width here? *) + let too_big = + spec_fold.Ui.h > 1 + || spec_fold.Ui.h > 0 + && spec_sum.Ui.w + spec_fold.Ui.w > 60 + in + if too_big then + Ui.join_y summary (Ui.join_x (string " ") fold) + else Ui.join_x summary fold) + + let hbox l = Lwd_utils.pack Ui.pack_x l + let vbox l = Lwd_utils.pack Ui.pack_y l + let zbox l = Lwd_utils.pack Ui.pack_z l + + let vlist ?(bullet = "- ") (l : Ui.t Lwd.t list) : Ui.t Lwd.t = + l + |> List.map (fun ui -> Lwd.map ~f:(Ui.join_x (string bullet)) ui) + |> Lwd_utils.pack Ui.pack_y + + (** A list of items with a dynamic filter on the items *) + let vlist_with ?(bullet = "- ") + ?(filter = Lwd.return (fun _ -> true)) (f : 'a -> Ui.t Lwd.t) + (l : 'a list Lwd.t) : Ui.t Lwd.t = + let open Lwd.Infix in + let rec filter_map_ acc f l = + match l with + | [] -> List.rev acc + | x :: l' -> + let acc' = + match f x with None -> acc | Some y -> y :: acc + in + filter_map_ acc' f l' + in + let l = + l + >|= List.map (fun x -> + (x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x)) + in + let l_filter : _ list Lwd.t = + filter >>= fun filter -> + l + >|= filter_map_ [] (fun (x, ui) -> + if filter x then Some ui else None) + in + l_filter >>= Lwd_utils.pack Ui.pack_y + + let rec iterate n f x = if n = 0 then x else iterate (n - 1) f (f x) + + (** A grid layout, with alignment in all rows/columns. + @param max_h maximum height of a cell + @param max_w maximum width of a cell + @param bg attribute for controlling background style + @param h_space horizontal space between each cell in a row + @param v_space vertical space between each row + @param pad used to control padding of cells + @param crop used to control cropping of cells + TODO: control padding/alignment, vertically and horizontally + TODO: control align left/right in cells + TODO: horizontal rule below headers + TODO: headers *) + let grid ?max_h ?max_w ?pad ?crop ?bg ?(h_space = 0) ?(v_space = 0) + ?(headers : Ui.t Lwd.t list option) + (rows : Ui.t Lwd.t list list) : Ui.t Lwd.t = + let rows = + match headers with None -> rows | Some r -> r :: rows + in + (* build a [ui list list Lwd.t] *) + Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows + >>= fun (rows : Ui.t list list) -> + (* determine width of each column and height of each row *) + let n_cols = + List.fold_left (fun n r -> max n (List.length r)) 0 rows + in + let col_widths = Array.make n_cols 1 in + List.iter + (fun row -> + List.iteri + (fun col_j cell -> + let w = (Ui.layout_spec cell).Ui.w in + col_widths.(col_j) <- max col_widths.(col_j) w) + row) + rows; + (match max_w with + | None -> () + | Some max_w -> + (* limit width *) + Array.iteri + (fun i x -> col_widths.(i) <- min x max_w) + col_widths); + (* now render, with some padding *) + let pack_pad_x = + if h_space <= 0 then (Ui.empty, Ui.join_x) + else (Ui.empty, fun x y -> Ui.hcat [ x; Ui.space h_space 0; y ]) + and pack_pad_y = + if v_space = 0 then (Ui.empty, Ui.join_y) + else (Ui.empty, fun x y -> Ui.vcat [ x; Ui.space v_space 0; y ]) + in + let rows = + List.map + (fun row -> + let row_h = + List.fold_left + (fun n c -> max n (Ui.layout_spec c).Ui.h) + 0 row + in + let row_h = + match max_h with + | None -> row_h + | Some max_h -> min row_h max_h + in + let row = + List.mapi + (fun i c -> + Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c) + row + in + Lwd_utils.reduce pack_pad_x row) + rows + in + (* TODO: mouse and keyboard handling *) + let ui = Lwd_utils.reduce pack_pad_y rows in + Lwd.return ui + + (** Turn the given [ui] into a clickable button, calls [f] when clicked. *) + let button_of ui f = + Ui.mouse_area + (fun ~x:_ ~y:_ _ -> + f (); + `Handled) + ui + + (** A clickable button that calls [f] when clicked, labelled with a string. *) + let button ?(attr = attr_clickable) s f = + button_of (string ~attr s) f + + (* file explorer for selecting a file *) + let file_select ?(abs = false) ?filter ~(on_select : string -> unit) + () : Ui.t Lwd.t = + let rec aux ~fold path = + try + let p_rel = if path = "" then "." else path in + if Sys.is_directory p_rel then + let ui () = + let arr = Sys.readdir p_rel in + let l = + Array.to_list arr |> List.map (Filename.concat path) + in + (* apply potential filter *) + let l = + match filter with + | None -> l + | Some f -> List.filter f l + in + let l = Lwd.return @@ List.sort String.compare l in + vlist_with ~bullet:"" (aux ~fold:true) l + in + if fold then + unfoldable ~folded_by_default:true + (Lwd.return @@ string @@ path ^ "/") + ui + else ui () + else + Lwd.return + @@ button + ~attr:A.(st underline) + path + (fun () -> on_select path) + with e -> + Lwd.return + @@ Ui.vcat + [ + printf ~attr:A.(bg red) "cannot list directory %s" path; + string @@ Printexc.to_string e; + ] + in + let start = if abs then Sys.getcwd () else "" in + aux ~fold:false start + + let toggle, toggle' = + let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) : + Ui.t Lwd.t = + let mk_but st_v lbl_v = + let lbl = + Ui.hcat + [ + printf "[%s|" lbl_v; + string ~attr:attr_clickable (if st_v then "✔" else "×"); + string "]"; + ] + in + button_of lbl (fun () -> + let new_st = not st_v in + Lwd.set st new_st; + f new_st) + in + Lwd.map2 ~f:mk_but (Lwd.get st) lbl + in + (* Similar to {!toggle}, except it directly reflects the state of a variable. *) + let toggle' (lbl : string Lwd.t) (v : bool Lwd.var) : Ui.t Lwd.t = + toggle_ v lbl (Lwd.set v) + (* a toggle, with a true/false state *) + and toggle ?(init = false) (lbl : string Lwd.t) (f : bool -> unit) + : Ui.t Lwd.t = + let st = Lwd.var init in + toggle_ st lbl f + in + (toggle, toggle') + + type scrollbox_state = { w : int; h : int; x : int; y : int } + + let adjust_offset visible total off = + let off = + if off + visible > total then total - visible else off + in + let off = if off < 0 then 0 else off in + off + + let decr_if x cond = if cond then x - 1 else x + let scrollbar_bg = Notty.A.gray 4 + let scrollbar_fg = Notty.A.gray 7 + + let scrollbar_click_step = + 3 (* Clicking scrolls one third of the screen *) + + let scrollbar_wheel_step = + 8 (* Wheel event scrolls 1/8th of the screen *) + + let hscrollbar visible total offset ~set = + let prefix = offset * visible / total in + let suffix = (total - offset - visible) * visible / total in + let handle = visible - prefix - suffix in + let render size color = + Ui.atom Notty.(I.char (A.bg color) ' ' size 1) + in + let mouse_handler ~x ~y:_ = function + | `Left -> + if x < prefix then ( + set (offset - max 1 (visible / scrollbar_click_step)); + `Handled) + else if x > prefix + handle then ( + set (offset + max 1 (visible / scrollbar_click_step)); + `Handled) + else + `Grab + ( (fun ~x:x' ~y:_ -> + set (offset + ((x' - x) * total / visible))), + fun ~x:_ ~y:_ -> () ) + | `Scroll dir -> + let dir = match dir with `Down -> 1 | `Up -> -1 in + set (offset + (dir * max 1 (visible / scrollbar_wheel_step))); + `Handled + | _ -> `Unhandled + in + let ( ++ ) = Ui.join_x in + Ui.mouse_area mouse_handler + (render prefix scrollbar_bg + ++ render handle scrollbar_fg + ++ render suffix scrollbar_bg) + + let vscrollbar visible total offset ~set = + let prefix = offset * visible / total in + let suffix = (total - offset - visible) * visible / total in + let handle = visible - prefix - suffix in + let render size color = + Ui.atom Notty.(I.char (A.bg color) ' ' 1 size) + in + let mouse_handler ~x:_ ~y = function + | `Left -> + if y < prefix then ( + set (offset - max 1 (visible / scrollbar_click_step)); + `Handled) + else if y > prefix + handle then ( + set (offset + max 1 (visible / scrollbar_click_step)); + `Handled) + else + `Grab + ( (fun ~x:_ ~y:y' -> + set (offset + ((y' - y) * total / visible))), + fun ~x:_ ~y:_ -> () ) + | `Scroll dir -> + let dir = match dir with `Down -> 1 | `Up -> -1 in + set (offset + (dir * max 1 (visible / scrollbar_wheel_step))); + `Handled + | _ -> `Unhandled + in + let ( ++ ) = Ui.join_y in + Ui.mouse_area mouse_handler + (render prefix scrollbar_bg + ++ render handle scrollbar_fg + ++ render suffix scrollbar_bg) + + let scrollbox t = + (* Keep track of scroll state *) + let state_var = Lwd.var { w = 0; h = 0; x = 0; y = 0 } in + (* Keep track of size available for display *) + let update_size ~w ~h = + let state = Lwd.peek state_var in + if state.w <> w || state.h <> h then + Lwd.set state_var { state with w; h } + in + let measure_size body = + Ui.size_sensor update_size + (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body) + in + (* Given body and state, composite scroll bars *) + let compose_bars body state = + let bw, bh = (Ui.layout_width body, Ui.layout_height body) in + (* Logic to determine which scroll bar should be visible *) + let hvisible = state.w < bw and vvisible = state.h < bh in + let hvisible = hvisible || (vvisible && state.w = bw) in + let vvisible = vvisible || (hvisible && state.h = bh) in + (* Compute size and offsets based on visibility *) + let state_w = decr_if state.w vvisible in + let state_h = decr_if state.h hvisible in + let state_x = adjust_offset state_w bw state.x in + let state_y = adjust_offset state_h bh state.y in + (* Composite visible scroll bars *) + let crop b = + Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0 + (Ui.shift_area state_x state_y b) + in + let set_vscroll y = + let state = Lwd.peek state_var in + if state.y <> y then Lwd.set state_var { state with y } + in + let set_hscroll x = + let state = Lwd.peek state_var in + if state.x <> x then Lwd.set state_var { state with x } + in + let ( <-> ) = Ui.join_y and ( <|> ) = Ui.join_x in + match (hvisible, vvisible) with + | false, false -> body + | false, true -> + crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll + | true, false -> + crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll + | true, true -> + crop body + <|> vscrollbar state_h bh state_y ~set:set_vscroll + <-> (hscrollbar state_w bw state_x ~set:set_hscroll + <|> Ui.space 1 1) + in + (* Render final box *) + Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size -> + measure_size (compose_bars ui size)) *) +end