From 7baa6f364809317756dc7ee417deb07caa68195e Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 10 Dec 2022 14:27:22 -0600 Subject: [PATCH] compute ui.w and ui.h during update --- boot_js.ml | 39 ++++- human.ml | 438 ++++++++++++++++++++++++++++++----------------------- 2 files changed, 282 insertions(+), 195 deletions(-) diff --git a/boot_js.ml b/boot_js.ml index 0d1972b..ab3f315 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -4,8 +4,7 @@ module NVG = Graphv_webgl let _ = Logs.set_reporter (Human.Logs_reporter.console_reporter ()); - Logs.set_level (Some Debug); - Logs.debug (fun m -> m "hello") + Logs.set_level (Some Debug) module Log = (val Logs.src_log Logs.default : Logs.LOG) @@ -87,13 +86,37 @@ let _ = let vg = graphv_initialize webgl_ctx in let open Js_of_ocaml_lwt.Lwt_js_events in let edit_me = Lwd.var ("edit me?", 0) in + let open Nottui in + let gravity_pad = Gravity.make ~h:`Negative ~v:`Negative in + let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in + let body = Lwd.var (Lwd.pure Ui.empty) in + let wm = Nottui_widgets.window_manager (Lwd.join (Lwd.get body)) in + let ui = + Nottui_widgets.( + let string s = Lwd.pure @@ Nottui_widgets.string s in + scroll_area + @@ Lwd_utils.pack Ui.pack_y + [ + edit_field edit_me; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + main_menu_item wm "Quit" (fun () -> exit 0); + ]) + in let root = - let open Nottui_widgets in - edit_field (Lwd.get edit_me) - ~on_change:(fun ((text, pos) as state) -> - Log.debug (fun m -> m "--- on_change (%s,%d)" text pos); - Lwd.set edit_me state) - ~on_submit:ignore + Lwd.set body + (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui); + Nottui_widgets.window_manager_view wm in let events, push_event = Lwt_stream.create () in diff --git a/human.ml b/human.ml index ca2c247..75bd17e 100644 --- a/human.ml +++ b/human.ml @@ -91,8 +91,7 @@ end let _ = Logs.set_reporter (Logs_reporter.console_reporter ()); - Logs.set_level (Some Debug); - Logs.debug (fun m -> m "hello") + Logs.set_level (Some Debug) module Log = Logs module Cohttp_backend = Cohttp_lwt_jsoo @@ -585,49 +584,100 @@ module NVG = struct and lightwhite = rgbf ~r:1.0 ~g:1.0 ~b:1.0 let ( ++ ) a b = - { - r = Float.clamp ~min:0. ~max:1. (a.r +. b.r); - g = Float.clamp ~min:0. ~max:1. (a.g +. b.g); - b = Float.clamp ~min:0. ~max:1. (a.b +. b.b); - a = Float.clamp ~min:0. ~max:1. (a.a +. b.a); - } + (* { + r = Float.clamp ~min:0. ~max:1. (a.r +. b.r); + g = Float.clamp ~min:0. ~max:1. (a.g +. b.g); + b = Float.clamp ~min:0. ~max:1. (a.b +. b.b); + a = Float.clamp ~min:0. ~max:1. (a.a +. b.a); + } *) + if a = none then b else a let pp ppf t : unit = - F.( - fmt "%a" ppf - (list ~sep:(any "|") float) - [ t.r; t.g; t.b; t.a ]) + if t != none then + F.( + fmt "%a" ppf + (list (fmt "%02X")) + (List.map + (fun e -> int_of_float (e *. 255.)) + [ t.r; t.g; t.b; t.a ])) + else F.fmt "_" ppf end end -open NVG +module Color = NVG.Color -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) +(* from notty.ml *) +let btw (x : int) a b = a <= x && x <= b -let fill_box vg color b = - let module Path = NVG.Path in - let open NVG in - NVG.save vg; - 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; - NVG.restore vg; - Log.debug (fun m -> m "fill_box: %a" Box2.pp b); - Box2.size b +module Buffer = struct + include Stdlib.Buffer -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.size b + 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 + include NVG.Text + + 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 "\"%s\"" ppf s) +end module Style = struct module Font = struct @@ -701,15 +751,8 @@ module Style = struct type t = { fg : Color.t; bg : Color.t; font : Font.t } type attr = t - let pp ppf = - F.( - fmt "%a" ppf - (record - [ - field "fg" (fun a -> a.fg) Color.pp; - field "bg" (fun a -> a.bg) Color.pp; - field "font" (fun a -> a.font) Font.pp; - ])) + let pp ppf a = + F.(fmt "@[%a/%a@]" ppf Color.pp a.fg Color.pp a.bg) let equal = ( == ) @@ -758,77 +801,6 @@ module Pad = struct 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 @@ -1048,6 +1020,33 @@ module I = struct type p = P2.t type d = [ `X | `Y | `Z ] + 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 + NVG.save vg; + 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; + NVG.restore vg; + Log.debug (fun m -> m "fill_box: %a" Box2.pp b); + Box2.size 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.size b + let vcat d a b = match d with | `X -> @@ -1062,11 +1061,11 @@ module I = struct let open F in let compose = pair (parens (pp ~attr)) (parens (pp ~attr)) in function - | Empty -> F.(fmt "Empty" ppf) - | Segment v -> F.(fmt "Segment %a" ppf (parens Text.pp) v) + | Empty -> fmt "Empty" ppf + | Segment v -> fmt "@[Segment %a@]" ppf Text.pp v | Attr (t, a) -> - fmt "attr %a" ppf - (pair A.pp (parens (pp ~attr:A.(attr ++ a)))) + fmt "@[Attr %a@]" ppf + (pair ~sep:comma A.pp (pp ~attr:A.(attr ++ a))) (A.(attr ++ a), t) | Hcompose a -> fmt "hcat %a" ppf compose a | Vcompose a -> fmt "vcat %a" ppf compose a @@ -1209,24 +1208,12 @@ module Nottui = struct val p2 : t2 -> t end = struct type direction = [ `Negative | `Neutral | `Positive ] - type t = int - type t2 = int + type t = { h : direction; v : direction } - 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 default = { h = `Neutral; v = `Neutral } + let make ~h ~v = { h; v } + let h x = x.h + let v x = x.v let pp_direction ppf dir = let text = @@ -1241,9 +1228,11 @@ module Nottui = struct 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 + type t2 = t * t + + let pair t1 t2 = (t1, t2) + let p1 (t, _) = t + let p2 (_, t) = t end type gravity = Gravity.t @@ -1321,9 +1310,9 @@ module Nottui = struct x:float -> y:float -> w:float -> h:float -> unit -> unit type t = { - w : float; + mutable w : float; + mutable h : float; sw : float; - h : float; sh : float; mutable desc : desc; focus : Focus.status; @@ -1444,9 +1433,9 @@ module Nottui = struct { 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 = + ?(attr = A.empty) t : t = let g = prepare_gravity (pad, crop) in - { t with w; h; sw; sh; desc = Resize (t, g, bg) } + { t with w; h; sw; sh; desc = Resize (t, g, attr) } let event_filter ?focus f t : t = let focus = @@ -1501,29 +1490,29 @@ module Nottui = struct 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 "@[@[%a@]@]" pp_desc t.desc + let rec pp ppf t = Format.fprintf ppf "@[%a@]" pp_desc t.desc and pp_desc ppf = function - | Atom _ -> Format.fprintf ppf "Atom _" + | Atom a -> + Format.fprintf ppf "Atom @[(%a)@]" + (I.Draw.pp ?attr:None) a | Size_sensor (desc, _) -> - Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc + Format.fprintf ppf "Size_sensor (%a, _)" pp desc | Transient_sensor (desc, _) -> - Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc + Format.fprintf ppf "Transient_sensor (%a,@ _)" pp desc | Permanent_sensor (desc, _) -> - Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp 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) + Format.fprintf ppf "Resize (%a,@ %a,@ %a)" Gravity.pp + (Gravity.p1 gravity) Gravity.pp (Gravity.p2 gravity) pp + desc | 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 + Format.fprintf ppf "%a" (*"Mouse (%a,@ _)"*) pp n + | Focus_area (n, _) -> Format.fprintf ppf "Focus (%a,@ _)" pp n + | Shift_area (n, x, y) -> + Format.fprintf ppf "Shift (%.0f,%.0f,%a)" x y pp n | Event_filter (n, _) -> - Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n + Format.fprintf ppf "Event (%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 @@ -1556,12 +1545,15 @@ module Nottui = struct (x:float -> y:float -> unit) * (x:float -> y:float -> unit) type t = { + vg : NVG.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 make vg () = + { vg; mouse_grab = None; size = P2.o; view = Ui.empty } + let size t = t.size let solve_focus ui i = @@ -1586,14 +1578,20 @@ module Nottui = struct 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 x, y = + 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) + in + Log.debug (fun m -> + m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)" + fixed stretch total x y); + (x, y) let has_transient_sensor flags = flags land flag_transient_sensor <> 0 @@ -1658,8 +1656,53 @@ module Nottui = struct | Focus.Empty | Focus.Handle _ -> () | Focus.Conflict i -> solve_focus ui i + let rec update_size vg (size : box2) ui = + let s1 = + match ui.desc with + | Atom i -> I.size vg (Box2.o size) i + | Size_sensor (t, _) + | Mouse_handler (t, _) + | Focus_area (t, _) + | Event_filter (t, _) + | Transient_sensor (t, _) + | Permanent_sensor (t, _) -> + update_size vg size t + | Resize (t, g2, _) -> update_size vg size t + | Shift_area (t, sx, sy) -> + update_size vg + (Box2.of_pts + V2.(of_tuple (sx, sy) - Box2.o size) + (Box2.max size)) + t + | X (a, b) -> + let p1 = update_size vg size a in + let p2 = + update_size vg + (Box2.of_pts + V2.(v (x p1) (Box2.miny size)) + (Box2.max size)) + b + in + I.p2_max p1 p2 + | Y (a, b) -> + let p1 = update_size vg size a in + let p2 = + update_size vg + (Box2.of_pts + V2.(v (Box2.minx size) (y p1)) + (Box2.max size)) + b + in + I.p2_max p1 p2 + | Z (a, b) -> + I.p2_max (update_size vg size a) (update_size vg size b) + in + ui.w <- V2.x s1 -. Box2.minx size; + ui.h <- V2.y s1 -. Box2.miny size; + s1 + let update t size ui = - t.size <- size; + t.size <- update_size t.vg (Box2.v V2.zero size) ui; t.view <- ui; update_sensors 0. 0. (P2.x size) (P2.y size) ui; update_focus ui @@ -1760,6 +1803,11 @@ module Nottui = struct let rec render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1) (vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache = + (* Log.debug (fun m -> + m + "render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \ + sw=%.0f@ sh=%.0f@ @[%a@]" + vx1 vy1 vx2 vy2 sw sh pp t); *) if let cache = t.cache in vx1 >= Interval.fst cache.vx @@ -1807,6 +1855,11 @@ module Nottui = struct let cb = render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b in + Log.debug (fun m -> + m + "render_node X()@ vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ \ + vy2=%.0f@ sw=%.0f@ sh=%.0f aw=%.0f bw=%.0f" + vx1 vy1 vx2 vy2 sw sh aw bw); let vx = Interval.make (max (Interval.fst ca.vx) @@ -1840,6 +1893,11 @@ module Nottui = struct and image = resize_canvas vg sw sh (I.( <-> ) ca.image cb.image) in + Log.debug (fun m -> + m + "render_node Y()@ vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ \ + vy2=%.0f@ sw=%.0f@ sh=%.0f ah=%.0f bh=%.0f" + vx1 vy1 vx2 vy2 sw sh ah bh); { vx; vy; image } | Z (a, b) -> let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in @@ -1869,11 +1927,11 @@ module Nottui = struct (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 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 } @@ -2051,7 +2109,7 @@ module Nottui_lwt = struct stream let render vg ?quit ~size events doc = - let renderer = Renderer.make () in + let renderer = Renderer.make vg () in let refresh_stream, push_refresh = Lwt_stream.create () in let root = Lwd.observe @@ -2186,7 +2244,7 @@ module Nottui_widgets = struct in let bg = Ui.resize_to (Ui.layout_spec body) - ~bg:A.(bg Color.lightgreen) + ~attr:A.(bg Color.lightgreen) Ui.empty in let catchall = @@ -2332,14 +2390,14 @@ module Nottui_widgets = struct | `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 + (* 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.mouse_area scroll_handler*) |> Ui.keyboard_area focus_handler) let main_menu_item wm text f = @@ -2487,8 +2545,12 @@ module Nottui_widgets = struct 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 edit_field ?(focus = Focus.make ()) ?(on_change = ignore) + ?(on_submit = ignore) state = + let on_change a = + on_change a; + Lwd.set state a + in let update focus_h focus (text, pos) = let pos = min (max 0 pos) (String.length text) in let content = @@ -2566,7 +2628,7 @@ module Nottui_widgets = struct Ui.keyboard_area ~focus handler content in let node = - Lwd.map2 ~f:(update focus) (Focus.status focus) state + Lwd.map2 ~f:(update focus) (Focus.status focus) (Lwd.get state) in node (* let mouse_grab (text, pos) ~x ~y:_ = function @@ -2905,12 +2967,14 @@ module Nottui_widgets = struct let scrollbar_wheel_step = 8. (* Wheel event scrolls 1/8th of the screen *) + let scrollbar_width = 10. + 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 (I.char ~attr:(A.bg color) ' ' size 1.) + Ui.atom (I.attr (A.bg color) (I.void size scrollbar_width)) in let mouse_handler ~x ~y:_ = function | `Left ->