wip: ecs hashtbl; bad

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

src/dune

@@ -45,7 +45,7 @@
 
 (library
  (name shared)
- (modules entity map network state)
+ (modules component entity map network state)
  (libraries uuidm))
 
 (rule

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

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

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

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