implement wheat !

src/island.ml

@@ -17,7 +17,11 @@ let get request =
   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 ]
+    let wheat_img = mk_img false "wheat" in
+    let wheat_lvl = span ~a:[ a_id "wheat_lvl" ] [ txt "0" ] in
+    div
+      ~a:[ a_class [ "centered" ] ]
+      [ mana_img; mana_lvl; wheat_img; wheat_lvl ]
   in
 
   let canvas =
@@ -32,14 +36,24 @@ let get request =
   let canvas_images =
     div
     @@ List.map (mk_img true)
-         [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ]
+         [ "grass"
+         ; "papy_left"
+         ; "papy_right"
+         ; "papy_down"
+         ; "papy_up"
+         ; "water"
+         ; "wheat"
+         ]
   in
 
   let bottombar =
     let medidate_button =
       button ~a:[ a_id "medidate_button" ] [ txt "Medidate" ]
     in
-    div ~a:[ a_class [ "centered" ] ] [ medidate_button ]
+    let plant_wheat_button =
+      button ~a:[ a_id "plant_wheat_button" ] [ txt "Plant wheat" ]
+    in
+    div ~a:[ a_class [ "centered" ] ] [ medidate_button; plant_wheat_button ]
   in
 
   let page = div [ topbar; canvas; bottombar; canvas_images ] in

src/island_client.ml

@@ -51,6 +51,8 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up")
 
 let water = C2d.image_src_of_el (get_el "water")
 
+let wheat = C2d.image_src_of_el (get_el "wheat")
+
 let draw_canvas =
   let offset_conv =
     let m = float_of_int @@ (tile_size / 2) in
@@ -78,6 +80,7 @@ let draw_canvas =
           | Grass -> grass
           | Water -> water
           | Black -> water
+          | Wheat -> wheat
         in
         C2d.draw_image context tile_img ~x:tile_x ~y:tile_y
       done
@@ -92,9 +95,13 @@ let draw_canvas =
     C2d.draw_image context papy ~x:papy_x ~y:papy_y
 
 let draw_topbar state =
+  (* draw mana level *)
   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)
+    (Jv.of_string @@ string_of_int state.Shared.State.mana);
+  (* draw wheat level *)
+  let wheat_lvl = Jv.get Jv.global "wheat_lvl" in
+  Jv.set wheat_lvl "innerHTML" (Jv.of_string @@ string_of_int state.wheat)
 
 (* queue for action to be done *)
 let input_queue = Queue.create ()
