implement grid offset

src/island_client.ml

@@ -52,16 +52,27 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up")
 let water = C2d.image_src_of_el (get_el "water")
 
 let draw_canvas =
+  let offset_conv =
+    let m = float_of_int @@ (tile_size / 2) in
+    fun offset -> m *. offset
+  in
   let papy_x = float_of_int (width - tile_size) /. 2. in
   let papy_y = (float_of_int height /. 2.) -. (float_of_int tile_size *. 1.5) in
+  let half_tiles_per_w = tiles_per_w / 2 in
+  let half_tiles_per_h = tiles_per_h / 2 in
   fun state ->
     let open State in
-    for x = 0 to tiles_per_w - 1 do
+    (* TODO: it could be possible to optimize starting/ending index by looking at the offset *)
-      let map_x = x + state.player_pos.x - (tiles_per_w / 2) in
+    for x = -2 to tiles_per_w + 1 do
-      let tile_x = float_of_int ((x * tile_size) + orig_x) in
+      let map_x = x + state.player_pos.x - half_tiles_per_w in
-      for y = 0 to tiles_per_h - 1 do
+      let tile_x =
-        let map_y = y + state.player_pos.y - (tiles_per_h / 2) in
+        float_of_int ((x * tile_size) + orig_x) +. offset_conv state.offset_x
-        let tile_y = float_of_int ((y * tile_size) + orig_y) in
+      in
+      for y = -2 to tiles_per_h + 1 do
+        let map_y = y + state.player_pos.y - half_tiles_per_h in
+        let tile_y =
+          float_of_int ((y * tile_size) + orig_y) +. offset_conv state.offset_y
+        in
         let tile_img =
           match Map.get_tile_kind ~x:map_x ~y:map_y state.map with
           | Grass -> grass
