From fd2ef8609852058ddb7dc7450fb16da0e95cd40a Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Sun, 2 Aug 2020 18:33:04 +0200
Subject: Submit votes

---
 server/lib/Cafp/Game.hs     | 31 ++++++++++++++++++++-----------
 server/lib/Cafp/Messages.hs |  3 ++-
 2 files changed, 22 insertions(+), 12 deletions(-)

(limited to 'server/lib')

diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index 16350ab..8475a90 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -21,7 +21,7 @@ module Cafp.Game
 import           Cafp.Messages
 import           Control.Lens              (Lens', at, ix, over, to, traverseOf,
                                             (%%=), (%=), (%~), (&), (.~), (^.),
-                                            (^..), (^?), _1, _2, (.=))
+                                            (^..), (^?), _1, _2, (.=), _3)
 import           Control.Lens.TH           (makeLenses, makePrisms)
 import           Control.Monad             (guard, replicateM, (>=>))
 import           Control.Monad.State       (State, state, execState, runState)
@@ -44,7 +44,6 @@ data Table
         !(HMS.HashMap PlayerId Proposal)
     | TableVoting
         !BlackCard
-        !(HMS.HashMap PlayerId Proposal)
         !(V.Vector (Proposal, [PlayerId]))
         !(HMS.HashMap PlayerId Int)
     deriving (Show)
@@ -127,9 +126,9 @@ stepGame game = case game ^. gameTable of
                 (shuffled, seed) = shuffle
                     (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in
             game & gameSeed .~ seed
-                & gameTable .~ TableVoting black proposals shuffled HMS.empty
+                & gameTable .~ TableVoting black shuffled HMS.empty
         | otherwise -> game
-    TableVoting _ _ _ _ -> game
+    TableVoting _ _ _ -> game
 
 processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
 processClientMessage pid msg game = case msg of
@@ -146,6 +145,19 @@ processClientMessage pid msg game = case msg of
         -- All good.
         | otherwise -> stepGame $
             game & gameTable . _TableProposing . _2 . at pid .~ Just cs
+
+    SubmitVote i -> case game ^. gameTable of
+        TableProposing _ _ -> 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 $ game
+                & gameTable . _TableVoting . _3 . at pid .~ Just i
   where
     hand = game ^.. gamePlayers . ix pid . playerHand . traverse
 
@@ -156,20 +168,17 @@ gameViewForPlayer self game =
             guard $ pid /= self
             pure $ Opponent (p ^. playerName) $ case game ^. gameTable of
                 TableProposing _ proposals -> HMS.member pid proposals
-                TableVoting _ _ _ votes -> HMS.member pid votes
+                TableVoting _ _ votes -> HMS.member pid votes
 
         player = game ^. gamePlayers . at self
 
         table = case game ^. gameTable of
             TableProposing black proposals ->
                 Proposing black . fromMaybe [] $ HMS.lookup self proposals
-            TableVoting black proposals shuffled votes -> Voting
+            TableVoting black shuffled votes -> Voting
                 black
-                (fromMaybe [] $ HMS.lookup self proposals)
-                [ proposal
-                | (proposal, players) <- V.toList shuffled
-                , not $ self `elem` players
-                ]
+                (fst <$> V.toList shuffled)
+                (fromMaybe 0 $ V.findIndex ((self `elem`) . snd) shuffled)
                 (HMS.lookup self votes) in
     GameView
         { gameViewOpponents = opponents
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index ea6361c..df447c3 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -39,8 +39,8 @@ data TableView
     = Proposing BlackCard [WhiteCard]
     | Voting
         BlackCard
-        [WhiteCard]    -- ^ My proposal
         [[WhiteCard]]  -- ^ Proposals to vote for
+        Int            -- ^ My proposal
         (Maybe Int)    -- ^ My vote
     deriving (Show)
 
@@ -61,6 +61,7 @@ data ServerMessage
 data ClientMessage
     = ChangeMyName Text
     | ProposeWhiteCards [WhiteCard]
+    | SubmitVote Int
     deriving (Show)
 
 deriveBoth defaultOptions ''BlackCard
-- 
cgit v1.2.3