(* A Simple Mini-World Map Generator
 Copyright (C) 2024 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.
*)

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

(* 16 * 34 = 544 *)
(* 16 * 50 = 800 *)
let width, height = (800, 544)

let w, h = (130, 90)

(*
let t0 = int_of_float (Js.Date.now ())
*)

let texture_loaded = ref false

type cell =
  | Grass
  | Water1 | Water2 | Water3
  | Sand
  | Bridge1 | Bridge2
  | Road
  | Tree1 | Tree2 | Tree3
  | Field1 | Field2 | Field3
  | House of int


let get_tile_coords cell =
  match cell with
  | Tree1 -> Some (16, 240)
  | Tree2 -> Some (32, 240)
  | Tree3 -> Some (48, 240)
  | House 1 -> Some (96, 48)
  | House 2 -> Some (112, 48)
  | House 3 -> Some (128, 48)
  | House 4 -> Some (96, 80)
  | House 5 -> Some (112, 80)
  | House 6 -> Some (128, 80)
  | House 7 -> Some (144, 64)
  | House 8 -> Some (160, 64)
  | House 9 -> Some (176, 64)
  | House 10 -> Some (160, 48)
  | House 11 -> Some (176, 48)
  | Bridge1 -> Some (176, 288)
  | Bridge2 -> Some (144, 288)
  | Field1 -> Some (16, 256)
  | Field2 -> Some (32, 256)
  | Field3 -> Some (48, 256)
  | _ -> None


type seeds = {
  seed1: float;
  seed2: float;
  seed3: float;
}

(* requested dir *)
type r_dir = {
  left: bool;
  right: bool;
  up: bool;
  down: bool;
}

type dir =
  | Left
  | Right
  | Up
  | Down


(* display *)
let _display (_x, _y) texture world player chars =
  Array.iteri (fun j line ->
    Array.iteri (fun i cell ->
      let x, y = (i * 16, j * 16) in
      let x, y = (x - _x, y - _y) in

      if (x < 0) || (y < 0) then () else
      if (x > (50 - 1) * 16) || (y > (34 - 1) * 16) then () else
      begin

        let color0 = "#42acaf" in (* dark blue *)
        let color1 = "#4ebcb9" in (* blue *)
        let color2 = "#b1d354" in (* green *)
        let color3 = "#e7d593" in (* sand *)
        let color4 = "#d3a061" in (* wood *)

        let color =
          match cell with
          | Water1 -> color1
          | Water2 -> color1
          | Water3 -> color0
          | Grass -> color2
          | Tree1 | Tree2 | Tree3 -> color2
          | Sand -> color3
          | Bridge1 -> color4
          | Bridge2 -> color4
          | Road -> color3
          | House _ -> color3
          | _ -> color2
        in
        (* display background color *)
        Canvas.fillStyle ctx color;
        Canvas.fillRect ctx x y 16 16;

        (* display tiles *)
        begin
          let tile = get_tile_coords cell in
          match tile with
          | None -> ()
          | Some (sx, sy) ->
              let sw, sh = (16, 16) in
              let dx, dy, dw, dh = (x, y, 16, 16) in
              Canvas.drawImage8 ctx texture sx sy sw sh dx dy dw dh;
        end;
      end;
    ) line;
  ) world;

  (* display characters *)
  let disp_char (i, j, _, sxy) =
    let x, y = (i * 16, j * 16) in
    let x, y = (x - _x, y - _y) in

    if (x < 0) || (y < 0) then () else
    if (x > (50 - 1) * 16) || (y > (34 - 1) * 16) then () else
    begin
      let dx, dy, dw, dh = (x, y, 16, 16) in
      let sw, sh = (16, 16) in
      let sx, sy = sxy in
      Canvas.drawImage8 ctx texture sx sy sw sh dx dy dw dh;
    end;
  in
  List.iter disp_char !chars;

  (* display player *)
  begin
    match player with
    | Some player -> disp_char player;
    | None -> ()
  end;

  ()
;;

let display pos texture world player chars =
  if !texture_loaded
  then _display pos texture world player chars
  else begin
    let color = "rgba(20, 20, 120, 1)" in
    Canvas.fillStyle ctx color;

    let s = "loading..." in
    Canvas.font ctx "bold 16px Arial";
    Canvas.textBaseline ctx "top";
    Canvas.fillText ctx s (width / 4) (height / 3);
  end;
  ()
;;


let tree () =
  match Random.int 7 with
  | 0 | 1 -> Tree1 | 2 | 3 -> Tree2 | 4 | 5 -> Tree3
  | _ -> Grass

let field () =
  match Random.int 6 with
  | 0 -> Field1 | 1 -> Field2 | 2 -> Field3
  | _ -> Grass

let field2 () =
  match Random.int 3 with
  | 0 -> Field1 | 1 -> Field2 | _ -> Field3

let water2 () =
  match Random.int 3 with
  | 0 -> Water2 | _ -> Water3

let tree_f () =
  match Random.int 7 with
  | 0 -> Tree1 | 1 -> Tree2 | 2 -> Tree3
  | 3 -> Field1 | 4 -> Field2 | 5 -> Field3
  | _ -> Grass

let house () =
  House (1 + Random.int 11)

let rand_char () =
  match Random.int 8 with
  | 0 -> (944, 128)
  | 1 -> (272, 0)
  | 2 -> (192, 0)
  | 3 -> (352, 0)
  | 4 -> (512, 0)
  | 5 -> (432, 0)
  | 6 -> (496, 96)
  | _ -> (608, 0)


(* init world *)
let init_world seeds (a, b) () =

  Noise.seed (seeds.seed1);

  let world = Array.make_matrix h w Grass in
  let chars = ref [] in

  for i = 0 to pred w do
    for j = 0 to pred h do
      let x, y =
        let i = (i + a * w) in
        let j = (j + b * h) in
        (i * 16, j * 16)
      in

      (* All noise functions return values in the range of -1 to 1. *)
      let v1 = Noise.perlin2 (float x /. 320.0) (float y /. 320.0) in
      let v3 = abs_float v1 in

      let cell =
        if v3 < 0.014 then water2 () else
        if v3 < 0.056 then Water1 else
        if v3 < 0.086 then Sand else
        if v3 > 0.15 then tree () else
        if v3 > 0.14 then tree_f () else
        if v3 > 0.12 then field () else Grass
      in
      world.(j).(i) <- cell;
    done;
  done;

  (* roads *)
  Noise.seed (seeds.seed2);
  for i = 0 to pred w do
    for j = 0 to pred h do
      let x, y =
        let i = (i + a * w) in
        let j = (j + b * h) in
        (i * 16, j * 16)
      in
      let v1 = Noise.perlin2 (float x /. 280.0) (float y /. 280.0) in
      let v3 = abs_float v1 in

      if v3 < 0.04 then
      begin
        match world.(j).(i) with
        | Water1 | Water2 | Water3 -> ()
        | _ -> world.(j).(i) <- Road
      end;
    done;
  done;

  (* check for diagonal roads *)
  for i = 1 to pred w do
    for j = 1 to pred h do

      let is_road i j =
        match world.(j).(i) with
        | Road -> true | _ -> false
      in
      let is_tree i j =
        match world.(j).(i) with
        | Tree1 | Tree2 | Tree3 -> true
        | _ -> false
      in

      if is_road i j &&
         is_tree (i-1) j &&
         is_road (i-1) (j-1) &&
         is_tree  i    (j-1)
      then
        world.(j).(i-1) <- Grass;

      if is_tree i j &&
         is_road (i-1) j &&
         is_tree (i-1) (j-1) &&
         is_road  i    (j-1)
      then
        world.(j).(i) <- Grass;

    done;
  done;

  (* houses *)
  Noise.seed (seeds.seed3);
  for i = 0 to pred w do
    for j = 0 to pred h do
      let x, y =
        let i = (i + a * w) in
        let j = (j + b * h) in
        (i * 16, j * 16)
      in
      let v1 = Noise.perlin2 (float x /. 120.0) (float y /. 120.0) in
      let v2 = (v1 +. 1.0) /. 2.0 in  (* range 0 to 1 *)

      let is_water i j =
        try
          match world.(j).(i) with
          | Water1 | Water2 -> true
          | _ -> false
        with _ -> false
      in
      let water_next i j =
        is_water (i+1) j ||
        is_water (i-1) j ||
        is_water i (j+1) ||
        is_water i (j-1) ||
        is_water i j
      in

      if v2 < 0.35 then
      begin
        if water_next i j then () else
          if Random.int 10 > 5
          then world.(j).(i) <- house ()
          else world.(j).(i) <- Sand;
      end;

      if v2 > 0.36 && v2 < 0.37 then
      begin
        match world.(j).(i) with
        | Grass | Tree1 | Tree2 | Tree3 -> world.(j).(i) <- field2 ()
        | _ -> ()
      end;
    done;
  done;

  (* bridges *)
  let is_ground i j =
    match world.(j).(i) with
    | Sand | Grass | Road -> true | _ -> false
  in
  let is_water i j =
    match world.(j).(i) with
    | Water1 | Water2 -> true | _ -> false
  in
  for i = 1 to w - 3 do
    for j = 1 to h - 3 do

      if is_ground (i-1) (j) &&
         is_water  (i)   (j) &&
         is_ground (i+1) (j)
      then begin
        if Random.int 30 < 3
        then world.(j).(i) <- Bridge1
      end;

      if is_ground (i) (j-1) &&
         is_water  (i) (j)   &&
         is_ground (i) (j+1)
      then begin
        if Random.int 30 < 3
        then world.(j).(i) <- Bridge2
      end;

      if is_ground (i-1) (j) &&
         is_water  (i)   (j) &&
         is_water  (i+1) (j) &&
         is_ground (i+2) (j)
      then begin
        if Random.int 30 < 3
        then ( world.(j).(i) <- Bridge1;
               world.(j).(i+1) <- Bridge1; )
      end;

      if is_ground (i) (j-1) &&
         is_water  (i) (j)   &&
         is_water  (i) (j+1) &&
         is_ground (i) (j+2)
      then begin
        if Random.int 30 < 3
        then ( world.(j).(i) <- Bridge2;
               world.(j+1).(i) <- Bridge2; )
      end;

    done;
  done;

  (* bridges 3 *)
  for i = 1 to w - 4 do
    for j = 1 to h - 4 do

      if is_ground (i-1) (j) &&
         is_water  (i)   (j) &&
         is_water  (i+1) (j) &&
         is_water  (i+2) (j) &&
         is_ground (i+3) (j)
      then begin
        if Random.int 30 < 3
        then ( world.(j).(i) <- Bridge1;
               world.(j).(i+1) <- Bridge1;
               world.(j).(i+2) <- Bridge1; )
      end;

      if is_ground (i) (j-1) &&
         is_water  (i) (j)   &&
         is_water  (i) (j+1) &&
         is_water  (i) (j+2) &&
         is_ground (i) (j+3)
      then begin
        if Random.int 30 < 3
        then ( world.(j).(i) <- Bridge2;
               world.(j+1).(i) <- Bridge2;
               world.(j+2).(i) <- Bridge2; )
      end;

    done;
  done;

  (* add characters *)
  for i = 0 to pred w do
    for j = 0 to pred h do
      let is_road i j =
        try
          match world.(j).(i) with
          | Road -> true
          | _ -> false
        with _ -> false
      in
      if is_road i j then
        if Random.int 60 < 4
        then chars := (i, j, Down, rand_char ()) :: !chars;
    done;
  done;
  chars := List.sort (fun (i1, j1, _, _) (i2, j2, _, _) -> (i1 + j1) - (i2 + j2)) !chars;
  let player = ref (Some (List.hd !chars)) in
  chars := List.tl !chars;

  (chars, world, player)
