Full game flow

4 files changed, 149 insertions, 64 deletions

diff --git a/server/cafp.cabal b/server/cafp.cabal
index 14ef7ad..f80184c 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -35,6 +35,8 @@ Library
     text                 >= 1.2  && < 1.3,
     unordered-containers >= 0.2  && < 0.3,
     vector               >= 0.12 && < 0.13,
+    vector-algorithms    >= 0.8  && < 0.9,
+    vector-instances     >= 3.4  && < 3.5,
     vector-shuffling     >= 1.1  && < 1.2,
     wai                  >= 3.2  && < 3.3,
     wai-websockets       >= 3.0  && < 3.1,
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index 14228fd..379b3a5 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types        #-}
 {-# LANGUAGE RecordWildCards   #-}
@@ -19,26 +20,31 @@ module Cafp.Game
     ) where
 
 import           Cafp.Messages
-import           Control.Lens              (Lens', at, ix, orOf, over, 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 qualified Data.HashMap.Strict       as HMS
-import           Data.List                 (sort)
-import           Data.Maybe                (fromMaybe)
-import           Data.Text                 (Text)
-import qualified Data.Text                 as T
-import qualified Data.Vector               as V
-import           System.Random             (StdGen)
-import           VectorShuffling.Immutable (shuffle)
+import           Control.Lens                 (Lens', at, imap, ix, orOf, over,
+                                               to, (%%=), (%=), (&), (+=), (.=),
+                                               (.~), (^.), (^..), (^?), _1, _2,
+                                               _3)
+import           Control.Lens.TH              (makeLenses, makePrisms)
+import           Control.Monad                (guard)
+import Data.Ord (comparing, Down (..))
+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.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 = [WhiteCard]
+type Proposal = V.Vector WhiteCard
 
 data Table
     = TableProposing
@@ -48,12 +54,16 @@ data Table
         !BlackCard
         !(V.Vector (Proposal, [PlayerId]))
         !(HMS.HashMap PlayerId Int)
+    | TableTally
+        !BlackCard
+        !(V.Vector VotedView)
     deriving (Show)
 
 data Player = Player
-    { _playerName  :: !Text
-    , _playerHand  :: !(V.Vector WhiteCard)
-    , _playerAdmin :: !Bool
+    { _playerName   :: !Text
+    , _playerHand   :: !(V.Vector WhiteCard)
+    , _playerAdmin  :: !Bool
+    , _playerPoints :: !Int
     } deriving (Show)
 
 data Game = Game
@@ -119,7 +129,7 @@ joinGame = runState $ do
     pid <- gameNextPlayerId %%= (\x -> (x, x + 1))
     let name = "Player " <> T.pack (show pid)
     hand <- V.replicateM 6 popWhiteCard
-    gamePlayers %= HMS.insert pid (Player name hand False)
+    gamePlayers %= HMS.insert pid (Player name hand False 0)
     modify assignAdmin
     pure pid
 
@@ -130,9 +140,44 @@ blackCardBlanks :: Cards -> BlackCard -> Int
 blackCardBlanks cards (BlackCard c) =
     maybe 0 (length . T.breakOnAll "\\BLANK") $ 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
+
 stepGame :: Game -> Game
 stepGame game = case game ^. gameTable of
     TableProposing black proposals
+        -- Everyone has proposed.
         | HMS.null ((game ^. gamePlayers) `HMS.difference` proposals) ->
             let proposalsMap = HMS.fromListWith (++) $ do
                     (pid, proposal) <- HMS.toList proposals
@@ -142,12 +187,22 @@ stepGame game = case game ^. gameTable of
             game & gameSeed .~ seed
                 & gameTable .~ TableVoting black shuffled HMS.empty
         | otherwise -> game
-    TableVoting _ _ _ -> game
+    TableVoting black shuffled votes
+        -- Everyone has voted.
+        | HMS.null ((game ^. gamePlayers) `HMS.difference` votes) ->
+            let (voted, wins) = tallyVotes game shuffled votes in
+            flip execState game $ do
+            for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1
+            gameTable .= TableTally black voted
+        | otherwise -> game
+    TableTally _ _ -> game
 
 processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
 processClientMessage pid msg game = case msg of
-    ChangeMyName name ->
-        game & gamePlayers . ix pid . playerName .~ name
+    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
@@ -162,6 +217,7 @@ processClientMessage pid msg game = case msg of
 
     SubmitVote i -> case game ^. gameTable of
         TableProposing _ _ -> game
+        TableTally _ _ -> game
         TableVoting _ shuffled votes
             -- Vote out of bounds.
             | i < 0 || i >= V.length shuffled -> game
@@ -172,32 +228,47 @@ processClientMessage pid msg game = case msg of
             -- Ok vote.
             | otherwise -> stepGame $ game
                 & gameTable . _TableVoting . _3 . at pid .~ Just i
+
+    ConfirmTally
+        | TableTally _ _ <- game ^. gameTable
+        , Just True <- game ^? gamePlayers . ix pid . playerAdmin ->
+            flip execState game $ do
+            black <- popBlackCard
+            gameTable .= TableProposing black HMS.empty
+        | otherwise -> game
   where
     hand = game ^.. gamePlayers . ix pid . playerHand . traverse
 
 gameViewForPlayer :: PlayerId -> Game -> GameView
 gameViewForPlayer self game =
-    let opponents = do
-            (pid, p) <- HMS.toList $ game ^. gamePlayers
-            guard $ pid /= self
-            let ready = case game ^. gameTable of
-                    TableProposing _ proposals -> HMS.member pid proposals
-                    TableVoting _ _ votes      -> HMS.member pid votes
-            pure $ Opponent (p ^. playerName) (p ^. playerAdmin) ready
-
-        player = game ^. gamePlayers . at self
+    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 [] $ HMS.lookup self proposals
+                Proposing black . fromMaybe V.empty $ HMS.lookup self proposals
             TableVoting black shuffled votes -> Voting
                 black
-                (fst <$> V.toList shuffled)
+                (fst <$> shuffled)
                 (fromMaybe 0 $ V.findIndex ((self `elem`) . snd) shuffled)
-                (HMS.lookup self votes) in
+                (HMS.lookup self votes)
+            TableTally black voted -> Tally black voted in
     GameView
-        { gameViewOpponents = opponents
-        , gameViewMyName    = maybe "" (^. playerName) player
-        , gameViewTable     = table
-        , gameViewHand      = player ^.. traverse . playerHand . traverse
+        { 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
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index b1e6efe..ccf19e8 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -13,7 +13,8 @@ main = putStrLn $ makeElmModule "Messages"
     [ DefineElm (Proxy :: Proxy BlackCard)
     , DefineElm (Proxy :: Proxy WhiteCard)
     , DefineElm (Proxy :: Proxy Cards)
-    , DefineElm (Proxy :: Proxy Opponent)
+    , DefineElm (Proxy :: Proxy PlayerView)
+    , DefineElm (Proxy :: Proxy VotedView)
     , DefineElm (Proxy :: Proxy TableView)
     , DefineElm (Proxy :: Proxy GameView)
     , DefineElm (Proxy :: Proxy ServerMessage)
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index cfc8597..4e5123d 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -4,7 +4,8 @@ module Cafp.Messages
     ( BlackCard (..)
     , WhiteCard (..)
     , Cards (..)
-    , Opponent (..)
+    , PlayerView (..)
+    , VotedView (..)
     , TableView (..)
     , GameView (..)
     , ServerMessage (..)
@@ -26,49 +27,59 @@ data WhiteCard = WhiteCard Int deriving (Eq, Generic, Show)
 instance Hashable WhiteCard
 
 data Cards = Cards
-    { cardsBlack :: Vector Text
-    , cardsWhite :: Vector Text
+    { cardsBlack :: !(Vector Text)
+    , cardsWhite :: !(Vector Text)
     } deriving (Show)
 
-data Opponent = Opponent
-    { opponentName  :: Text
-    , opponentAdmin :: Bool
-    , opponentReady :: Bool
+data PlayerView = PlayerView
+    { playerViewName   :: !Text
+    , playerViewAdmin  :: !Bool
+    , playerViewReady  :: !Bool
+    , playerViewPoints :: !Int
+    } deriving (Show)
+
+data VotedView = VotedView
+    { votedProposal :: !(Vector WhiteCard)
+    , votedScore    :: !Int
+    , votedWinners  :: !(Vector Text)
     } deriving (Show)
 
 data TableView
-    = Proposing BlackCard [WhiteCard]
+    = Proposing !BlackCard !(Vector WhiteCard)
     | Voting
-        BlackCard
-        [[WhiteCard]]  -- ^ Proposals to vote for
-        Int            -- ^ My proposal
-        (Maybe Int)    -- ^ My vote
+        !BlackCard
+        !(Vector (Vector WhiteCard))  -- ^ Proposals to vote for
+        !Int            -- ^ My proposal
+        !(Maybe Int)    -- ^ My vote
+    | Tally !BlackCard !(Vector VotedView)
     deriving (Show)
 
 data GameView = GameView
-    { gameViewOpponents :: [Opponent]
-    , gameViewMyName    :: Text
-    , gameViewTable     :: TableView
-    , gameViewHand      :: [WhiteCard]
+    { gameViewPlayers :: !(Vector PlayerView)
+    , gameViewMe      :: !PlayerView
+    , gameViewTable   :: !TableView
+    , gameViewHand    :: !(Vector WhiteCard)
     } deriving (Show)
 
 data ServerMessage
-    = Welcome Int
-    | SyncCards Cards
-    | SyncGameView GameView
+    = Welcome !Int
+    | SyncCards !Cards
+    | SyncGameView !GameView
     | Bye
     deriving (Show)
 
 data ClientMessage
-    = ChangeMyName Text
-    | ProposeWhiteCards [WhiteCard]
-    | SubmitVote Int
+    = ChangeMyName !Text
+    | ProposeWhiteCards !(Vector WhiteCard)
+    | SubmitVote !Int
+    | ConfirmTally
     deriving (Show)
 
 deriveBoth defaultOptions ''BlackCard
 deriveBoth defaultOptions ''WhiteCard
 deriveBoth (defaultOptionsDropLower 5) ''Cards
-deriveBoth (defaultOptionsDropLower 8) ''Opponent
+deriveBoth (defaultOptionsDropLower 10) ''PlayerView
+deriveBoth (defaultOptionsDropLower 5) ''VotedView
 deriveBoth defaultOptions ''TableView
 deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage