boot/main.ml

open Lwt.Infix
module F = Fmt
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)

module Display = struct
  open Tgles2
  open Tsdl
  open Gg
  open CamomileLibrary

  let ( >>= ) x f = match x with Ok a -> f a | Error _ as result -> result

  let get_result = function Ok x -> x | Error (`Msg msg) -> failwith msg

  type keymod = Shift | Ctrl | Meta | Fn

  type key = {
    char : char;
    uchar : CamomileLibrary.UChar.t;
    keycode : Sdl.keycode;
    scancode : Sdl.scancode;
    mods : keymod list;
  }

  type mouse = int * int

  type event =
    [ `Key_down of key
    | `Key_up of key
    | `Text_editing of string
    | `Text_input of string
    | `Mouse of mouse
    | `Quit
    | `Fullscreen of bool
    | `None ]

  let str_of_key k =
    Printf.sprintf
      "(char=%C;uchar=%C;keycode=%x;scancode=%x;name=%s;(%s%s%s%s))" k.char
      (CamomileLibrary.UChar.char_of k.uchar)
      k.keycode k.scancode
      (Sdl.get_key_name k.keycode)
      (if List.mem Shift k.mods then "shift" else "")
      (if List.mem Ctrl k.mods then "ctrl" else "")
      (if List.mem Meta k.mods then "meta" else "")
      (if List.mem Fn k.mods then " fn" else "")

  let event_of_sdlevent ev =
    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
    | `Text_editing ->
        `None
    | `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
    | (`Key_down | `Key_up) as w ->
        let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
        let keycode = Sdl.Event.get ev Sdl.Event.keyboard_keycode in
        let uchar =
          CamomileLibrary.UChar.of_int
            (if keycode land Sdl.K.scancode_mask > 0 then 0 else keycode)
        in
        let mods =
          List.filter_map
            (fun (m, v) -> if km land m > 0 then Some v else None)
            Sdl.Kmod.[ (shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn) ]
        in
        let k =
          {
            char = UChar.char_of uchar;
            uchar;
            keycode;
            scancode = Sdl.Event.get ev Sdl.Event.keyboard_scancode;
            mods;
          }
        in
        let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
        if repeat < 1 then
          match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k
        else `None
    | `Mouse_motion ->
        let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
        `Mouse mouse_xy
    | `Quit ->
        `Quit
    | _ -> (*F.epr "Unknown Event@." ; *) `None

  let key_up : Sdl.keycode = 0x40000052

  let key_down : Sdl.keycode = 0x40000051

  let key_left : Sdl.keycode = 0x40000050

  let key_right : Sdl.keycode = 0x4000004f

  let handle_keyevents (el : event list) f = List.iter f el

  (* 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.

  let on_failure ~cleanup result =
    (match result with Ok _ -> () | Error _ -> cleanup ());
    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 + resizable (*+ input_grabbed*))
    >>= fun sdl_win ->
    Sdl.set_window_title sdl_win title;
    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 ev = Sdl.Event.create () in
    let el = ref [ `None ] in
    while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
      let e = event_of_sdlevent ev in
      if e != `None then el := !el @ [ e ]
      (* HACK? *)
    done;
    (* Filter the events *)
    el :=
      List.filter_map
        (function
          | `Quit ->
              frame.quit <- true;
              None
          | `Fullscreen a ->
              if a then (
                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
          | `Key_up a -> Some (`Key_up a)
          | `Key_down a -> Some (`Key_down a)
          | `Mouse a -> Some (`Mouse a)
          | a -> Some a (*| a -> Some a*))
        !el;
    if List.length !el > 0 then (
      let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
      let _, (_, image) =
        render
          {
            box = Box2.v (P2.v 0. 0.) (P2.v (float width) (float height));
            time = ticks ();
            events = !el;
            wall = frame.wall;
          }
      in
      Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
      let width, height = 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;
      Ok ())
    else 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 "fonts/entypo.ttf")

let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf")

let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf")

let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf")

let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")

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 ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(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 ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(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 ~cx:(Box2.midx b) ~cy:(Box2.midy b) ~r:(Box2.w b /. 2.) )
    ) )


(** Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
    This way basic widgets will just expand to the full area of a box, while other widgets can have
    the express purpose of limiting the size of an object in a larger system of limitations. 


    Widgets return a tuple: (state, (box, image))
    state is the updated state, where state.box is always 
      - the top left corner of the box the pane drew in, and
      - the bottom right corner of the state.box that was passed in
    box is the area the widget actually drew in (or wants to sort of "use")
    image is the Wall.image to compose with other panes and draw to the display
*)
  