;;


let free_at world i j =
  try
    match world.(j).(i) with
    | Sand | Grass | Road | Bridge1 | Bridge2 -> true
    | _ -> false
  with _ -> false
;;

let char_at chars i j =
  List.exists (fun (i_, j_, _, _) -> (i_, j_) = (i, j)) chars
;;


let update_chars world chars =
  let next_pos i j =
    match Random.int 6 with
    | 0 -> (i+1, j), Right
    | 1 -> (i-1, j), Left
    | 2 -> (i, j+1), Down
    | 3 -> (i, j-1), Up
    | _ -> (i, j), Down
  in

  chars :=
    List.fold_left (fun acc (i, j, dir, sxy) ->
      let (_i, _j), _dir = next_pos i j in
      if free_at world _i _j && not (char_at acc _i _j)
      then (_i, _j, _dir, sxy) :: acc
      else (i, j, dir, sxy) :: acc
    ) [] (List.rev !chars);

  ()
;;


let update_water world =
  let _h = Array.length world in
  let _w = Array.length world.(0) in
  for j = 0 to pred _h do
    let world_j = world.(j) in
    for i = 0 to pred _w do
      match world_j.(i) with
      | Water2 -> if Random.int 30 = 0 then world.(j).(i) <- Water3
      | Water3 -> if Random.int 30 = 0 then world.(j).(i) <- Water2
      | _ -> ()
    done;
  done;
;;


let update_pos r_dir pos =
  let x, y = !pos in
  let x, y =
    match !r_dir with
    | { left = true; right = false; up = false; down = false } -> (x - 16, y)
    | { left = false; right = true; up = false; down = false } -> (x + 16, y)
    | { left = false; right = false; up = true; down = false } -> (x, y - 16)
    | { left = false; right = false; up = false; down = true } -> (x, y + 16)

    | { left = true; right = false; up = true; down = false } -> (x - 16, y - 16)
    | { left = true; right = false; up = false; down = true } -> (x - 16, y + 16)
    | { left = false; right = true; up = true; down = false } -> (x + 16, y - 16)
    | { left = false; right = true; up = false; down = true } -> (x + 16, y + 16)

    | _ -> (x, y)
  in

  r_dir := (
    match !r_dir with
    | { left = true; right = false; up = false; down = false } -> { !r_dir with left = false }
    | { left = false; right = true; up = false; down = false } -> { !r_dir with right = false }
    | { left = false; right = false; up = true; down = false } -> { !r_dir with up = false }
    | { left = false; right = false; up = false; down = true } -> { !r_dir with down = false }
    (*
    | _ -> !r_dir
    *)
    | _ -> { left = false; right = false; up = false; down = false }
  );

  let x = max 0 x in
  let y = max 0 y in

  let _w = (w * 16) - width in
  let _h = (h * 16) - height in

  let x = min x _w in
  let y = min y _h in

  pos := (x, y);
  ()
;;

