tmp

src/irmin-pack-tools/store_ui/context.ml

@@ -8,7 +8,6 @@ type ctx = {
   w : Sdl.window;
   wr : Sdl.rect;
   f : Ttf.font;
-  t : Timers.t;
   indexes : (string * Int63.t) list;
   store_path : string;
   mutable drag : (int * int) option;
@@ -39,11 +38,10 @@ let init_context store_path i =
     get @@ Ttf.open_font "/home/gwenaelle/Work/irmin/irmin/src/irmin-pack-tools/store_ui/data/OpenSans-Bold.ttf"
     12
   in
-  let t = Timers.create_timers () in
   let last_refresh = Unix.gettimeofday () in
   let indexes = Load_tree.load_index store_path in
   let current = i in
-  { r; w; wr; f; t; 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;

src/irmin-pack-tools/store_ui/dune

@@ -1,6 +1,6 @@
 (executable
  (name graphics)
- (modules graphics context load_tree tree timers sdl_util layout loading)
+ (modules graphics context load_tree tree sdl_util layout loading)
  (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
  (preprocess
   (pps ppx_repr)))

src/irmin-pack-tools/store_ui/graphics.ml

@@ -31,15 +31,13 @@ let generate_tree ctx d =
   let layout = layout ctx loading tree in
   (* extract *)
   let (tree_w, tree_h), render = Prettree.extract layout in
-  Fmt.pr "%f - %f@." tree_w tree_h;
   let scale_w = (float_of_int (Sdl.Rect.w tr)) /. tree_w in
   let scale_h = (float_of_int (Sdl.Rect.h tr)) /. tree_h in
-  let box = {min_w = 0.; max_w = tree_w; min_h = 0.; max_h = tree_h; scale_w; scale_h; zoom = 1.} in
+  let box = {min_w = 0.; max_w = tree_w; min_h = 0.; max_h = tree_h; scale_w; scale_h; zoom = 0.9} in
   Loading.destroy loading;
   render, box
 
 let generate_tree_texture ctx tree box =
-  Fmt.pr "Render texture: {min_w = %f; max_w = %f; min_h = %f; max_h = %f; scale_w = %f; scale_h = %f; zoom = %f}@." box.min_w box.max_w box.min_h box.max_h box.scale_w box.scale_h box.zoom;
   (* create texture *)
   let tr = get_tree_rect ctx.w ctx.wr in
   let t =
@@ -81,6 +79,10 @@ type texture = {
   mutable texture: Sdl.texture
 }
 
+let set_texture t texture =
+  Sdl.destroy_texture t.texture;
+  t.texture <- texture
+
 let main store_path i d =
   let () = get @@ Sdl.init Sdl.Init.(video + events) in
    let () = get @@ Ttf.init () in
@@ -127,7 +129,7 @@ let main store_path i d =
          | `Mouse_wheel ->
            let wheel_zoom = Sdl.Event.(get e mouse_wheel_y) in
            let data = tree_texture.data in
-           tree_texture.data <- { data with zoom = min (max (data.zoom +. float wheel_zoom /. 10.) 1. ) 4. };
+           tree_texture.data <- { data with zoom = min (max (data.zoom +. float wheel_zoom /. 10.) 0.9 ) 4. };
            ctx.updated <- true
          | `Key_up ->
            let key = Sdl.Event.(get e keyboard_keycode) in
@@ -138,23 +140,22 @@ let main store_path i d =
              tree_texture.data <- data;
              tree_texture.render <- render;
              let texture = generate_tree_texture ctx render data in
-             tree_texture.texture <- texture);
+             set_texture tree_texture texture);
            if key = Sdl.K.right
            then
              (ctx.current <- min (ctx.current + 1) (List.length ctx.indexes - 1);
              let render, box = generate_tree ctx d in
              tree_texture.data <- box;
              tree_texture.render <- render;
              let texture = generate_tree_texture ctx render box in
-             tree_texture.texture <- texture);
+             set_texture tree_texture texture);
             ()
          | _ -> ()
        done;
       if ctx.updated
       then
