entity

src/animal.ml

@@ -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

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

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

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 *)
+        begin
-        Herd.iter
+          match Entity.get_entity state.tbl ~x:map_x ~y:map_y with
-          (fun _v k ->
+          | None -> ()
-            let pos = Animal.pos k in
+          | Some e ->
-            if pos.x = map_x && pos.y = map_y then
+            if e <> player then
-              C2d.draw_image context sheep ~x:tile_x ~y:tile_y )
+              let tile_img =
-          state.animals
+                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"
+  let mana = Entity.get_mana state.State.tbl state.State.player in
-    (Jv.of_string @@ string_of_int state.Shared.State.player.mana);
+  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
+  | (State.Move_offset _ | Move _ | Meditate | Plant_wheat) as action -> (
-    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
+           | "KeyW" | "ArrowUp" -> Move_offset (player, Up)
-           | "KeyA" | "ArrowLeft" -> Move_offset Left
+           | "KeyA" | "ArrowLeft" -> Move_offset (player, Left)
-           | "KeyS" | "ArrowDown" -> Move_offset Down
+           | "KeyS" | "ArrowDown" -> Move_offset (player, Down)
-           | "KeyD" | "ArrowRight" -> Move_offset Right
+           | "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;

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

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
+  ; player : [ `F ] Entity.t
-  ; animals : Herd.t
+  ; tbl : Entity.tbl
   }
 
 let init () =
   let map = Map.init () in
-  { map
+  let tbl = Entity.init_tbl () in
-  ; wheat = 0
+  for _i = 0 to 50 do
-  ; player = Animal.make_fairy ~x:0 ~y:0
+    let _id =
-  ; animals = Herd.init map
+      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_offset of ([ `S | `F ] Entity.t * Map.dir)
-  | Move of Map.dir
+  | Move of ([ `S | `F ] Entity.t * Map.dir)
-  | Animal_move of int * 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
+  | Add_mana of ([ `F ] Entity.t * int)
-  | Set_player_position of Map.position
+  | Set_position of ([ `S | `F ] Entity.t * Map.position)
-  | Set_animal_position of (int * Map.position)
+  | Set_offset of ([ `S | `F ] Entity.t * (float * float))
-  | Set_offset of float * float
+  | Spawn_wheat of int * int
-  | 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_offset (e, dir) ->
-  | Move dir -> Format.fprintf fmt "Move %a" Map.pp_dir dir
+    Format.fprintf fmt "Move_offset (%d,%a)" (Entity.id e) Map.pp_dir dir
-  | Animal_move (id, dir) ->
+  | Move (e, dir) ->
-    Format.fprintf fmt "Animal_move %d %a" id Map.pp_dir 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
+  | Add_mana (Fairy id, n) -> Format.fprintf fmt "Add_mana (%d,%d)" id n
-  | Set_player_position pos ->
+  | Set_position (e, pos) ->
-    Format.fprintf fmt "Set_player_position (%a)" Map.pp_position pos
+    Format.fprintf fmt "Set_position (%d,%a)" (Entity.id e) Map.pp_position pos
-  | Set_animal_position (id, pos) ->
+  | Set_offset (e, (x, y)) ->
-    Format.fprintf fmt "Set_animal_position (%d,%a)" id Map.pp_position pos
+    Format.fprintf fmt "Set_offset (%d,(%f, %f))" (Entity.id e) x y
-  | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y
+  | Spawn_wheat (x, y) -> Format.fprintf fmt "Plant_wheat (%d, %d)" 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 ->
-    if state.player.mana < 99 then Ok [ Add_mana 1 ] else Error "maximum mana"
+    if Entity.get_mana state.tbl state.player < 99 then
-  | Move dir -> (
+      Ok [ Add_mana (state.player, 1) ]
-    match Map.check_move state.map state.player.pos dir with
+    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 ] )
+    | Ok pos -> Ok [ Set_position (e, pos) ] )
-  | Animal_move (id, dir) -> (
+  | Move_offset (e, dir) ->
-    match Herd.find_opt id state.animals with
+    let pos = Entity.get_pos state.tbl e in
-    | None -> Error (Format.sprintf "unknown animal id: %d" id)
+    if dir <> pos.dir then Ok [ Set_position (e, { pos with dir }) ]
-    | 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 } ]
     else
       let offset_x, offset_y, dir' =
-        Offset.check_move ~x:state.player.pos.offset_x
+        Offset.check_move ~x:pos.offset_x ~y:pos.offset_y dir
-          ~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)
-        ]
       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 ->
+  | Add_mana (e, n) ->
-    { state with player = { state.player with mana = state.player.mana + n } }
+    let old_mana = Entity.get_mana state.tbl e in
-  | Set_player_position pos -> { state with player = { state.player with pos } }
+    Entity.set_mana state.tbl e (old_mana + n)
-  | Set_animal_position (id, pos) ->
+  | Set_position (e, pos) -> Entity.set_pos state.tbl e pos
-    { state with
+  | Set_offset (e, offset) -> Entity.set_offset state.tbl e offset
-      animals = Herd.update id (Option.map (Animal.set_pos pos)) state.animals
+  | Spawn_wheat (x, y) -> state.map.tiles.(x).(y) <- Map.Wheat
-    }
-  | 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 }
-    }
 
 let auto_update state =
-  let state =
+  (* mut state *)
+  begin
     match check_action state Meditate with
-    | Error _e -> state
+    | Error _e -> ()
-    | Ok actions -> List.fold_left perform_action state actions
+    | Ok actions -> List.iter (perform_action state) actions
-  in
+  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 pp fmt { wheat; player; map; tbl } =
-  let bg = Map.get_tile_kind ~x:player.pos.x ~y:player.pos.y map in
+  (* TODO coercion huuuu *)
-  Format.fprintf fmt "wheat = %d; player = %a; %a; animals = %a" wheat Animal.pp
+  let (Fairy player) = player in
-    (Fairy player) Map.pp_background bg Herd.pp animals
+  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

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