diff --git a/src/dune b/src/dune index c5a5f3a..db008b0 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,7 @@ (library (name shared) - (modules map network state) + (modules log map network state time) (libraries)) (rule diff --git a/src/island.ml b/src/island.ml index eab4678..411d570 100644 --- a/src/island.ml +++ b/src/island.ml @@ -1,27 +1,39 @@ open Tyxml.Html open Syntax -let mk_img name = +let mk_img hidden name = + let a = [ a_id name ] in img ~src:(Format.sprintf "/assets/img/%s.png" name) ~alt:name - ~a:[ a_hidden (); a_id name ] + ~a:(if hidden then a_hidden () :: a else a) () let get request = let** () = User.assert_logged request in + let title = "Your island" in + + let topbar = + let mana_img = mk_img false "mana" in + let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in + div ~a:[ a_class [ "centered" ] ] @@ [ mana_img; mana_lvl ] + in + let canvas = canvas ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let images = - List.map mk_img + + let canvas_images = + List.map (mk_img true) [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] in - let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in + let page = + div ~a:[ a_class [ "centered" ] ] @@ (topbar :: canvas :: canvas_images) + in let js = script diff --git a/src/island_client.ml b/src/island_client.ml index 5e430e0..d75855d 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -12,7 +12,7 @@ end let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with - | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) + | None -> Log.err "could not find element with id `%s`" id | Some el -> el let tile_size = 40 @@ -51,17 +51,16 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw = +let draw_canvas = 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 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 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 + player_y - (tiles_per_h / 2) in + 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 let tile_img = match Map.get_tile_kind ~x:map_x ~y:map_y state.map with @@ -73,7 +72,7 @@ let draw = done done; let papy = - match player_dir with + match state.player_pos.dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -81,6 +80,11 @@ let draw = in C2d.draw_image context papy ~x:papy_x ~y:papy_y +let draw_topbar state = + let mana_lvl = Jv.get Jv.global "mana_lvl" in + Jv.set mana_lvl "innerHTML" + (Jv.of_string @@ string_of_int state.Shared.State.mana) + (* queue for action to be done *) let input_queue = Queue.create () @@ -89,8 +93,13 @@ 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) + | 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 kb_handler ev = let open State in @@ -105,31 +114,31 @@ let kb_handler ev = in Queue.add act input_queue -let last_auto_state_update = ref 0. +let render state = + draw_canvas state; + draw_topbar state -let rec game_loop state timestamp = - draw state; - let new_state = - (* TODO repesct order of action *) - (* apply to_apply_queue *) +let rec game_loop state last_auto_update timestamp = + render state; + let should_auto_update = + timestamp -. last_auto_update + >= Time.ms_to_float (Time.s_to_ms State.auto_update_rate) + in + + let last_auto_update = + if should_auto_update then timestamp else last_auto_update + in + let state = + (* apply queue of actions *) 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; - - (* auto_update *) - if - timestamp -. !last_auto_state_update - >= float_of_int @@ (State.auto_state_update_rate * 1000) - then ( - Format.printf "MANA: %d@." state.mana; - last_auto_state_update := timestamp; - State.auto_update state ) - else state + (* state auto update *) + if should_auto_update then State.auto_update state else state in - G.request_animation_frame (game_loop new_state) + G.request_animation_frame (game_loop state last_auto_update) let () = (* init canvas *) @@ -147,10 +156,10 @@ let () = match server_msg with | Full_state _state -> (* TODO reset state to received state *) - Format.printf "received Full_state message@\n" + Log.debug "received `Full_state` message@\n" | Update_result res -> ( match res with - | Error e -> Format.printf "received update result error: %s" e + | Error e -> Log.debug "received update result error: %s@\n" e | Ok action' -> Queue.add action' to_apply_queue ) ); (* bind keys *) let _e : Ev.listener = @@ -160,9 +169,9 @@ let () = Fut.await initial_state_fut (fun msg -> match Ws_client.to_server_msg msg with | Update_result _res_msg -> - failwith + Log.err "invalid first server message received; received Update expected \ Full_state" | Full_state state -> (* start game *) - G.request_animation_frame (game_loop state) ) + G.request_animation_frame (game_loop state 0.) ) diff --git a/src/log.ml b/src/log.ml new file mode 100644 index 0000000..12308c3 --- /dev/null +++ b/src/log.ml @@ -0,0 +1,9 @@ +let debug_on = ref true + +let debug_output = ref Format.std_formatter + +let debug t = + if !debug_on then Format.fprintf !debug_output t + else Format.ifprintf Format.err_formatter t + +let err f = Format.kasprintf failwith f diff --git a/src/map.ml b/src/map.ml index 4860914..516d7a6 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,7 +9,30 @@ type background = | Water | Black -type position = int * int * dir +let pp_dir fmt dir = + let s = + match dir with + | Left -> "Left" + | Right -> "Right" + | Down -> "Down" + | Up -> "Up" + in + Format.pp_print_string fmt s + +let pp_background fmt b = + let s = + match b with Grass -> "Grass" | Water -> "Water" | Black -> "Black" + in + Format.pp_print_string fmt s + +type position = + { x : int + ; y : int + ; dir : dir + } + +let pp_position fmt p = + Format.fprintf fmt "(x = %d; y = %d; dir = %a)" p.x p.y pp_dir p.dir type t = { tiles : background array array @@ -18,8 +41,8 @@ type t = } let init () = - let width = 1000 in - let height = 1000 in + let width = 100 in + let height = 90 in let tiles = Array.init width (fun _x -> Array.init height (fun _y -> @@ -30,17 +53,17 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -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 +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 -> Error "invalid terrain" - | Grass -> Ok (x, y, dir) + 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/pellest.ml b/src/pellest.ml index 7356070..97ce928 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -16,9 +16,9 @@ let update_online_user_state () = let () = regularly_call_fun update_online_user_state - (float_of_int Shared.State.auto_state_update_rate); + (Shared.Time.s_to_float Shared.State.auto_update_rate); regularly_call_fun update_offline_user_state - (float_of_int Shared.State.auto_state_update_rate) + (Shared.Time.s_to_float Shared.State.auto_update_rate) let () = let logger = if App.log then Dream.logger else Fun.id in diff --git a/src/state.ml b/src/state.ml index 4b3564d..7ef6b1d 100644 --- a/src/state.ml +++ b/src/state.ml @@ -4,7 +4,8 @@ type t = ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } +let init () = + { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } } type action = | Meditate @@ -18,6 +19,17 @@ type action' = | Set_player_position of Map.position | Look_at_the_sky +let pp_action fmt = function + | Meditate -> Format.pp_print_string fmt "Meditate" + | 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" + let check_action state = function | Meditate -> if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" @@ -39,4 +51,9 @@ let auto_update state = let state = perform_action state action' in state -let auto_state_update_rate = 5 (* in secs *) +let auto_update_rate = Time.mk_s 1 + +let pp fmt { mana; player_pos; map } = + 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 diff --git a/src/time.ml b/src/time.ml new file mode 100644 index 0000000..c96655d --- /dev/null +++ b/src/time.ml @@ -0,0 +1,27 @@ +include ( + struct + type s = int + + type ms = int + + let mk_s = Fun.id + + let s_to_float = float_of_int + + let s_to_ms s = 1000 * s + + let ms_to_float = float_of_int + end : + sig + type s + + type ms + + val mk_s : int -> s + + val s_to_float : s -> float + + val s_to_ms : s -> ms + + val ms_to_float : ms -> float + end ) diff --git a/src/user.ml b/src/user.ml index a3dfe83..e0e9517 100644 --- a/src/user.ml +++ b/src/user.ml @@ -233,4 +233,7 @@ let set_state = Hashtbl.replace state_ht let get_state user_id = match Hashtbl.find_opt state_ht user_id with | Some state -> Ok state - | None -> Ok (Shared.State.init ()) + | None -> + let state = Shared.State.init () in + Hashtbl.replace state_ht user_id state; + Ok state diff --git a/src/ws.ml b/src/ws.ml index b94646c..827aef9 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -1,40 +1,41 @@ open Lwt.Syntax open Shared +let get_state_unsafe user_id = + match User.get_state user_id with + | Error _e -> assert false + | Ok state -> state + let handle_client request client = match Dream.session "user_id" request with | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> - (* TODO catch marshal failure *) - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in - let state_msg = Network.Full_state state in - - (* send user island state *) + (* send user island state for the first time *) + let state = get_state_unsafe user_id in let* () = - Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) + Dream.send ~text_or_binary:`Text client + (Network.marshal (Network.Full_state state)) in let rec loop () = match%lwt Dream.receive client with - | None -> Dream.close_websocket client + | None -> + (* TODO: backup everything to database *) + Dream.close_websocket client | Some s -> - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in + let state = get_state_unsafe user_id in let (Network.Action_msg action : Network.client_message) = Network.unmarshal s in + Dream.log "checking action %a" State.pp_action action; + Dream.log "current state %a" State.pp state; let res = match State.check_action state action with - | Error _e as error -> error + | Error msg as e -> + Dream.log "check_action error: %s" msg; + e | Ok action' -> - (* update server state *) + Dream.log "check_action ok: %a" State.pp_action' action'; let state = State.perform_action state action' in User.set_state user_id state; Ok action' diff --git a/src/ws_client.ml b/src/ws_client.ml index 41649a0..f34b86a 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -3,7 +3,6 @@ open Brr_io open Shared let ws = - Format.printf "create websocket@\n"; let ws_url = let location = Window.location G.window in let host = Uri.host location |> Jstr.to_string in @@ -18,30 +17,18 @@ let ws = let ws_target = Websocket.as_target ws -let on_event ws_event log_msg f = - let (_ : Ev.listener) = - Ev.listen ws_event - (fun ev -> - Format.printf "%s@\n" log_msg; - f ev ) - ws_target - in +let on_event ws_event f = + let (_ : Ev.listener) = Ev.listen ws_event f ws_target in () let to_server_msg ev = - Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in let server_msg : Network.server_message = Network.unmarshal data in - Format.printf "un-marshaled message from server yay ~ @\n"; server_msg let on_update_state_message f = - on_event Message.Ev.message "Websocket reveived message!" (fun ev -> - f (to_server_msg ev) ) + on_event Message.Ev.message (fun ev -> f (to_server_msg ev)) 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; - Format.printf "send action on websocket ~~ DONE @\n"; - () + Websocket.send_string ws s