summaryrefslogtreecommitdiff
path: root/src/Game.hs
diff options
context:
space:
mode:
authorFrederick Yin <fkfd@fkfd.me>2023-03-13 18:23:48 +0800
committerFrederick Yin <fkfd@fkfd.me>2023-03-13 18:23:48 +0800
commit8c6245fac35cdc9a1ef743d29eea9176448d350d (patch)
tree43755f230b1cfe0caee7d29156851479eb23f2b0 /src/Game.hs
parent84ee16536eabd4f637912d25643184cbcc118092 (diff)
Package into cabal projectHEADmain
Diffstat (limited to 'src/Game.hs')
-rw-r--r--src/Game.hs207
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