(* A Simple Platformer Game
 Copyright (C) 2023 Florent Monnier
 
 To the extent permitted by law, you can use, modify, and redistribute
 this software, and the associated elements, as long as you also respect
 the distribution agreements of these associated elements.
*)

module Rect : sig
  type t = {
    x: int;
    y: int;
    w: int;
    h: int;
  }

  val make1 : int * int * int * int -> t
  val make2 : pos:int * int -> dims:int * int -> t
  val make4 : int -> int -> int -> int -> t

  val has_intersection : t -> t -> bool

end = struct

  type t = {
    x: int;
    y: int;
    w: int;
    h: int;
  }

  let make1 (x, y, w, h) =
    { x; y; w; h }

  let make2 ~pos:(x, y) ~dims:(w, h) =
    { x; y; w; h }

  let make4 x y w h =
    { x; y; w; h }

  let has_intersection a b =
    if ((a.x + a.w) <= b.x) then (false) else
    if (a.x >= (b.x + b.w)) then (false) else
    if ((a.y + a.h) <= b.y) then (false) else
    if (a.y >= (b.y + b.h)) then (false) else
    (true)
  ;;
end


let width, height = (32, 18)
let tile_size = 18


let initial_pos1 = (2 * 18 - 1, 9 * 18)
let initial_pos2 = (1 * 18 - 1, 9 * 18)
let initial_pos3 = (0 * 18 - 1, 9 * 18)

type dir = Left | Right
type color = Red | Blue | Yellow

type pos = int * int

type player_dir = {
  left: bool;
  right: bool;
  up: bool;
  down: bool;
}

type player = {
  player_pos: pos;
  y_velocity: int;
  player_tile: (int * int) * (int * int);
  player_dir: dir;
  player_col: color;
}

type game_state = {
  players: player list;
  dir: player_dir;
  blocks: (pos * pos * Rect.t option * (color * Rect.t) option) array;
  items: (pos * pos * int) list;
  texture: Canvas.image;
  mutable texture_loaded: bool;
}

type key_change = KeyDown | KeyUp


let canvas = Canvas.getElementById Canvas.document "my_canvas"
let ctx = Canvas.getContext canvas "2d"


let player_tile1 = (194, 235), (264, 235)
let player_tile2 = (194, 283), (264, 283)
let player_tile3 = (194, 259), (264, 259)

let player1 = {
  y_velocity = 0;
  player_pos = initial_pos1;
  player_tile = player_tile1;
  player_dir = Right;
  player_col = Blue;
}
let player2 = {
  y_velocity = 0;
  player_pos = initial_pos2;
  player_tile = player_tile2;
  player_dir = Right;
  player_col = Yellow;
}
let player3 = {
  y_velocity = 0;
  player_pos = initial_pos3;
  player_tile = player_tile3;
  player_dir = Right;
  player_col = Red;
}


