diff --git a/src/component.ml b/src/component.ml new file mode 100644 index 0000000..9fabe45 --- /dev/null +++ b/src/component.ml @@ -0,0 +1,16 @@ +type dir = + | Left + | Right + | Down + | Up + +type mana = int + +type position = int * int * dir + +type image = Entity.archetype + +type t = + | Image of image + | Position of position + | Mana of mana diff --git a/src/dune b/src/dune index 47f5316..606eea6 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,7 @@ (library (name shared) - (modules entity map network state) + (modules component entity map network state) (libraries uuidm)) (rule diff --git a/src/entity.ml b/src/entity.ml index 6440157..b13cf05 100644 --- a/src/entity.ml +++ b/src/entity.ml @@ -1,24 +1,13 @@ -type kind = +type archetype = | Papy | Tree0 | Tree1 | Wheat -type dir = - | Left - | Right - | Down - | Up +(* + TODO +type 'archetype t = Uuidm.t +*) -type position = int * int * dir - -type t = - { kind : kind - ; id : Uuidm.t - ; position : position - ; mana : int - } - -let set_pos v e = { e with position = v } - -let set_mana v e = { e with mana = v } +(* TODO just use int ?*) +type t = Uuidm.t diff --git a/src/island_client.ml b/src/island_client.ml index 26e2100..f41e367 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -57,25 +57,6 @@ let tree1 = C2d.image_src_of_el (get_el "tree1") let wheat = C2d.image_src_of_el (get_el "wheat") -(* TODO FIX *) -let draw_entity context entity = - let e_x, e_y, e_dir = entity.Entity.position in - let tile_x = float_of_int ((e_x * tile_size) + orig_x) in - let tile_y = float_of_int ((e_y * tile_size) + orig_y) in - let img = - match entity.kind with - | Papy -> ( - match e_dir with - | Left -> papy_left - | Right -> papy_right - | Down -> papy_down - | Up -> papy_up ) - | Tree0 -> tree0 - | Tree1 -> tree1 - | Wheat -> wheat - in - C2d.draw_image context img ~x:tile_x ~y:tile_y - let draw = 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 diff --git a/src/map.ml b/src/map.ml index 8bcfde3..a7861a9 100644 --- a/src/map.ml +++ b/src/map.ml @@ -1,11 +1,3 @@ -type dir = Entity.dir = - | Left - | Right - | Down - | Up - -type position = int * int * dir - type background = | Grass | Water @@ -29,3 +21,6 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black + +let is_walkable ~x ~y map = + match get_tile_kind ~x ~y map with Water | Black -> false | Grass -> true diff --git a/src/state.ml b/src/state.ml index 9c978af..d197e88 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,83 +1,104 @@ -type t = - { map : Map.t - ; papy : Entity.t - ; entities : Entity.t list - } - let random_state = Random.State.make_self_init () +type t = + { map : Map.t + ; mana_component : (Entity.t, Component.mana) Hashtbl.t + ; position_component : (Entity.t, Component.position) Hashtbl.t + ; image_component : (Entity.t, Component.image) Hashtbl.t + ; papy : Entity.t + } + +let add_component state entity components = + match components with + | Component.Image image -> Hashtbl.replace state.image_component entity image + | Position position -> + Hashtbl.replace state.position_component entity position + | Mana mana -> Hashtbl.replace state.mana_component entity mana + +let make_entity state components = + let entity = Uuidm.v4_gen random_state () in + List.iter (add_component state entity) components; + entity + let init () = - let map = Map.init () in - let papy = - Entity. - { kind = Papy - ; id = Uuidm.v4_gen random_state () - ; position = (20, 3, Down) - ; mana = 0 - } + let state = + { map = Map.init () + ; mana_component = Hashtbl.create 1 + ; position_component = Hashtbl.create 1 + ; image_component = Hashtbl.create 1 + ; papy = Uuidm.v4_gen random_state () + } in + (* finish papy *) + List.iter + (add_component state state.papy) + Component.[ Position (20, 3, Down); Mana 13; Image Entity.Papy ]; (* add trees *) let tree_kind = if Random.bool () then Entity.Tree0 else Entity.Tree1 in - let entities = - let n = 5 * (map.width * map.height / 100) in - let ws = List.init n (fun _i -> Random.int map.width) in - let hs = List.init n (fun _i -> Random.int map.height) in - List.combine ws hs - |> List.filter (fun (x, y) -> - match Map.get_tile_kind ~x ~y map with - | Water | Black -> false - | Grass -> true ) + let n = 5 * (state.map.width * state.map.height / 100) in + let xs = List.init n (fun _i -> Random.int state.map.width) in + let ys = List.init n (fun _i -> Random.int state.map.height) in + let _entities : Entity.t list = + List.combine xs ys + |> List.filter (fun (x, y) -> Map.is_walkable ~x ~y state.map) |> List.map (fun (x, y) -> - Entity. - { kind = tree_kind - ; id = Uuidm.v4_gen random_state () - ; position = (x, y, Up) - ; mana = 0 - } ) + make_entity state + Component.[ Position (x, y, Up); Mana 0; Image tree_kind ] ) in - { map; papy; entities } + state type action = | Meditate (* TODO some action do not needs to be checked by server *) - | Move of Map.dir + | Move of Component.dir (* type for result of action send to the client by the server *) type action' = - | Add_mana of int - | Set_player_position of Map.position + | Add_mana of Entity.t * int + | Set_player_position of Component.position let check_papy_move state dir = - let x, y, current_dir = state.papy.position in - let x, y = - if current_dir <> dir then (x, y) + match Hashtbl.find_opt state.position_component state.papy with + | None -> failwith "couldn't find position component for papy" + | Some (x, y, current_dir) -> + if current_dir <> dir then Ok (x, y, dir) else - match dir with - | Map.Left -> (x - 1, y) - | Right -> (x + 1, y) - | Down -> (x, y + 1) - | Up -> (x, y - 1) - in - match Map.get_tile_kind ~x ~y state.map with - | Black | Water -> Error "invalid terrain" - | Grass -> - if - List.exists - (fun e -> e.Entity.position = state.papy.position) - state.entities - then Error "invalid move, space is occupied" - else Ok (x, y, dir) + let x, y = + match dir with + | Left -> (x - 1, y) + | Right -> (x + 1, y) + | Down -> (x, y + 1) + | Up -> (x, y - 1) + in + if not (Map.is_walkable ~x ~y state.map) then Error "invalid terrain" + else if + (* TODO map should know which entity are on which tile *) + Seq.exists + (fun (i, j, _d) -> i = x && j = y) + (Hashtbl.to_seq_values state.position_component) + then Error "invalid move, space is occupied" + else Ok (x, y, dir) let check_action state = function | Meditate -> - if state.papy.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" + let mana = + match Hashtbl.find_opt state.mana_component state.papy with + | None -> failwith "no mana component for papy" + | Some mana -> mana + in + if mana < 99 then Ok (Add_mana (state.papy, 1)) else Error "maximum mana" | Move dir -> ( match check_papy_move state dir with | Error _e as error -> error | Ok pos -> Ok (Set_player_position pos) ) let perform_action state = function - | Add_mana n -> - { state with papy = Entity.set_mana (state.papy.mana + n) state.papy } + | Add_mana (entity, n) -> + let mana = + match Hashtbl.find_opt state.mana_component state.papy with + | None -> failwith "no mana component for entity" + | Some mana -> mana + in + Hashtbl.replace state.mana_component entity (mana + n) | Set_player_position pos -> - { state with papy = Entity.set_pos pos state.papy } + Hashtbl.replace state.position_component state.papy pos