diff --git a/lib/Labyrinth/Game.hs b/lib/Labyrinth/Game.hs index 4c9862b..8597ab1 100644 --- a/lib/Labyrinth/Game.hs +++ b/lib/Labyrinth/Game.hs @@ -5,21 +5,15 @@ module Labyrinth.Game , PlayOrder(..) , Game(..) , Configuration + , Position ) where -import Lens.Micro.TH ( makeLenses ) import Labyrinth.Game.Position ( Position ) -import Labyrinth.Game.Board ( Board ) -import Labyrinth.Game.Cell ( TileCell - , GateCell - ) -import Labyrinth.Game.Treasure ( TreasureMap ) -import Data.Map.Strict ( Map ) import Labyrinth.Game.Player ( Player(..) , Players , Color(..) , PlayOrder(..) ) import Labyrinth.Game.Configuration ( Configuration ) -import Labyrinth.Game.Class ( Game(..) ) +import Labyrinth.Game.Class ( Game(..) ) diff --git a/lib/Labyrinth/Game/Cell.hs b/lib/Labyrinth/Game/Cell.hs index e50b445..1c4ecd3 100644 --- a/lib/Labyrinth/Game/Cell.hs +++ b/lib/Labyrinth/Game/Cell.hs @@ -3,7 +3,7 @@ module Labyrinth.Game.Cell , TileCell(..) , GateCell(..) , CellData(..) - , Terrain + , Terrain(..) , treasure , players , isOpen diff --git a/lib/Labyrinth/Game/NewGame.hs b/lib/Labyrinth/Game/NewGame.hs index 9300a91..b85bb03 100644 --- a/lib/Labyrinth/Game/NewGame.hs +++ b/lib/Labyrinth/Game/NewGame.hs @@ -1,46 +1,55 @@ module Labyrinth.Game.NewGame - ( NewGame - , newGame - , resolveUnassignedPositions - , resolveDirection + ( TileD + , HasTreasure + , availablePositions + , addPositions + , addPlayers + , chooseDirections + , addTreasures ) where - +import Control.Monad ( guard + , forM + ) +import Data.List ( partition ) import Data.Set ( Set ) import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Maybe ( fromJust , isJust ) - +import Lens.Micro ( _2 + , _3 + , _4 + , _5 + , (^.) + , (.~) + , (?~) + , (&) + ) +import qualified Data.Random as Random import Labyrinth.Game.Cell ( Terrain + , Cell + , TileCell , GateCell ) import Labyrinth.Game.Position ( Position ) import Labyrinth.Game.Treasure ( Treasure ) import qualified Labyrinth.Game.Direction as D import Labyrinth.Game.Direction ( Direction ) -import Labyrinth.Game.Player ( Players ) +import Labyrinth.Game.Player ( Players + , Player + , PlayOrder + ) import Labyrinth.Game.Class ( Game ) +import Labyrinth.Game.Board ( Board ) -type AddTreasure = Bool -type CellD = (Terrain, Maybe Position, Maybe Direction, AddTreasure, Players) -type ResolvedCellD = (Terrain, Position, Direction, Maybe Treasure, Players) -type GateD = (Position, GateCell) - -data NewGame = NewGame - { cells :: [CellD] - , gates :: [GateD] - , players :: Players - , rowCount :: Int - , colCount :: Int - , treasures :: [Treasure] - , extraTile :: Position - , positions :: Set Position - } deriving (Show) +type HasTreasure = Bool +type TileD a b = (Terrain, Maybe Position, Maybe Direction, a, Maybe b) newGame - :: [CellD] - -> [GateD] + :: [TileD HasTreasure PlayOrder] + -> Board GateCell -> Players -> Int -> Int @@ -48,14 +57,45 @@ newGame -> Position -> Set Position -> IO (Maybe Game) -newGame cells gates players rowCount colCount treasures extraTile positions = - undefined +newGame cells gates players rows cols treasures extraT positions = do + let mPos = Set.fromList $ map (^. _2) cells + aPosList = availablePositions positions mPos + shufPos <- Random.shuffle aPosList + shufTre <- Random.shuffle treasures + return Nothing + +availablePositions :: Set Position -> Set (Maybe Position) -> [Position] +availablePositions p mp = + Set.toList $ Set.map fromJust $ Set.difference (Set.map Just p) mp + +addPlayers :: Players -> [TileD a PlayOrder] -> Maybe [TileD a Player] +addPlayers ps ts = do + guard (sameLength && uniqOrders) + Just [] + where + (withP, noP) = partition (isJust . (^. _5)) ts + sameLength = length withP == Map.size ps + uniqOrders = length withP == (Set.size $ Set.fromList orders) + orders = map (fromJust . (^. _5)) withP + +addPositions :: [Position] -> [TileD a b] -> Maybe [TileD a b] +addPositions ps ts = do + guard (length ps == length needsP) + Just $ hasP <> zipWith (_2 ?~) ps needsP + where (hasP, needsP) = partition (isJust . (^. _2)) ts + +chooseDirections :: [TileD a b] -> IO [TileD a b] +chooseDirections ts = forM ts $ \t -> do + d <- chooseDirection (t ^. _3) + return $ t & _3 ?~ d -resolveUnassignedPositions - :: Set Position -> Set (Maybe Position) -> Set Position -resolveUnassignedPositions p mp = - Set.map fromJust $ Set.difference (Set.map Just p) mp +addTreasures + :: [Treasure] -> [TileD HasTreasure b] -> Maybe [TileD (Maybe Treasure) b] +addTreasures trs tls = do + guard (length withT == length trs) + Just $ map (_4 .~ Nothing) noT <> zipWith (_4 ?~) trs withT + where (withT, noT) = partition (^. _4) tls -resolveDirection :: Maybe Direction -> IO Direction -resolveDirection md | isJust md = return $ fromJust md - | otherwise = D.random +chooseDirection :: Maybe Direction -> IO Direction +chooseDirection md | isJust md = return $ fromJust md + | otherwise = D.random diff --git a/lib/Labyrinth/Game/Player.hs b/lib/Labyrinth/Game/Player.hs index 10e5a92..91fa010 100644 --- a/lib/Labyrinth/Game/Player.hs +++ b/lib/Labyrinth/Game/Player.hs @@ -1,4 +1,4 @@ -module Labyrinth.Game.Player + module Labyrinth.Game.Player ( Player(..) , Color(..) , PlayOrder(..) @@ -9,10 +9,12 @@ module Labyrinth.Game.Player , colors , count , toList + , fromList ) where import Lens.Micro.TH ( makeLenses ) +import Lens.Micro ( (^.) ) import qualified Data.Map.Strict as Map import Data.Map.Strict ( Map ) import Data.Text ( Text ) @@ -36,3 +38,6 @@ count = Map.size toList :: Players -> [Player] toList = map snd . Map.toList + +fromList :: [Player] -> Players +fromList = Map.fromList . map (\p -> (p ^. order, p)) diff --git a/lib/Labyrinth/Game/Treasure.hs b/lib/Labyrinth/Game/Treasure.hs index beb5f46..b3297b4 100644 --- a/lib/Labyrinth/Game/Treasure.hs +++ b/lib/Labyrinth/Game/Treasure.hs @@ -15,7 +15,6 @@ import qualified Data.Set as Set import Data.Set ( Set ) import Lens.Micro.TH ( makeLenses ) import Lens.Micro ( (^.) ) -import qualified Data.Random as Random data Treasure = TA | TB | TC | TD | TE | TF | TG | TH | TI | TJ | TK | TL diff --git a/test/Game/NewGameSpec.hs b/test/Game/NewGameSpec.hs index cf8add0..17e5701 100644 --- a/test/Game/NewGameSpec.hs +++ b/test/Game/NewGameSpec.hs @@ -3,37 +3,181 @@ import Test.Hspec import qualified Data.Set as Set import Data.Set ( Set ) +import Data.Maybe ( isJust ) +import Lens.Micro ( _3 + , (^.) + ) import Linear.V2 ( V2(..) ) +import Labyrinth.Game ( Player(..) + , Players + , PlayOrder(..) + , Color(..) + ) +import qualified Labyrinth.Game.Player as P import Labyrinth.Game.Position ( Position ) -import qualified Labyrinth.Game.NewGame as NG - +import Labyrinth.Game.Treasure ( Treasure(..) ) +import Labyrinth.Game.Direction ( Direction(..) ) +import Labyrinth.Game.Cell ( Terrain(..) ) +import Labyrinth.Game.NewGame ( TileD + , HasTreasure + , availablePositions + , addPositions + , addTreasures + , addPlayers + , chooseDirections + ) spec :: Spec spec = describe "NewGame" $ do - let positions = - Set.fromList - [ V2 0 0 - , V2 0 1 - , V2 0 2 - , V2 1 0 - , V2 1 1 - , V2 1 2 - , V2 2 0 - , V2 2 1 - , V2 2 2 - ] :: Set Position - posDescriptions = - Set.fromList - [ Just $ V2 0 0 - , Just $ V2 0 1 - , Just $ V2 0 2 - , Nothing - , Nothing - , Nothing - , Just $ V2 2 0 - , Just $ V2 2 1 - , Just $ V2 2 2 - ] :: Set (Maybe Position) - it "Missing possitions should be unassigned" $ do - let actual = NG.resolveUnassignedPositions positions posDescriptions - actual `shouldBe` Set.fromList [V2 1 0, V2 1 1, V2 1 2] + context "availablePositions" $ do + let positions = + Set.fromList + [ V2 0 0 + , V2 0 1 + , V2 0 2 + , V2 1 0 + , V2 1 1 + , V2 1 2 + , V2 2 0 + , V2 2 1 + , V2 2 2 + ] :: Set Position + posDescriptions = + Set.fromList + [ Just $ V2 0 0 + , Just $ V2 0 1 + , Just $ V2 0 2 + , Nothing + , Nothing + , Nothing + , Just $ V2 2 0 + , Just $ V2 2 1 + , Just $ V2 2 2 + ] :: Set (Maybe Position) + + it "should be calculated from missing possitions" $ do + let actual = availablePositions positions posDescriptions + actual `shouldBe` [V2 1 0, V2 1 1, V2 1 2] + + context "addPositions" $ do + it "should assing missing positions" $ do + let pos = [V2 0 0] :: [Position] + tiles = + [ (Path, Nothing , Nothing, False, Nothing) + , (Path, Just (V2 0 1), Nothing, False, Nothing) + ] :: [TileD HasTreasure PlayOrder] + expected = + Just + [ (Path, Just (V2 0 1), Nothing, False, Nothing) + , (Path, Just (V2 0 0), Nothing, False, Nothing) + ] :: Maybe [TileD HasTreasure PlayOrder] + actual = addPositions pos tiles + + actual `shouldBe` expected + + it "should fail when there are less positions" $ do + let tiles = + [ (Path, Nothing , Nothing, False, Nothing) + , (Path, Just (V2 0 1), Nothing, False, Nothing) + ] :: [TileD HasTreasure PlayOrder] + actual = addPositions [] tiles + + actual `shouldBe` Nothing + + it "should fail when there are more positions" $ do + let pos = [V2 0 0, V2 1 0] :: [Position] + tiles = + [ (Path, Nothing , Nothing, False, Nothing) + , (Path, Just (V2 0 1), Nothing, False, Nothing) + ] :: [TileD HasTreasure PlayOrder] + actual = addPositions pos tiles + + actual `shouldBe` Nothing + + context "chooseDirections" + $ it "should choose random directions for missing directions" + $ do + let tiles = + [ (Path, Nothing , Just North, False, Nothing) + , (Path, Just (V2 0 1), Nothing , False, Nothing) + ] :: [TileD HasTreasure PlayOrder] + + actual <- chooseDirections tiles + all (isJust . (^. _3)) actual `shouldBe` True + + context "addTreasures" $ do + it "should add treasures" $ do + let treasures = [TA, TB] + tiles = + [ (Path, Nothing, Nothing, True , Nothing) + , (Path, Nothing, Nothing, False, Nothing) + , (Path, Nothing, Nothing, True , Nothing) + ] :: [TileD HasTreasure PlayOrder] + expected = + Just + [ (Path, Nothing, Nothing, Nothing, Nothing) + , (Path, Nothing, Nothing, Just TA, Nothing) + , (Path, Nothing, Nothing, Just TB, Nothing) + ] :: Maybe [TileD (Maybe Treasure) PlayOrder] + addTreasures treasures tiles `shouldBe` expected + + it "should fail if there are less treasures" $ do + let tiles = + [(Path, Nothing, Nothing, True, Nothing)] :: [ TileD + HasTreasure + PlayOrder + ] + addTreasures [] tiles `shouldBe` Nothing + + it "should fail if there are more treasures" $ do + let treasures = [TA, TB] + tiles = + [(Path, Nothing, Nothing, True, Nothing)] :: [ TileD + HasTreasure + PlayOrder + ] + addTreasures treasures tiles `shouldBe` Nothing + + context "sddPlayers" $ do + it "should fail if need to add more players than given" $ do + let players = P.fromList [Player "p1" Yellow First] + tiles = + [ (Path, Nothing, Nothing, False, Just First) + , (Path, Nothing, Nothing, False, Just Second) + ] :: [TileD HasTreasure PlayOrder] + addPlayers players tiles `shouldBe` Nothing + + it "should fail if need to add less players than given" $ do + let tiles = + [ (Path, Nothing, Nothing, False, Just First) + , (Path, Nothing, Nothing, False, Just Second) + ] :: [TileD HasTreasure PlayOrder] + addPlayers mempty tiles `shouldBe` Nothing + + it "should fail when trying to add same PlayOrder more than once" $ do + let players = + P.fromList [Player "p1" Yellow First, Player "p2" Red Second] + tiles = + [ (Path, Nothing, Nothing, False, Just First) + , (Path, Nothing, Nothing, False, Just First) + ] :: [TileD HasTreasure PlayOrder] + addPlayers players tiles `shouldBe` Nothing + + + it "should add players to the game" $ do + let p1 = Player "p1" Yellow First + p2 = Player "p2" Yellow Second + players = P.fromList [p1, p2] + tiles = + [ (Path, Nothing, Nothing, False, Just First) + , (Path, Nothing, Nothing, False, Just Second) + , (Path, Nothing, Nothing, False, Nothing) + ] :: [TileD HasTreasure PlayOrder] + expected = + Just + [ (Path, Nothing, Nothing, False, Nothing) + , (Path, Nothing, Nothing, False, Just p1) + , (Path, Nothing, Nothing, False, Just p2) + ] :: Maybe [TileD HasTreasure Player] + + addPlayers players tiles `shouldBe` expected