From caffcbb527ffd6aff9aeafac23b34ddc8f23ff62 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 26 Dec 2022 02:06:13 +0100 Subject: [PATCH] do not send whole state on action --- src/island_client.ml | 92 ++++++++++++++++++++++++++++++-------------- src/map.ml | 25 ++++++------ src/network.ml | 6 +++ src/state.ml | 36 ++++++++++++----- src/ws.ml | 34 +++++++++++----- src/ws_client.ml | 8 ++-- 6 files changed, 135 insertions(+), 66 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 8142813..37aaccd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,11 +51,12 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw_map = +let draw = 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 - fun map -> - let player_x, player_y = map.Map.player_pos in + fun state -> + let open State in + let player_x, player_y, player_dir = state.player_pos in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -63,7 +64,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y map with + match Map.get_tile_kind ~x:map_x ~y:map_y state.map with | Grass -> grass | Water -> water | Black -> water @@ -72,7 +73,7 @@ let draw_map = done done; let papy = - match map.Map.player_dir with + match player_dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -80,19 +81,43 @@ let draw_map = in C2d.draw_image context papy ~x:papy_x ~y:papy_y -let kb_handler state ev = - let move = Map.move !state.State.map in - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> move Up - | "KeyA" | "ArrowLeft" -> move Left - | "KeyS" | "ArrowDown" -> move Down - | "KeyD" | "ArrowRight" -> move Right - | "KeyM" -> Ws_client.send State.Meditate - | _s -> () +(* queue for action to be done *) +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 -> Format.printf "Invalid action: %s@\n" e + | Ok _ -> Ws_client.send (Network.Action_msg action) + +let kb_handler ev = + let open State in + let act = + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> Move Up + | "KeyA" | "ArrowLeft" -> Move Left + | "KeyS" | "ArrowDown" -> Move Down + | "KeyD" | "ArrowRight" -> Move Right + | "KeyM" -> Meditate + | _s -> Do_nothing + in + Queue.add act input_queue let rec game_loop state _timestamp = - draw_map !state.State.map; - let new_state = state in + draw state; + let new_state = + (* TODO repesct order of action *) + (* apply to_apply_queue *) + let state = Queue.fold State.perform_action state to_apply_queue in + (* TODO can this bug because of concurrency? *) + Queue.clear to_apply_queue; + (* send input action to server *) + Queue.iter (send_action state) input_queue; + Queue.clear input_queue; + state + in G.request_animation_frame (game_loop new_state) let () = @@ -106,16 +131,27 @@ let () = (* get state from server*) let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in + (* attach message listener to update state *) + Ws_client.on_update_state_message (fun server_msg -> + match server_msg with + | Full_state _state -> + (* TODO reset state to received state *) + Format.printf "received Full_state message@\n" + | Update_result res -> ( + match res with + | Error e -> Format.printf "received update result error: %s" e + | Ok action' -> Queue.add action' to_apply_queue ) ); + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + in + Fut.await initial_state_fut (fun msg -> - let initial_state = Ws_client.to_server_msg msg in - let state_ref = ref initial_state in - (* bind keys *) - let _e : Ev.listener = - Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window) - in - (* attach message listener to update state *) - Ws_client.on_update_state_message (fun received -> - state_ref := received; - Format.printf "YOUR MANA IS: %d@." !state_ref.mana ); - (* start game *) - G.request_animation_frame (game_loop state_ref) ) + match Ws_client.to_server_msg msg with + | Update_result _res_msg -> + failwith + "invalid first server message received; received Update expected \ + Full_state" + | Full_state state -> + (* start game *) + G.request_animation_frame (game_loop state) ) diff --git a/src/map.ml b/src/map.ml index 36160e9..4860914 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,10 +9,10 @@ type background = | Water | Black +type position = int * int * dir + type t = { tiles : background array array - ; mutable player_pos : int * int - ; mutable player_dir : dir ; width : int ; height : int } @@ -25,23 +25,22 @@ let init () = Array.init height (fun _y -> if Random.int 1000 <= 42 then Water else Grass ) ) in - { tiles; player_pos = (20, 3); player_dir = Down; width; height } + { tiles; width; height } let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let move map dir = - if map.player_dir = dir then begin - let x, y = map.player_pos in - let x, y = +let check_move map entity_pos dir = + let x, y, current_dir = entity_pos in + let x, y = + if current_dir <> dir then (x, y) + else match 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 -> () - | Grass -> map.player_pos <- (x, y) - end - else map.player_dir <- dir + in + match get_tile_kind ~x ~y map with + | Black | Water -> Error "invalid terrain" + | Grass -> Ok (x, y, dir) diff --git a/src/network.ml b/src/network.ml index aecc640..729b569 100644 --- a/src/network.ml +++ b/src/network.ml @@ -3,3 +3,9 @@ let marshal o = Marshal.to_string o [] |> Format.sprintf "%S" let unmarshal o = let s = Scanf.sscanf o "%S" (fun s -> s) in Marshal.from_string s 0 + +type server_message = + | Full_state of State.t + | Update_result of (State.action', string) result + +type client_message = Action_msg of State.action diff --git a/src/state.ml b/src/state.ml index fa434c8..69f86f6 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,17 +1,33 @@ type t = { map : Map.t - ; mutable mana : int + ; mana : int + ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0 } +let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } -type action = Meditate +type action = + | Meditate + (* TODO some action do not needs to be checked by server *) + | Move of Map.dir + | Do_nothing -(* TODO do not send whole state *) -let handle_action state action = - match action with +(* 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 + +let check_action state = function | Meditate -> - if state.mana < 99 then ( - state.mana <- succ state.mana; - Ok state ) - 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 + +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 diff --git a/src/ws.ml b/src/ws.ml index d4a377c..78f7a29 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -6,23 +6,37 @@ let handle_client request client = | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> (* TODO catch marshal failure *) - Dream.log " SEND USER ISLAND"; - (* send user island state *) let state = match User.get_state user_id with | Error _e -> assert false | Ok state -> state in - let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in - Dream.log " SENDED USER ISLAND"; + let state_msg = Network.Full_state state in - let rec loop () = + (* send user island state *) + let* () = + Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) + in + + let rec loop state = match%lwt Dream.receive client with | None -> Dream.close_websocket client | Some s -> - let action : State.action = Network.unmarshal s in - let state_res = State.handle_action state action in - let* () = Dream.send client (Network.marshal state_res) in - loop () + let (Network.Action_msg action : Network.client_message) = + Network.unmarshal s + in + let res, state = + match State.check_action state action with + | Error _e as error -> (error, state) + | Ok action' -> + (* update server state *) + let state = State.perform_action state action' in + User.set_state user_id state; + (Ok action', state) + in + let* () = + Dream.send client (Network.marshal (Network.Update_result res)) + in + loop state in - loop () + loop state diff --git a/src/ws_client.ml b/src/ws_client.ml index ab612ef..8f7102b 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -25,17 +25,15 @@ let on_event ws_event log_msg f = let to_server_msg ev = Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in - let state_res : (State.t, string) result = Network.unmarshal data in + let server_msg : Network.server_message = Network.unmarshal data in Format.printf "un-marshaled message from server yay ~ @\n"; - match state_res with - | Error e -> failwith (Format.sprintf "action resulted in error: %s" e) - | Ok state -> state + server_msg let on_update_state_message f = on_event Message.Ev.message "Websocket reveived message!" (fun ev -> f (to_server_msg ev) ) -let send msg = +let send (msg : Network.client_message) = Format.printf "send msg on websocket ~~ @\n"; let s = Jstr.of_string (Network.marshal msg) in Websocket.send_string ws s;