Package into cabal projectHEADmain

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