@@ -91,15 +102,24 @@ let input_queue = Queue.create ()
 (* queue for action' to apply to client state *)
 let to_apply_queue : State.action' Queue.t = Queue.create ()
 
-let send_action state action =
+let send_action state = function
-  match State.check_action state action with
+  (* actions we don't need to send to the server *)
-  | Error e ->
+  | (State.Move_offset _ | Move _) as action -> begin
-    (* TODO: display this in the window *)
+    match State.check_action state action with
-    Log.debug "invalid action: %s@\n" e
+    | Error e ->
-  | Ok Look_at_the_sky -> ()
+      (* TODO: display this in the window *)
-  | Ok _ ->
+      Log.debug "invalid action: %s@\n" e
-    Log.debug "sending action %a to server@\n" State.pp_action action;
+    | Ok actions -> List.iter (fun a -> Queue.add a to_apply_queue) actions
-    Ws_client.send (Network.Action_msg action)
+  end
+  (* actions we want to send to the server *)
+  | Meditate as action -> (
+    match State.check_action state action with
+    | Error e ->
+      (* TODO: display this in the window *)
+      Log.debug "invalid action: %s@\n" e
+    | Ok _actions ->
+      Log.debug "sending action %a to server@\n" State.pp_action action;
+      Ws_client.send (Network.Action_msg action) )
 
 module Kb : sig
   (* this keeps an ordered sequence of unique values,
@@ -165,10 +185,10 @@ let apply_last_key () =
          let act =
            (* when you add something here, don't forget to add the corresponding case in `keypress_handler` *)
            match code_or_key with
-           | "KeyW" | "ArrowUp" -> Move Up
+           | "KeyW" | "ArrowUp" -> Move_offset Up
-           | "KeyA" | "ArrowLeft" -> Move Left
+           | "KeyA" | "ArrowLeft" -> Move_offset Left
-           | "KeyS" | "ArrowDown" -> Move Down
+           | "KeyS" | "ArrowDown" -> Move_offset Down
-           | "KeyD" | "ArrowRight" -> Move Right
+           | "KeyD" | "ArrowRight" -> Move_offset Right
            | "m" -> Meditate
            | _ ->
              (* if this happen, it means we're adding
@@ -225,7 +245,8 @@ let () =
       | Update_result res -> (
         match res with
         | Error e -> Log.debug "received update result error: %s@\n" e
-        | Ok action' -> Queue.add action' to_apply_queue ) );
+        | Ok actions ->
+          List.iter (fun action -> Queue.add action to_apply_queue) actions ) );
 
   (* bind keys *)
   let _e : Ev.listener =

src/map.ml

@@ -53,17 +53,15 @@ let init () =
 let get_tile_kind ~x ~y map =
   try map.tiles.(x).(y) with Invalid_argument _ -> Black
 
-let check_move map ({ x; y; dir } as pos) movement_dir =
+let check_move map ({ x; y; _ } as pos) movement_dir =
-  if dir <> movement_dir then Ok { pos with dir = movement_dir }
+  let x, y =
-  else
+    match movement_dir with
-    let x, y =
+    | Left -> (x - 1, y)
-      match movement_dir with
+    | Right -> (x + 1, y)
-      | Left -> (x - 1, y)
+    | Down -> (x, y + 1)
-      | Right -> (x + 1, y)
+    | Up -> (x, y - 1)
-      | Down -> (x, y + 1)
+  in
-      | Up -> (x, y - 1)
+  match get_tile_kind ~x ~y map with
-    in
+  | (Black | Water) as bg ->
-    match get_tile_kind ~x ~y map with
+    Error (Format.asprintf "can't move on %a" pp_background bg)
-    | (Black | Water) as bg ->
+  | Grass -> Ok { pos with x; y }
-      Error (Format.asprintf "can't move on %a" pp_background bg)
-    | Grass -> Ok { pos with x; y }

src/network.ml

@@ -6,6 +6,6 @@ let unmarshal o =
 
 type server_message =
   | Full_state of State.t
-  | Update_result of (State.action', string) result
+  | Update_result of (State.action' list, string) result
 
 type client_message = Action_msg of State.action

src/state.ml

@@ -1,59 +1,124 @@
+module Offset : sig
+  val check_move :
+    x:float -> y:float -> Map.dir -> float * float * Map.dir Option.t
+end = struct
+  let limit = 1.
+
+  let step = 0.25
+
+  let check_move ~x ~y = function
+    | Map.Left ->
+      let x' = x +. step in
+      if x' >= limit then begin
+        let x' = ~-.limit in
+        (x', y, Some Map.Left)
+      end
+      else (x', y, None)
+    | Right ->
+      let x' = x -. step in
+      if x' <= ~-.limit then begin
+        let x' = limit in
+        (x', y, Some Right)
+      end
+      else (x', y, None)
+    | Down ->
+      let y' = y -. step in
+      if y' <= ~-.limit then begin
+        let y' = limit in
+        (x, y', Some Down)
+      end
+      else (x, y', None)
+    | Up ->
+      let y' = y +. step in
+      if y' >= limit then begin
+        let y' = ~-.limit in
+        (x, y', Some Up)
+      end
+      else (x, y', None)
+end
+
 type t =
   { map : Map.t
   ; mana : int
   ; player_pos : Map.position
+  ; offset_x : float
+  ; offset_y : float
   }
 
 let init () =
-  { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } }
+  { map = Map.init ()
+  ; mana = 0
+  ; player_pos = { x = 0; y = 0; dir = Down }
+  ; offset_x = 0.
+  ; offset_y = 0.
+  }
 
 type action =
   | Meditate
   (* TODO some action do not needs to be checked by server *)
+  | Move_offset of Map.dir
   | Move of Map.dir
-  | Do_nothing
 
 (* type for result of action send to the client by the server *)
 type action' =
   | Add_mana of int
   | Set_player_position of Map.position
-  | Look_at_the_sky
+  | Set_offset of float * float
 
 let pp_action fmt = function
   | Meditate -> Format.pp_print_string fmt "Meditate"
+  | Move_offset dir -> Format.fprintf fmt "Move_offset %a" Map.pp_dir dir
   | Move dir -> Format.fprintf fmt "Move %a" Map.pp_dir dir
-  | Do_nothing -> Format.pp_print_string fmt "Do_nothing"
 
 let pp_action' fmt = function
   | Add_mana n -> Format.fprintf fmt "Add_mana %d" n
   | Set_player_position pos ->
     Format.fprintf fmt "Set_player_position (%a)" Map.pp_position pos
-  | Look_at_the_sky -> Format.pp_print_string fmt "Look_at_the_sky"
+  | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y
 
-let check_action state = function
+let rec check_action state = function
   | Meditate ->
-    if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana"
+    if state.mana < 99 then Ok [ Add_mana 1 ] else Error "maximum mana"
   | Move dir -> (
     match Map.check_move state.map state.player_pos dir with
     | Error _e as error -> error
-    | Ok pos -> Ok (Set_player_position pos) )
+    | Ok pos -> Ok [ Set_player_position pos ] )
-  | Do_nothing -> Ok Look_at_the_sky
+  | Move_offset dir ->
+    if dir <> state.player_pos.dir then
+      Ok [ Set_player_position { state.player_pos with dir } ]
+    else
+      let offset_x, offset_y, dir' =
+        Offset.check_move ~x:state.offset_x ~y:state.offset_y dir
+      in
+      let offset_action =
+        [ Set_player_position { state.player_pos with dir }
+        ; Set_offset (offset_x, offset_y)
+        ]
+      in
+      begin
+        match dir' with
+        | None -> Ok offset_action
+        | Some dir' -> begin
+          match check_action state (Move dir') with
+          | Error _e as e -> e
+          | Ok actions -> Ok (offset_action @ actions)
+        end
+      end
 
 let perform_action state = function
   | Add_mana n -> { state with mana = state.mana + n }
   | Set_player_position player_pos -> { state with player_pos }
-  | Look_at_the_sky -> state
+  | Set_offset (offset_x, offset_y) -> { state with offset_x; offset_y }
 
 let auto_update state =
   match check_action state Meditate with
   | Error _e -> state
-  | Ok action' ->
+  | Ok actions -> List.fold_left perform_action state actions
-    let state = perform_action state action' in
-    state
 
 let auto_update_rate = Time.mk_s 1
 
-let pp fmt { mana; player_pos; map } =
+let pp fmt { mana; player_pos; map; offset_x; offset_y } =
   let bg = Map.get_tile_kind ~x:player_pos.x ~y:player_pos.y map in
-  Format.fprintf fmt "mana = %d; player_pos = %a; %a" mana Map.pp_position
+  Format.fprintf fmt
-    player_pos Map.pp_background bg
+    "mana = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f" mana
+    Map.pp_position player_pos Map.pp_background bg offset_x offset_y

src/ws.ml

@@ -35,8 +35,12 @@ let handle_client request client =
             Dream.log "check_action error: %s" msg;
             e
           | Ok action' ->
-            Dream.log "check_action ok: %a" State.pp_action' action';
+            Dream.log "check_action ok: %a"
-            let state = State.perform_action state action' in
+              (Format.pp_print_list
+                 ~pp_sep:(fun fmt () -> Format.fprintf fmt " ; ")
+                 State.pp_action' )
+              action';
+            let state = List.fold_left State.perform_action state action' in
             User.set_state user_id state;
             Ok action'
         in