diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Card.hs | 61 | ||||
| -rw-r--r-- | src/Color.hs | 13 | ||||
| -rw-r--r-- | src/Game.hs | 207 | ||||
| -rw-r--r-- | src/Main.hs | 44 | ||||
| -rw-r--r-- | src/Player.hs | 56 |
5 files changed, 381 insertions, 0 deletions
diff --git a/src/Card.hs b/src/Card.hs new file mode 100644 index 0000000..c674b5d --- /dev/null +++ b/src/Card.hs @@ -0,0 +1,61 @@ +module Card where + +import qualified Data.List as L +import System.Random (RandomGen, random) + +data Suit = Spade | Heart | Diamond | Club deriving (Show, Eq, Ord, Enum) +data Rank = Two | Three | Four | Five | Six | Seven | Eight + | Nine | Ten | Jack | Queen | King | Ace + deriving (Show, Eq, Ord, Enum) +data Card = Card { suit :: Suit, rank :: Rank } deriving (Show, Eq, Ord) + +-- | Pretty print a card. +showCard :: Card -> String +showCard (Card st rk) = (show st) ++ " " ++ (rkStr) + where rkStr = case rk of + Jack -> "J" + Queen -> "Q" + King -> "K" + Ace -> "A" + _ -> show $ fromEnum rk + 2 + +-- | Pretty print a list of cards. +showCards :: [Card] -> String +showCards = L.intercalate ", " . map showCard + +-- | Produce one full 52-deck. +fullDeck = [Card st rk | st <- allSuits, rk <- allRanks] + where allSuits = enumFrom $ toEnum 0 + allRanks = enumFrom $ toEnum 0 + +-- | Produce n full 52-decks. +fullDecks :: Int -> [Card] +fullDecks n = concat $ replicate n fullDeck + +-- | Shuffle a list. Works by taking a random entry each time. +shuffle :: (RandomGen g) => g -> [a] -> [a] +shuffle _ [] = [] +shuffle _ [x] = [x] +shuffle gen xs = (head right):(shuffle newGen (left ++ (tail right))) + where (rand, newGen) = random gen + i = rand `mod` (length xs) + (left, right) = splitAt i xs + +-- | Check if card is special. +isSpecial :: Card -> Bool +isSpecial (Card _ rk) + | rk `elem` [Two, Three, Seven, Jack, Queen] = True + | otherwise = False + +-- | Check if card attacks. +isAttack :: Card -> Bool +isAttack (Card _ rk) + | rk `elem` [Two, Three] = True + | otherwise = False + +-- | Check if `card` is valid after `prev`. +-- | If `att > 1`, player is under attack and `card` must be special. +isValid :: Card -> Int -> Card -> Bool +isValid prev@(Card st' rk') att card@(Card st rk) = + match && (att < 2 || isSpecial card) + where match = (st == st') || (rk == rk') diff --git a/src/Color.hs b/src/Color.hs new file mode 100644 index 0000000..1d63fcd --- /dev/null +++ b/src/Color.hs @@ -0,0 +1,13 @@ +module Color where + +red :: String -> String +red s = "\x001b[31m" ++ s ++ "\x001b[0m" + +green :: String -> String +green s = "\x001b[32m" ++ s ++ "\x001b[0m" + +yellow :: String -> String +yellow s = "\x001b[33m" ++ s ++ "\x001b[0m" + +blue :: String -> String +blue s = "\x001b[34m" ++ s ++ "\x001b[0m" 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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..1b4996f --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,44 @@ +import Options.Applicative +import Game (Game(..), Setup(..), beginGame) + +setup :: Parser Setup +setup = Setup + <$> option auto + ( short 'n' + <> long "player-number" + <> metavar "n" + <> value 4 + <> help "n players, n must be larger than 2 (default: 4)" + ) + <*> option auto + ( short 'r' + <> long "rounds" + <> metavar "r" + <> value 1 + <> help "play r rounds, r must be at least 1 (default: 1)" + ) + <*> option auto + ( short 'd' + <> long "decks" + <> metavar "d" + <> value 2 + <> help "use d decks 52 cards each, d must be at least 2 (default: 2)" + ) + <*> option auto + ( short 'c' + <> long "initial-cards" + <> metavar "c" + <> value 5 + <> help "deal c cards per player, c must be at least 2 (default: 5)" + ) + <*> switch + ( short 'a' + <> long "auto" + <> help "run in demo mode" + ) + +main :: IO () +main = do + let opts = info (setup <**> helper) (fullDesc <> progDesc "One Card") + beginGame =<< execParser opts + return () diff --git a/src/Player.hs b/src/Player.hs new file mode 100644 index 0000000..8b64c79 --- /dev/null +++ b/src/Player.hs @@ -0,0 +1,56 @@ +module Player where + +import qualified Data.List as L +import Card (Card) +import qualified Card as C +import qualified Color + +data Player = Player { name :: String + , penalty :: Int + , cards :: [Card] + } + +defaultPlayers :: [Player] +defaultPlayers = map (\name -> Player name 0 []) $ + ["Alice", "Bob", "Carol", "David", "Eve", "Frank", "Gina", "Howard"] + +-- | Update `i`-th player in `ps` to `p`. +update :: [Player] -> Int -> Player -> [Player] +update ps i p = + let (left, right) = splitAt i ps + in left ++ [p] ++ (tail right) + +-- | Same player after shedding card specified. +shed :: Player -> Card -> Player +shed (Player n p cs) c = Player n p $ L.delete c cs + +-- | Same player after drawing cards specified. +draw :: Player -> [Card] -> Player +draw (Player n p cs) cs' = Player n p $ L.sort (cs' ++ cs) + +-- | Show player's cards, e.g. "1. Spade 2" +showCards :: Player -> Card -> Int -> String +showCards (Player _ _ cs) prev att = + unlines $ zipWith joinAndColorize [1..] cs + where joinAndColorize n c = + if C.isValid prev att c + then if C.isSpecial c + then Color.green $ join n c + else join n c + else Color.red $ join n c + join n c = (show n) ++ ". " ++ (C.showCard c) + +-- | Empty all players' cards. +clearCards :: [Player] -> [Player] +clearCards plyrs = map clear plyrs + where clear (Player n p _) = Player n p [] + +-- | Update penalty for each player after a round. +calcPenalties :: [Player] -> [Player] +calcPenalties plyrs = map penalize plyrs + where penalize (Player n p c) = Player n (p + length c) c + +-- | Pretty print penalties. +showPenalties :: [Player] -> String +showPenalties = unlines . map showPenalty + where showPenalty (Player n p _) = n ++ ":\t" ++ show p |