@@ -104,15 +111,17 @@ let to_apply_queue : State.action' Queue.t = Queue.create ()
 
 let send_action state = function
   (* actions we don't need to send to the server *)
-  | (State.Move_offset _ | Move _) as action -> begin
+  (*
+    | (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 -> (
+  | (State.Move_offset _ | Move _ | Meditate | Plant_wheat) as action -> (
     match State.check_action state action with
     | Error e ->
       (* TODO: display this in the window *)
@@ -160,7 +169,7 @@ let keypress_handler =
      ; "KeyW"
     |];
   let keys = Hashtbl.create 512 in
-  Array.iter (fun key -> Hashtbl.add keys key ()) [| "m" |];
+  Array.iter (fun key -> Hashtbl.add keys key ()) [| "m"; "p" |];
   (* TODO: I'm not sure the Hashtbl business is worth it.
      Before, we were matching on values instead of calling Hashtbl.mem.
      It should be better with Hashtbl but it wasn't benchmarked. *)
@@ -190,6 +199,7 @@ let apply_last_key () =
            | "KeyS" | "ArrowDown" -> Move_offset Down
            | "KeyD" | "ArrowRight" -> Move_offset Right
            | "m" -> Meditate
+           | "p" -> Plant_wheat
            | _ ->
              (* if this happen, it means we're adding
                 bad values in `keypress_handler`
@@ -270,6 +280,15 @@ let () =
       meditate_button
   in
 
+  let _e : Ev.listener =
+    let plant_wheat_button =
+      Jv.get Jv.global "plant_wheat_button" |> Ev.target_of_jv
+    in
+    Ev.listen Ev.click
+      (fun _ev -> Queue.add (State.Plant_wheat : State.action) input_queue)
+      plant_wheat_button
+  in
+
   Fut.await initial_state_fut (fun msg ->
       match Ws_client.to_server_msg msg with
       | Update_result _res_msg ->

src/map.ml

@@ -8,6 +8,7 @@ type background =
   | Grass
   | Water
   | Black
+  | Wheat
 
 let pp_dir fmt dir =
   let s =
@@ -21,7 +22,11 @@ let pp_dir fmt dir =
 
 let pp_background fmt b =
   let s =
-    match b with Grass -> "Grass" | Water -> "Water" | Black -> "Black"
+    match b with
+    | Grass -> "Grass"
+    | Water -> "Water"
+    | Black -> "Black"
+    | Wheat -> "Wheat"
   in
   Format.pp_print_string fmt s
 
@@ -53,6 +58,19 @@ let init () =
 let get_tile_kind ~x ~y map =
   try map.tiles.(x).(y) with Invalid_argument _ -> Black
 
+let count_wheat map =
+  Array.fold_left
+    (fun count a ->
+      let count' =
+        Array.fold_left
+          (fun count -> function
+            | Wheat -> succ count
+            | Black | Grass | Water -> count )
+          0 a
+      in
+      count + count' )
+    0 map
+
 let check_move map ({ x; y; _ } as pos) movement_dir =
   let x, y =
     match movement_dir with
@@ -64,4 +82,4 @@ let check_move map ({ x; y; _ } as pos) movement_dir =
   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 }
+  | Grass | Wheat -> Ok { pos with x; y }

src/state.ml

@@ -40,6 +40,7 @@ end
 type t =
   { map : Map.t
   ; mana : int
+  ; wheat : int
   ; player_pos : Map.position
   ; offset_x : float
   ; offset_y : float
@@ -48,6 +49,7 @@ type t =
 let init () =
   { map = Map.init ()
   ; mana = 0
+  ; wheat = 0
   ; player_pos = { x = 0; y = 0; dir = Down }
   ; offset_x = 0.
   ; offset_y = 0.
@@ -58,23 +60,30 @@ type action =
   (* TODO some action do not needs to be checked by server *)
   | Move_offset of Map.dir
   | Move of Map.dir
+  | Plant_wheat
+(* TODO: we don't need dir so we should change the type of Map.position *)
 
 (* type for result of action send to the client by the server *)
 type action' =
   | Add_mana of int
   | Set_player_position of Map.position
   | Set_offset of float * float
+  | Plant_wheat of int * int
 
 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
+  | Plant_wheat -> Format.fprintf fmt "Plant_wheat"
 
 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
   | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y
+  | Plant_wheat (x, y) -> Format.fprintf fmt "Plant_wheat (%d, %d)" x y
+
+let plant_wheat_cost = 10
 
 let rec check_action state = function
   | Meditate ->
@@ -104,21 +113,44 @@ let rec check_action state = function
           | Ok actions -> Ok (offset_action @ actions)
         end
       end
+  | Plant_wheat -> (
+    let { Map.x; y; dir } = state.player_pos in
+    let x, y =
+      match dir with
+      | Down -> (x, y + 1)
+      | Left -> (x - 1, y)
+      | Right -> (x + 1, y)
+      | Up -> (x, y - 1)
+    in
+    match Map.get_tile_kind ~x ~y state.map with
+    | Map.Black -> Error "can't plant wheat in space !"
+    | Water -> Error "can't plant wheat in water !"
+    | Wheat -> Error "there's already some wheat there !"
+    | Grass ->
+      if state.mana >= plant_wheat_cost then Ok [ Plant_wheat (x, y) ]
+      else Error "not enough mana..." )
 
 let perform_action state = function
   | Add_mana n -> { state with mana = state.mana + n }
   | Set_player_position player_pos -> { state with player_pos }
   | Set_offset (offset_x, offset_y) -> { state with offset_x; offset_y }
+  | Plant_wheat (x, y) ->
+    state.map.tiles.(x).(y) <- Map.Wheat;
+    { state with mana = state.mana - plant_wheat_cost }
 
 let auto_update state =
-  match check_action state Meditate with
+  let state =
-  | Error _e -> state
+    match check_action state Meditate with
-  | Ok actions -> List.fold_left perform_action state actions
+    | Error _e -> state
+    | Ok actions -> List.fold_left perform_action state actions
+  in
+  let count_wheat = Map.count_wheat state.map.tiles in
+  { state with wheat = state.wheat + count_wheat }
 
 let auto_update_rate = Time.mk_s 1
 
-let pp fmt { mana; player_pos; map; offset_x; offset_y } =
+let pp fmt { mana; wheat; 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; offset_x = %f; offset_y = %f" mana
+    "mana = %d; wheat = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f"
-    Map.pp_position player_pos Map.pp_background bg offset_x offset_y
+    mana wheat Map.pp_position player_pos Map.pp_background bg offset_x offset_y