[@@@ocaml.warning "-6-9-26-27"]
open Lwt.Infix
module F = Fmt

(* komm / konsole / tafel *)
(* let f = try float_of_string Sys.argv.(1) with _ -> 1.0 *)

module Lump = struct
  module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
  type t = { conf : Irmin.config;
             repo : Pile.Repo.t;
             branch : Pile.branch;
             path : string list;
           }

  let branch repo_loc branch =
    let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
    Lwt_main.run (Pile.of_branch repo branch)
  
  let get repo_loc branch path =
    let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
    let branch = Lwt_main.run (Pile.of_branch repo branch) in
    let node = Pile.get branch path in
    Lwt_main.run node
  
(*  val pile_conf path = Irmin_git.config path
  val pile_repo conf = Pile.Repo.v conf
  val pile_branch conf name = pile_repo conf*)
end

(*let pos = ref (Lump.get "./kommstore" "current" ["init"])*)
(* magic position [ref Lump.t]*)



module Display = struct
  open Wall
  open Tgles2
  open Tsdl
  open Gg
  let (>>=) x f = match x with
    | Ok a -> f a
    | Error x as result -> result
  
  let get_result = function
    | Ok x -> x
    | Error (`Msg msg) -> failwith msg

  type key = int
  type mouse = (int * int)
  type event = [ `Key_down of key
               | `Key_up of key
               | `Mouse of mouse
               | `Quit
               | `Fullscreen of bool
               | `None ]

  let event_of_sdlevent ev = 
    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
    | `Key_up -> F.pr "Key_up\n"; let key = Sdl.Event.get ev Sdl.Event.keyboard_keycode in `Key_up key
    | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel ->
       F.pr "Mouse Event\n";
       let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy
    | `Quit -> F.pr "Quit Event\n"; `Quit
    | _ -> `None
          
  (* current window state to be passed to window renderer *)
  type state = { box: box2; (* This is cannonically box within which the next element should draw *)
                 time: float;
                 events: event list;
                 wall: Wall.renderer;
               }

  type image = (box2 * Wall.image) (* the box2 here is cannonically the place the returner drew 
                                      (the Wall.image extents) *)
  type pane = state -> (state * image)
  
  type frame = { sdl_win: Sdl.window;
                 gl: Sdl.gl_context;
                 wall: Wall.renderer;
                 mutable quit: bool;
                 mutable fullscreen: bool; }

  let ticks () = (Int32.to_float (Sdl.get_ticks ())) /. 1000.0
  
  let on_failure ~cleanup result = begin
      match result with
      | Ok _ -> ()
      | Error _ -> cleanup ()
    end; result

  let video_initialized = lazy (Sdl.init Sdl.Init.video)

  let make_frame ?(title="komm") ~w ~h =
    Lazy.force video_initialized >>= fun () ->
    Sdl.create_window ~w ~h title
      Sdl.Window.(opengl + allow_highdpi + input_grabbed)
    >>= fun sdl_win ->
    ignore (Sdl.gl_set_swap_interval (-1));
    ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1);
    on_failure (
        Sdl.gl_create_context sdl_win >>= fun gl ->
        let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in
        Ok { sdl_win; gl; wall; quit = false; fullscreen = false }
      ) ~cleanup:(fun () -> Sdl.destroy_window sdl_win)
  
  let display_frame frame render =
    (* create and fill event list *)
    let tstart = ticks () in
    let ev = Sdl.Event.create () in
    let el = ref [`None] in
    while Sdl.poll_event (Some ev) do
      let e = event_of_sdlevent ev in
      if e != `None then el := e :: !el
    done;
    F.pr "Receieved %d handled events" (List.length !el);    
    
    (* Handle some of the events *)
    el := List.filter_map
            (function 
             | `Quit -> frame.quit <- true; None
             | `Fullscreen ->
                frame.fullscreen <- not frame.fullscreen;
                ignore (Sdl.show_cursor (not frame.fullscreen) : _ result);
                ignore (Sdl.set_window_fullscreen frame.sdl_win
                          (if frame.fullscreen
                           then Sdl.Window.fullscreen_desktop
                           else Sdl.Window.windowed)
                        : _ result); None                           
             | a -> Some a) !el;
    
    let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
    let width = float width and height = float height in
    let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height));
                                         time = ticks (); events = []; wall = frame.wall} in
    Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
    let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
    Gl.viewport 0 0 width height;
    Gl.clear_color 0.0 0.0 0.0 1.0;
    Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit));
    Gl.enable Gl.blend;
    Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha;
    Gl.enable Gl.cull_face_enum;
    Gl.disable Gl.depth_test;
    let width = float width and height = float height in
    Wall.Renderer.render frame.wall ~width ~height image;
    Sdl.gl_swap_window frame.sdl_win;
    F.pr "event loop took %0.2fms\n" (ticks () -. tstart); Ok ()
  
  let run frame render () =
    let frame = get_result frame in
    Sdl.show_window frame.sdl_win;
    while not frame.quit do
      ignore (display_frame frame render)
    done;
    print_endline "quit";
    Sdl.hide_window frame.sdl_win; ()

  let gray ?(a=1.0) v = Color.v v v v a
