From 79df19a5fdd110da378cadf955ff376a33907760 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 28 Dec 2022 01:45:16 +0100 Subject: [PATCH] wip entity --- src/dune | 4 +-- src/entity.ml | 24 ++++++++++++++++ src/island.ml | 11 ++++++- src/island_client.ml | 31 ++++++++++++++++++-- src/map.ml | 21 ++------------ src/state.ml | 68 +++++++++++++++++++++++++++++++++++++++----- 6 files changed, 129 insertions(+), 30 deletions(-) create mode 100644 src/entity.ml diff --git a/src/dune b/src/dune index c5a5f3a..47f5316 100644 --- a/src/dune +++ b/src/dune @@ -45,8 +45,8 @@ (library (name shared) - (modules map network state) - (libraries)) + (modules entity map network state) + (libraries uuidm)) (rule (target content.ml) diff --git a/src/entity.ml b/src/entity.ml new file mode 100644 index 0000000..6440157 --- /dev/null +++ b/src/entity.ml @@ -0,0 +1,24 @@ +type kind = + | Papy + | Tree0 + | Tree1 + | Wheat + +type dir = + | Left + | Right + | Down + | Up + +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 } diff --git a/src/island.ml b/src/island.ml index eab4678..ea23444 100644 --- a/src/island.ml +++ b/src/island.ml @@ -18,7 +18,16 @@ let get request = in let images = List.map mk_img - [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + [ "grass" + ; "papy_left" + ; "papy_right" + ; "papy_down" + ; "papy_up" + ; "water" + ; "tree0" + ; "tree1" + ; "wheat" + ] in let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in diff --git a/src/island_client.ml b/src/island_client.ml index b5f0dce..26e2100 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,12 +51,37 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") +let tree0 = C2d.image_src_of_el (get_el "tree0") + +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 fun state -> let open State in - let player_x, player_y, player_dir = state.player_pos in + let player_x, player_y, player_dir = state.papy.position in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -79,7 +104,9 @@ let draw = | Down -> papy_down | Up -> papy_up in - C2d.draw_image context papy ~x:papy_x ~y:papy_y + C2d.draw_image context papy ~x:papy_x ~y:papy_y; + (*draw_entity context state.papy;*) + List.iter (draw_entity context) state.entities (* queue for action to be done *) let input_queue = ref [] diff --git a/src/map.ml b/src/map.ml index 4860914..8bcfde3 100644 --- a/src/map.ml +++ b/src/map.ml @@ -1,16 +1,16 @@ -type dir = +type dir = Entity.dir = | Left | Right | Down | Up +type position = int * int * dir + type background = | Grass | Water | Black -type position = int * int * dir - type t = { tiles : background array array ; width : int @@ -29,18 +29,3 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black - -let check_move map entity_pos dir = - let x, y, current_dir = entity_pos in - let x, y = - if current_dir <> dir then (x, y) - else - match dir with - | Left -> (x - 1, y) - | Right -> (x + 1, y) - | Down -> (x, y + 1) - | Up -> (x, y - 1) - in - match get_tile_kind ~x ~y map with - | Black | Water -> Error "invalid terrain" - | Grass -> Ok (x, y, dir) diff --git a/src/state.ml b/src/state.ml index 4f05ee6..9c978af 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,10 +1,41 @@ type t = { map : Map.t - ; mana : int - ; player_pos : Map.position + ; papy : Entity.t + ; entities : Entity.t list } -let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } +let random_state = Random.State.make_self_init () + +let init () = + let map = Map.init () in + let papy = + Entity. + { kind = Papy + ; id = Uuidm.v4_gen random_state () + ; position = (20, 3, Down) + ; mana = 0 + } + in + (* 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 ) + |> List.map (fun (x, y) -> + Entity. + { kind = tree_kind + ; id = Uuidm.v4_gen random_state () + ; position = (x, y, Up) + ; mana = 0 + } ) + in + { map; papy; entities } type action = | Meditate @@ -16,14 +47,37 @@ type action' = | Add_mana of int | Set_player_position of Map.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) + 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 check_action state = function | Meditate -> - if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" + if state.papy.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" | Move dir -> ( - match Map.check_move state.map state.player_pos dir with + 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 mana = state.mana + n } - | Set_player_position pos -> { state with player_pos = pos } + | Add_mana n -> + { state with papy = Entity.set_mana (state.papy.mana + n) state.papy } + | Set_player_position pos -> + { state with papy = Entity.set_pos pos state.papy }