-        (Fmt.pr "Update tree@.";
-        let texture = generate_tree_texture ctx tree_texture.render tree_texture.data in
-        tree_texture.texture <- texture;
+        (let texture = generate_tree_texture ctx tree_texture.render tree_texture.data in
+        set_texture tree_texture texture;
         ctx.updated <- false);
        (* clear screen *)
        let () = get @@ Sdl.set_render_draw_color ctx.r 0xff 0xff 0xff 0xff in
@@ -171,7 +172,6 @@ let main store_path i d =
      delete_context ctx;
      Ttf.quit ();
      Sdl.quit ();
-     Timers.save_timers ctx.t;
      exit 0
 
 (* cmdliner *)

src/irmin-pack-tools/store_ui/layout.ml

@@ -12,13 +12,22 @@ type texture_data = {
   zoom : float
 }
 
-let must_be_shown (x, y) size t =
-  x +. size >= t.min_w && x <= (t.max_w +. t.zoom /. t.zoom) && y +. size >= t.min_h && y <= (t.max_h +. t.zoom /. t.zoom)
+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)
 
-let render_rect renderer color size path font current (x, y) t =
+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))
+
+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 must_be_shown = must_be_shown (x, y) size t 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
     (
@@ -28,13 +37,29 @@ let render_rect renderer color size path font current (x, y) t =
         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
-      ignore @@ draw_text renderer font path black center));
+      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
 
+let get_text_texture ctx text =
+  let open Tsdl in
+  let open Tsdl_ttf in
+  let s = get @@ Ttf.render_text_solid ctx.f text black in
+  let ttf_w, ttf_h = Sdl.get_surface_size s in
+  let text_texture = get @@ Sdl.create_texture_from_surface ctx.r s in
+  Sdl.free_surface s;
+  let text_rect (c_x, c_y) =
+    Sdl.Rect.create
+      ~x:(int @@ (c_x -. (float ttf_w /. 2.)))
+      ~y:(int @@ (c_y -. (float ttf_h /. 2.)))
+      ~w:ttf_w ~h:ttf_h
+  in
+  text_texture, text_rect, float ttf_w /. 10.
+
 let layout ctx loading =
   let rec layout_rec { depth = _; path; obj; current } =
     let open Prettree in
@@ -43,26 +68,29 @@ let layout ctx loading =
     match obj with
     | Leaf ->
         loading.current.entries <- loading.current.entries + 1;
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
         Prettree.make
-          (size *. float (String.length path), size)
+          (size *. text_width, size)
           (fun pos t ->
-            render_rect ctx.r blue size path ctx.f 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 *. float (String.length path), size)
+          (size *. text_width, size)
           (fun pos t ->
-              render_rect ctx.r red size path ctx.f 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 =
-          Prettree.make
-            (size *. float (String.length path), 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 path ctx.f 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 ->
@@ -74,19 +102,21 @@ let layout ctx loading =
         loading.current.inodes <- loading.current.inodes + 1;
         match i with
         | Values None ->
-            Prettree.make
-              (size *. float (String.length path), size)
-              (fun pos t ->
-                  render_rect ctx.r green size path ctx.f 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 =
-              Prettree.make
-                (size *. float (String.length path), size)
-                (fun pos t ->
-                    render_rect ctx.r green size path ctx.f 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 ->
@@ -96,19 +126,21 @@ let layout ctx loading =
                 l;
               parent_pos
         | Tree None ->
-            Prettree.make
-              (size *. float (String.length path), size)
-              (fun pos t ->
-                  render_rect ctx.r purple size path ctx.f 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 =
-              Prettree.make
-                (size *. float (String.length path), size)
-                (fun pos t ->
-                    render_rect ctx.r purple size path ctx.f 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 ->

src/irmin-pack-tools/store_ui/load_tree.ml

@@ -176,6 +176,5 @@ let load_index store_path =
   Index.iter
     (fun h (off, _, _) -> l := (string_of_int @@ Hash.short_hash h, off) :: !l)
     index;
-  Fmt.pr "Found %d indexed commits@." (List.length !l);
   let cmp (_, off1) (_, off2) = Int63.(to_int @@ sub off1 off2) in
   List.sort cmp !l

src/irmin-pack-tools/store_ui/sdl_util.ml

@@ -40,6 +40,9 @@ 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 draw_text r f text color (c_x, c_y) =
   let s = get @@ Ttf.render_text_solid f text color in
   let ttf_w, ttf_h = Sdl.get_surface_size s in
@@ -51,7 +54,7 @@ let draw_text r f text color (c_x, c_y) =
       ~y:(int @@ (c_y -. (float ttf_h /. 2.)))
       ~w:ttf_w ~h:ttf_h
   in
-  let () = get @@ Sdl.render_copy ~dst:rect_text r ttx_t in
+  render_text r ttx_t rect_text;
   (ttf_w, ttf_h)
 
 let white = Sdl.Color.create ~r:256 ~g:256 ~b:256 ~a:0xff