Full game flow

7 files changed, 231 insertions, 87 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index e3ecbf6..7cac663 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -26,6 +26,8 @@ type Msg
     -- Voting
     | SelectVote Int
     | SubmitVote
+    -- Tally
+    | ConfirmTally
 
 type alias Cards = {black : Array String, white : Array String}
 
@@ -49,12 +51,12 @@ parseRoomId url = case String.split "/" url.path of
     _ :: "rooms" :: roomId :: _ -> Ok roomId
     _ -> Err <| "Invalid path: " ++ url.path
 
-viewOpponent : Messages.Opponent -> Html msg
-viewOpponent opponent = Html.div [] <|
-    [ Html.text opponent.name
+viewPlayer : Messages.PlayerView -> Html msg
+viewPlayer player = Html.div [] <|
+    [ Html.text player.name
     ] ++
-    (if opponent.admin then [Html.text " 👑"] else []) ++
-    (if opponent.ready then [Html.text " ✅"] else [])
+    (if player.admin then [Html.text " 👑"] else []) ++
+    (if player.ready then [Html.text " ✅"] else [])
 
 view : Model -> List (Html Msg)
 view model = case model of
@@ -67,10 +69,10 @@ view model = case model of
             [Html.text <| "Connecting to room " ++ state.roomId ++ "..."]
         ]
     Game game ->
-        [ Html.h1 [] [Html.text "Opponents"]
+        [ Html.h1 [] [Html.text "Players"]
         , Html.ul [] <| List.map
-            (\o -> Html.li [] [viewOpponent o])
-            game.view.opponents
+            (\o -> Html.li [] [viewPlayer o])
+            game.view.players
         , Html.h1 [] [Html.text "You"]
         , Html.form
             [ Html.Attributes.action ""
@@ -84,7 +86,8 @@ view model = case model of
             , Html.button
                 [ Html.Attributes.type_ "submit"
                 , Html.Attributes.disabled <|
-                    game.view.myName == game.changeMyName
+                    game.view.me.name == game.changeMyName ||
+                    String.length game.changeMyName > 32
                 ]
                 [Html.text "Update name"]
             ]
@@ -100,6 +103,7 @@ tableBlackCard : GameState -> Maybe BlackCard
 tableBlackCard game = case game.view.table of
     Messages.Proposing b _ -> Just b
     Messages.Voting b _ _ _ -> Just b
+    Messages.Tally b _ -> Just b
 
 selectedWhiteCards : GameState -> List WhiteCard
 selectedWhiteCards game = case game.view.table of
@@ -148,6 +152,23 @@ viewTable game = case game.view.table of
             [Html.text "Vote"]
         ]
 
+    Messages.Tally black results -> Html.div [] <|
+        [Html.h2 [] [Html.text "Vote results"]] ++
+        List.map (\voted ->
+            let attrs =
+                    if List.length voted.winners > 0 then
+                        [Html.Attributes.class "winner"]
+                    else
+                        [] in
+            blackCard attrs game.cards black voted.proposal)
+            results ++
+        if not game.view.me.admin then
+            []
+        else
+            [ Html.button
+                [Html.Events.onClick ConfirmTally] [Html.text "Next round"]
+            ]
+
 intersperseWith : List a -> a -> List a -> List a
 intersperseWith values def list = case list of
     [] -> []
@@ -222,7 +243,7 @@ update msg model = case msg of
                         ( Game
                             { cards = {black = Array.empty, white = Array.empty}
                             , view = gameView
-                            , changeMyName = gameView.myName
+                            , changeMyName = gameView.me.name
                             , selectedWhiteCards = []
                             , selectedVote = Nothing
                             }
@@ -280,6 +301,8 @@ update msg model = case msg of
             _ -> (model, Cmd.none)
         _ -> (model, Cmd.none)
 
+    ConfirmTally -> (model, send <| Messages.ConfirmTally)
+
 main : Program () Model Msg
 main = Browser.application
     { init = \() url key -> case parseRoomId url of
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 3324886..a100dbf 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -56,25 +56,51 @@ jsonEncCards  val =
 
 
 
-type alias Opponent  =
+type alias PlayerView  =
    { name: String
    , admin: Bool
    , ready: Bool
+   , points: Int
    }
 
-jsonDecOpponent : Json.Decode.Decoder ( Opponent )
-jsonDecOpponent =
-   Json.Decode.succeed (\pname padmin pready -> {name = pname, admin = padmin, ready = pready})
+jsonDecPlayerView : Json.Decode.Decoder ( PlayerView )
+jsonDecPlayerView =
+   Json.Decode.succeed (\pname padmin pready ppoints -> {name = pname, admin = padmin, ready = pready, points = ppoints})
    |> required "name" (Json.Decode.string)
    |> required "admin" (Json.Decode.bool)
    |> required "ready" (Json.Decode.bool)
+   |> required "points" (Json.Decode.int)
 
-jsonEncOpponent : Opponent -> Value
-jsonEncOpponent  val =
+jsonEncPlayerView : PlayerView -> Value
+jsonEncPlayerView  val =
    Json.Encode.object
    [ ("name", Json.Encode.string val.name)
    , ("admin", Json.Encode.bool val.admin)
    , ("ready", Json.Encode.bool val.ready)
+   , ("points", Json.Encode.int val.points)
+   ]
+
+
+
+type alias VotedView  =
+   { proposal: (List WhiteCard)
+   , score: Int
+   , winners: (List String)
+   }
+
+jsonDecVotedView : Json.Decode.Decoder ( VotedView )
+jsonDecVotedView =
+   Json.Decode.succeed (\pproposal pscore pwinners -> {proposal = pproposal, score = pscore, winners = pwinners})
+   |> required "proposal" (Json.Decode.list (jsonDecWhiteCard))
+   |> required "score" (Json.Decode.int)
+   |> required "winners" (Json.Decode.list (Json.Decode.string))
+
+jsonEncVotedView : VotedView -> Value
+jsonEncVotedView  val =
+   Json.Encode.object
+   [ ("proposal", (Json.Encode.list jsonEncWhiteCard) val.proposal)
+   , ("score", Json.Encode.int val.score)
+   , ("winners", (Json.Encode.list Json.Encode.string) val.winners)
    ]
 
 
@@ -82,12 +108,14 @@ jsonEncOpponent  val =
 type TableView  =
     Proposing BlackCard (List WhiteCard)
     | Voting BlackCard (List (List WhiteCard)) Int (Maybe Int)
+    | Tally BlackCard (List VotedView)
 
 jsonDecTableView : Json.Decode.Decoder ( TableView )
 jsonDecTableView =
     let jsonDecDictTableView = Dict.fromList
             [ ("Proposing", Json.Decode.lazy (\_ -> Json.Decode.map2 Proposing (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecWhiteCard)))))
             , ("Voting", Json.Decode.lazy (\_ -> Json.Decode.map4 Voting (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (Json.Decode.list (jsonDecWhiteCard)))) (Json.Decode.index 2 (Json.Decode.int)) (Json.Decode.index 3 (Json.Decode.maybe (Json.Decode.int)))))
+            , ("Tally", Json.Decode.lazy (\_ -> Json.Decode.map2 Tally (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecVotedView)))))
             ]
     in  decodeSumObjectWithSingleField  "TableView" jsonDecDictTableView
 
