Skip to content

Commit

Permalink
irmin-pack-tools: Apply fmt
Browse files Browse the repository at this point in the history
  • Loading branch information
@clecat
clecat committed Sep 4, 2023
1 parent 09bad9e commit 9631eb6
Show file tree
Hide file tree
Showing 4 changed files with 91 additions and 53 deletions.
23 changes: 16 additions & 7 deletions src/irmin-pack-tools/store_ui/context.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ type ctx = {
mutable drag : (int * int) option;
mutable current : int;
mutable last_refresh : float;
mutable updated : bool
mutable updated : bool;
}

let get_window_rect () =
Expand All @@ -29,19 +29,28 @@ let init_context store_path font_path i =
let w =
let open Sdl.Rect in
get
@@ Sdl.create_window ~x:(x wr) ~y:(y wr) ~w:(w wr) ~h:(h wr) "Tezos store explorer" Sdl.Window.opengl
@@ Sdl.create_window ~x:(x wr) ~y:(y wr) ~w:(w wr) ~h:(h wr)
"Tezos store explorer" Sdl.Window.opengl
in
let r =
get @@ Sdl.create_renderer ~index:(-1) ~flags:Sdl.Renderer.accelerated w
in
let f =
get @@ Ttf.open_font font_path
12
in
let f = get @@ Ttf.open_font font_path 12 in
let last_refresh = Unix.gettimeofday () in
let indexes = Load_tree.load_index store_path in
let current = i in
{ r; w; wr; f; store_path; indexes; current; drag = None; last_refresh; updated = false }
{
r;
w;
wr;
f;
store_path;
indexes;
current;
drag = None;
last_refresh;
updated = false;
}

let delete_context ctx =
Ttf.close_font ctx.f;
Expand Down
110 changes: 70 additions & 40 deletions src/irmin-pack-tools/store_ui/layout.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,41 +9,49 @@ type texture_data = {
max_h : float;
scale_w : float;
scale_h : float;
zoom : float
zoom : float;
}

let must_be_shown (x, y) (size_w, size_h) t =
x +. size_w >= t.min_w && x <= (t.max_w +. t.zoom /. t.zoom) && y +. size_h >= t.min_h && y <= (t.max_h +. t.zoom /. t.zoom)
x +. size_w >= t.min_w
&& x <= t.max_w +. (t.zoom /. t.zoom)
&& y +. size_h >= t.min_h
&& y <= t.max_h +. (t.zoom /. t.zoom)

let scale_text_rect ttx_r (scale_w, scale_h) =
let open Tsdl in
let text_w = float (Sdl.Rect.w ttx_r) in
let text_h = float (Sdl.Rect.h ttx_r) in
let corrected_w = min scale_w text_w in
let corrected_h = min scale_h text_h in
Sdl.Rect.(create ~x:(x ttx_r + (int @@ (text_w -. corrected_w) /. 2.)) ~y:(y ttx_r) ~w:(int corrected_w) ~h:(int corrected_h))
Sdl.Rect.(
create
~x:(x ttx_r + (int @@ ((text_w -. corrected_w) /. 2.)))
~y:(y ttx_r) ~w:(int corrected_w) ~h:(int corrected_h))

let render_rect renderer color size (ttx_t, ttx_r, ttx_width) current (x, y) t =
let scale_w, scale_h = t.scale_w *. t.zoom *. size, t.scale_h *. t.zoom *. size in
let x', y' = (x -. t.min_w) *. scale_w, (y -. t.min_h) *. scale_h in
let scale_w, scale_h =
(t.scale_w *. t.zoom *. size, t.scale_h *. t.zoom *. size)
in
let x', y' = ((x -. t.min_w) *. scale_w, (y -. t.min_h) *. scale_h) in
let scale_w = scale_w *. ttx_width in
let must_be_shown = must_be_shown (x, y) (size *. ttx_width, size) t in
if must_be_shown
then
(
if must_be_shown then
if min scale_w scale_h < 1. then draw_point renderer color (x', y')
else (
if not current then
fill_rect renderer light_grey (x', y') (scale_w, scale_h);
draw_rect renderer color (x', y') (scale_w, scale_h);
let center = (x' +. (scale_w /. 2.), y' +. (scale_h /. 2.)) in
let ttx_r = scale_text_rect (ttx_r center) (scale_w, scale_h) in
render_text renderer ttx_t ttx_r));
(must_be_shown, (x' +. (scale_w /. 2.), y'), (x' +. (scale_w /. 2.), y' +. scale_h)), t
let ttx_r = scale_text_rect (ttx_r center) (scale_w, scale_h) in
render_text renderer ttx_t ttx_r);
( ( must_be_shown,
(x' +. (scale_w /. 2.), y'),
(x' +. (scale_w /. 2.), y' +. scale_h) ),
t )

