module Key = struct
  let sdlkey_map = Hashtbl.create 1024

  let () =
    let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in
    aa return `Enter ;
    aa escape `Escape ;
    aa backspace `Backspace ;
    aa tab `Tab ;
    aa f1 (`Function 1) ;
    aa f2 (`Function 2) ;
    aa f3 (`Function 3) ;
    aa f4 (`Function 4) ;
    aa f5 (`Function 5) ;
    aa f6 (`Function 6) ;
    aa f7 (`Function 7) ;
    aa f8 (`Function 8) ;
    aa f9 (`Function 9) ;
    aa f10 (`Function 10) ;
    aa f11 (`Function 11) ;
    aa f12 (`Function 12) ;
    aa insert `Insert ;
    aa delete `Delete ;
    aa home `Home ;
    aa kend `End ;
    aa pageup (`Page `Up) ;
    aa pagedown (`Page `Down) ;
    aa right (`Arrow `Right) ;
    aa left (`Arrow `Left) ;
    aa down (`Arrow `Down) ;
    aa up (`Arrow `Up)

  let key_of_sdlkey ev =
    let (kc : Sdl.keycode) =
      Sdl.Event.get ev Sdl.Event.keyboard_keycode
      land lnot Sdl.K.scancode_mask in
    match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with
    | Some s, _ -> Some s
    | None, true -> Some (`Uchar (Uchar.of_int kc))
    | None, false -> None

  let event_of_sdlevent ev : t option =
    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
    | (`Key_down | `Key_up) as d -> (
      match key_of_sdlkey ev with
      | None -> None
      | Some code ->
          let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
          Some
            (`Key
              ( ( match d with
                | _
                  when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1
                  ->
                    `Repeat
                | `Key_up -> `Release
                | _ -> `Press )
              , { code
                ; ctrl= km land Sdl.Kmod.ctrl > 0
                ; meta= km land Sdl.Kmod.alt > 0
                ; super= km land Sdl.Kmod.gui > 0
                ; shift= km land Sdl.Kmod.shift > 0 } ) ) )
    | `Mouse_motion ->
        let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in
        Some (`Mouse (V2.v (float x) (float y)))
    | `Quit -> Some `Quit
    (* Unhandled events *)
    | `Text_editing -> Some (`Unknown "`Text_editing")
    | `Text_input -> Some (`Unknown "`Text_input")
    | `App_did_enter_background ->
        Some (`Unknown "`App_did_enter_background")
    | `App_did_enter_foreground ->
        Some (`Unknown "`App_did_enter_foreground ")
    | `App_low_memory -> Some (`Unknown "`App_low_memory ")
    | `App_terminating -> Some (`Unknown "`App_terminating ")
    | `App_will_enter_background ->
        Some (`Unknown "`App_will_enter_background ")
    | `App_will_enter_foreground ->
        Some (`Unknown "`App_will_enter_foreground ")
    | `Clipboard_update -> Some (`Unknown "`Clipboard_update ")
    | `Controller_axis_motion ->
        Some (`Unknown "`Controller_axis_motion ")
    | `Controller_button_down ->
        Some (`Unknown "`Controller_button_down ")
    | `Controller_button_up -> Some (`Unknown "`Controller_button_up ")
    | `Controller_device_added ->
        Some (`Unknown "`Controller_device_added ")
    | `Controller_device_remapped ->
        Some (`Unknown "`Controller_device_remapped ")
    | `Controller_device_removed ->
        Some (`Unknown "`Controller_device_removed ")
    | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ")
    | `Dollar_record -> Some (`Unknown "`Dollar_record ")
    | `Drop_file -> Some (`Unknown "`Drop_file ")
    | `Finger_down -> Some (`Unknown "`Finger_down")
    | `Finger_motion -> Some (`Unknown "`Finger_motion ")
    | `Finger_up -> Some (`Unknown "`Finger_up ")
    | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ")
    | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ")
    | `Joy_button_down -> Some (`Unknown "`Joy_button_down ")
    | `Joy_button_up -> Some (`Unknown "`Joy_button_up ")
    | `Joy_device_added -> Some (`Unknown "`Joy_device_added ")
    | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ")
    | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ")
    | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ")
    | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up")
    | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ")
    | `Multi_gesture -> Some (`Unknown "`Multi_gesture")
    | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ")
    | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e))
    | `User_event -> Some (`Unknown "`User_event ")
    | `Display_event -> Some (`Unknown "`Display_event ")
    | `Sensor_update -> Some (`Unknown "`Sensor_update ")
    | `Window_event -> Some (`Unknown "`Window_event ")

  let key_up : Sdl.keycode = 0x40000052
  let key_down : Sdl.keycode = 0x40000051
  let key_left : Sdl.keycode = 0x40000050
  let key_right : Sdl.keycode = 0x4000004f