let pane_box next_point_func (subpanes : Display.pane list) (so : Display.state) =
  let sr, (br, ir) = 
    List.fold_left
      (fun (sp, (bp, ip)) (pane : Display.pane) -> (* uses br to hold max extent of boxes *)
         let sr, (br, ir) = pane sp in (* draw the pane *)
         let _, (_, irb) = path_box Color.blue br sr in (* draw the box around the pane *)
         ( { sr with box = Box2.of_pts (next_point_func br) (Box2.max sp.box) },
           ((Box2.of_pts (Box2.o bp) (P2.v (max (Box2.maxx br) (Box2.maxx bp))
                               (max (Box2.maxy br) (Box2.maxy bp)))), Image.seq [ ip; irb; ir ]))
      )
      (so, ((Box2.of_pts (Box2.o so.box) (Box2.o so.box)), Image.empty))
      subpanes
  in
  let _, (_, redbox) = path_box Color.red br sr in
  (sr, (br, Image.stack redbox ir))

(* draws the second item below if there's room in so.box *)
let pane_vbox = pane_box Box2.tl_pt (* tl_pt is actually bl_pt in the Wall coordinate system *)
(* draws second item to right if there's room in so.box *)
let pane_hbox = pane_box Box2.br_pt (* br_pt is actually tr_pt in the Wall coordinate system *)

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.red 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)) ) )

type Format.stag += Color_bg of Wall.color

type Format.stag += Color_fg of Wall.color

type Format.stag += Cursor of Wall.color

let draw_pp height fpp (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 font = Text.Font.make ~size:height (Lazy.force font_sans) in
  let fm = Text.Font.font_metrics font in
  let font_height = fm.ascent -. fm.descent +. fm.line_gap in
  let max_x = ref 0. in
  let out_string text o l =
    let sp = !sc in
    push @@ simple_text font (String.sub text o l) !sc;
    max_x := max !max_x (Box2.maxx !box);
    sc :=
      {
        !sc with
        box =
          Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box);
      }
  in
  let out_flush () =
    ()
  in
  let out_newline () =
    sc :=
      {
        !sc with
        box =
          Box2.of_pts
            (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height))
            (Box2.max s.box);
      }
  in
  let out_spaces n =
    let wpx = Text.Font.text_width font " " in
    if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then (
      (* WRAP *)
      out_newline ());
    let so = !sc in
    (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
    push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*)
    box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height);
    sc := { !sc with box = Box2.of_pts (Box2.br_pt !box) (Box2.max so.box) }
  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);
      }
  in
  let out_funs =
    Format.{ out_string; out_flush; out_newline; out_spaces; out_indent }
  in
  let pp = Format.formatter_of_out_functions out_funs in
  Format.pp_set_formatter_stag_functions pp
    {
      mark_open_stag =
        (fun s ->
          (match s with
          | Cursor c ->
              push
              @@ fill_box c
                   (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height))
                   !sc
          | Color_bg c -> push @@ fill_box c !box !sc
          | _ -> ());
          "");
      mark_close_stag =
        (function
        | _ ->
            ();
            "");
      print_open_stag = (fun _ -> (*"<open_stag>"*) ());
      (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
      print_close_stag = (fun _ -> (*"<close_stag>"*) ());
    };
  Format.pp_set_tags pp true;
  let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in
  let max_indent = margin - 1 in
  Format.pp_safe_set_geometry pp ~max_indent ~margin;
  fpp pp;
  Format.pp_force_newline pp ();
  (!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node))

type textedit = { ze : unit Zed_edit.t; zc : Zed_cursor.t }

let make_textedit () =
  let z = Zed_edit.create () in
  { ze = z; zc = Zed_edit.new_cursor z }

