summaryrefslogtreecommitdiff
path: root/src/Game.hs
blob: 7e553e78d86d7c055f213d526e5f7ce22700c37b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
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