end

open Wall
open Gg
module I = Image
module P = Path
module Text = Wall_text

let load_font name =
  let ic = open_in_bin name in
  let dim = in_channel_length ic in
  let fd = Unix.descr_of_in_channel ic in
  let buffer =
    Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|]
    |> Bigarray.array1_of_genarray
  in
  let offset = List.hd (Stb_truetype.enum buffer) in
  match Stb_truetype.init buffer offset with
  | None -> assert false
  | Some font -> font

let font_icons = lazy (load_font "entypo.ttf")
let font_sans = lazy (load_font "Roboto-Regular.ttf")
let font_sans_bold = lazy (load_font "Roboto-Bold.ttf")
let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf")

let str_of_pnt p = Printf.sprintf "(x:%0.1f y:%0.1f)" (P2.x p) (P2.y p)
let str_of_box b = Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) (Box2.oy b) (Box2.maxx b) (Box2.maxy b)

let draw_label text b =
  let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in
  ((Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))),
   (I.paint (Paint.color (Display.gray ~a:0.5 1.0))
      Text.(simple_text f ~valign:`BASELINE ~halign:`LEFT
              ~x:(Box2.ox b) ~y:((Box2.oy b)+.(Box2.h b)*.0.75) text)))

let fill_box c b (s:Display.state) =
  (s, (b, I.paint (Paint.color c)
            (I.fill_path @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b))))

let path_box c b (s:Display.state) =
  (s, (b, I.paint (Paint.color c)
            (I.stroke_path
               (Outline.make ()) @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b))))

let path_circle c b (s:Display.state) =
  (s, (b, I.paint (Paint.color c)
            (I.stroke_path
               (Outline.make ()) @@ fun t -> P.circle t (Box2.midx b) (Box2.midy b) ((Box2.w b) /. 2.))))

let layout_hor v () = []

let layout_ver v () = []