let level1 = [|
  171;171;171;172;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;358;358;0;0;0;0;0;0;0;0;0;112;0;
  0;0;0;0;382;0;0;0;0;182;183;184;0;0;0;0;0;0;34;7;31;0;0;0;0;0;0;0;0;0;136;0;
  0;0;0;382;0;382;0;0;0;180;180;0;0;0;0;0;0;0;0;0;0;0;0;0;142;0;0;0;0;0;160;0;
  0;0;0;0;0;0;0;0;180;0;0;0;0;0;0;0;141;0;0;0;0;0;0;165;189;0;0;381;0;0;134;157;
  142;0;0;34;34;34;0;0;0;0;0;0;0;0;31;34;56;56;0;0;0;0;0;0;0;0;0;156;80;0;0;0;
  144;0;0;0;0;0;0;0;0;0;7;7;0;0;0;0;0;0;0;0;0;0;0;0;0;0;214;215;215;216;0;0;
  0;0;0;0;0;0;0;0;57;58;59;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
  0;0;7;7;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;141;10;0;0;0;0;0;0;0;0;
  0;0;0;0;0;0;152;0;0;0;0;0;0;0;0;0;0;0;0;0;0;10;10;10;10;0;0;0;0;132;0;0;
  0;0;0;0;0;2;3;4;0;18;19;20;0;0;80;0;0;0;0;0;0;0;0;0;0;0;0;0;0;156;151;0;
  0;0;0;0;0;0;0;0;0;42;43;44;0;93;93;93;0;0;0;0;0;0;0;0;0;0;0;0;26;27;27;27;
  149;0;0;0;0;0;0;0;0;66;114;68;0;0;0;0;0;358;0;0;0;335;336;0;0;131;0;0;146;147;147;147;
  27;27;28;0;0;0;0;0;0;0;113;0;0;0;0;0;0;0;0;0;0;359;360;0;0;155;0;0;146;147;147;147;
  147;147;148;0;0;105;0;0;0;0;137;0;357;0;0;0;0;0;0;26;27;27;27;27;27;27;27;27;27;27;27;27;
  147;147;27;27;27;27;27;28;0;0;162;0;156;149;150;0;26;27;27;27;27;147;147;147;147;147;147;147;147;147;147;147;
  147;147;147;147;147;147;147;29;27;27;27;27;27;27;27;27;27;27;28;147;147;147;147;147;147;147;147;147;147;147;147;147;
  27;27;27;27;28;147;147;147;147;147;147;147;147;147;147;147;147;26;27;27;27;27;27;27;27;27;147;147;147;147;147;147;
  147;147;147;147;148;147;147;147;147;147;147;147;147;147;147;147;147;146;147;147;147;147;147;147;147;147;147;147;147;147;147;147
|]
let level2 = [|
  0;0;0;160;0;182;183;184;0;0;0;0;0;0;0;0;382;0;0;0;0;0;0;0;0;182;183;184;0;0;0;0;
  157;158;159;135;0;0;0;0;0;0;80;34;0;0;0;0;10;0;0;0;0;0;142;0;0;0;0;0;0;0;358;382;
  0;180;0;0;0;0;0;0;0;34;34;0;0;382;141;0;0;0;0;0;0;93;93;93;0;0;0;0;0;7;31;56;
  180;0;180;0;0;0;0;180;0;0;0;0;0;0;10;141;0;0;0;0;93;93;0;0;0;0;142;142;0;0;0;0;
  215;215;216;0;0;0;0;0;0;0;0;0;0;10;10;10;10;0;0;0;0;0;0;0;0;2;3;4;0;0;0;0;
  0;0;0;0;0;0;144;144;144;0;0;0;0;0;0;0;0;0;381;0;0;0;0;0;0;0;0;0;0;0;0;0;
  0;80;0;0;153;0;0;0;0;0;0;0;0;0;0;0;0;0;156;0;80;0;0;0;180;0;149;0;0;382;151;151;
  117;117;0;0;213;0;0;382;0;0;0;0;0;0;0;0;0;0;57;58;58;59;0;0;1;0;1;0;0;2;3;3;
  0;0;0;189;0;0;382;0;382;0;0;0;0;0;358;358;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;
  0;0;0;0;0;15;14;13;14;16;0;0;0;358;0;0;358;0;0;0;0;0;0;0;0;0;0;0;131;0;0;0;
  0;0;0;0;0;0;0;61;0;0;0;0;15;14;13;14;14;16;0;0;0;0;0;0;0;0;0;0;155;0;0;152;
  0;0;0;0;0;0;0;37;0;0;0;0;0;0;61;0;0;0;0;0;0;0;0;0;356;0;0;74;75;75;40;75;
  0;0;0;149;0;0;0;61;0;0;0;0;0;0;37;0;0;0;0;132;0;0;152;0;156;0;0;146;147;147;64;147;
  75;75;75;75;76;0;0;85;0;0;0;0;0;0;61;0;0;0;0;156;0;0;74;75;75;40;75;75;147;147;64;147;
  147;125;147;147;148;75;40;75;76;0;0;149;150;0;85;0;0;74;75;75;75;75;30;147;147;64;147;147;147;147;64;147;
  75;75;76;147;29;75;64;29;75;75;75;75;75;75;75;75;75;75;75;76;147;125;147;125;147;64;147;125;147;147;64;147;
  147;125;148;147;125;147;88;147;147;125;147;125;147;147;74;75;75;75;75;75;75;75;75;76;147;88;147;147;147;147;88;147;
  38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38;38
|]
let level3 = [|
  0;0;0;0;134;157;158;159;135;0;0;182;183;184;0;0;0;0;0;0;0;0;0;0;57;58;59;0;0;0;0;0;
  141;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;382;382;382;0;0;0;0;0;0;0;0;0;0;0;80;149;
  123;124;0;0;0;0;0;0;0;180;0;0;0;0;0;12;118;10;10;0;0;0;0;0;0;0;0;0;0;34;7;31;
  147;148;0;0;121;0;0;0;180;0;180;0;0;0;0;0;0;0;0;0;0;0;142;0;0;0;0;0;0;0;0;0;
  171;172;0;0;145;0;97;0;0;0;0;0;0;0;0;358;0;0;0;0;95;94;93;213;0;0;0;0;0;0;0;381;
  0;0;0;0;169;0;0;98;99;99;100;0;0;0;358;0;0;0;0;0;0;0;0;0;213;0;0;0;0;149;149;156;
  132;0;0;0;0;0;0;0;0;0;0;0;0;358;0;0;144;144;0;0;0;0;0;0;0;0;0;0;213;214;215;215;
  156;80;0;0;0;0;0;0;0;0;0;0;0;0;0;144;0;0;0;0;141;0;0;0;0;0;0;213;0;0;0;0;
  58;58;59;0;0;0;142;0;0;0;0;0;144;144;144;0;0;0;0;0;11;0;0;0;0;0;0;0;0;0;0;0;
  0;0;0;0;0;0;117;0;141;0;0;0;0;0;0;0;0;0;0;0;0;12;0;0;0;0;0;0;0;0;149;150;
  0;0;0;0;0;0;0;117;189;165;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;166;151;0;122;123;
  0;0;0;0;0;0;0;0;0;0;0;0;0;0;180;382;0;0;0;0;0;0;0;131;0;0;122;123;123;123;123;123;
  0;0;0;105;0;0;0;0;0;0;0;0;0;358;0;0;0;0;0;0;0;0;0;155;0;152;146;147;147;147;125;147;
  123;123;123;124;0;356;0;0;0;0;0;0;103;0;0;0;0;0;0;142;77;0;122;123;123;123;30;125;147;147;147;147;
  147;147;147;148;0;156;0;0;0;0;0;0;122;124;0;0;0;0;0;122;123;123;30;147;147;147;147;147;147;122;123;123;
  125;147;147;123;123;124;0;0;103;0;151;0;146;148;0;126;0;152;0;146;147;147;125;147;147;147;121;147;147;146;147;147;
  147;125;147;147;147;147;123;123;123;123;123;123;30;29;123;123;123;123;123;123;123;147;147;147;121;147;145;147;147;170;171;171;
  147;147;147;125;147;147;147;125;147;147;147;147;125;147;147;147;147;125;147;147;147;147;121;147;145;147;145;147;147;147;147;147
|]
let level4 = [|
  165;0;185;0;106;0;106;0;0;182;183;184;0;0;185;0;0;0;0;0;0;185;0;0;141;0;0;0;0;0;0;185;
  0;0;0;0;130;180;130;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;10;10;0;0;0;0;80;0;
  141;0;0;0;144;144;144;0;0;0;0;382;0;0;0;0;142;127;0;1;0;0;180;0;0;0;0;0;15;14;13;16;
  215;216;0;0;0;0;0;0;0;382;0;0;0;80;0;2;3;4;0;0;0;180;0;180;0;0;0;0;0;0;61;0;
  189;0;0;0;0;0;0;382;0;0;0;73;0;73;0;0;0;0;0;0;0;15;13;14;16;0;0;358;0;0;37;0;
  0;0;0;0;0;127;0;0;0;73;0;145;0;145;0;0;0;358;0;0;0;0;37;0;0;0;0;358;0;0;61;0;
  0;0;0;0;0;50;51;52;0;169;0;169;0;169;0;0;31;0;0;0;0;0;61;0;0;0;0;358;149;0;85;126;
  149;142;0;0;0;0;0;0;0;0;0;0;0;0;0;56;0;7;7;0;0;0;85;149;149;0;0;26;27;40;27;27;
  3;3;4;0;0;0;152;0;0;0;0;0;0;0;0;0;0;0;0;0;0;2;3;3;4;0;0;170;171;64;171;171;
  0;0;0;0;0;2;3;4;0;0;0;80;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;64;0;0;
  0;0;0;0;0;0;0;0;0;0;10;10;0;0;0;0;117;141;0;0;0;0;0;0;0;0;0;0;0;64;0;0;
  0;0;0;0;0;0;0;0;0;0;0;10;10;10;0;0;0;189;0;0;0;142;0;0;0;0;0;0;0;64;0;0;
  0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;93;93;0;0;0;149;150;149;0;64;0;149;
  27;27;28;0;151;0;0;0;0;180;0;0;0;0;0;0;0;0;0;0;0;0;0;0;26;27;27;27;27;88;27;27;
  147;147;148;27;27;27;28;0;151;0;149;0;149;149;0;382;150;0;0;0;0;358;0;0;146;147;26;28;38;38;38;26;
  147;147;148;147;147;147;29;27;27;27;27;27;27;27;27;27;27;28;0;151;0;0;150;0;146;147;146;148;86;86;86;146;
  171;171;172;27;28;147;125;147;147;147;147;147;147;147;147;147;147;29;27;27;27;27;27;27;27;27;30;29;408;408;408;30;
  147;147;147;147;148;147;147;147;125;26;27;27;27;27;27;28;147;147;125;147;147;147;147;125;147;147;147;147;125;125;147;147
|]
let levels = [|
  level1;
  level2;
  level3;
  level4;
|]
let li = ref 0