let draw_textedit (te : textedit) height (s : Display.state) =
  let ctx = Zed_edit.context te.ze te.zc in
  List.iter
    (function
      | `Key_down (k : Display.key) -> (
          match k with
          | { keycode = kc; mods = []; _ } when kc = Display.key_up ->
              Zed_edit.prev_line ctx
          | { keycode = kc; mods = []; _ } when kc = Display.key_down ->
              Zed_edit.next_line ctx
          | { keycode = kc; mods = []; _ } when kc = Display.key_left ->
              Zed_edit.prev_char ctx
          | { keycode = kc; mods = []; _ } when kc = Display.key_right ->
              Zed_edit.next_char ctx
          | { char = '\r'; mods = []; _ } -> Zed_edit.newline ctx
          | { char = 'b'; mods = [ Ctrl ]; _ } -> Zed_edit.prev_char ctx
          | { char = 'f'; mods = [ Ctrl ]; _ } -> Zed_edit.next_char ctx
          | { char = 'a'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_bol ctx
          | { char = 'e'; mods = [ Ctrl ]; _ } -> Zed_edit.goto_eol ctx
          | { char = 'd'; mods = [ Ctrl ]; _ } -> Zed_edit.remove_next ctx 1
          | { char = 'd'; mods = [ Meta ]; _ } -> Zed_edit.kill_next_word ctx
          | { char = '\b'; mods = []; _ } -> Zed_edit.remove_prev ctx 1
          | { char = '\b'; mods = [ Meta ]; _ } -> Zed_edit.kill_prev_word ctx
          | { char = '\t'; mods = []; _ } ->
              Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
          | { char = 'k'; mods = [ Ctrl ]; _ } -> Zed_edit.kill_next_line ctx
          | _ -> ())
      | `Key_up _ -> ()
      | `Text_input s ->
          Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s));
          ()
      | _ -> ())
    s.events;
  draw_pp height
    (fun pp ->
      let zrb, zra =
        Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc)
      in
      let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in
      let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in
      Format.pp_open_hvbox pp 0;
      F.text pp before_cursor;
      Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3));
      F.pf pp "";
      Format.pp_close_stag pp ();
      F.text pp after_cursor;
      F.pf pp "@.";
      Format.pp_close_box pp ())
    s

let str_of_textedit (te : textedit) =
  Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))

type storeview = { s : Store.t; path : string list }

let make_storeview storepath branch ?(path = []) () =
  {
    s =
      Lwt_main.run
        (Store.of_branch
           (Lwt_main.run (Store.Repo.v (Irmin_git.config storepath)))
           branch);
    path;
  }

let draw_storeview (r : storeview) height (s : Display.state) =
  let indent = ref 0 in
  let rec draw_levels (tree : (string * Store.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 (Store.Tree.list node []) in
        draw_levels subtree pp;
        Format.pp_close_box pp ())
      tree;
    indent := !indent - 1
  in
  let root =
    Lwt_main.run (Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n [])
  in
  draw_pp height (draw_levels root) s

type top = {
  te : textedit;
  res : Format.symbolic_output_buffer;
  mutable eval : Topinf.evalenv option;
  path : string list;
  histpath : string list;
  storeview : storeview;
}

let format_symbolic_output_buffer (ppf : Format.formatter) buf =
  List.iter
    Format.(
      function
      | Output_flush -> F.pf ppf "@?"
      | Output_newline -> F.pf ppf "@."
      | Output_string s -> Format.pp_print_string ppf s
      | Output_spaces n | Output_indent n ->
          Format.pp_print_string ppf (String.make n ' '))
    buf

let out_funs_of_sob sob =
  Format.
    {
      out_string =
        (fun s p n ->
          add_symbolic_output_item sob (Output_string (String.sub s p n)));
      out_flush = (fun () -> add_symbolic_output_item sob Output_flush);
      out_indent = (fun n -> add_symbolic_output_item sob (Output_indent n));
      out_newline = (fun () -> add_symbolic_output_item sob Output_newline);
      out_spaces = (fun n -> add_symbolic_output_item sob (Output_spaces n));
    }

let make_top storepath ?(branch = "current") () =
  let t =
    {
      te = make_textedit ();
      res = Format.make_symbolic_output_buffer ();
      eval = None;
      path = [ "init" ];
      histpath = [ "history" ];
      storeview = make_storeview storepath branch ();
    }
  in
(*  Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res;
    Format.pp_set_formatter_out_functions Format.std_formatter (out_funs_of_sob t.res);*)
  let zctx = Zed_edit.context t.te.ze t.te.zc in
  Zed_edit.insert zctx
    (Zed_rope.of_string
       (Zed_string.of_utf8 (Lwt_main.run (Store.get t.storeview.s t.path))));
  t

let draw_top (t : top) height (s : Display.state) =
  let ppf = Format.formatter_of_symbolic_output_buffer t.res in
  Topinf.ppf := ppf;
  let eval =
    match t.eval with
    | None ->
      let e = match !Topinf.eval with | Some e -> e | None -> Topinf.init ppf in
      t.eval <- Some e;
      (*      e ppf "#use \"init.ml\";;"; *)
      e
    | Some e -> e
  in
  (* HACK use Lazy.? *)
  Display.handle_keyevents s.events (function
    | `Key_up { char = '\r'; mods = [ Ctrl ]; _ } ->
      (* HACK overwriting stdout formatter because fucking ocaml/toplevel/topdirs.ml hardcodes it *)
      Format.pp_set_formatter_out_functions Format.std_formatter (out_funs_of_sob t.res);

      let b = Buffer.create 69 in
      format_symbolic_output_buffer (Format.formatter_of_buffer b) (Format.flush_symbolic_output_buffer t.res); 
      ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree ->
                            Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b)));
      ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "history")
                              t.path (str_of_textedit t.te)));
      eval ppf (str_of_textedit t.te ^ ";;"); (*HACK to prevent getting stuck in parser*)
        ignore
          (Lwt_main.run
             ( Store.tree t.storeview.s >>= fun tree ->
               Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) ))
    | _ -> ());
  pane_vbox
    [
      draw_textedit t.te height;
      draw_pp height (fun pp ->
          Format.pp_open_hovbox pp 0;
          format_symbolic_output_buffer pp
            (Format.get_symbolic_output_buffer t.res);
          Format.pp_close_box pp ();
          F.flush pp ());
      draw_storeview t.storeview height;
    ]
    s

let top_1 = make_top "../rootstore" ()

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
  push @@ fill_box (Display.gray 0.125) s.box !state;
  (* gray bg *)
  push @@ draw_top top_1 30. { s with box = !state.box };
  (!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node))

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



(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)

(* also, i'm tired *)