end

module Display = struct
  open Tgles2
  open Tsdl
  open Gg
  open Wall
  module I = Image
  module P = Path

  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

  (* 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
    ; wall: Wall.renderer }

  (* the box2 here is cannonically the place the returner drew
     (the Wall.image extents) *)
  type image = box2 * Wall.image
  type pane = state -> state * image
  type actor = (Event.events -> pane Lwt.t) ref

  let pane_empty s =
    (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty))

  type frame =
    { sdl_win: Sdl.window
    ; gl: Sdl.gl_context
    ; wall: Wall.renderer
    ; mutable last_pane: pane
    ; 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
        ; last_pane= pane_empty } )
      ~cleanup:(fun () -> Sdl.destroy_window sdl_win)

  let handle_frame_events frame events =
    List.iter
      (fun (e : Event.t) ->
        match e with
        | `Quit -> frame.quit <- true
        | `Fullscreen a ->
            frame.fullscreen <- a ;
            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 )
        | _ -> () )
      events

  let draw_pane frame pane =
    let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
    let _, (_, image) =
      pane
        { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height))
        ; time= ticks ()
        ; wall= frame.wall } in
    Sdl.gl_make_current frame.sdl_win frame.gl
    >>>= fun () ->
    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 ()

  let rec get_events () : Event.t list =
    (* create and fill event list *)
    let ev = Sdl.Event.create () in
    if Sdl.poll_event (Some ev) then
      match Event.event_of_sdlevent ev with
      | Some e -> get_events () @ [e]
      | None -> get_events ()
    else []

  let successful_actor = ref (fun _ -> Lwt.return pane_empty)

  let display_frame frame (actor : actor) =
    let events = get_events () in
    handle_frame_events frame events ;
    if List.length events > 0 then (
      (* recompute the actor definition with the new events to return a new pane *)
      ( try
          !actor events
          >|= fun p ->
          successful_actor := !actor ;
          p
        with e ->
          F.epr
            "Display.display_frame (!actor events) failed with:@. %s \
             @."
            (Printexc.to_string e) ;
          actor := !successful_actor ;
          !actor events )
      >>= fun p ->
      frame.last_pane <- p ;
      (* call draw_pane because we should redraw now that we have updated *)
      ignore (draw_pane frame frame.last_pane) ;
      Lwt.return_unit )
    else Lwt.return_unit

  let run frame actor () =
    let frame = get_result frame in
    Sdl.show_window frame.sdl_win ;
    let rec loop () =
      Lwt.pause () (* seems required for the irc connection to work *)
      >>= fun () ->
      Lwt_unix.sleep 0.030
      >>= fun () ->
      display_frame frame actor
      >>= fun () ->
      if not frame.quit then loop () else Lwt.return_unit in
    Lwt_main.run (loop ()) ;
    print_endline "quit" ;
    Sdl.hide_window frame.sdl_win ;
    Sdl.gl_delete_context frame.gl ;
    Sdl.destroy_window frame.sdl_win ;
    Sdl.quit () ;
    ()

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

  module FontCache = Map.Make (String)

  let font_cache = ref FontCache.empty

  let load_font name =
    match FontCache.find_opt name !font_cache with
    | Some font -> font
    | None -> (
        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_cache := FontCache.add name font !font_cache ;
            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_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf")

  let font_sans_bold_italic =
    lazy (load_font "fonts/Roboto-BoldItalic.ttf")

  let font_serif =
    lazy (load_font "fonts/ScheherazadeNew-Regular.ttf")

  let font_serif_bold =
    lazy (load_font "fonts/ScheherazadeNew-Bold.ttf")

  let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular")

  let font_mono_bold =
    lazy (load_font "fonts/static/RobotoMono-Regular")

  let font_mono_light =
    lazy (load_font "fonts/static/RobotoMono-Regular")

  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 =
      Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans)
    in
    ( Box2.v (Box2.o b)
        (P2.v (Wall_text.Font.text_width f text) (Box2.h b))
    , I.paint
        (Paint.color (gray ~a:0.5 1.0))
        Wall_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 =
    ( 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 draw_filled_box c (s : state) = (s, fill_box c s.box)

  let path_box c b (s : 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 : 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. 

    Panes 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 simple_text f text (s : state) =
    let fm = Wall_text.Font.font_metrics f in
    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
    let tm = Wall_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 (gray ~a:0.5 1.0))
          Wall_text.(
            simple_text f ~valign:`BASELINE ~halign:`LEFT
              ~x:(Box2.ox s.box)
              ~y:(Box2.oy s.box +. fm.ascent)
              text) ) )

  let pane_box next_point_func (subpanes : pane list) (so : state) =
    let sr, (br, ir) =
      List.fold_left
        (fun (sp, (bp, ip)) (pane : 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))
end