diff --git a/src/island_client.ml b/src/island_client.ml index 33ef546..e0dfb72 100644 --- a/src/island_client.ml +++ b/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 - let map_x = x + state.player_pos.x - (tiles_per_w / 2) in - let tile_x = float_of_int ((x * tile_size) + orig_x) in - for y = 0 to tiles_per_h - 1 do - let map_y = y + state.player_pos.y - (tiles_per_h / 2) in - let tile_y = float_of_int ((y * tile_size) + orig_y) in + (* TODO: it could be possible to optimize starting/ending index by looking at the offset *) + for x = -2 to tiles_per_w + 1 do + let map_x = x + state.player_pos.x - half_tiles_per_w in + let tile_x = + float_of_int ((x * tile_size) + orig_x) +. offset_conv state.offset_x + 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 = - match State.check_action state action with - | Error e -> - (* TODO: display this in the window *) - Log.debug "invalid action: %s@\n" e - | Ok Look_at_the_sky -> () - | Ok _ -> - Log.debug "sending action %a to server@\n" State.pp_action action; - Ws_client.send (Network.Action_msg action) +let send_action state = function + (* actions we don't need to send to the server *) + | (State.Move_offset _ | Move _) as action -> begin + match State.check_action state action with + | Error e -> + (* TODO: display this in the window *) + Log.debug "invalid action: %s@\n" e + | Ok actions -> List.iter (fun a -> Queue.add a to_apply_queue) actions + 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 - | "KeyA" | "ArrowLeft" -> Move Left - | "KeyS" | "ArrowDown" -> Move Down - | "KeyD" | "ArrowRight" -> Move Right + | "KeyW" | "ArrowUp" -> Move_offset Up + | "KeyA" | "ArrowLeft" -> Move_offset Left + | "KeyS" | "ArrowDown" -> Move_offset Down + | "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 = diff --git a/src/map.ml b/src/map.ml index 516d7a6..6bffeae 100644 --- a/src/map.ml +++ b/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 = - if dir <> movement_dir then Ok { pos with dir = movement_dir } - else - let x, y = - match movement_dir with - | Left -> (x - 1, y) - | Right -> (x + 1, y) - | Down -> (x, y + 1) - | Up -> (x, y - 1) - in - match get_tile_kind ~x ~y map with - | (Black | Water) as bg -> - Error (Format.asprintf "can't move on %a" pp_background bg) - | Grass -> Ok { pos with x; y } +let check_move map ({ x; y; _ } as pos) movement_dir = + let x, y = + match movement_dir with + | Left -> (x - 1, y) + | Right -> (x + 1, y) + | Down -> (x, y + 1) + | Up -> (x, y - 1) + in + match get_tile_kind ~x ~y map with + | (Black | Water) as bg -> + Error (Format.asprintf "can't move on %a" pp_background bg) + | Grass -> Ok { pos with x; y } diff --git a/src/network.ml b/src/network.ml index 729b569..83cd67f 100644 --- a/src/network.ml +++ b/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 diff --git a/src/state.ml b/src/state.ml index 7ef6b1d..9b2ca6f 100644 --- a/src/state.ml +++ b/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) ) - | Do_nothing -> Ok Look_at_the_sky + | Ok pos -> Ok [ Set_player_position pos ] ) + | 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' -> - let state = perform_action state action' in - state + | Ok actions -> List.fold_left perform_action state actions 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 - player_pos Map.pp_background bg + Format.fprintf fmt + "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 diff --git a/src/ws.ml b/src/ws.ml index 827aef9..3d832f8 100644 --- a/src/ws.ml +++ b/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'; - let state = State.perform_action state action' in + Dream.log "check_action ok: %a" + (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