add topbar with mana, fix bug where newly created state was not stored

in the hashtbl 😠, clean code

src/dune

@@ -45,7 +45,7 @@
 
 (library
  (name shared)
- (modules map network state)
+ (modules log map network state time)
  (libraries))
 
 (rule

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

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
+  | Error e ->
-  | Ok _ -> Ws_client.send (Network.Action_msg action)
+    (* 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 =
+let rec game_loop state last_auto_update timestamp =
-  draw state;
+  render state;
-  let new_state =
+  let should_auto_update =
-    (* TODO repesct order of action *)
+    timestamp -. last_auto_update
-    (* apply to_apply_queue *)
+    >= 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;
-
+    (* state auto update *)
-    (* auto_update *)
+    if should_auto_update then State.auto_update state else state
-    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
   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.) )

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

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 width = 100 in
-  let height = 1000 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 check_move map ({ x; y; dir } as pos) movement_dir =
-  let x, y, current_dir = entity_pos in
+  if dir <> movement_dir then Ok { pos with dir = movement_dir }
-  let x, y =
+  else
-    if current_dir <> dir then (x, y)
+    let x, y =
-    else
+      match movement_dir with
-      match dir with
       | Left -> (x - 1, y)
       | Right -> (x + 1, y)
       | Down -> (x, y + 1)
       | Up -> (x, y - 1)
-  in
+    in
-  match get_tile_kind ~x ~y map with
+    match get_tile_kind ~x ~y map with
-  | Black | Water -> Error "invalid terrain"
+    | (Black | Water) as bg ->
-  | Grass -> Ok (x, y, dir)
+      Error (Format.asprintf "can't move on %a" pp_background bg)
+    | Grass -> Ok { pos with x; y }

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

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

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 )

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

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 *)
+    (* send user island state for the first time *)
-    let state =
+    let state = get_state_unsafe user_id in
-      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 *)
     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 =
+        let state = get_state_unsafe user_id in
-          match User.get_state user_id with
-          | Error _e -> assert false
-          | Ok state -> state
-        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'

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 on_event ws_event f =
-  let (_ : Ev.listener) =
+  let (_ : Ev.listener) = Ev.listen ws_event f ws_target in
-    Ev.listen ws_event
-      (fun ev ->
-        Format.printf "%s@\n" log_msg;
-        f ev )
-      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 ->
+  on_event Message.Ev.message (fun ev -> f (to_server_msg 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;
+  Websocket.send_string ws s
-  Format.printf "send action on websocket ~~ DONE @\n";
-  ()