let render_link renderer ((b1, _, bottom), _) ((b2, top, _), _) =
if b1 || b2
then draw_line renderer bottom top
if b1 || b2 then draw_line renderer bottom top

let get_text_texture ctx text =
let open Tsdl in
Expand All @@ -58,7 +66,7 @@ let get_text_texture ctx text =
~y:(int @@ (c_y -. (float ttf_h /. 2.)))
~w:ttf_w ~h:ttf_h
in
text_texture, text_rect, float ttf_w /. 10.
(text_texture, text_rect, float ttf_w /. 10.)

let layout ctx loading =
let rec layout_rec { depth = _; path; obj; current } =
Expand All @@ -72,25 +80,31 @@ let layout ctx loading =
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r blue size (text_texture, text_rect, text_width) current pos t)
render_rect ctx.r blue size
(text_texture, text_rect, text_width)
current pos t)
| Commit None ->
loading.current.commits <- loading.current.commits + 1;
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r red size (text_texture, text_rect, text_width) current pos t)
render_rect ctx.r red size
(text_texture, text_rect, text_width)
current pos t)
| Commit (Some child) ->
loading.current.commits <- loading.current.commits + 1;
Prettree.vert
@@
let open Prettree.Syntax in
let+ parent =
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r red size (text_texture, text_rect, text_width) current pos t)
render_rect ctx.r red size
(text_texture, text_rect, text_width)
current pos t)
and+ () = Prettree.padding 1.
and+ child = layout_rec child in
fun t ->
Expand All @@ -102,21 +116,29 @@ let layout ctx loading =
loading.current.inodes <- loading.current.inodes + 1;
match i with
| Values None ->
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r green size (text_texture, text_rect, text_width) current pos t)
let text_texture, text_rect, text_width =
get_text_texture ctx path
in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r green size
(text_texture, text_rect, text_width)
current pos t)
| Values (Some l) ->
Prettree.vert
@@
let open Prettree.Syntax in
let+ parent =
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r green size (text_texture, text_rect, text_width) current pos t)
let text_texture, text_rect, text_width =
get_text_texture ctx path
in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r green size
(text_texture, text_rect, text_width)
current pos t)
and+ () = Prettree.padding 1.
and+ l = horz (list ~padding:size (List.map layout_rec l)) in
fun scale ->
Expand All @@ -126,21 +148,29 @@ let layout ctx loading =
l;
parent_pos
| Tree None ->
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r purple size (text_texture, text_rect, text_width) current pos t)
let text_texture, text_rect, text_width =
get_text_texture ctx path
in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r purple size
(text_texture, text_rect, text_width)
current pos t)
| Tree (Some l) ->
Prettree.vert
@@
let open Prettree.Syntax in
let+ parent =
let text_texture, text_rect, text_width = get_text_texture ctx path in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r purple size (text_texture, text_rect, text_width) current pos t)
let text_texture, text_rect, text_width =
get_text_texture ctx path
in
Prettree.make
(size *. text_width, size)
(fun pos t ->
render_rect ctx.r purple size
(text_texture, text_rect, text_width)
current pos t)
and+ () = Prettree.padding 1.
and+ l = horz (list ~padding:size (List.map layout_rec l)) in
fun scale ->
Expand Down
8 changes: 4 additions & 4 deletions src/irmin-pack-tools/store_ui/loading.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -117,10 +117,10 @@ let check_close_event () =
let e = Sdl.Event.create () in
while Sdl.poll_event (Some e) do
match Sdl.Event.(enum (get e typ)) with
| `Window_event ->
(match Sdl.Event.(window_event_enum (get e window_event_id)) with
| `Close -> raise Exit
| _ -> ());
| `Window_event -> (
match Sdl.Event.(window_event_enum (get e window_event_id)) with
| `Close -> raise Exit
| _ -> ())
| _ -> ()
done

Expand Down
3 changes: 1 addition & 2 deletions src/irmin-pack-tools/store_ui/sdl_util.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,8 +40,7 @@ let draw_line r (x0, y0) (x1, y1) =

open Tsdl_ttf

let render_text r texture dst =
get @@ Sdl.render_copy ~dst r texture
let render_text r texture dst = get @@ Sdl.render_copy ~dst r texture

let draw_text r f text color (c_x, c_y) =
let s = get @@ Ttf.render_text_solid f text color in
Expand Down

0 comments on commit 9631eb6

Please sign in to comment.