(* draws the second item below if there's room *)
let pane_vbox (subpanes:Display.pane list) (so:Display.state) = 
  let sr, (br, ir) =
    List.fold_left
      (fun (sp, (_, ip)) (pane:Display.pane) ->
        let sr, (br, ir) = pane sp in
        let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
        ({sr with box = (Box2.of_pts (Box2.tl_pt br) (Box2.max sp.box))},
         (br, Image.seq [ ip; sir; ir])))
      (so, (so.box, Image.empty)) subpanes
  in
  let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in 
  let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
  (sr, (b, (Image.stack i_redbox ir)))

(* draws second item to right if there's room *)
let pane_hbox (subpanes:Display.pane list) (so:Display.state) = 
  let sr, (br, ir) =
    List.fold_left
      (fun (sp, (_, ip)) (pane:Display.pane) ->
        let sr, (br, ir) = pane sp in
        let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
        ({sr with box = (Box2.of_pts (Box2.br_pt br) (Box2.max sp.box))},
         (br, Image.seq [ ip; sir; ir])))
      (so, (so.box, Image.empty)) subpanes
  in
  let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in 
  let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
  (sr, (b, (Image.stack i_redbox ir)))



let pane_label text height ~subpanes (s:Display.state) = 
  let label_box, label_image = draw_label text (Box2.v (Box2.o s.box) (P2.v (Box2.w s.box) height)) in
  Box2.pp Format.std_formatter label_box; 
  (label_box, Image.seq [
                  List.fold_left (fun image pane -> Image.seq [image; (pane s)]) Image.empty subpanes;
                  I.paint (* red box *)
                    (Paint.color (Color.v 0.5 0.125 0.125 1.0))
                    (I.stroke_path (Outline.make ()) @@
                       fun t -> P.rect t (Box2.ox s.box) (Box2.oy s.box) (Box2.w s.box) height);
                  label_image; ])


let simple_text f text (s:Display.state) =
  let fm = Text.Font.font_metrics f in
  let font_height = fm.ascent -. fm.descent +. fm.line_gap in
  let tm = Text.Font.text_measure f text in
  let br_pt = (P2.v ((Box2.ox s.box) +. tm.width) ((Box2.oy s.box) +. font_height)) in
  let bextent = (Box2.of_pts (Box2.o s.box) br_pt) in
  let (_, (_, redbox)) = path_box (Color.v 0.5 0.125 0.125 1.0) bextent s in
  ({s with box = (Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box))},
   (bextent,
    (I.stack redbox
       (I.paint (Paint.color (Display.gray ~a:0.5 1.0))
          Text.(simple_text f ~valign:`BASELINE ~halign:`LEFT
                  ~x:(Box2.ox s.box) ~y:((Box2.oy s.box) +. fm.ascent) text)))))

let draw_pp height ppf (s:Display.state) =
  let node, sc, box = ref I.empty, ref s, ref Box2.zero in
  let push (s, (b, i)) = node := I.stack !node i; sc := s; box := b in
  let f = Text.Font.make ~size:height (Lazy.force font_sans) in
  let fm =  Text.Font.font_metrics f in
  (* Printf.printf "Font Metrics:\n\tascent:%f\n\tdescent:%f\n\tline_gap:%f\n" fm.ascent fm.descent fm.line_gap; *)
  let font_height = fm.ascent -. fm.descent +. fm.line_gap in F.pr "font_height: %f\n" font_height;
  let out_string text o l =
    let text = String.sub text o l in
    let sp = !sc in
    push @@ simple_text f text !sc;
    sc := {!sc with box = (Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box))};
    F.pr "out_string: (\"%s\")\n\tsp.box=%s\n\t!sc.box=%s\n\t!box=%s@."
      text (str_of_box sp.box) (str_of_box !sc.box) (str_of_box !box)
  in
  let out_flush () =
    print_endline ("out_flush: () " ^ (str_of_box !sc.box)) ; () in
  let out_newline () =
    let nlp = P2.v (Box2.ox s.box) ((Box2.oy !sc.box) +. font_height) in
    sc := {!sc with box = Box2.of_pts nlp (Box2.max s.box)}; 
    Printf.printf "out_newline: (%0.1f %0.1f) %s\n" (P2.x nlp) (P2.y nlp) (str_of_box !sc.box); flush stdout
  in
  let out_spaces n =
    let nf = float n in 
    let wpx = Text.Font.text_width f " " in
    let nl =  ((Box2.ox !sc.box) +. (nf *. wpx)) > (Box2.maxx !sc.box) in
    if nl then begin (* WRAP *)
        F.pr "out_spaces: ===== WRAP =======@.";
        out_newline ()
      end;
    let so = !sc in
    let bo = Box2.v (Box2.o !sc.box) (P2.v (nf *. wpx) height) in
    let ws = (Box2.w !box) /. nf in
    for m = 0 to n-1 do
      let mf = float m in
      let bsp = (Box2.v (Box2.br_pt !box) (P2.v wpx height)) in
      F.pr "out_space(%d): %s -> %s \n" m (str_of_box !box) (str_of_box bsp); 
      push @@ pane_hbox [path_circle (Color.v 0.125 1.0 0.125 0.125) bsp] !sc;
    done;
    box := bo;
    sc := {!sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box)};
    Printf.printf "out_spaces: (n=%d=%0.2fpx, nl=%b) %s\n\tbo=%s\n" n (nf *. wpx) nl (str_of_box !sc.box)
      (str_of_box bo); flush stdout
  in
  let out_indent n =
    let p = (min ((Box2.w !sc.box)-.1.) (height *. 2.0 *. (float n))) in
    sc := {!sc with box = Box2.of_pts
                            (P2.v ((Box2.ox !sc.box) +. p) (Box2.oy !sc.box))
                            (Box2.max !sc.box)};
    Printf.printf "out_indent: (n=%d=%0.2fpx) %s\n" n p (str_of_box !sc.box); flush stdout in
  let pp = Format.formatter_of_out_functions {out_string; out_flush; out_newline; out_spaces; out_indent;} in
  let margin = int_of_float ((Box2.w s.box) /. (Text.Font.text_width f " ")) in
  let max_indent = margin in
  Format.pp_safe_set_geometry pp ~max_indent ~margin;
  F.pr "draw_pp-2:\n\t!sc=%s\n" (str_of_box !sc.box);
  F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ());
  ppf pp;
  Format.pp_force_newline pp ();
  F.pr "draw_pp-1:\n\t!sc=%s\n" (str_of_box !sc.box);
  F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ());
  let (sr, (br, ir)) = (!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)) in
  F.pr "draw_pp:\n\tso=%s\n\tbr=%s\n\tsr=%s\n" (str_of_box s.box) (str_of_box br) (str_of_box sr.box);
  (sr, (br, ir))

