From 8c6245fac35cdc9a1ef743d29eea9176448d350d Mon Sep 17 00:00:00 2001 From: Frederick Yin Date: Mon, 13 Mar 2023 18:23:48 +0800 Subject: Package into cabal project --- .gitignore | 1 + Card.hs | 61 ----------------- Color.hs | 13 ---- Game.hs | 211 ---------------------------------------------------------- Main.hs | 44 ------------ Player.hs | 52 --------------- onecard.cabal | 19 ++++++ src/Card.hs | 61 +++++++++++++++++ src/Color.hs | 13 ++++ src/Game.hs | 207 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 44 ++++++++++++ src/Player.hs | 56 ++++++++++++++++ 12 files changed, 401 insertions(+), 381 deletions(-) delete mode 100644 Card.hs delete mode 100644 Color.hs delete mode 100644 Game.hs delete mode 100644 Main.hs delete mode 100644 Player.hs create mode 100644 onecard.cabal create mode 100644 src/Card.hs create mode 100644 src/Color.hs create mode 100644 src/Game.hs create mode 100644 src/Main.hs create mode 100644 src/Player.hs diff --git a/.gitignore b/.gitignore index c56f049..a7d265a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .undodir/ +dist-newstyle/ *.hi *.o Main diff --git a/Card.hs b/Card.hs deleted file mode 100644 index c674b5d..0000000 --- a/Card.hs +++ /dev/null @@ -1,61 +0,0 @@ -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/Color.hs b/Color.hs deleted file mode 100644 index 1d63fcd..0000000 --- a/Color.hs +++ /dev/null @@ -1,13 +0,0 @@ -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/Game.hs b/Game.hs deleted file mode 100644 index 2888bbe..0000000 --- a/Game.hs +++ /dev/null @@ -1,211 +0,0 @@ -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 diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 1b4996f..0000000 --- a/Main.hs +++ /dev/null @@ -1,44 +0,0 @@ -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/Player.hs b/Player.hs deleted file mode 100644 index 3bec60c..0000000 --- a/Player.hs +++ /dev/null @@ -1,52 +0,0 @@ -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] - } - --- | 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 diff --git a/onecard.cabal b/onecard.cabal new file mode 100644 index 0000000..c4d2ef4 --- /dev/null +++ b/onecard.cabal @@ -0,0 +1,19 @@ +name: onecard +version: 0.1.0 +build-type: Simple +cabal-version: 1.18 + +library + default-language: Haskell2010 + exposed-modules: Game, Player, Card, Color + hs-source-dirs: src + build-depends: base, random + ghc-options: -dynamic + +executable onecard + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base, random, optparse-applicative, onecard + main-is: Main.hs + other-modules: Game, Player, Card, Color + ghc-options: -dynamic 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 -- cgit v1.2.3