Comparar commits
6 Commits
master
...
nottui-ful
Autor | SHA1 | Fecha |
---|---|---|
Frédéric Bour | bfc481aa54 | |
Frédéric Bour | a995047176 | |
Frédéric Bour | b4447f82f3 | |
Frédéric Bour | fe42d56bf5 | |
Frédéric Bour | 9eb18e2207 | |
Frédéric Bour | 07823fed56 |
6
Makefile
6
Makefile
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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', _) ->
|
||||
|
|
|
@ -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
|
||||
|
|
Cargando…
Referencia en una nueva incidencia