let draw_sob sob s =
  let sc = ref s in
  let items = Format.flush_symbolic_output_buffer sob in
  List.iter (fun itm ->
      ()) items;
  (s, Image.empty)

let draw_lumptree height (s:Display.state) =
  let from = [] in (* future optional arg *)
  let pile = Lump.branch "./kommpile" "current" in (* future args *)
  let indent = ref 0 in
  let rec draw_levels (tree:(string * Lump.Pile.tree) list) pp =
    indent := !indent + 1;
    List.iter (fun (step, node) ->
        Format.pp_open_vbox pp 0;
        Format.pp_open_hbox pp ();
        for _ = 0 to !indent do Format.pp_print_space pp () done;
        Format.fprintf pp "%d-%s@." !indent step;
        Format.pp_close_box pp ();
        let subtree = Lwt_main.run (Lump.Pile.Tree.list node []) in
        draw_levels subtree pp;
        Format.pp_close_box pp ()
      ) tree;
    indent := !indent - 1
  in
  let root = Lwt_main.run (Lump.Pile.get_tree pile from >>= (fun n -> Lump.Pile.Tree.list n [])) in
  Printf.printf "Lumplist length: %d\n" (List.length root);
  draw_pp height (draw_levels root) s

let draw_komm (s:Display.state) =
  let node, state, box = ref I.empty, ref s, ref s.box in
  let push (s, (b, i))  = node := I.stack !node i; state := s; box := b in
  let _, (mouse_x, mouse_y) = Tsdl.Sdl.get_mouse_state () in
  F.pr "\n\n\t================================================\t vvvvvvvvvvvvvvv\n";
  push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *)
  push @@ pane_vbox [
              draw_lumptree 50.;
              draw_pp 30.
                  (fun pp ->
                  Box2.pp pp s.box;
                  Format.pp_open_box pp 0;
                  Format.pp_force_newline pp ();
                  Format.pp_print_string pp "fuck off!";
                  Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]";
                  Format.pp_print_newline pp ();
                  Format.pp_print_flush pp ();
                  Format.fprintf pp "%f@." 0.2;
                  Format.pp_print_if_newline pp ();
                  Format.fprintf pp "@[%s@ %d@]@." "x =" 1;
                  Format.pp_close_box pp ();
                  Format.pp_print_flush pp ()
                  )] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))};
  (!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node)) 

let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900) draw_komm) ()