Comparar commits

...

6 Commits

Autor SHA1 Mensaje Fecha
Frédéric Bour bfc481aa54 WIP 2020-08-30 11:45:30 +02:00
Frédéric Bour a995047176 implement permanent sensors 2020-08-30 11:45:30 +02:00
Frédéric Bour b4447f82f3 wip 2020-08-30 11:45:30 +02:00
Frédéric Bour fe42d56bf5 full_sensor before/after 2020-08-30 11:45:30 +02:00
Frédéric Bour 9eb18e2207 Full_sensor trigger only once 2020-08-30 11:45:30 +02:00
Frédéric Bour 07823fed56 full-sensor 2020-08-30 11:45:30 +02:00
Se han modificado 4 ficheros con 321 adiciones y 196 borrados

Ver fichero

@ -3,6 +3,9 @@ all:
TESTS=minimal misc reranger stress
$(TESTS):
dune build examples/$@.bc
run-minimal:
dune exec examples/minimal.bc
@ -18,6 +21,9 @@ run-stress:
run-pretty:
dune exec examples/pretty.bc
run-pretty-lambda:
dune exec examples/pretty_lambda.bc
run-stress.exe:
dune exec examples/stress.exe

Ver fichero

@ -48,13 +48,15 @@ let attr_menu_main = A.(bg green ++ fg black)
let attr_menu_sub = A.(bg lightgreen ++ fg black)
let menu_overlay ?dx ?dy handler t =
let placeholder = Lwd.return (Ui.atom (I.void 1 0)) in
ignore (dx, dy, handler, t);
assert false
(*let placeholder = Lwd.return (Ui.atom (I.void 1 0)) in
let body = Lwd_utils.pack Ui.pack_x [placeholder; t; placeholder] in
let bg = Lwd.map' body @@ fun t ->
let {Ui. w; h; _} = Ui.layout_spec t in
Ui.atom (I.char A.(bg lightgreen) ' ' w h)
in
Lwd.map (Ui.overlay ?dx ?dy ~handler) (Lwd_utils.pack Ui.pack_z [bg; body])
Lwd.map (Ui.overlay ?dx ?dy ~handler) (Lwd_utils.pack Ui.pack_z [bg; body])*)
let scroll_step = 1
@ -95,7 +97,7 @@ let vscroll_area ~state ~change t =
t
|> Ui.scroll_area 0 state.position
|> Ui.resize ~h:0 ~sh:1
|> Ui.size_sensor (fun _ h ->
|> 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)
@ -230,7 +232,7 @@ let v_pane left right =
in
splitter $= Lwd.map (Ui.mouse_area action) (Lwd.get splitter_bg);
render ();
let on_resize ew eh =
let on_resize ~w:ew ~h:eh =
if !w <> ew || !h <> eh then (
w := ew; h := eh;
render ()
@ -239,44 +241,112 @@ let v_pane left right =
Lwd.map' node @@ fun t ->
Ui.size_sensor on_resize (Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 t)
let h_pane top bottom =
let w = ref 10 in
let h = ref 10 in
let split = ref 0.5 in
let splitter = Lwd.var empty_lwd in
let splitter_bg = Lwd.var Ui.empty in
let top_pane = Lwd.var empty_lwd in
let bot_pane = Lwd.var empty_lwd in
let node = Lwd_utils.pack Ui.pack_x [!$top_pane; !$splitter; !$bot_pane] in
let render () =
let split = int_of_float (!split *. float !w) in
let split = min (!w - 1) (max split 0) in
top_pane $= Lwd.map' top
(fun t -> Ui.resize ~w:split ~h:!h t);
bot_pane $= Lwd.map' bottom
(fun t -> Ui.resize ~w:(!w - split - 1) ~h:!h t);
splitter_bg $= Ui.atom (Notty.I.char Notty.A.(bg lightyellow) ' ' 1 !h);
type pane_state =
| Split of { pos: int; max: int }
| Re_split of { pos: int; max: int; at: int }
let h_pane l r =
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
let action ~x:_ ~y:_ = function
| `Left ->
let x0 = int_of_float (!split *. float !w) in
`Grab ((fun ~x ~y:_ ->
let x0' = x0 + x in
split := min 1.0 (max 0.0 (float x0' /. float !w));
render ()
), (fun ~x:_ ~y:_ -> ()))
| _ -> `Unhandled
Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)
(*type pane_state =
| Static of { w : int; h : int; split : float }
| Resizing of { w : int; h : int; split : float; x : int; y : int; }
let pane_h (Static {h; _} | Resizing {h; _}) = h
let pane_w (Static {w; _} | Resizing {w; _}) = w
let pane_split (Static {split; _} | Resizing {split; _}) = split
let h_pane l r =
let state_var = Lwd.var (Static {w = 0; h = 0 ; split = 0.5}) in
let render state (l, r) =
let h = pane_h state in
let split = int_of_float (pane_split state *. float (pane_w state)) in
let l = Ui.resize ~w:split ~h l in
let r = Ui.resize ~w:(pane_w state - split - 1) ~h r in
let splitter = Ui.atom (Notty.I.char Notty.A.(bg lightyellow) ' ' 1 h) in
let splitter =
Ui.mouse_area (fun ~x:_ ~y:_ -> function
| `Left ->
`Grab (
(fun ~x ~y:_ ->
match Lwd.peek state_var with
| Static {w; h; split} ->
Lwd.set state_var (Resizing {x = min_int; y = min_int; w; h; split})
| Resizing r ->
if r.x > min_int then
let split = float (x - r.x) /. float r.w in
Lwd.set state_var (Resizing {r with split})
),
(fun ~x:_ ~y:_ ->
match Lwd.peek state_var with
| Static _ -> ()
| Resizing {w; h; split; _} ->
Lwd.set state_var (Static {w; h; split})
)
)
| _ -> `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
| Static _ ->
Ui.size_sensor (fun ~w ~h ->
match Lwd.peek state_var with
| Static r ->
if r.w <> w || r.h <> h then
Lwd.set state_var (Static {r with w; h})
| Resizing _ -> ()
) ui
| Resizing _ ->
Ui.permanent_sensor (fun ~x ~y ~w ~h ->
match Lwd.peek state_var with
| Static _ -> ignore
| Resizing r ->
if r.x <> x || r.y <> y || r.w <> w || r.h <> h then
Lwd.set state_var (Resizing {x; y; w; h; split = r.split});
ignore
) ui
in
ui
in
splitter $= Lwd.map (Ui.mouse_area action) (Lwd.get splitter_bg);
render ();
let on_resize ew eh =
if !w <> ew || !h <> eh then (
w := ew; h := eh;
render ()
)
in
Lwd.map' node @@ fun t ->
Ui.size_sensor on_resize (Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 t)
Lwd.map2 render (Lwd.get state_var) (Lwd.pair l r)*)
let sub' str p l =
if p = 0 && l = String.length str

Ver fichero

@ -81,9 +81,6 @@ sig
val h : t -> direction
val v : t -> direction
val bottom_left : t
val bottom_right : t
type t2
val pair : t -> t -> t2
val p1 : t2 -> t
@ -112,9 +109,6 @@ struct
let h x = unpack (x lsr 2)
let v x = unpack (x land 3)
let bottom_left = make ~h:`Negative ~v:`Positive
let bottom_right = make ~h:`Positive ~v:`Positive
let pp_direction ppf dir =
let text = match dir with
| `Negative -> "`Negative"
@ -134,6 +128,35 @@ struct
end
type gravity = Gravity.t
module Interval : sig
type t = private int
val make : int -> int -> t
val shift : t -> int -> t
val fst : t -> int
val snd : t -> int
(*val size : t -> int*)
val zero : t
end = struct
type t = int
let half = Sys.word_size lsr 1
let mask = (1 lsl half) - 1
let make x y =
let size = y - x in
(*assert (size >= 0);*)
(x lsl half) lor (size land mask)
let shift t d =
t + d lsl half
let fst t = t asr half
let size t = t land mask
let snd t = fst t + size t
let zero = 0
end
module Ui =
struct
type may_handle = [ `Unhandled | `Handled ]
@ -165,42 +188,41 @@ struct
let pp_layout_spec ppf { w; h; sw; sh } =
Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh
type 'a desc =
| Atom of image
| Size_sensor of 'a * (int -> int -> unit)
| Resize of 'a * Gravity.t2 * A.t
| Mouse_handler of 'a * mouse_handler
| Focus_area of 'a * (key -> may_handle)
| Scroll_area of 'a * int * int
| Event_filter of 'a * ([`Key of key | `Mouse of mouse] -> may_handle)
| Overlay of 'a overlay
| X of 'a * 'a
| Y of 'a * 'a
| Z of 'a * 'a
type flags = int
let flags_none = 0
let flag_transient_sensor = 1
let flag_permanent_sensor = 2
and 'a overlay = {
o_n : 'a;
o_h : mouse_handler;
o_x : int;
o_y : int;
o_z : int;
o_origin : Gravity.t;
o_direction : Gravity.t;
}
type size_sensor = w:int -> h:int -> unit
type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit
type t = {
w : int; sw : int;
h : int; sh : int;
desc : t desc;
mutable desc : desc;
focus : Focus.status;
mutable flags : flags;
mutable sensor_cache : (int * int * int * int) option;
mutable cache : cache;
}
and cache = {
vx1 : int; vy1 : int;
vx2 : int; vy2 : int;
vx : Interval.t; vy : Interval.t;
image : image;
overlays: t overlay list;
}
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)
| Scroll_area of t * int * int
| 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 }
@ -210,18 +232,19 @@ struct
let layout_stretch_height t = t.sh
let cache : cache =
{ vx1 = 0; vy1 = 0; vx2 = 0; vy2 = 0;
image = I.empty; overlays = [] }
{ vx = Interval.zero; vy = Interval.zero; image = I.empty }
let empty : t =
{ w = 0; sw = 0; h = 0; sh = 0;
focus = Focus.empty; desc = Atom I.empty; cache }
{ 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 = I.width img; sw = 0;
h = I.height img; sh = 0;
focus = Focus.empty;
desc = Atom img; cache }
focus = Focus.empty; flags = flags_none;
desc = Atom img;
sensor_cache = None; cache; }
let void x y = atom (I.void x y)
@ -241,6 +264,14 @@ struct
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 resize ?w ?h ?sw ?sh ?fill ?crop ?(bg=A.empty) t : t =
let g = match fill, crop with
| None, None -> Gravity.(pair default default)
@ -252,19 +283,6 @@ struct
(Some sw, _ | None, sw), (Some sh, _ | None, sh) ->
{t with w; h; sw; sh; desc = Resize (t, g, bg)}
(* TODO: dangerous in a bind? use [Lwd_utils.local_state] instead? *)
let last_z = ref 0
let overlay ?dx:(o_x=0) ?dy:(o_y=0)
?handler:(o_h=fun ~x:_ ~y:_ _ -> `Unhandled)
?origin:(o_origin=Gravity.bottom_left)
?direction:(o_direction=Gravity.bottom_right)
=
let o_z = incr last_z; !last_z in
fun o_n ->
let desc = Overlay { o_n; o_x; o_y; o_h; o_z; o_origin; o_direction } in
{ w = 0; sw = 0; h = 0; sh = 0; desc; focus = Focus.empty; cache }
let event_filter ?focus f t : t =
let focus = match focus with
| None -> t.focus
@ -275,19 +293,25 @@ struct
let join_x a b = {
w = (a.w + b.w); sw = (a.sw + b.sw);
h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
focus = Focus.merge a.focus b.focus; desc = X (a, b); cache
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 = (maxi a.w b.w); sw = (maxi a.sw b.sw);
h = (a.h + b.h); sh = (a.sh + b.sh);
focus = Focus.merge a.focus b.focus; desc = Y (a, b); cache;
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 = (maxi a.w b.w); sw = (maxi a.sw b.sw);
h = (maxi a.h b.h); sh = (maxi a.sh b.sh);
focus = Focus.merge a.focus b.focus; desc = Z (a, b); cache;
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)
@ -309,6 +333,10 @@ struct
| 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)
@ -321,22 +349,16 @@ struct
Format.fprintf ppf "Scroll_area (@[%a,@ _@])" pp n
| Event_filter (n, _) ->
Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n
| Overlay o -> Format.fprintf ppf "Overlay (@[%a,@ _@])" pp_overlay o
| 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
and pp_overlay ppf r =
Format.fprintf ppf
"{@[o_n=%a;@ o_h=%s;@ o_h=%d;@ o_x=%d;@ o_y=%d;@ \
o_origin=%a;@ o_direction=%a@]}" pp r.o_n "_" r.o_x r.o_y r.o_z
Gravity.pp r.o_origin Gravity.pp r.o_direction
let iter f ui = match ui.desc with
| Atom _ -> ()
| Size_sensor (u, _) | Resize (u, _, _) | Mouse_handler (u, _)
| Size_sensor (u, _) | Transient_sensor (u, _) | Permanent_sensor (u, _)
| Resize (u, _, _) | Mouse_handler (u, _)
| Focus_area (u, _) | Scroll_area (u, _, _) | Event_filter (u, _)
| Overlay {o_n = u; _} -> f u
-> f u
| X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> f u1; f u2
end
type ui = Ui.t
@ -351,7 +373,7 @@ struct
type t = {
mutable size : size;
mutable view : ui;
mutable mouse_grab : (int * int * grab_function) option;
mutable mouse_grab : grab_function option;
}
let make () = {
@ -372,19 +394,6 @@ struct
in
aux ui
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_focus ui
let sort_overlays o = List.sort
(fun o1 o2 -> - compare o1.o_z o2.o_z) o
let split ~a ~sa ~b ~sb total =
let stretch = sa + sb in
let flex = total - a - b in
@ -410,12 +419,72 @@ struct
| `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
| Scroll_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 (fst size) (snd 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 (ox, oy, f); true
| `Grab f -> st.mouse_grab <- Some f; true
in
let rec aux ox oy sw sh t =
match t.desc with
@ -439,8 +508,8 @@ struct
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, _) ->
aux ox oy sw sh desc
| Size_sensor (desc, _)
| Transient_sensor (desc, _) | Permanent_sensor (desc, _)
| Focus_area (desc, _) ->
aux ox oy sw sh desc
| Scroll_area (desc, sx, sy) ->
@ -450,32 +519,20 @@ struct
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
| Overlay _ ->
false
| Event_filter (n, f) ->
begin match f (`Mouse (`Press btn, (x, y), [])) with
| `Handled -> true
| `Unhandled -> aux ox oy sw sh n
end
in
let rec overlays ox oy ovs =
List.exists (fun o ->
let ox = ox + o.o_x and oy = oy + o.o_y in
let ow = I.width o.o_n.cache.image in
let oh = I.height o.o_n.cache.image in
overlays ox oy o.o_n.cache.overlays
|| aux ox oy (ox + ow) (oy + oh) o.o_n
|| handle ox oy o.o_h
) (sort_overlays ovs)
in
overlays 0 0 t.cache.overlays || aux 0 0 w h t
aux 0 0 w h t
let release_grab st x y =
match st.mouse_grab with
| None -> ()
| Some (ox, oy, (_, release)) ->
| Some (_, release) ->
st.mouse_grab <- None;
release ~x:(x - ox) ~y:(y - oy)
release ~x ~y
let dispatch_mouse t (event, (x, y), _mods) =
if
@ -487,15 +544,13 @@ struct
| `Drag ->
begin match t.mouse_grab with
| None -> false
| Some (ox, oy, (drag, _)) -> drag ~x:(x - ox) ~y:(y - oy); true
| Some (drag, _) -> drag ~x ~y; true
end
| `Release ->
release_grab t x y; true
then `Handled
else `Unhandled
let shift_o x y o = {o with o_x = o.o_x + x; o_y = o.o_y + y}
let resize_canvas rw rh image =
let w = I.width image in
let h = I.height image in
@ -515,20 +570,23 @@ struct
let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache =
if
let cache = t.cache in
vx1 >= cache.vx1 && vy1 >= cache.vy1 &&
vx2 <= cache.vx2 && vy2 <= cache.vy2 &&
vx1 >= Interval.fst cache.vx && vy1 >= Interval.fst cache.vy &&
vx2 <= Interval.snd cache.vx && vy2 <= Interval.snd cache.vy &&
same_size sw sh cache.image
then t.cache
else if vx2 < 0 || vy2 < 0 || sw < vx1 || sh < vy1 then
{ vx1; vy1; vx2; vy2; image = I.void sw sh; overlays = [] }
let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
{ vx; vy; image = I.void sw sh }
else
let cache = match t.desc with
| Atom image ->
{ vx1 = 0; vy1 = 0; vx2 = sw; vy2 = sh;
overlays = [];
{ vx = Interval.make 0 sw;
vy = Interval.make 0 sh;
image = resize_canvas sw sh image }
| Size_sensor (desc, handler) ->
handler sw sh;
handler ~w:sw ~h:sh;
render_node vx1 vy1 vx2 vy2 sw sh desc
| Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
render_node vx1 vy1 vx2 vy2 sw sh desc
| Focus_area (desc, _) | Mouse_handler (desc, _) ->
render_node vx1 vy1 vx2 vy2 sw sh desc
@ -536,45 +594,44 @@ struct
let cache = render_node
(vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t'
in
{ vx1; vx2; vy1; vy2;
overlays = (List.map (shift_o (-sx) (-sy)) cache.overlays);
image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) }
let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in
let image = resize_canvas 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 vx1 vy1 vx2 vy2 aw sh a in
let cb = render_node (vx1 - aw) vy1 (vx2 - aw) vy2 bw sh b in
{ vx1 = maxi ca.vx1 (cb.vx1 + aw);
vx2 = mini ca.vx2 (cb.vx2 + aw);
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = List.map (shift_o aw 0) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<|>) ca.image cb.image) }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx + aw))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx + aw))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy))
and image = resize_canvas 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 vx1 vy1 vx2 vy2 sw ah a in
let cb = render_node vx1 (vy1 - ah) vx2 (vy2 - ah) sw bh b in
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 (cb.vy1 + ah);
vy2 = mini ca.vy2 (cb.vy2 + ah);
overlays = List.map (shift_o 0 ah) cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(<->) ca.image cb.image) }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy + ah))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy + ah))
and image = resize_canvas sw sh (I.(<->) ca.image cb.image) in
{ vx; vy; image }
| Z (a, b) ->
let ca = render_node vx1 vy1 vx2 vy2 sw sh a in
let cb = render_node vx1 vy1 vx2 vy2 sw sh b in
{ vx1 = maxi ca.vx1 cb.vx1;
vx2 = mini ca.vx2 cb.vx2;
vy1 = maxi ca.vy1 cb.vy1;
vy2 = mini ca.vy2 cb.vy2;
overlays = cb.overlays @ ca.overlays;
image = resize_canvas sw sh (I.(</>) cb.image ca.image) }
| Overlay overlay ->
let ow = overlay.o_n.w and oh = overlay.o_n.h in
let c = render_node 0 0 ow oh ow oh overlay.o_n in
{ vx1; vx2; vy1; vy2;
overlays = overlay ::
List.map (shift_o overlay.o_x overlay.o_y) c.overlays;
image = resize_canvas sw sh I.empty }
let vx = Interval.make
(maxi (Interval.fst ca.vx) (Interval.fst cb.vx))
(mini (Interval.snd ca.vx) (Interval.snd cb.vx))
and vy = Interval.make
(maxi (Interval.fst ca.vy) (Interval.fst cb.vy))
(mini (Interval.snd ca.vy) (Interval.snd cb.vy))
and image = resize_canvas sw sh (I.(</>) cb.image ca.image) in
{ vx; vy; image }
| 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
@ -589,30 +646,17 @@ struct
else
image
in
{ vx1 = c.vx1 + dx; vx2 = c.vx2 + dx;
vy1 = c.vy1 + dy; vy2 = c.vy2 + dy;
overlays = List.map (shift_o dx dy) c.overlays;
image
}
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 vx1 vy1 vx2 vy2 sw sh t
in
t.cache <- cache;
cache
let image st =
let flatten (im,todo) o =
let todo = List.map (shift_o o.o_x o.o_y) o.o_n.cache.overlays @ todo in
let ovi = I.pad ~l:o.o_x ~t:o.o_y o.o_n.cache.image in
(I.(</>) ovi im, todo)
in
let rec process = function
| (im, []) -> im
| (im, ovs) -> process (List.fold_left flatten (im, []) ovs)
in
let (w, h) = st.size in
let cache = render_node 0 0 w h w h st.view in
process (cache.image, cache.overlays)
let image {size = (w, h); view; _} =
(render_node 0 0 w h w h view).image
let dispatch_raw_key st key =
let rec iter (st: ui list) : [> `Unhandled] =
@ -620,7 +664,7 @@ struct
| [] -> `Unhandled
| ui :: tl ->
begin match ui.desc with
| Atom _ | Overlay _ -> iter tl
| Atom _ -> iter tl
| X (a, b) | Y (a, b) | Z (a, b) ->
(* Try left/top most branch first *)
let st' =
@ -638,6 +682,7 @@ struct
| `Unhandled -> iter tl
end
| Mouse_handler (t, _) | Size_sensor (t, _)
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) ->
iter (t :: tl)
| Event_filter (t, f) ->
@ -662,8 +707,9 @@ struct
let rec dispatch_focus t dir =
match t.desc with
| Atom _ | Overlay _ -> false
| Atom _ -> false
| Mouse_handler (t, _) | Size_sensor (t, _)
| Transient_sensor (t, _) | Permanent_sensor (t, _)
| Scroll_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) ->
dispatch_focus t dir
| Focus_area (t', _) ->

Ver fichero

@ -67,14 +67,17 @@ sig
val has_focus : t -> bool
val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t
val scroll_area : int -> int -> t -> t
val size_sensor : (int -> int -> unit) -> t -> t
type size_sensor = w:int -> h:int -> unit
val size_sensor : size_sensor -> t -> t
type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit
val transient_sensor : frame_sensor -> t -> t
val permanent_sensor : frame_sensor -> t -> t
val resize :
?w:int -> ?h:int -> ?sw:int -> ?sh:int ->
?fill:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t
val overlay :
?dx:int -> ?dy:int ->
?handler:mouse_handler -> ?origin:gravity -> ?direction:gravity ->
t -> t
val event_filter :
?focus:Focus.status ->
([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t