let slide lst =
  let rec aux acc lst =
    match lst with
    | [] -> []
    | x :: [] -> x :: (List.rev acc)
    | x :: xs -> aux (x::acc) xs
  in
  aux [] lst
;;


let display_game state =
  let bg_color = "#cfd6f5" in
  let tex = state.texture in

  (* background *)
  Canvas.fillStyle ctx bg_color;
  Canvas.fillRect ctx 0 0 (width * 18) (height * 18);

  let draw_tex tex (sx, sy) (sw, sh) (dx, dy) (dw, dh) =
    Canvas.drawImage8 ctx tex sx sy sw sh dx dy dw dh;
  in

  (* blocks *)
  Array.iter (fun (xy, txy, _, _) ->
    draw_tex tex txy (18, 18) xy (18, 18)
  ) state.blocks;

  (* player *)
  List.iter (fun player ->
    let s_xy1, s_xy2 = player.player_tile in
    let s_xy = match player.player_dir with Left -> s_xy1 | Right -> s_xy2 in
    draw_tex tex s_xy (20, 23) player.player_pos (20, 23);
  ) (List.rev state.players);

  (* items *)
  List.iter (fun (xy, txy, _) ->
    draw_tex tex txy (18, 18) xy (18, 18)
  ) state.items;
;;



