diff --git a/src/animal.ml b/src/animal.ml deleted file mode 100644 index 473f96b..0000000 --- a/src/animal.ml +++ /dev/null @@ -1,62 +0,0 @@ -type fairy = - { mana : int - ; pos : Map.position - } - -type t = - | Sheep of { pos : Map.position } - | Fairy of fairy - -let pp fmt = function - | Sheep o -> Format.fprintf fmt "Sheep: %a" Map.pp_position o.pos - | Fairy o -> - Format.fprintf fmt "Fairy : mana = %d, %a" o.mana Map.pp_position o.pos - -let make_sheep ~x ~y = - Sheep - { pos = - Map. - { x; y; offset_x = 0.; offset_y = 0.; dir = Obj.magic (x * y mod 4) } - } - -let make_fairy ~x ~y = - { mana = 1; pos = Map.{ x; y; offset_x = 0.; offset_y = 0.; dir = Down } } - -let pos = function Sheep o -> o.pos | Fairy o -> o.pos - -let set_pos pos = function - | Sheep _o -> Sheep { pos } - | Fairy o -> Fairy { o with pos } - -module Herd = struct - (* ... or just use a mutable state and a hashtbl? *) - module IntMap = Stdlib.Map.Make (struct - type t = int - - let compare = Int.compare - end) - - type nonrec t = t IntMap.t - - let find_opt = IntMap.find_opt - - let update = IntMap.update - - let iter = IntMap.iter - - let init map = - List.init 50 (fun _i -> - let x = Random.int map.width in - let y = Random.int map.height in - (x, y) ) - |> List.filter (fun (x, y) -> Map.get_tile_kind ~x ~y map = Grass) - |> List.mapi (fun i (x, y) -> (i, make_sheep ~x ~y)) - |> List.to_seq |> IntMap.of_seq - - let pp fmt o = - Format.fprintf fmt "[%a]" - (Format.pp_print_list - ~pp_sep:(fun _fmt () -> Format.pp_print_string fmt "; ") - pp ) - (IntMap.to_seq o |> List.of_seq |> List.map snd) -end diff --git a/src/dune b/src/dune index 9e5e468..942d3eb 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,7 @@ (library (name shared) - (modules animal log map network state time) + (modules entity log map network state time) (libraries)) (rule diff --git a/src/entity.ml b/src/entity.ml new file mode 100644 index 0000000..9854203 --- /dev/null +++ b/src/entity.ml @@ -0,0 +1,88 @@ +type _ t = + | Sheep : int -> [> `S ] t + | Fairy : int -> [> `F ] t + +(* todo move to State? *) +type tbl = + { mutable count : int + ; positions : ([ `S | `F ] t, Map.position) Hashtbl.t + ; positions' : (int * int, [ `S | `F ] t) Hashtbl.t + ; manas : ([ `F ] t, int) Hashtbl.t + } + +let init_tbl () = + { count = 0 + ; positions = Hashtbl.create 42 + ; positions' = Hashtbl.create 42 + ; manas = Hashtbl.create 42 + } + +let pp fmt tbl entity = + let pos = Hashtbl.find tbl.positions entity in + match entity with + | Sheep id -> Format.fprintf fmt "Sheep %d: %a" id Map.pp_position pos + | Fairy id as fairy -> + let mana = Hashtbl.find tbl.manas fairy in + Format.fprintf fmt "Fairy %d : mana = %d, %a" id mana Map.pp_position pos + +let make_sheep tbl ~x ~y = + let entity = Sheep tbl.count in + tbl.count <- tbl.count + 1; + let pos = + Map.{ x; y; offset_x = 0.; offset_y = 0.; dir = Obj.magic (x * y mod 4) } + in + (* todo unsafe position could be taken already *) + Hashtbl.replace tbl.positions entity pos; + Hashtbl.replace tbl.positions' (pos.x, pos.y) entity; + entity + +let make_fairy tbl ~x ~y = + let entity = Fairy tbl.count in + tbl.count <- tbl.count + 1; + let pos = Map.{ x; y; offset_x = 0.; offset_y = 0.; dir = Down } in + (* todo unsafe position could be taken already *) + Hashtbl.replace tbl.positions entity pos; + Hashtbl.replace tbl.positions' (pos.x, pos.y) entity; + Hashtbl.replace tbl.manas entity 1; + entity + +let get_pos tbl e = Hashtbl.find tbl.positions e + +let set_pos tbl id pos = + let old_pos = Hashtbl.find tbl.positions id in + Hashtbl.remove tbl.positions' (old_pos.x, old_pos.y); + Hashtbl.replace tbl.positions id pos; + Hashtbl.replace tbl.positions' (pos.x, pos.y) id + +let set_offset tbl id (offset_x, offset_y) = + let old_pos = Hashtbl.find tbl.positions id in + let pos = { old_pos with offset_x; offset_y } in + Hashtbl.replace tbl.positions id pos + +let move tbl map id dir = + match Hashtbl.find_opt tbl.positions id with + | None -> Error "bad entity type, can not move" + | Some old_pos -> ( + (* check if valid terrain to move to *) + match Map.check_move map old_pos dir with + | Error _e as error -> error + | Ok pos -> ( + (* check if no entity already on it *) + match Hashtbl.find_opt tbl.positions' (pos.x, pos.y) with + | Some other_entity -> + let pp fmt = pp fmt tbl in + Error + (Format.asprintf "can't move here: %a, place taken by %a" + Map.pp_position pos pp other_entity ) + | None -> + set_pos tbl id pos; + Ok pos ) ) + +let get_mana tbl id = Hashtbl.find tbl.manas id + +let set_mana tbl id n = Hashtbl.replace tbl.manas id n + +(* todo better name *) +let get_entity tbl ~x ~y = Hashtbl.find_opt tbl.positions' (x, y) + +let id = function Sheep id | Fairy id -> id diff --git a/src/island_client.ml b/src/island_client.ml index e5d3593..c34c1ff 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -67,17 +67,21 @@ let draw_canvas = fun state -> let open State in (* TODO: it could be possible to optimize starting/ending index by looking at the offset *) + (* TODO huuuu coercion *) + let (Fairy player) = state.player in + let player = Entity.Fairy player in + let player_pos = Entity.get_pos state.tbl player in for x = -2 to tiles_per_w + 1 do - let map_x = x + state.player.pos.x - half_tiles_per_w in + let map_x = x + player_pos.x - half_tiles_per_w in let tile_x = float_of_int ((x * tile_size) + orig_x) - +. offset_conv state.player.pos.offset_x + +. offset_conv player_pos.offset_x in for y = -2 to tiles_per_h + 1 do - let map_y = y + state.player.pos.y - half_tiles_per_h in + let map_y = y + player_pos.y - half_tiles_per_h in let tile_y = float_of_int ((y * tile_size) + orig_y) - +. offset_conv state.player.pos.offset_y + +. offset_conv player_pos.offset_y in let tile_img = match Map.get_tile_kind ~x:map_x ~y:map_y state.map with @@ -87,17 +91,20 @@ let draw_canvas = | Wheat -> wheat in C2d.draw_image context tile_img ~x:tile_x ~y:tile_y; - (* TODO *) - Herd.iter - (fun _v k -> - let pos = Animal.pos k in - if pos.x = map_x && pos.y = map_y then - C2d.draw_image context sheep ~x:tile_x ~y:tile_y ) - state.animals + begin + match Entity.get_entity state.tbl ~x:map_x ~y:map_y with + | None -> () + | Some e -> + if e <> player then + let tile_img = + match e with Sheep _ -> sheep | Fairy _ -> papy_up + in + C2d.draw_image context tile_img ~x:tile_x ~y:tile_y + end done done; let papy = - match state.player.pos.dir with + match player_pos.dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -108,8 +115,8 @@ let draw_canvas = 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.player.mana); + let mana = Entity.get_mana state.State.tbl state.State.player in + Jv.set mana_lvl "innerHTML" (Jv.of_string @@ string_of_int 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) @@ -132,8 +139,7 @@ let send_action state = function end *) (* actions we want to send to the server *) - | (State.Move_offset _ | Move _ | Animal_move _ | Meditate | Plant_wheat) 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 *) @@ -199,17 +205,20 @@ let keypress_handler = let key = Ev.Keyboard.key ev |> Jstr.to_string in if Hashtbl.mem keys key then f key -let apply_last_key () = +let apply_last_key state = let open State in Kb.get_last () |> Option.iter (fun code_or_key -> + (* TODO coercion huuuu *) + let (Fairy player) = state.player in + let player = Entity.Fairy player in let act = (* when you add something here, don't forget to add the corresponding case in `keypress_handler` *) match code_or_key with - | "KeyW" | "ArrowUp" -> Move_offset Up - | "KeyA" | "ArrowLeft" -> Move_offset Left - | "KeyS" | "ArrowDown" -> Move_offset Down - | "KeyD" | "ArrowRight" -> Move_offset Right + | "KeyW" | "ArrowUp" -> Move_offset (player, Up) + | "KeyA" | "ArrowLeft" -> Move_offset (player, Left) + | "KeyS" | "ArrowDown" -> Move_offset (player, Down) + | "KeyD" | "ArrowRight" -> Move_offset (player, Right) | "m" -> Meditate | "p" -> Plant_wheat | _ -> @@ -234,10 +243,10 @@ let rec game_loop state last_auto_update timestamp = let last_auto_update = if should_auto_update then timestamp else last_auto_update in - apply_last_key (); + apply_last_key state; let state = (* apply queue of actions *) - let state = Queue.fold State.perform_action state to_apply_queue in + Queue.iter (State.perform_action state) to_apply_queue; Queue.clear to_apply_queue; (* send input action to server *) Queue.iter (send_action state) input_queue; diff --git a/src/map.ml b/src/map.ml index 492cc97..197e246 100644 --- a/src/map.ml +++ b/src/map.ml @@ -30,12 +30,6 @@ let pp_background fmt b = in Format.pp_print_string fmt s -type simple_position = - { x : int - ; y : int - ; dir : dir - } - type position = { x : int ; y : int diff --git a/src/state.ml b/src/state.ml index ea3913b..bfb4012 100644 --- a/src/state.ml +++ b/src/state.ml @@ -37,97 +37,87 @@ end = struct else (x, y', None) end -module Herd = Animal.Herd - type t = { map : Map.t ; wheat : int - ; player : Animal.fairy - ; animals : Herd.t + ; player : [ `F ] Entity.t + ; tbl : Entity.tbl } let init () = let map = Map.init () in - { map - ; wheat = 0 - ; player = Animal.make_fairy ~x:0 ~y:0 - ; animals = Herd.init map - } + let tbl = Entity.init_tbl () in + for _i = 0 to 50 do + let _id = + Entity.make_sheep tbl ~x:(Random.int map.width) ~y:(Random.int map.height) + in + () + done; + { map; wheat = 0; player = Entity.make_fairy ~x:0 ~y:0 tbl; tbl } type action = | Meditate (* TODO some action do not needs to be checked by server *) - | Move_offset of Map.dir - | Move of Map.dir - | Animal_move of int * Map.dir + | Move_offset of ([ `S | `F ] Entity.t * Map.dir) + | Move of ([ `S | `F ] Entity.t * 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_animal_position of (int * Map.position) - | Set_offset of float * float - | Plant_wheat of int * int + | Add_mana of ([ `F ] Entity.t * int) + | Set_position of ([ `S | `F ] Entity.t * Map.position) + | Set_offset of ([ `S | `F ] Entity.t * (float * float)) + | Spawn_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 - | Animal_move (id, dir) -> - Format.fprintf fmt "Animal_move %d %a" id Map.pp_dir dir + | Move_offset (e, dir) -> + Format.fprintf fmt "Move_offset (%d,%a)" (Entity.id e) Map.pp_dir dir + | Move (e, dir) -> + Format.fprintf fmt "Move (%d,%a)" (Entity.id e) 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_animal_position (id, pos) -> - Format.fprintf fmt "Set_animal_position (%d,%a)" id 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 + | Add_mana (Fairy id, n) -> Format.fprintf fmt "Add_mana (%d,%d)" id n + | Set_position (e, pos) -> + Format.fprintf fmt "Set_position (%d,%a)" (Entity.id e) Map.pp_position pos + | Set_offset (e, (x, y)) -> + Format.fprintf fmt "Set_offset (%d,(%f, %f))" (Entity.id e) x y + | Spawn_wheat (x, y) -> Format.fprintf fmt "Plant_wheat (%d, %d)" x y let plant_wheat_cost = 10 let rec check_action state = function | Meditate -> - if state.player.mana < 99 then Ok [ Add_mana 1 ] else Error "maximum mana" - | Move dir -> ( - match Map.check_move state.map state.player.pos dir with + if Entity.get_mana state.tbl state.player < 99 then + Ok [ Add_mana (state.player, 1) ] + else Error "maximum mana" + | Move (e, dir) -> ( + match Entity.move state.tbl state.map e dir with | Error _e as error -> error - | Ok pos -> Ok [ Set_player_position pos ] ) - | Animal_move (id, dir) -> ( - match Herd.find_opt id state.animals with - | None -> Error (Format.sprintf "unknown animal id: %d" id) - | Some animal -> ( - match Map.check_move state.map (Animal.pos animal) dir with - | Error _e as error -> error - | Ok pos -> Ok [ Set_animal_position (id, pos) ] ) ) - | Move_offset dir -> - if dir <> state.player.pos.dir then - Ok [ Set_player_position { state.player.pos with dir } ] + | Ok pos -> Ok [ Set_position (e, pos) ] ) + | Move_offset (e, dir) -> + let pos = Entity.get_pos state.tbl e in + if dir <> pos.dir then Ok [ Set_position (e, { pos with dir }) ] else let offset_x, offset_y, dir' = - Offset.check_move ~x:state.player.pos.offset_x - ~y:state.player.pos.offset_y dir - in - let offset_action = - [ Set_player_position { state.player.pos with dir } - ; Set_offset (offset_x, offset_y) - ] + Offset.check_move ~x:pos.offset_x ~y:pos.offset_y dir in + let offset_action = [ Set_offset (e, (offset_x, offset_y)) ] in begin match dir' with | None -> Ok offset_action | Some dir' -> begin - match check_action state (Move dir') with + match check_action state (Move (e, dir')) with | Error _e as e -> e | Ok actions -> Ok (offset_action @ actions) end end | Plant_wheat -> ( - let { Map.x; y; dir; _ } = state.player.pos in + (* TODO huuuuuuuuuuuuuu coercion jpp *) + let (Fairy player) = state.player in + let { Map.x; y; dir; _ } = Entity.get_pos state.tbl (Fairy player) in let x, y = match dir with | Down -> (x, y + 1) @@ -140,41 +130,38 @@ let rec check_action state = function | Water -> Error "can't plant wheat in water !" | Wheat -> Error "there's already some wheat there !" | Grass -> - if state.player.mana >= plant_wheat_cost then Ok [ Plant_wheat (x, y) ] + if Entity.get_mana state.tbl state.player >= plant_wheat_cost then + Ok [ Spawn_wheat (x, y); Add_mana (state.player, -plant_wheat_cost) ] else Error "not enough mana..." ) +(* TODO imutable state? *) let perform_action state = function - | Add_mana n -> - { state with player = { state.player with mana = state.player.mana + n } } - | Set_player_position pos -> { state with player = { state.player with pos } } - | Set_animal_position (id, pos) -> - { state with - animals = Herd.update id (Option.map (Animal.set_pos pos)) state.animals - } - | Set_offset (offset_x, offset_y) -> - { state with - player = - { state.player with pos = { state.player.pos with offset_x; offset_y } } - } - | Plant_wheat (x, y) -> - state.map.tiles.(x).(y) <- Map.Wheat; - { state with - player = { state.player with mana = state.player.mana - plant_wheat_cost } - } + | Add_mana (e, n) -> + let old_mana = Entity.get_mana state.tbl e in + Entity.set_mana state.tbl e (old_mana + n) + | Set_position (e, pos) -> Entity.set_pos state.tbl e pos + | Set_offset (e, offset) -> Entity.set_offset state.tbl e offset + | Spawn_wheat (x, y) -> state.map.tiles.(x).(y) <- Map.Wheat let auto_update state = - let state = + (* mut state *) + begin match check_action state Meditate with - | Error _e -> state - | Ok actions -> List.fold_left perform_action state actions - in + | Error _e -> () + | Ok actions -> List.iter (perform_action state) actions + end; let count_wheat = Map.count_wheat state.map.tiles in (* TODO simulate animals *) { state with wheat = state.wheat + count_wheat } let auto_update_rate = Time.mk_s 1 -let pp fmt { wheat; player; map; animals } = - let bg = Map.get_tile_kind ~x:player.pos.x ~y:player.pos.y map in - Format.fprintf fmt "wheat = %d; player = %a; %a; animals = %a" wheat Animal.pp - (Fairy player) Map.pp_background bg Herd.pp animals +let pp fmt { wheat; player; map; tbl } = + (* TODO coercion huuuu *) + let (Fairy player) = player in + let player = Entity.Fairy player in + let pos = Entity.get_pos tbl player in + let bg = Map.get_tile_kind ~x:pos.x ~y:pos.y map in + Format.fprintf fmt "wheat = %d; player = %a; %a; tbl = TODO" wheat + (fun fmt player -> Entity.pp fmt tbl player) + player Map.pp_background bg diff --git a/src/ws.ml b/src/ws.ml index 3d832f8..131c059 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -40,7 +40,7 @@ let handle_client request client = ~pp_sep:(fun fmt () -> Format.fprintf fmt " ; ") State.pp_action' ) action'; - let state = List.fold_left State.perform_action state action' in + List.iter (State.perform_action state) action'; User.set_state user_id state; Ok action' in