From 18ee9ac8c5a4c47aa8cae6377164584a41447050 Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Tue, 5 Sep 2023 17:46:04 +0200
Subject: [PATCH 1/3] irmin-pack-tools: Add a GUI for tezos stores

---
 irmin-pack-tools.opam                         |   7 +
 src/irmin-pack-tools/README.md                |  23 +-
 .../tezos_explorer_gui/context.ml             |  58 +++++
 src/irmin-pack-tools/tezos_explorer_gui/dune  |   8 +
 .../tezos_explorer_gui/layout.ml              | 184 ++++++++++++++
 .../tezos_explorer_gui/load_tree.ml           | 180 ++++++++++++++
 .../tezos_explorer_gui/loading.ml             | 136 +++++++++++
 .../tezos_explorer_gui/main.ml                | 228 ++++++++++++++++++
 .../tezos_explorer_gui/sdl_util.ml            |  67 +++++
 .../tezos_explorer_gui/tree.ml                |   3 +
 10 files changed, 893 insertions(+), 1 deletion(-)
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/context.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/dune
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/layout.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/loading.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/main.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/sdl_util.ml
 create mode 100644 src/irmin-pack-tools/tezos_explorer_gui/tree.ml

diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam
index 89794983ca..3b494d2296 100644
--- a/irmin-pack-tools.opam
+++ b/irmin-pack-tools.opam
@@ -24,12 +24,19 @@ depends: [
   "cmdliner"    {>= "1.1.0"}
   "cmdliner"    {>= "1.1.0"}
   "notty"       {>= "0.2.3"}
+  "tsdl"        {>= "1.0.0"}
+  "tsdl-ttf"    {>= "0.6"}
+  "prettree"
   "ptime"
   "hex"
   "irmin-test"  {with-test & = version}
   "alcotest"    {with-test}
 ]
 