let num_color blocks =
  Array.fold_left (fun n (_, _, _, color) ->
    match color with None -> n
    | Some _ -> (n + 1)
  ) 0 blocks


let make_blocks level =
  let _, _blocks =
    Array.fold_left (fun (i, acc) t ->
      if t = 0 then (succ i, acc) else
        let x = i mod 32 in
        let y = i / 32 in
        let _t = t - 1 in
        let tx = _t mod 24 in
        let ty = _t / 24 in
        let pos = (x * 18, y * 18) in
        let _rect = Rect.make2 ~pos ~dims:(18, 18) in
        let collide = match t with
        |1|2|3|4|7|10|11|12|13|14|15|16|25|26|27|28|31|33|34|35|36|39
        |40|49|50|51|52|57|58|59|56|73|74|75|76|93|94|95|97|98|99|100
        |117|118|121|122|123|124|144|145|146|148|165|169|189
        |88 (* X *)
        |213|214|215|216 -> true
        | _ -> false in
        let color = match t with
        |142|180 -> Some (Yellow, _rect)
        |141|382 -> Some (Red, _rect)
        |80|166|358 -> Some (Blue, _rect)
        | _ -> None
        in
        let rect = if collide then Some (_rect) else None in
        let txy = (tx * 18, ty * 18) in
        (succ i, (pos, txy, rect, color) :: acc)
    ) (0, []) level
  in
  (Array.of_list _blocks)



let update_player blocks _dir (
  {
    player_pos;
    player_dir;
    y_velocity;
  } as player) =

  let x, y = player_pos in

  let y_velocity =
    match _dir with
    | Some dir -> if dir.up then (-17) else (y_velocity)
    | None -> (y_velocity)
  in

  let y_dest = (y + (y_velocity / 2)) in

  let next =
    if y_velocity > 0 then succ else pred
  in

  let rec y_loop y =
    if y = y_dest then (y, y_velocity) else
    let y_prev = y in
    let y = next y in
    let player = Rect.make2 ~pos:(x+1, y+5) ~dims:(18, 18) in
    let has_intersection =
      Array.fold_left (fun res (_, _, rect, _) ->
        match rect with
        | Some rect -> res || Rect.has_intersection player rect
        | None -> res
      ) false blocks
    in
    if has_intersection
    then (y_prev, 0)
    else y_loop y
  in
  let y, y_velocity = y_loop y in

  let x_dest =
    match _dir with
    | None -> (x)
    | Some dir ->
        if dir.left  then (x - 4) else
        if dir.right then (x + 4) else
        (x)
  in

  let player_dir =
    match _dir with
    | Some dir ->
        if dir.left  then (Left) else
        if dir.right then (Right) else
        (player_dir)
    | None ->
        (player_dir)
  in

  let next =
    if x_dest > x then succ else pred
  in

  let rec x_loop x =
    if x = x_dest then (x) else
    let x_prev = x in
    let x = next x in
    let player = Rect.make2 ~pos:(x+1, y+5) ~dims:(18, 18) in
    let has_intersection =
      Array.fold_left (fun res (_, _, rect, _) ->
        match rect with
        | Some rect -> res || Rect.has_intersection player rect
        | None -> res
      ) false blocks
    in
    if has_intersection then (x_prev)
    else x_loop x
  in
  let x = x_loop x in

  let y_velocity = y_velocity + 1 in

  let player_pos = (x, y) in
  (*
  let player_pos =
    if y < (-4 * 36)
    then (initial_pos1)
    else (x, y)
  in
  *)

  { player with
    player_pos;
    player_dir;
    y_velocity;
  }