let update_player r_dir pos world chars player =
  let i, j, dir, sxy = player in
  let (_i, _j), _dir =
    match !r_dir with
    | { left = true; right = false; up = false; down = false } -> (i - 1, j), Left
    | { left = false; right = true; up = false; down = false } -> (i + 1, j), Right
    | { left = false; right = false; up = true; down = false } -> (i, j - 1), Up
    | { left = false; right = false; up = false; down = true } -> (i, j + 1), Down
    (*
    | { left = true; right = false; up = true; down = false } -> (i - 1, j - 1)
    | { left = true; right = false; up = false; down = true } -> (i - 1, j + 1)
    | { left = false; right = true; up = true; down = false } -> (i + 1, j - 1)
    | { left = false; right = true; up = false; down = true } -> (i + 1, j + 1)
    *)
    | _ -> (i, j), dir
  in

  r_dir := (
    match !r_dir with
    | { left = true; right = false; up = false; down = false } -> { !r_dir with left = false }
    | { left = false; right = true; up = false; down = false } -> { !r_dir with right = false }
    | { left = false; right = false; up = true; down = false } -> { !r_dir with up = false }
    | { left = false; right = false; up = false; down = true } -> { !r_dir with down = false }
    (*
    | _ -> !r_dir
    *)
    | _ -> { left = false; right = false; up = false; down = false }
  );

  let i, j =
    if free_at world _i _j (* && not (char_at !chars _i _j) *)
    then (_i, _j)
    else (i, j)
  in

  let x =
    if i > (50 / 2)
    then i - (50 / 2)
    else 0
  in

  let y =
    if j > (34 / 2)
    then j - (34 / 2)
    else 0
  in

  let x = min x (w - 50) in
  let y = min y (h - 34) in

  pos := (x * 16, y * 16);

  let player = (i, j, _dir, sxy) in
  (player)
;;


let animate1 r_dir pos texture world player chars () =
  display !pos texture world !player chars;
  begin
    match !player with
    | None -> update_pos r_dir pos;
    | Some _player -> player := Some(update_player r_dir pos world chars _player)
  end;
  ()
;;

let animate2 world chars () =
  update_chars world chars;
  update_water world;
  ()
;;


type key_change = KeyDown | KeyUp

let ev_keychange r_dir pos world player chars key_change ev =
  let new_dir =
    match key_change, ev.Canvas.keyCode, ev.Canvas.key with
    | KeyDown, 37, _ -> (* Left *)
        { !r_dir with left = true }
    | KeyDown, 39, _ -> (* Right *)
        { !r_dir with right = true }
    | KeyDown, 38, _ -> (* Up *)
        { !r_dir with up = true }
    | KeyDown, 40, _ -> (* Down *)
        { !r_dir with down = true }

    (*
    | KeyUp, 37, _ -> (* Left *)
        { !r_dir with left = false }
    | KeyUp, 39, _ -> (* Right *)
        { !r_dir with right = false }
    | KeyUp, 38, _ -> (* Up *)
        { !r_dir with up = false }
    | KeyUp, 40, _ -> (* Down *)
        { !r_dir with down = false }
    *)

    (*
    | KeyDown, _, "z" ->
    | KeyUp, _, "z" ->
    | KeyDown, _, "s" ->
    | KeyDown, _, "d" ->
    | KeyDown, _, "p" ->
    | KeyDown, _, " " ->
    *)

    | _ -> !r_dir
  in
  r_dir := new_dir;

  (* square dist *)
  let sq_dist (x1, y1) (x2, y2) =
    let x = (x2 - x1) in
    let y = (y2 - y1) in
    (x * x) + (y * y)
  in
  begin
    match key_change, ev.Canvas.keyCode, ev.Canvas.key with
    | KeyDown, _, "t" ->
        begin
          match !player with
          | Some _player ->
              chars := _player :: !chars;
              player := None;
          | None ->
              let x, y = !pos in
              let x, y = (x / 16, y / 16) in
              let x, y = (x + (50 / 2), y + (34 / 2)) in

              let closer, _chars =
                List.fold_left (fun (this, acc) that ->
                  let i1, j1, _, _ = this in
                  let i2, j2, _, _ = that in
                  let d1 = sq_dist (i1, j1) (x, y) in
                  let d2 = sq_dist (i2, j2) (x, y) in
                  if d1 < d2
                  then (this, that::acc)
                  else (that, this::acc)
                ) (List.hd !chars, []) (List.tl !chars)
              in

              chars := _chars;
              player := Some closer;
        end
    | KeyDown, _, "d" ->
        (* remove a tree *)
        begin
          match !player with
          | None -> ()
          | Some _player ->
              let i, j, dir, _ = _player in
              let i2, j2 =
                match dir with
                | Left  -> (i-1, j)
                | Right -> (i+1, j)
                | Up    -> (i, j-1)
                | Down  -> (i, j+1)
              in
              let is_tree i j =
                try
                  match world.(j).(i) with
                  | Tree1 | Tree2 | Tree3 -> true
                  | _ -> false
                with _ -> false
              in
              if is_tree i2 j2
              then world.(j2).(i2) <- Grass
        end
    | KeyDown, _, "b" ->
        (* build a bridge *)
        begin
          match !player with
          | None -> ()
          | Some _player ->
              let i, j, dir, _ = _player in
              let (i2, j2), bridge =
                match dir with
                | Left  -> (i-1, j), Bridge1
                | Right -> (i+1, j), Bridge1
                | Up    -> (i, j-1), Bridge2
                | Down  -> (i, j+1), Bridge2
              in
              let is_water i j =
                try
                  match world.(j).(i) with
                  | Water1 | Water2 | Water3 -> true
                  | _ -> false
                with _ -> false
              in
              if is_water i2 j2
              then world.(j2).(i2) <- bridge
        end
    | KeyDown, _, "r" ->
        (* convert grass to road *)
        begin
          match !player with
          | None -> ()
          | Some _player ->
              let i, j, dir, _ = _player in
              let is_grass i j =
                try
                  match world.(j).(i) with
                  | Grass -> true
                  | _ -> false
                with _ -> false
              in
              if is_grass i j
              then world.(j).(i) <- Road
        end
    | KeyDown, _, "g" ->
        (* convert road to grass *)
        begin
          match !player with
          | None -> ()
          | Some _player ->
              let i, j, dir, _ = _player in
              let is_road i j =
                try
                  match world.(j).(i) with
                  | Road -> true
                  | _ -> false
                with _ -> false
              in
              if is_road i j
              then world.(j).(i) <- Grass
        end
    | _ -> ()
  end;

  ()
