diff --git a/src/island.ml b/src/island.ml index 50fdccc..ad37b85 100644 --- a/src/island.ml +++ b/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 diff --git a/src/island_client.ml b/src/island_client.ml index e0dfb72..1f25a64 100644 --- a/src/island_client.ml +++ b/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 -> diff --git a/src/map.ml b/src/map.ml index 6bffeae..ea9c498 100644 --- a/src/map.ml +++ b/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 } diff --git a/src/state.ml b/src/state.ml index 9b2ca6f..cc8af84 100644 --- a/src/state.ml +++ b/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 - | Error _e -> state - | Ok actions -> List.fold_left perform_action state actions + let state = + match check_action state Meditate with + | 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 - Map.pp_position player_pos Map.pp_background bg offset_x offset_y + "mana = %d; wheat = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f" + mana wheat Map.pp_position player_pos Map.pp_background bg offset_x offset_y