aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Uplcg/Game.hs
blob: 140f2b6bacdceef30863e19217c74975460e2db5 (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
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