From 09bad9eba2c3681460b3fe53209f5716a1c4a02e Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Mon, 4 Sep 2023 17:09:19 +0200
Subject: [PATCH] irmin-pack-tools: Add a GUI for tezos stores

---
 src/irmin-pack-tools/store_ui/context.ml   |  49 +++++
 src/irmin-pack-tools/store_ui/dune         |   8 +
 src/irmin-pack-tools/store_ui/layout.ml    | 154 +++++++++++++++
 src/irmin-pack-tools/store_ui/load_tree.ml | 180 ++++++++++++++++++
 src/irmin-pack-tools/store_ui/loading.ml   | 136 ++++++++++++++
 src/irmin-pack-tools/store_ui/main.ml      | 208 +++++++++++++++++++++
 src/irmin-pack-tools/store_ui/sdl_util.ml  |  68 +++++++
 src/irmin-pack-tools/store_ui/tree.ml      |   3 +
 8 files changed, 806 insertions(+)
 create mode 100644 src/irmin-pack-tools/store_ui/context.ml
 create mode 100644 src/irmin-pack-tools/store_ui/dune
 create mode 100644 src/irmin-pack-tools/store_ui/layout.ml
 create mode 100644 src/irmin-pack-tools/store_ui/load_tree.ml
 create mode 100644 src/irmin-pack-tools/store_ui/loading.ml
 create mode 100644 src/irmin-pack-tools/store_ui/main.ml
 create mode 100644 src/irmin-pack-tools/store_ui/sdl_util.ml
 create mode 100644 src/irmin-pack-tools/store_ui/tree.ml

diff --git a/src/irmin-pack-tools/store_ui/context.ml b/src/irmin-pack-tools/store_ui/context.ml
new file mode 100644
index 0000000000..94e66e6289
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/context.ml
@@ -0,0 +1,49 @@
+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/store_ui/dune b/src/irmin-pack-tools/store_ui/dune
new file mode 100644
index 0000000000..43283d7a93
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/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/store_ui/layout.ml b/src/irmin-pack-tools/store_ui/layout.ml
new file mode 100644
index 0000000000..bde046d619
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/layout.ml
@@ -0,0 +1,154 @@
+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/store_ui/load_tree.ml b/src/irmin-pack-tools/store_ui/load_tree.ml
new file mode 100644
index 0000000000..7fb3285a6d
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/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/store_ui/loading.ml b/src/irmin-pack-tools/store_ui/loading.ml
new file mode 100644
index 0000000000..a0dbffe15e
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/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/store_ui/main.ml b/src/irmin-pack-tools/store_ui/main.ml
new file mode 100644
index 0000000000..56479c71fa
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/main.ml
@@ -0,0 +1,208 @@
+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/store_ui/sdl_util.ml b/src/irmin-pack-tools/store_ui/sdl_util.ml
new file mode 100644
index 0000000000..e996cda44b
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/sdl_util.ml
@@ -0,0 +1,68 @@
+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/store_ui/tree.ml b/src/irmin-pack-tools/store_ui/tree.ml
new file mode 100644
index 0000000000..9b00fd5346
--- /dev/null
+++ b/src/irmin-pack-tools/store_ui/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