path: root/Game.hs

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
    let defaultPlayers = [ Player "Alice" 0 []
                         , Player "Bob"   0 []
                         , Player "Carol" 0 []
                         ]
    pidx <- firstPlayer defaultPlayers decks
    let game = Game { players     = 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