Package into cabal projectHEADmain

1 files changed, 207 insertions, 0 deletions

diff --git a/src/Game.hs b/src/Game.hs
new file mode 100644
index 0000000..7e553e7
--- /dev/null
+++ b/src/Game.hs
@@ -0,0 +1,207 @@
+module Game where
+
+import Prelude hiding (round)
+import qualified Data.List as L
+import Data.Char (isDigit)
+import Data.Function (on)
+import Control.Monad (mapM_)
+import System.Random (RandomGen, getStdGen, newStdGen)
+import Player (Player(..), shed, draw)
+import qualified Player as P
+import Card (Card(..))
+import qualified Card as C
+
+data Setup = Setup { playerN :: Int
+                   , roundN :: Int
+                   , deckN :: Int
+                   , cardN :: Int      -- ^ cards dealt to each player
+                   , autoMode :: Bool
+                   }
+
+data Game = Game { players :: [Player]
+                 , playerIdx :: Int
+                 , attack :: Int
+                 , direction :: Int      -- ^ 1 when CCW, -1 when CW
+                 , prevCard :: Card
+                 , stockPile :: [Card]
+                 , discardPile :: [Card]
+                 , round :: Int
+                 }
+
+-- | Set up game.
+beginGame :: Setup -> IO Game
+beginGame setup@(Setup n r d c a) = do
+    gen <- getStdGen
+    let decks = C.shuffle gen $ C.fullDecks d
+    let stock = drop n decks
+    pidx <- firstPlayer P.defaultPlayers decks
+    let game = Game { players     = P.defaultPlayers
+                    , playerIdx   = pidx
+                    , attack      = 1
+                    , direction   = 1
+                    , prevCard    = head stock
+                    , stockPile   = tail stock
+                    , discardPile = []
+                    , round       = 0
+                    }
+    beginRound setup game
+
+-- | Determine playerIdx from top `n` cards from `stock`.
+firstPlayer :: [Player] -> [Card] -> IO Int
+firstPlayer plyrs stock = do
+    let cards = take (length plyrs) stock
+    putStrLn "Drawing cards to determine playing order..."
+    mapM_ (\(Player name _ _, i) ->
+            putStrLn $ name ++ " draws " ++ C.showCard (cards !! i))
+        $ zip plyrs [0..]
+    let minRank = L.minimumBy (compare `on` C.rank)
+    let playerIdx = case L.elemIndex (minRank cards) cards of
+                      Just i -> i
+                      Nothing -> 0  -- impossible
+    putStrLn $ (P.name $ plyrs !! playerIdx) ++ " goes first"
+    return playerIdx
+
+-- | Begin round.
+beginRound :: Setup -> Game -> IO Game
+beginRound setup@(Setup _ r d c a) game =
+    if round game == r
+       then return game
+       else do
+           game' <- beginTurn setup $ dealCards c game
+           beginRound setup game'
+
+-- | Deal c cards from stock pile to each player in game.
+dealCards :: Int -> Game -> Game
+dealCards c game@(Game plyrs _ _ _ _ stock _ _)
+  | (length $ P.cards $ head plyrs) < c =
+      dealCards c game { players = newPlyrs, stockPile = newStock }
+  | otherwise = game
+    where newPlyrs = giveOneCardEach stock plyrs
+          newStock = drop c stock
+          giveOneCardEach =
+              zipWith (\card player -> player { P.cards = card:(P.cards player) })
+
+-- | Let current player take their turn.
+beginTurn :: Setup -> Game -> IO Game
+beginTurn setup@(Setup _ _ _ _ auto) game@(Game plyrs pidx att dir prev stock disc _) = do
+    let player = plyrs !! pidx
+
+    putStrLn $ replicate 80 '-'
+    putStrLn $ P.name player ++ "'s turn (input 0 to skip turn and draw card)"
+    putStrLn $ P.showCards player prev att
+    putStrLn $ "Stock: " ++ (show $ length stock)
+            ++ ", Discard: " ++ (show $ length disc)
+    putStrLn $ "Current attack: " ++ show att
+    putStrLn $ "Prev card: " ++ C.showCard prev
+
+    decision <- if auto
+                   then return $ automate game
+                   else prompt game
+    game' <- case decision of
+               Nothing -> drawAndSkip game
+               Just card -> shedAndContinue card game
+
+    if playerIdx game' == pidx  -- shedAndContinue does this when player wins
+       then endRound setup game'
+       else beginTurn setup game'
+
+-- | Game state after player draws card(s) and skips turn.
+drawAndSkip :: Game -> IO Game
+drawAndSkip game@(Game plyrs pidx att dir prev stock disc round) = do
+    gen <- newStdGen
+    let stockLongEnough = if length stock < att
+                             then stock ++ (C.shuffle gen disc)
+                             else stock
+    let stock' = drop att stockLongEnough
+    let disc' = if length stock < att
+                   then []
+                   else disc
+    let cardsToDraw = take att stockLongEnough
+    let player = plyrs !! pidx
+    let player' = player `draw` cardsToDraw
+    let plyrs' = P.update plyrs pidx player'
+    let pidx' = (pidx + dir) `mod` length plyrs
+    putStrLn $ (P.name player) ++ " draws " ++ (C.showCards cardsToDraw)
+    return $ Game plyrs' pidx' 1 dir prev stock' disc' round
+
+-- | Game state after player sheds card.
+shedAndContinue :: Card -> Game -> IO Game
+shedAndContinue card game@(Game plyrs pidx att dir prev stock disc round) = do
+    let player = plyrs !! pidx
+    let player' = player `shed` card
+    let disc' = card:disc
+    let plyrs' = P.update plyrs pidx player'
+    let dir' = case card of
+                 Card _ C.Queen -> negate dir
+                 _ -> dir
+    let pidx' = if null $ P.cards player'
+                   then pidx  -- round ends
+                   else case card of
+                          Card _ C.Jack -> (pidx + 2 * dir') `mod` length plyrs
+                          _ -> (pidx + dir') `mod` length plyrs
+    let att' = case card of
+                 Card _ C.Two   -> if att == 1 then 2 else att + 2
+                 Card _ C.Three -> if att == 1 then 3 else att + 3
+                 Card _ C.Seven -> 1
+                 _ -> att
+    putStrLn $ (P.name player) ++ " plays " ++ (C.showCard card)
+    return $ Game plyrs' pidx' att' dir' card stock disc' round
+
+-- | Prompt player to play a card (or draw card and skip turn).
+prompt :: Game -> IO (Maybe Card)
+prompt game@(Game plyrs pidx att _ prev _ _ _) = do
+    let player = plyrs !! pidx
+    let cards = P.cards player
+    cardIdxStr <- getLine
+    if any (== False) $ map isDigit cardIdxStr
+       then do
+           putStrLn "Please input card #"
+           prompt game
+       else do
+           let cardIdx = read cardIdxStr - 1
+           if cardIdx == -1
+              then do
+                 return Nothing
+              else do
+                  if cardIdx < 0 || cardIdx >= length cards
+                     then do
+                         putStrLn "This card does not exist, try again"
+                         prompt game
+                     else do
+                         let card = cards !! cardIdx
+                         if C.isValid prev att card
+                            then return $ Just card
+                            else do
+                                putStrLn "You cannot play this card, try again"
+                                prompt game
+
+-- | Make an automated decision to draw/shed card.
+automate :: Game -> Maybe Card
+automate game@(Game plyrs pidx att _ prev _ _ _) =
+    if null validCards
+       then Nothing
+       else Just (head validCards)
+           where validCards = filter (C.isValid prev att) $ P.cards (plyrs !! pidx)
+
+-- | Keep penalties and reset game for next round.
+endRound :: Setup -> Game -> IO Game
+endRound setup@(Setup _ r d _ _) game@(Game plyrs pidx _ _ _ _ _ roundNo) = do
+    putStrLn $ replicate 80 '#'
+    putStrLn $ (P.name $ plyrs !! pidx) ++ " wins round "
+            ++ (show $ roundNo + 1) ++ "!"
+    let plyrs' = P.clearCards $ P.calcPenalties plyrs
+    putStrLn "Penalties:"
+    putStrLn $ P.showPenalties plyrs'
+    let stock = C.fullDecks d
+    return Game { players    = plyrs'
+                , playerIdx  = pidx
+                , attack     = 1
+                , direction  = 1
+                , prevCard   = head stock
+                , stockPile  = tail stock
+                , discardPile = []
+                , round       = roundNo + 1
+                }
+
+wait :: a -> IO a
+wait x = getLine >> return x