+pin-depends: [
+  ["prettree.dev"  "git+https://github.com/art-w/prettree.git#568de08442f02dd87acc84ca6a91cc661b7e77bf"]
+]
+
 synopsis: "Utils for Irmin-pack"
 description: """
 `Irmin-pack-tools` defines useful binaries and libraries for
diff --git a/src/irmin-pack-tools/README.md b/src/irmin-pack-tools/README.md
index 0d84e0e376..445b547696 100644
--- a/src/irmin-pack-tools/README.md
+++ b/src/irmin-pack-tools/README.md
@@ -4,7 +4,8 @@ This folder contains several tools meant to provide usefull ways to debug and du
 Currently, there are the following tools:
 - [`ppcf`](#ppcf), a json printer for control files
 - [`ppidx`](#ppidx), a json printer for index folders
-- [`tezos-explorer`](#tezos-explorer), a gui for a fast exploration of tezos stores
+- [`tezos-explorer`](#tezos-explorer), a notty ui for a fast exploration of tezos stores
+- [`tezos-explorer-gyu`](#tezos-explorer-gui), a graphical ui for a fast exploration of tezos stores
 
 ## ppcf
 This tool prints a control file in a human readable manner (json), allowing to fetch important informations easily.
@@ -101,3 +102,23 @@ $ jq -s 'sort_by(.off)' -- index
 
 ## tezos-explorer
 TODO
+
+## tezos-explorer-gui
+This tool is a graphical UI, meant to allow the user to figure out rapidly the shape of a commit, giving him informations on it's content.
+It can be launched using the following command:
+```shell
+$ dune exec -- irmin-tezos-explorer-gui <path-to-store> <path-to-ttf-font> <commit>
+```
+
+The first argument is the path to the root of the store (e.g. `output/root/`).
+
+The second argument is the path to a `.ttf` file, necessary to know which font to use when printing strings.
+
+The third argument is an int, the `nth` commit stored in the index of the store that will be showned first.
+
+Once the program is launched, you can:
+- Navigate through the indexed commits using the left and right arrows.
+- Zoom in and out using the mouse wheel.
+- Drag the tree around when pressing the left mouse click and moving it around.
+
+Be aware that some commit are too big to be shown, and will take ages to compute for very little informations: You can shut the program down using the `alt-f4`` command.
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/context.ml b/src/irmin-pack-tools/tezos_explorer_gui/context.ml
new file mode 100644
index 0000000000..fdd12d2fc7
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/context.ml
@@ -0,0 +1,58 @@
+open Tsdl
+open Tsdl_ttf
+open Optint
+open Sdl_util
+
+type ctx = {
+  r : Sdl.renderer;
+  w : Sdl.window;
+  wr : Sdl.rect;
+  f : Ttf.font;
+  indexes : (string * Int63.t) list;
+  store_path : string;
+  mutable drag : (int * int) option;
+  mutable current : int;
+  mutable last_refresh : float;
+  mutable updated : bool;
+}
+
+let get_window_rect () =
+  let open Sdl.Rect in
+  let bounds = get @@ Sdl.get_display_bounds 0 in
+  let usable_bounds = get @@ Sdl.get_display_usable_bounds 0 in
+  let uw = w usable_bounds in
+  let uh = h usable_bounds in
+  create ~x:(w bounds - uw) ~y:(Sdl.Rect.h bounds - uh) ~w:uw ~h:uh
+
+let init_context store_path font_path i =
+  let wr = get_window_rect () in
+  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
+  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 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;
+  }
+
+let delete_context ctx =
+  Ttf.close_font ctx.f;
+  Sdl.destroy_renderer ctx.r;
+  Sdl.destroy_window ctx.w
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/dune b/src/irmin-pack-tools/tezos_explorer_gui/dune
new file mode 100644
index 0000000000..43283d7a93
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/dune
@@ -0,0 +1,8 @@
+(executable
+ (public_name irmin-tezos-explorer-gui)
+ (package irmin-pack-tools)
+ (name main)
+ (modules main context load_tree tree sdl_util layout loading)
+ (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
+ (preprocess
+  (pps ppx_repr)))
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/layout.ml b/src/irmin-pack-tools/tezos_explorer_gui/layout.ml
new file mode 100644
index 0000000000..061cca3a9b
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/layout.ml
@@ -0,0 +1,184 @@
+open Tree
+open Sdl_util
+open Context
+
+type texture_data = {
+  min_w : float;
+  max_w : float;
+  min_h : float;
+  max_h : float;
+  scale_w : float;
+  scale_h : 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)
+
+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 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 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 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
+    Loading.update loading;
+    let size = 1. in
+    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 *. text_width, size)
+          (fun 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)
+    | 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)
+            (fun 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 ->
+          let parent_info = parent t in
+          let child_info = child t in
+          render_link ctx.r parent_info child_info;
+          parent_info
+    | Inode i -> (
+        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)
+        | 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)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                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)
+        | 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)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                l;
+              parent_pos)
+  in
+  Loading.set_state loading Gen_layout;
+  layout_rec
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml b/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml
new file mode 100644
index 0000000000..7fb3285a6d
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/load_tree.ml
@@ -0,0 +1,180 @@
+open Optint
+module Kind = Irmin_pack.Pack_value.Kind
+module Conf = Irmin_tezos.Conf
+module Schema = Irmin_tezos.Schema
+module Maker = Irmin_pack_unix.Maker (Conf)
+module Store = Maker.Make (Schema)
+module Hash = Store.Hash
+module Key = Irmin_pack_unix.Pack_key.Make (Hash)
+module Io = Irmin_pack_unix.Io.Unix
+module Errs = Irmin_pack_unix.Io_errors.Make (Io)
+module Index = Irmin_pack_unix.Index.Make (Hash)
+module File_manager = Irmin_pack_unix.File_manager.Make (Io) (Index) (Errs)
+module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager)
+
+module Inode = struct
+  module Value = Schema.Node (Key) (Key)
+  include Irmin_pack.Inode.Make_internal (Conf) (Hash) (Key) (Value)
+
+  type compress = Compress.t [@@deriving repr ~decode_bin]
+end
+
+module Commit = struct
+  module Value = struct
+    include Schema.Commit (Key) (Key)
+    module Info = Schema.Info
+  end
+
+  include Irmin_pack.Pack_value.Of_commit (Hash) (Key) (Value)
+
+  type compress = Commit_direct.t [@@deriving repr ~decode_bin]
+end
+
+module Varint = struct
+  type t = int [@@deriving repr ~decode_bin ~encode_bin]
+
+  let max_encoded_size = 9
+end
+
+let max_bytes_needed_to_discover_length =
+  Hash.hash_size + 1 + Varint.max_encoded_size
+
+let min_bytes_needed_to_discover_length = Hash.hash_size + 1
+
+let decode_entry_header buffer =
+  let buffer = Bytes.unsafe_to_string buffer in
+  let i0 = 0 in
+
+  let imagic = i0 + Hash.hash_size in
+  let kind = Kind.of_magic_exn buffer.[imagic] in
+
+  let ilength = i0 + Hash.hash_size + 1 in
+  let pos_ref = ref ilength in
+  let suffix_length = Varint.decode_bin buffer pos_ref in
+  let length_length = !pos_ref - ilength in
+
+  (kind, Hash.hash_size + 1 + length_length + suffix_length)
+
+let decode_entry dispatcher buffer off =
+  let _ =
+    Dispatcher.read_range_exn dispatcher ~off
+      ~min_len:min_bytes_needed_to_discover_length
+      ~max_len:max_bytes_needed_to_discover_length buffer
+  in
+  let kind, len = decode_entry_header buffer in
+  let _ = Dispatcher.read_exn dispatcher ~off ~len:Hash.hash_size buffer in
+  let hash = Bytes.sub_string buffer 0 Hash.hash_size in
+  let _ = Dispatcher.read_exn dispatcher ~off ~len buffer in
+  let content = Bytes.sub_string buffer 0 len in
+  (hash, kind, len, content)
+
+exception Commit of string * Int63.t
+
+let buffer = Bytes.create (4096 * 4096)
+
+let get_entry dispatcher off =
+  let _, _, _, contents = decode_entry dispatcher buffer off in
+  contents
+
+open Tree
+
+let load_inode dispatcher addr =
+  let contents = get_entry dispatcher addr in
+  contents
+
+let load_commit dispatcher addr =
+  let contents = get_entry dispatcher addr in
+  let entry_header = Hash.hash_size + 2 in
+  let contents_len = String.length contents - entry_header in
+  let contents = String.sub contents entry_header contents_len in
+  contents
+
+let get_name dict (n : Inode.Compress.name) =
+  match n with
+  | Indirect dict_key ->
+      let key = File_manager.Dict.find dict dict_key in
+      Option.get key
+  | Direct step -> step
+
+let get_tree_from_commit (loading : Loading.t) dispatcher dict max_depth
+    last_commit_off commit_hash =
+  let rec get_commit_tree depth (commit : Commit.Commit_direct.t) =
+    loading.max.commits <- loading.max.commits + 1;
+    Loading.update loading;
+    if depth <> max_depth then
+      match commit.node_offset with
+      | Offset addr ->
+          let current = addr > last_commit_off in
+          let contents = load_inode dispatcher addr in
+          let inode = Inode.decode_bin_compress contents (ref 0) in
+          {
+            depth;
+            path = commit_hash;
+            obj = Commit (Some (get_node_tree (depth + 1) "root" inode current));
+            current = true;
+          }
+      | Hash _hash -> assert false
+    else { depth; path = commit_hash; obj = Commit None; current = true }
+  and get_node_tree depth name (inode : Inode.compress) current =
+    let addr_show name (addr : Inode.Compress.address) =
+      match addr with
+      | Offset addr ->
+          let current = addr > last_commit_off in
+          let contents = load_inode dispatcher addr in
+          let inode = Inode.decode_bin_compress contents (ref 0) in
+          get_node_tree (depth + 1) name inode current
+      | Hash _hash -> assert false
+    in
+    let value (v : Inode.Compress.value) =
+      match v with
+      | Contents (n, addr, ()) -> (
+          match addr with
+          | Offset addr ->
+              let current = addr > last_commit_off in
+              loading.max.entries <- loading.max.entries + 1;
+              Loading.update loading;
+              { depth = depth + 1; path = get_name dict n; obj = Leaf; current }
+          | Hash _hash -> assert false)
+      | Node (n, addr) -> addr_show (get_name dict n) addr
+    in
+    let ptr (p : Inode.Compress.ptr) =
+      addr_show (string_of_int p.index) p.hash
+    in
+    let tree (t : Inode.Compress.tree) = List.map ptr t.entries in
+    let v (tv : Inode.Compress.v) =
+      if depth <> max_depth && current then
+        match tv with
+        | Values l -> Tree.Values (Some (List.map value l))
+        | Tree t -> Tree (Some (tree t))
+      else match tv with Values _ -> Tree.Values None | Tree _ -> Tree None
+    in
+    let l =
+      match inode.tv with
+      | V1_stable tv | V1_unstable tv -> v tv
+      | V2_root tv | V2_nonroot tv -> v tv.v
+    in
+    loading.max.inodes <- loading.max.inodes + 1;
+    Loading.update loading;
+    { depth; path = name; obj = Inode l; current }
+  in
+  get_commit_tree 0
+
+let load_tree loading store_path ~max_depth (hash, off) last_commit_off =
+  Loading.set_state loading Load_tree;
+  let conf = Irmin_pack.Conf.init store_path in
+  let fm = Errs.raise_if_error @@ File_manager.open_ro conf in
+  let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
+  let dict = File_manager.dict fm in
+  let contents = load_commit dispatcher off in
+  let commit = Commit.decode_bin_compress contents (ref 0) in
+  get_tree_from_commit loading dispatcher dict max_depth last_commit_off hash
+    commit
+
+let load_index store_path =
+  let index = Index.v_exn ~readonly:true ~log_size:500_000 store_path in
+  let l = ref [] in
+  Index.iter
+    (fun h (off, _, _) -> l := (string_of_int @@ Hash.short_hash h, off) :: !l)
+    index;
+  let cmp (_, off1) (_, off2) = Int63.(to_int @@ sub off1 off2) in
+  List.sort cmp !l
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/loading.ml b/src/irmin-pack-tools/tezos_explorer_gui/loading.ml
new file mode 100644
index 0000000000..005b0f2e3f
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/loading.ml
@@ -0,0 +1,136 @@
+open Tsdl
+open Tsdl_ttf
+open Sdl_util
+
+type state = Load_tree | Gen_layout
+
+type counter = {
+  mutable entries : int;
+  mutable commits : int;
+  mutable inodes : int;
+}
+
+type t = {
+  w : Sdl.window;
+  r : Sdl.renderer;
+  mutable state : state;
+  mutable last_refresh : float;
+  mutable current : counter;
+  max : counter;
+  f : Ttf.font;
+}
+
+let init f =
+  let w =
+    get
+    @@ Sdl.create_window ~w:256 ~h:90 "Loading tree"
+         Sdl.Window.(opengl + popup_menu)
+  in
+  let r =
+    get @@ Sdl.create_renderer ~index:(-1) ~flags:Sdl.Renderer.accelerated w
+  in
+  let current = { entries = 0; commits = 0; inodes = 0 } in
+  let max = { entries = 0; commits = 0; inodes = 0 } in
+  let last_refresh = Unix.gettimeofday () in
+  { w; r; state = Load_tree; last_refresh; current; max; f }
+
+let set_state t state =
+  t.state <- state;
+  t.current <- { entries = 0; commits = 0; inodes = 0 }
+
+let get_state_text t =
+  match t.state with
+  | Load_tree -> "loading tree      (1/2)"
+  | Gen_layout -> "generating layout (2/2)"
+
+let get_progress t =
+  let current = t.current.commits + t.current.inodes + t.current.entries in
+  let max = t.max.commits + t.max.inodes + t.max.entries in
+  if max > 0 then float current /. float max else 0.
+
+let update_frame t =
+  let ww, wh = Sdl.get_window_size t.w in
+  let texture =
+    get
+    @@ Sdl.create_texture t.r
+         (Sdl.get_window_pixel_format t.w)
+         Sdl.Texture.access_target ~w:ww ~h:wh
+  in
+  (* setup texture *)
+  let () = get @@ Sdl.set_render_target t.r (Some texture) in
+  let () = get @@ Sdl.set_render_draw_color t.r 0xf0 0xf0 0xf0 0xff in
+  let () = get @@ Sdl.render_clear t.r in
+  let () = get @@ Sdl.set_render_draw_color t.r 0x00 0x00 0x00 0x00 in
+  let () = Sdl.render_present t.r in
+  (* write text *)
+  let state_text = get_state_text t in
+  let _progress = get_progress t in
+  let state = Fmt.str "state: %s" state_text in
+  let head_lines =
+    [ Fmt.str "commits:"; Fmt.str "inodes:"; Fmt.str "entries:" ]
+  in
+  let currents =
+    [
+      Fmt.str "%d" t.current.commits;
+      Fmt.str "%d" t.current.inodes;
+      Fmt.str "%d" t.current.entries;
+    ]
+  in
+  let maxes =
+    [
+      Fmt.str "/ %d@." t.max.commits;
+      Fmt.str "/ %d@." t.max.inodes;
+      Fmt.str "/ %d@." t.max.entries;
+    ]
+  in
+  let show_text ?(x = 0) (h, max_w) text =
+    let s = get @@ Ttf.render_text_solid t.f text black in
+    let ttf_w, ttf_h = Sdl.get_surface_size s in
+    let ttx_t = get @@ Sdl.create_texture_from_surface t.r s in
+    Sdl.free_surface s;
+    let rect_text = Sdl.Rect.create ~x ~y:h ~w:ttf_w ~h:ttf_h in
+    let () = get @@ Sdl.render_copy ~dst:rect_text t.r ttx_t in
+    (h + ttf_h, max (x + ttf_w) max_w)
+  in
+  let h, _ = show_text (0, 0) state in
+  let _, max_w = List.fold_left show_text (h, 0) head_lines in
+  let _, max_w = List.fold_left (show_text ~x:(max_w + 10)) (h, 0) currents in
+  let h, _ = List.fold_left (show_text ~x:(max_w + 10)) (h, 0) maxes in
+  (* progress bar *)
+  let progress_w = int (get_progress t *. float ww) in
+  let progress_h = wh - h in
+  let rect_progress = Sdl.Rect.create ~x:0 ~y:h ~w:progress_w ~h:progress_h in
+  let () = get @@ Sdl.set_render_draw_color t.r 0x00 0xff 0x00 0xff in
+  let () = get @@ Sdl.render_fill_rect t.r (Some rect_progress) in
+  let rect_progress_border = Sdl.Rect.create ~x:0 ~y:h ~w:ww ~h:progress_h in
+  let () = get @@ Sdl.set_render_draw_color t.r 0x00 0x00 0x00 0x00 in
+  let () = get @@ Sdl.render_draw_rect t.r (Some rect_progress_border) in
+  (* reset render target *)
+  let () = get @@ Sdl.set_render_target t.r None in
+  (* copy texture *)
+  let () = get @@ Sdl.render_copy t.r texture in
+  (* present *)
+  let () = Sdl.render_present t.r in
+  ()
+
+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
+        | _ -> ())
+    | _ -> ()
+  done
+
+let update t =
+  let framerate = 1. /. 20. in
+  let now = Unix.gettimeofday () in
+  let wait_time = (t.last_refresh +. framerate -. now) *. 1000. in
+  if wait_time < 0. then (
+    check_close_event ();
+    update_frame t;
+    t.last_refresh <- Unix.gettimeofday ())
+
+let destroy t = Sdl.destroy_window t.w
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/main.ml b/src/irmin-pack-tools/tezos_explorer_gui/main.ml
new file mode 100644
index 0000000000..265cfc4530
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/main.ml
@@ -0,0 +1,228 @@
+open Tsdl
+open Tsdl_ttf
+open Sdl_util
+open Layout
+open Context
+
+let get_tree_rect w wr =
+  let bst, bsl, bsb, bsr = get @@ Sdl.get_window_borders_size w in
+  let open Sdl.Rect in
+  let tw, th = (w wr - bsl - bsr, h wr - bst - bsb) in
+  let w = tw in
+  let h = th in
+  let x = 0 in
+  let y = 0 in
+  create ~x ~y ~w ~h
+
+let generate_tree ctx d =
+  let tr = get_tree_rect ctx.w ctx.wr in
+  let loading = Loading.init ctx.f in
+  Loading.update loading;
+  (* load tree *)
+  let commit_info = List.nth ctx.indexes ctx.current in
+  let last_commit_addr =
+    if ctx.current = 0 then Optint.Int63.of_int (-1)
+    else snd @@ List.nth ctx.indexes (ctx.current - 1)
+  in
+  let tree =
+    Load_tree.load_tree loading ctx.store_path ~max_depth:d commit_info
+      last_commit_addr
+  in
+  (* layout *)
+  let layout = layout ctx loading tree in
+  (* extract *)
+  let (tree_w, tree_h), render = Prettree.extract layout in
+  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 = 0.9;
+    }
+  in
+  Loading.destroy loading;
+  (render, box)
+
+let generate_tree_texture ctx tree box =
+  (* create texture *)
+  let tr = get_tree_rect ctx.w ctx.wr in
+  let t =
+    get
+    @@ Sdl.create_texture ctx.r
+         (Sdl.get_window_pixel_format ctx.w)
+         Sdl.Texture.access_target ~w:(Sdl.Rect.w tr) ~h:(Sdl.Rect.h tr)
+  in
+  (* setup texture *)
+  let () = get @@ Sdl.set_render_target ctx.r (Some t) in
+  let () = get @@ Sdl.set_render_draw_color ctx.r 0xff 0xff 0xff 0xff in
+  let () = get @@ Sdl.render_clear ctx.r in
+  let () = get @@ Sdl.set_render_draw_color ctx.r 0x00 0x00 0x00 0x00 in
+  (* render *)
+  let _ = tree (0., 0.) box in
+  let () = get @@ Sdl.set_render_target ctx.r None in
+  t
+
+let wait_shown () =
+  let e = Sdl.Event.create () in
+  let _ = get @@ Sdl.wait_event (Some e) in
+  while
+    Sdl.Event.(
+      enum (get e typ) <> `Window_event
+      || window_event_enum (get e window_event_id) <> `Shown)
+  do
+    let _ = get @@ Sdl.wait_event (Some e) in
+    ()
+  done
+
+let refresh_rate ctx =
+  let framerate = 1. /. 60. in
+  let now = Unix.gettimeofday () in
+  let wait_time = (ctx.last_refresh +. framerate -. now) *. 1000. in
+  if wait_time > 0. then Sdl.delay (Int32.of_float wait_time);
+  ctx.last_refresh <- Unix.gettimeofday ()
+
+type texture = {
+  mutable data : Layout.texture_data;
+  mutable render :
+    Prettree.v2 ->
+    Layout.texture_data ->
+    (bool * (float * float) * (float * float)) * Layout.texture_data;
+  mutable texture : Sdl.texture;
+}
+
+let set_texture t texture =
+  Sdl.destroy_texture t.texture;
+  t.texture <- texture
+
+let main store_path font_path i d =
+  let () = get @@ Sdl.init Sdl.Init.(video + events) in
+  let () = get @@ Ttf.init () in
+  let ctx = init_context store_path font_path i in
+  (* wait for the window to be showned *)
+  wait_shown ();
+  try
+    (* generate tree *)
+    let render, data = generate_tree ctx d in
+    let texture = generate_tree_texture ctx render data in
+    let tree_texture = { data; render; texture } in
+    (* main loop *)
+    while true do
+      (* fetch events *)
+      let e = Sdl.Event.create () in
+      while Sdl.poll_event (Some e) do
+        match Sdl.Event.(enum (get e typ)) with
+        | `Quit -> raise Exit
+        | `Mouse_button_down ->
+            let button = Sdl.Event.(get e mouse_button_button) in
+            if button = Sdl.Button.left then
+              let _, pos = Sdl.get_mouse_state () in
+              ctx.drag <- Some pos
+        | `Mouse_button_up ->
+            let button = Sdl.Event.(get e mouse_button_button) in
+            if button = Sdl.Button.left then ctx.drag <- None
+        | `Mouse_motion -> (
+            match ctx.drag with
+            | None -> ()
+            | Some (x, y) ->
+                let data = tree_texture.data in
+                let _, (x', y') = Sdl.get_mouse_state () in
+                ctx.drag <- Some (x', y');
+                let move_x = float (x - x') /. data.scale_w /. data.zoom in
+                let move_y = float (y - y') /. data.scale_h /. data.zoom in
+                tree_texture.data <-
+                  {
+                    data with
+                    min_w = data.min_w +. move_x;
+                    max_w = data.max_w +. move_x;
+                    min_h = data.min_h +. move_y;
+                    max_h = data.max_h +. move_y;
+                  };
+                ctx.updated <- true)
+        | `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.)) 0.9) 4.;
+              };
+            ctx.updated <- true
+        | `Key_up ->
+            let key = Sdl.Event.(get e keyboard_keycode) in
+            if key = Sdl.K.left then (
+              ctx.current <- max 0 (ctx.current - 1);
+              let render, data = generate_tree ctx d in
+              tree_texture.data <- data;
+              tree_texture.render <- render;
+              let texture = generate_tree_texture ctx render data in
+              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
+              set_texture tree_texture texture);
+            ()
+        | _ -> ()
+      done;
+      if ctx.updated then (
+        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
+      let () = get @@ Sdl.render_clear ctx.r in
+      (* render tree *)
+      let () = get @@ Sdl.render_copy ctx.r tree_texture.texture in
+      (* present *)
+      let () = Sdl.render_present ctx.r in
+      (* framerate delay *)
+      refresh_rate ctx;
+      ()
+    done
+  with Exit ->
+    delete_context ctx;
+    Ttf.quit ();
+    Sdl.quit ();
+    exit 0
+
+(* cmdliner *)
+
+open Cmdliner
+
+let store_path =
+  Arg.(
+    required
+    & pos 0 (some string) None
+    & info [] ~docv:"store path" ~doc:"path to the store")
+
+let font_path =
+  Arg.(
+    required
+    & pos 1 (some string) None
+    & info [] ~docv:"font path" ~doc:"path to the text font")
+
+let commit =
+  Arg.(
+    required
+    & pos 2 (some int) None
+    & info [] ~docv:"id commit" ~doc:"if of the commit")
+
+let depth =
+  Arg.(
+    value & opt int (-1) & info [ "d"; "depth" ] ~docv:"depth" ~doc:"max depth")
+
+let main_cmd =
+  let doc = "a gui for tezos store exploration" in
+  let info = Cmd.info "graphics" ~doc in
+  Cmd.v info Term.(const main $ store_path $ font_path $ commit $ depth)
+
+let () = exit (Cmd.eval ~catch:false main_cmd)
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/sdl_util.ml b/src/irmin-pack-tools/tezos_explorer_gui/sdl_util.ml
new file mode 100644
index 0000000000..5a70050405
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/sdl_util.ml
@@ -0,0 +1,67 @@
+open Tsdl
+
+let get = function
+  | Ok r -> r
+  | Error (`Msg e) ->
+      Sdl.log "Error: %s" e;
+      exit 1
+
+let int x = int_of_float (floor x)
+
+let draw_point r c (x, y) =
+  let () =
+    get
+    @@ Sdl.set_render_draw_color r (Sdl.Color.r c) (Sdl.Color.g c)
+         (Sdl.Color.b c) (Sdl.Color.a c)
+  in
+  get @@ Sdl.render_draw_point r (int x) (int y)
+
+let fill_rect r c (x, y) (w, h) =
+  let () =
+    get
+    @@ Sdl.set_render_draw_color r (Sdl.Color.r c) (Sdl.Color.g c)
+         (Sdl.Color.b c) (Sdl.Color.a c)
+  in
+  let rect = Sdl.Rect.create ~x:(int x) ~y:(int y) ~w:(int w) ~h:(int h) in
+  get @@ Sdl.render_fill_rect r (Some rect)
+
+let draw_rect r c (x, y) (w, h) =
+  let () =
+    get
+    @@ Sdl.set_render_draw_color r (Sdl.Color.r c) (Sdl.Color.g c)
+         (Sdl.Color.b c) (Sdl.Color.a c)
+  in
+  let rect = Sdl.Rect.create ~x:(int x) ~y:(int y) ~w:(int w) ~h:(int h) in
+  get @@ Sdl.render_draw_rect r (Some rect)
+
+let draw_line r (x0, y0) (x1, y1) =
+  let () = get @@ Sdl.set_render_draw_color r 0x00 0x00 0x00 0xff in
+  get @@ Sdl.render_draw_line r (int x0) (int y0) (int x1) (int 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
+  let ttx_t = get @@ Sdl.create_texture_from_surface r s in
+  Sdl.free_surface s;
+  let rect_text =
+    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
+  render_text r ttx_t rect_text;
+  (ttf_w, ttf_h)
+
+let white = Sdl.Color.create ~r:256 ~g:256 ~b:256 ~a:0xff
+let light_grey = Sdl.Color.create ~r:200 ~g:200 ~b:200 ~a:0xff
+let grey = Sdl.Color.create ~r:80 ~g:80 ~b:80 ~a:0xff
+let black = Sdl.Color.create ~r:0 ~g:0 ~b:0 ~a:0xff
+let red = Sdl.Color.create ~r:255 ~g:0 ~b:0 ~a:0xff
+let green = Sdl.Color.create ~r:0 ~g:255 ~b:0 ~a:0xff
+let blue = Sdl.Color.create ~r:0 ~g:0 ~b:255 ~a:0xff
+let purple = Sdl.Color.create ~r:255 ~g:0 ~b:255 ~a:0xff
+let lighten_color c = Sdl.Color.(create ~r:(r c) ~g:(r c) ~b:(r c)) ~a:0xff
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/tree.ml b/src/irmin-pack-tools/tezos_explorer_gui/tree.ml
new file mode 100644
index 0000000000..9b00fd5346
--- /dev/null
+++ b/src/irmin-pack-tools/tezos_explorer_gui/tree.ml
@@ -0,0 +1,3 @@
+type t = { depth : int; path : string; obj : obj; current : bool }
+and obj = Leaf | Commit of t option | Inode of inode
+and inode = Tree of t list option | Values of t list option

From d28e42786f9f1a2044795a453ef0537b1147164e Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Tue, 3 Oct 2023 17:28:22 +0200
Subject: [PATCH 2/3] Fix dep issue

---
 irmin-pack-tools.opam                        |  2 --
 src/irmin-pack-tools/README.md               |  1 +
 src/irmin-pack-tools/tezos_explorer_gui/dune | 16 ++++++++--------
 3 files changed, 9 insertions(+), 10 deletions(-)

diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam
index 3b494d2296..2b9cbd6bfb 100644
--- a/irmin-pack-tools.opam
+++ b/irmin-pack-tools.opam
@@ -24,8 +24,6 @@ depends: [
   "cmdliner"    {>= "1.1.0"}
   "cmdliner"    {>= "1.1.0"}
   "notty"       {>= "0.2.3"}
-  "tsdl"        {>= "1.0.0"}
-  "tsdl-ttf"    {>= "0.6"}
   "prettree"
   "ptime"
   "hex"
diff --git a/src/irmin-pack-tools/README.md b/src/irmin-pack-tools/README.md
index 445b547696..a13bb6b434 100644
--- a/src/irmin-pack-tools/README.md
+++ b/src/irmin-pack-tools/README.md
@@ -105,6 +105,7 @@ TODO
 
 ## tezos-explorer-gui
 This tool is a graphical UI, meant to allow the user to figure out rapidly the shape of a commit, giving him informations on it's content.
+In order to launch it, uncomment the `dune` file under the path `src/irmin-pack-tools/tezos_explorer_gui` and install the deps `tsdl` and `tsdl-ttf`.
 It can be launched using the following command:
 ```shell
 $ dune exec -- irmin-tezos-explorer-gui <path-to-store> <path-to-ttf-font> <commit>
diff --git a/src/irmin-pack-tools/tezos_explorer_gui/dune b/src/irmin-pack-tools/tezos_explorer_gui/dune
index 43283d7a93..75e31ff95e 100644
--- a/src/irmin-pack-tools/tezos_explorer_gui/dune
+++ b/src/irmin-pack-tools/tezos_explorer_gui/dune
@@ -1,8 +1,8 @@
-(executable
- (public_name irmin-tezos-explorer-gui)
- (package irmin-pack-tools)
- (name main)
- (modules main context load_tree tree sdl_util layout loading)
- (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
- (preprocess
-  (pps ppx_repr)))
+; (executable
+;  (public_name irmin-tezos-explorer-gui)
+;  (package irmin-pack-tools)
+;  (name main)
+;  (modules main context load_tree tree sdl_util layout loading)
+;  (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
+;  (preprocess
+;   (pps ppx_repr)))

From 5b287e4ac2b8301c54fdcd54e7cf27d7faa54e50 Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Tue, 17 Oct 2023 14:36:24 +0200
Subject: [PATCH 3/3] irmin-pack-tools: Fix readme

---
 irmin-pack-tools.opam          | 5 -----
 src/irmin-pack-tools/README.md | 7 ++++---
 2 files changed, 4 insertions(+), 8 deletions(-)

diff --git a/irmin-pack-tools.opam b/irmin-pack-tools.opam
index 6b5ae8bc04..31d1a332e8 100644
--- a/irmin-pack-tools.opam
+++ b/irmin-pack-tools.opam
@@ -25,7 +25,6 @@ depends: [
   "cmdliner"    {>= "1.1.0"}
   "cmdliner"    {>= "1.1.0"}
   "notty"       {>= "0.2.3"}
-  "prettree"
   "ppx_repr"    {>= "0.7.0"}
   "ptime"
   "hex"
@@ -33,10 +32,6 @@ depends: [
   "alcotest"    {with-test}
 ]
 
-pin-depends: [
-  ["prettree.dev"  "git+https://github.com/art-w/prettree.git#568de08442f02dd87acc84ca6a91cc661b7e77bf"]
-]
-
 synopsis: "Utils for Irmin-pack"
 description: """
 `Irmin-pack-tools` defines useful binaries and libraries for