@@ -96,30 +124,31 @@ jsonEncTableView  val =
     let keyval v = case v of
                     Proposing v1 v2 -> ("Proposing", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncWhiteCard) v2]))
                     Voting v1 v2 v3 v4 -> ("Voting", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list (Json.Encode.list jsonEncWhiteCard)) v2, Json.Encode.int v3, (maybeEncode (Json.Encode.int)) v4]))
+                    Tally v1 v2 -> ("Tally", encodeValue (Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncVotedView) v2]))
     in encodeSumObjectWithSingleField keyval val
 
 
 
 type alias GameView  =
-   { opponents: (List Opponent)
-   , myName: String
+   { players: (List PlayerView)
+   , me: PlayerView
    , table: TableView
    , hand: (List WhiteCard)
    }
 
 jsonDecGameView : Json.Decode.Decoder ( GameView )
 jsonDecGameView =
-   Json.Decode.succeed (\popponents pmyName ptable phand -> {opponents = popponents, myName = pmyName, table = ptable, hand = phand})
-   |> required "opponents" (Json.Decode.list (jsonDecOpponent))
-   |> required "myName" (Json.Decode.string)
+   Json.Decode.succeed (\pplayers pme ptable phand -> {players = pplayers, me = pme, table = ptable, hand = phand})
+   |> required "players" (Json.Decode.list (jsonDecPlayerView))
+   |> required "me" (jsonDecPlayerView)
    |> required "table" (jsonDecTableView)
    |> required "hand" (Json.Decode.list (jsonDecWhiteCard))
 
 jsonEncGameView : GameView -> Value
 jsonEncGameView  val =
    Json.Encode.object
-   [ ("opponents", (Json.Encode.list jsonEncOpponent) val.opponents)
-   , ("myName", Json.Encode.string val.myName)
+   [ ("players", (Json.Encode.list jsonEncPlayerView) val.players)
+   , ("me", jsonEncPlayerView val.me)
    , ("table", jsonEncTableView val.table)
    , ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand)
    ]
@@ -157,6 +186,7 @@ type ClientMessage  =
     ChangeMyName String
     | ProposeWhiteCards (List WhiteCard)
     | SubmitVote Int
+    | ConfirmTally 
 
 jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage )
 jsonDecClientMessage =
@@ -164,6 +194,7 @@ jsonDecClientMessage =
             [ ("ChangeMyName", Json.Decode.lazy (\_ -> Json.Decode.map ChangeMyName (Json.Decode.string)))
             , ("ProposeWhiteCards", Json.Decode.lazy (\_ -> Json.Decode.map ProposeWhiteCards (Json.Decode.list (jsonDecWhiteCard))))
             , ("SubmitVote", Json.Decode.lazy (\_ -> Json.Decode.map SubmitVote (Json.Decode.int)))
+            , ("ConfirmTally", Json.Decode.lazy (\_ -> Json.Decode.succeed ConfirmTally))
             ]
     in  decodeSumObjectWithSingleField  "ClientMessage" jsonDecDictClientMessage
 
@@ -173,6 +204,7 @@ jsonEncClientMessage  val =
                     ChangeMyName v1 -> ("ChangeMyName", encodeValue (Json.Encode.string v1))
                     ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue ((Json.Encode.list jsonEncWhiteCard) v1))
                     SubmitVote v1 -> ("SubmitVote", encodeValue (Json.Encode.int v1))
+                    ConfirmTally  -> ("ConfirmTally", encodeValue (Json.Encode.list identity []))
     in encodeSumObjectWithSingleField keyval val
 
 
diff --git a/client/style.css b/client/style.css
index 4a134c6..e3824b6 100644
--- a/client/style.css
+++ b/client/style.css
@@ -25,6 +25,10 @@ html {
   background: #003300;
 }
 
+.winner {
+  background: #701e58;
+}
+
 .white {
   color: black;
   background: white;
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