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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Uplcg.Game
( PlayerId
, Table (..)
, Player (..)
, Game (..)
, gameLog, gameCards, gamePlayers, gameNextPlayerId
, newGame
, joinGame
, leaveGame
, processClientMessage
, gameViewForPlayer
) where
import Uplcg.Messages
import Control.Lens (Lens', at, iall, ifor_, imap, ix,
orOf, to, (%%=), (%=), (%~), (&),
(+=), (.=), (.~), (^.), (^..),
(^?), _1, _2, _3)
import Control.Lens.TH (makeLenses, makePrisms)
import Control.Monad (guard)
import Control.Monad.State (State, execState, modify,
runState, state)
import Data.Bifunctor (first)
import Data.Foldable (for_)
import qualified Data.HashMap.Strict as HMS
import Data.List (sort)
import Data.Maybe (fromMaybe)
import Data.Ord (Down (..), comparing)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Merge as V
import Data.Vector.Instances ()
import System.Random (StdGen)
import VectorShuffling.Immutable (shuffle)
type PlayerId = Int
type Proposal = V.Vector WhiteCard
data Table
= TableProposing
!BlackCard
!(HMS.HashMap PlayerId Proposal)
| TableVoting
!BlackCard
!(V.Vector (Proposal, [PlayerId]))
!(HMS.HashMap PlayerId Int)
| TableTally
!BlackCard
!(V.Vector VotedView)
deriving (Show)
data Player = Player
{ _playerId :: !PlayerId
, _playerName :: !Text
, _playerHand :: !(V.Vector WhiteCard)
, _playerAdmin :: !Bool
, _playerPoints :: !Int
} deriving (Show)
data Game = Game
{ _gameCards :: !Cards
, _gameSeed :: !StdGen
, _gameLog :: ![Text]
, _gameBlack :: ![BlackCard]
, _gameWhite :: ![WhiteCard]
, _gamePlayers :: !(HMS.HashMap PlayerId Player)
, _gameTable :: !Table
, _gameNextPlayerId :: !Int
} deriving (Show)
makePrisms ''Table
makeLenses ''Player
makeLenses ''Game
popCard
:: (Cards -> V.Vector t) -> (Int -> c) -> Lens' Game [c]
-> State Game c
popCard getDeck mk queue = state $ \game -> case game ^. queue of
(x : xs) -> (x, game & queue .~ xs)
[] ->
let deck = game ^. gameCards . to getDeck
idxs = V.imap (\i _ -> mk i) deck
(cs, seed) = first V.toList $ shuffle idxs (game ^. gameSeed) in
case cs of
[] -> error "popCard: Cards are empty"
x : xs -> (x, game & queue .~ xs & gameSeed .~ seed)
popBlackCard :: State Game BlackCard
popBlackCard = popCard cardsBlack BlackCard gameBlack
popWhiteCard :: State Game WhiteCard
popWhiteCard = popCard cardsWhite WhiteCard gameWhite
newGame :: Cards -> StdGen -> Game
newGame cards gen = flip execState state0 $ do
black <- popBlackCard
gameTable .= TableProposing black HMS.empty
where
state0 = Game
{ _gameCards = cards
, _gameSeed = gen
, _gameLog = []
, _gameBlack = []
, _gameWhite = []
, _gamePlayers = HMS.empty
, _gameTable = TableProposing (BlackCard 0) HMS.empty
, _gameNextPlayerId = 1
}
defaultHandSize :: Int
defaultHandSize = 8
drawNewWhiteCards :: Game -> Game
drawNewWhiteCards game = flip execState game $ do
ifor_ (game ^. gamePlayers) $ \pid player -> do
let num = defaultHandSize - V.length (player ^. playerHand)
new <- V.replicateM num popWhiteCard
gamePlayers . ix pid . playerHand %= (<> new)
assignAdmin :: Game -> Game
assignAdmin game
-- Admin already assigned.
| orOf (gamePlayers . traverse . playerAdmin) game = game
-- Assign to first player
| (p1 : _) <- sort (game ^. gamePlayers . to HMS.keys) =
game & gamePlayers . ix p1 . playerAdmin .~ True
-- No players
| otherwise = game
joinGame :: Maybe Player -> Game -> (PlayerId, Game)
joinGame mbPlayer = runState $ do
player <- case mbPlayer of
Nothing -> do
pid <- gameNextPlayerId %%= (\x -> (x, x + 1))
let name = "Player " <> T.pack (show pid)
hand <- V.replicateM defaultHandSize popWhiteCard
pure $ Player pid name hand False 0
Just p -> pure $ p & playerAdmin .~ False
gamePlayers %= HMS.insert (player ^. playerId) player
modify assignAdmin
pure $ player ^. playerId
leaveGame :: PlayerId -> Game -> (Maybe Player, Game)
leaveGame pid game = case game ^? gamePlayers . ix pid of
Nothing -> (Nothing, game)
Just p -> (Just p, assignAdmin $ game & gamePlayers %~ HMS.delete pid)
blackCardBlanks :: Cards -> BlackCard -> Int
blackCardBlanks cards (BlackCard c) =
maybe 0 (length . T.breakOnAll "_") $ cardsBlack cards V.!? c
maximaOn :: Ord o => (a -> o) -> [a] -> [a]
maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs
where
go best _ [] = reverse best
go best bestScore (x : xs) =
let score = f x in
case compare score bestScore of
LT -> go best bestScore xs
EQ -> go (x : best) bestScore xs
GT -> go [x] score xs
tallyVotes
:: Game
-> (V.Vector (Proposal, [PlayerId]))
-> (HMS.HashMap PlayerId Int)
-> (V.Vector VotedView, [PlayerId])
tallyVotes game shuffled votes =
let counts :: HMS.HashMap Int Int -- Index, votes received.
counts = HMS.fromListWith (+) [(idx, 1) | (_, idx) <- HMS.toList votes]
best = map fst . maximaOn snd $ HMS.toList counts in
( byScore $ V.imap (\i (proposal, players) -> VotedView
{ votedProposal = proposal
, votedScore = fromMaybe 0 $ HMS.lookup i counts
, votedWinners = V.fromList $ do
guard $ i `elem` best
p <- players
game ^.. gamePlayers . ix p . playerName
})
shuffled
, [player | idx <- best, player <- snd $ shuffled V.! idx]
)
where
byScore = V.modify $ V.sortBy . comparing $ Down . votedScore
-- | Create nice messages about the winners in the logs.
votedMessages :: Cards -> BlackCard -> V.Vector VotedView -> [T.Text]
votedMessages cards (BlackCard black) voteds = do
voted <- V.toList voteds
guard $ V.length (votedWinners voted) > 0
pure $
T.intercalate ", " (V.toList $ votedWinners voted) <> " won with " <>
cardsBlack cards V.! black <> " | " <>
T.intercalate " / "
[ cardsWhite cards V.! i
| WhiteCard i <- V.toList $ votedProposal voted
]
stepGame :: Bool -> Game -> Game
stepGame skip game = case game ^. gameTable of
TableProposing black proposals
-- Everyone has proposed.
| skip || iall (const . (`HMS.member` proposals)) (game ^. gamePlayers) ->
let proposalsMap = HMS.fromListWith (++) $ do
(pid, proposal) <- HMS.toList proposals
pure (proposal, [pid])
(shuffled, seed) = shuffle
(V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in
-- There's a recursive call because in some one-player cases we
-- skip the voting process entirely.
stepGame False $ game
& gameSeed .~ seed
& gameTable .~ TableVoting black shuffled HMS.empty
& gamePlayers %~ imap (\pid player ->
let used = fromMaybe V.empty $ HMS.lookup pid proposals in
player & playerHand %~ V.filter (not . (`V.elem` used)))
| otherwise -> game
TableVoting black shuffled votes
-- Everyone has voted.
| skip || iall hasVoted (game ^. gamePlayers) ->
let (voted, wins) = tallyVotes game shuffled votes in
flip execState game $ do
for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1
gameTable .= TableTally black voted
gameLog %= (votedMessages (game ^. gameCards) black voted ++)
| otherwise -> game
where
hasVoted pid _ = HMS.member pid votes ||
-- The person cannot vote for anything since all the proposals
-- are theirs. This can happen when the game starts out with a
-- single person.
V.all (\(_, pids) -> pid `elem` pids) shuffled
TableTally _ _ -> game
processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
processClientMessage pid msg game = case msg of
ChangeMyName name
| T.length name > 32 -> game
| otherwise -> game & gamePlayers . ix pid . playerName .~ name
ProposeWhiteCards cs
-- Bad card(s) proposed, i.e. not in hand of player.
| any (not . (`elem` hand)) cs -> game
-- Proposal already made.
| Just _ <- game ^? gameTable . _TableProposing . _2 . ix pid -> game
-- Not enough cards submitted.
| Just b <- game ^? gameTable . _TableProposing . _1
, blackCardBlanks (game ^. gameCards) b /= length cs -> game
-- All good.
| otherwise -> stepGame False $
game & gameTable . _TableProposing . _2 . at pid .~ Just cs
SubmitVote i -> case game ^. gameTable of
TableProposing _ _ -> game
TableTally _ _ -> game
TableVoting _ shuffled votes
-- Vote out of bounds.
| i < 0 || i >= V.length shuffled -> game
-- Already voted.
| pid `HMS.member` votes -> game
-- Can't vote for self.
| pid `elem` snd (shuffled V.! i) -> game
-- Ok vote.
| otherwise -> stepGame False $ game
& gameTable . _TableVoting . _3 . at pid .~ Just i
AdminConfirmTally
| TableTally _ _ <- game ^. gameTable, admin ->
flip execState game $ do
black <- popBlackCard
gameTable .= TableProposing black HMS.empty
modify drawNewWhiteCards
| otherwise -> game
AdminSkipProposals
| TableProposing _ _ <- game ^. gameTable, admin -> stepGame True $
game & gameLog %~ ("Admin skipped proposals" :)
| otherwise -> game
AdminSkipVotes
| TableVoting _ _ _ <- game ^. gameTable, admin -> stepGame True $
game & gameLog %~ ("Admin skipped votes" :)
| otherwise -> game
where
hand = game ^.. gamePlayers . ix pid . playerHand . traverse
admin = fromMaybe False $ game ^? gamePlayers . ix pid . playerAdmin
gameViewForPlayer :: PlayerId -> Game -> GameView
gameViewForPlayer self game =
let playerView pid player = PlayerView
{ playerViewName = player ^. playerName
, playerViewAdmin = player ^. playerAdmin
, playerViewReady = case game ^. gameTable of
TableProposing _ proposals -> HMS.member pid proposals
TableVoting _ _ votes -> HMS.member pid votes
TableTally _ _ -> False
, playerViewPoints = player ^. playerPoints
}
table = case game ^. gameTable of
TableProposing black proposals ->
Proposing black . fromMaybe V.empty $ HMS.lookup self proposals
TableVoting black shuffled votes -> Voting
black
(fst <$> shuffled)
(V.findIndex ((self `elem`) . snd) shuffled)
(HMS.lookup self votes)
TableTally black voted -> Tally black voted in
GameView
{ gameViewPlayers = V.fromList . map snd . HMS.toList
. HMS.delete self . imap playerView $ game ^. gamePlayers
, gameViewMe = maybe dummy (playerView self) $
game ^? gamePlayers . ix self
, gameViewTable = table
, gameViewHand = fromMaybe V.empty $
game ^? gamePlayers . ix self . playerHand
}
where
dummy = PlayerView "" False False 0
|