;;




let update_state (
  {
    players; dir; blocks; items;
    _
  } as state) =

  let players =
    match players with [] -> []
    | player0 :: players ->
        (update_player blocks (Some dir) player0) :: (
           List.map (update_player blocks None) players)
  in

  let dir =
    if dir.up then { dir with up = false } else dir
  in

  (* items to catch *)
  let _items, blocks =
    Array.fold_left (fun (acc1, acc2) ((_, _, _, color) as block) ->
      match color with None -> (acc1, block::acc2)
      | Some (color, rect) ->
          let res =
            List.fold_left (fun res player ->
              let pos = player.player_pos in
              let _player = Rect.make2 ~pos ~dims:(20, 23) in
              if color = player.player_col && Rect.has_intersection rect _player
              then Some(block)
              else res
            ) None players
          in
          match res with
          | Some(block) -> (block::acc1, acc2)
          | None -> (acc1, block::acc2)
    ) ([], []) blocks
  in
  let blocks = Array.of_list blocks in
  let items =
    List.fold_left (fun acc (pos, txy, _, _) ->
      (pos, txy, -8) :: acc
    ) items _items
  in
  let items =
    List.map (fun ((x, y), txy, vel) ->
      let vel = vel + 1 in
      ((x, y + vel), txy, vel)
    ) items
  in
  let items =
    List.filter (fun ((_, y), _, _) ->
      (y < height * 18)
    ) items
  in

  let blocks, players =
    if num_color blocks = 0 && items = []
    then begin
      incr li;
      if !li >= (Array.length levels) then li := 0;
      ( make_blocks levels.(!li), [ player1; player3; player2 ] )
    end
    else (blocks, players)
  in

  { state with
    dir; players; blocks; items;
  }



let up_first players =
  let up_vel player =
    { player with
      y_velocity = player.y_velocity - 6;
    }
  in
  match players with [] -> []
  | player0 :: players ->
      (up_vel player0) :: players
;;




let () =
  let tiles_tex = "./assets/kenney_pixel-platformer/Tilemap/tilemap_all.png" in
  let texture = Canvas.newImage () in
  Canvas.setImgSrc texture tiles_tex;

  let blocks = make_blocks level1 in

  let initial_state = {
    blocks;
    players = [ player1; player3; player2 ];
    dir = {
      left = false;
      right = false;
      up = false;
      down = false;
    };
    items = [];
    texture;
    texture_loaded = false;
  } in

  let state = ref initial_state in

  Canvas.imgOnload texture (fun () ->
    !state.texture_loaded <- true;
  );

  let keychange_event key_change ev =
    let dir = !state.dir in
    let dir =
      match key_change, ev.Canvas.keyCode with
      | KeyDown, 37 -> { dir with left = true }
      | KeyDown, 39 -> { dir with right = true }
      | KeyDown, 38 -> { dir with up = true }
      | KeyDown, 40 -> { dir with down = true }

      | KeyUp, 37 -> { dir with left = false }
      | KeyUp, 39 -> { dir with right = false }
      | KeyUp, 38 -> { dir with up = false }
      | KeyUp, 40 -> { dir with down = false }

      | _ -> (dir)
    in
    let players = !state.players in
    let players =
      match key_change, ev.Canvas.key with
      | KeyDown, "x" -> up_first (slide players)
      | _ -> (players)
    in
    state := { !state with dir; players }
  in

  let animate () =
    state := update_state !state;
    display_game !state;
    ()
  in

  Canvas.imageSmoothingEnabled ctx false;

  Canvas.addKeyEventListener Canvas.window "keydown" (keychange_event KeyDown) true;
  Canvas.addKeyEventListener Canvas.window "keyup"   (keychange_event KeyUp) true;

  let _ = Canvas.setInterval animate (1000/20) in
  ()
;;