WIP: creating new games

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(..) )

lib/Labyrinth/Game/Cell.hs

@@ -3,7 +3,7 @@ module Labyrinth.Game.Cell
   , TileCell(..)
   , GateCell(..)
   , CellData(..)
-  , Terrain
+  , Terrain(..)
   , treasure
   , players
   , isOpen

lib/Labyrinth/Game/NewGame.hs

@@ -1,61 +1,101 @@
 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
   -> [Treasure]
   -> 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

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

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