diff --git a/src/irmin-pack-tools/README.md b/src/irmin-pack-tools/README.md
index a13bb6b434..a90b2e6973 100644
--- a/src/irmin-pack-tools/README.md
+++ b/src/irmin-pack-tools/README.md
@@ -5,7 +5,7 @@ Currently, there are the following tools:
 - [`ppcf`](#ppcf), a json printer for control files
 - [`ppidx`](#ppidx), a json printer for index folders
 - [`tezos-explorer`](#tezos-explorer), a notty ui for a fast exploration of tezos stores
-- [`tezos-explorer-gyu`](#tezos-explorer-gui), a graphical ui for a fast exploration of tezos stores
+- [`tezos-explorer-gui`](#tezos-explorer-gui), a graphical ui for a fast exploration of tezos stores
 
 ## ppcf
 This tool prints a control file in a human readable manner (json), allowing to fetch important informations easily.
@@ -104,8 +104,9 @@ $ jq -s 'sort_by(.off)' -- index
 TODO
 
 ## tezos-explorer-gui
-This tool is a graphical UI, meant to allow the user to figure out rapidly the shape of a commit, giving him informations on it's content.
+This tool is a graphical UI, meant to allow the user to figure out rapidly the shape of a commit, giving them informations on its content.
 In order to launch it, uncomment the `dune` file under the path `src/irmin-pack-tools/tezos_explorer_gui` and install the deps `tsdl` and `tsdl-ttf`.
+You will also need to pin the package `prettree` with `git+https://github.com/art-w/prettree.git#568de08442f02dd87acc84ca6a91cc661b7e77bf`.
 It can be launched using the following command:
 ```shell
 $ dune exec -- irmin-tezos-explorer-gui <path-to-store> <path-to-ttf-font> <commit>
@@ -115,7 +116,7 @@ The first argument is the path to the root of the store (e.g. `output/root/`).
 
 The second argument is the path to a `.ttf` file, necessary to know which font to use when printing strings.
 
-The third argument is an int, the `nth` commit stored in the index of the store that will be showned first.
+The third argument is an int, the `nth` commit stored in the index of the store that will be shown first.
 
 Once the program is launched, you can:
 - Navigate through the indexed commits using the left and right arrows.