;;

(*
type mouse_change = MouseDown | MouseUp

let ev_mousechange change ev =
  ()
;;
*)

(* init texture *)
let init_texture () =
  Canvas.imageSmoothingEnabled ctx false;

  let tex_file = "./AllAssetsPreviewi.png" in

  (*
     Details about this .png file:
       Author's nickname: Shade
       License: CC0
         https://creativecommons.org/publicdomain/zero/1.0/

     Origin of this file:
       https://opengameart.org/content/miniworld-sprites

     Other URL for this graphics kit:
       https://merchant-shade.itch.io/16x16-mini-world-sprites
  *)

  (* Load the sprite sheets from image files *)

  let texture = Canvas.newImage () in
  Canvas.setImgSrc texture tex_file;

  (* Report when the sprite sheet is loaded *)
  Canvas.imgOnload texture (fun () ->
    texture_loaded := true;
  );

  (texture)
;;


(* main *)
let () =
  Random.self_init ();
  let seed1 = (Random.float 1.0) in
  let seed2 = (Random.float 1.0) in
  let seed3 = (Random.float 1.0) in

  let seeds = {
    seed1;
    seed2;
    seed3;
  } in

  let r_dir = ref {
    left = false;
    right = false;
    up = false;
    down = false;
  } in

  let pos = ref (0, 0) in

  let chars, world, player = init_world seeds (0, 0) () in
  let texture = init_texture () in

  Canvas.addKeyEventListener Canvas.window "keydown" (ev_keychange r_dir pos world player chars KeyDown) true;
  Canvas.addKeyEventListener Canvas.window "keyup" (ev_keychange r_dir pos world player chars KeyUp) true;

  (*
  Canvas.addMouseEventListener Canvas.window "mousedown" (ev_mousechange MouseDown) true;
  Canvas.addMouseEventListener Canvas.window "mouseup" (ev_mousechange MouseUp) true;
  *)

  let loop1 = Canvas.setInterval (animate1 r_dir pos texture world player chars) (1000/16) in
  let loop2 = Canvas.setInterval (animate2 world chars) (1000/2) in
  ignore(loop1);
  ignore(loop2);
  ()
;;