Start voting phase

5 files changed, 79 insertions, 19 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 5170e64..246748b 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -94,6 +94,7 @@ view model = case model of
 tableBlackCard : GameState -> Maybe BlackCard
 tableBlackCard game = case game.view.table of
     Messages.Proposing b _ -> Just b
+    Messages.Voting b _ _ _ -> Just b
 
 selectedWhiteCards : GameState -> List WhiteCard
 selectedWhiteCards game = case game.view.table of
@@ -116,6 +117,13 @@ viewTable game = case game.view.table of
             ]
             [Html.text "Propose"]
         ]
+    Messages.Voting black myProposal proposals myVote -> Html.div [] <|
+        [ Html.h2 [] [Html.text "Your proposal"]
+        , blackCard game.cards black myProposal
+        ] ++
+        [ Html.h2 [] [Html.text "Opponent proposals"]
+        ] ++
+        List.map (blackCard game.cards black) proposals
 
 intersperseWith : List a -> a -> List a -> List a
 intersperseWith values def list = case list of
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 11c34ca..3979587 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -78,15 +78,22 @@ jsonEncOpponent  val =
 
 type TableView  =
     Proposing BlackCard (List WhiteCard)
+    | Voting BlackCard (List WhiteCard) (List (List WhiteCard)) (Maybe Int)
 
 jsonDecTableView : Json.Decode.Decoder ( TableView )
 jsonDecTableView =
-    Json.Decode.lazy (\_ -> Json.Decode.map2 Proposing (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecWhiteCard))))
-
+    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 (jsonDecWhiteCard))) (Json.Decode.index 2 (Json.Decode.list (Json.Decode.list (jsonDecWhiteCard)))) (Json.Decode.index 3 (Json.Decode.maybe (Json.Decode.int)))))
+            ]
+    in  decodeSumObjectWithSingleField  "TableView" jsonDecDictTableView
 
 jsonEncTableView : TableView -> Value
-jsonEncTableView (Proposing v1 v2) =
-    Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncWhiteCard) v2]
+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 jsonEncWhiteCard) v2, (Json.Encode.list (Json.Encode.list jsonEncWhiteCard)) v3, (maybeEncode (Json.Encode.int)) v4]))
+    in encodeSumObjectWithSingleField keyval val
 
 
 
diff --git a/server/cafp.cabal b/server/cafp.cabal
index e4d4194..14ef7ad 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -26,6 +26,7 @@ Library
     base                 >= 4.9  && < 5,
     bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
+    hashable             >= 1.3  && < 1.4,
     lens                 >= 4.18 && < 4.19,
     mtl                  >= 2.2  && < 2.3,
     random               >= 1.1  && < 1.2,
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index fa1c4aa..16350ab 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -36,13 +36,22 @@ import           VectorShuffling.Immutable (shuffle)
 
 type PlayerId = Int
 
+type Proposal = [WhiteCard]
+
 data Table
-    = TableProposing BlackCard (HMS.HashMap PlayerId [WhiteCard])
+    = TableProposing
+        !BlackCard
+        !(HMS.HashMap PlayerId Proposal)
+    | TableVoting
+        !BlackCard
+        !(HMS.HashMap PlayerId Proposal)
+        !(V.Vector (Proposal, [PlayerId]))
+        !(HMS.HashMap PlayerId Int)
     deriving (Show)
 
 data Player = Player
-    { _playerName :: Text
-    , _playerHand :: [WhiteCard]
+    { _playerName :: !Text
+    , _playerHand :: !(V.Vector WhiteCard)
     } deriving (Show)
 
 data Game = Game
@@ -97,7 +106,7 @@ joinGame :: Game -> (PlayerId, Game)
 joinGame = runState $ do
     pid <- gameNextPlayerId %%= (\x -> (x, x + 1))
     let name = "Player " <> T.pack (show pid)
-    hand <- replicateM 6 popWhiteCard
+    hand <- V.replicateM 6 popWhiteCard
     gamePlayers %= HMS.insert pid (Player name hand)
     pure pid
 
@@ -108,20 +117,34 @@ blackCardBlanks :: Cards -> BlackCard -> Int
 blackCardBlanks cards (BlackCard c) =
     maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c
 
+stepGame :: Game -> Game
+stepGame game = case game ^. gameTable of
+    TableProposing black proposals
+        | HMS.null ((game ^. gamePlayers) `HMS.difference` proposals) ->
+            let proposalsMap = HMS.fromListWith (++) $ do
+                    (pid, proposal) <- HMS.toList proposals
+                    pure (proposal, [pid])
+                (shuffled, seed) = shuffle
+                    (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in
+            game & gameSeed .~ seed
+                & gameTable .~ TableVoting black proposals shuffled HMS.empty
+        | otherwise -> game
+    TableVoting _ _ _ _ -> game
+
 processClientMessage :: PlayerId -> ClientMessage -> Game -> Game
 processClientMessage pid msg game = case msg of
     ChangeMyName name ->
         game & gamePlayers . ix pid . playerName .~ name
     ProposeWhiteCards cs
-        -- Bad card(s) proposed.
+        -- 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
-        -- TODO: Check that the card is in the hand of the player.
-        | otherwise                                  ->
+        -- All good.
+        | otherwise -> stepGame $
             game & gameTable . _TableProposing . _2 . at pid .~ Just cs
   where
     hand = game ^.. gamePlayers . ix pid . playerHand . traverse
@@ -133,15 +156,24 @@ 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
 
         player = game ^. gamePlayers . at self
 
         table = case game ^. gameTable of
             TableProposing black proposals ->
-                Proposing black . fromMaybe [] $ HMS.lookup self proposals in
+                Proposing black . fromMaybe [] $ HMS.lookup self proposals
+            TableVoting black proposals shuffled votes -> Voting
+                black
+                (fromMaybe [] $ HMS.lookup self proposals)
+                [ proposal
+                | (proposal, players) <- V.toList shuffled
+                , not $ self `elem` players
+                ]
+                (HMS.lookup self votes) in
     GameView
         { gameViewOpponents = opponents
         , gameViewMyName    = maybe "" (^. playerName) player
         , gameViewTable     = table
-        , gameViewHand      = maybe [] (^. playerHand) player
+        , gameViewHand      = player ^.. traverse . playerHand . traverse
         }
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index aae49cc..ea6361c 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Cafp.Messages
     ( BlackCard (..)
@@ -10,17 +11,23 @@ module Cafp.Messages
     , ClientMessage (..)
     ) where
 
-import           Data.Text   (Text)
-import           Data.Vector (Vector)
+import           Data.Hashable (Hashable)
+import           Data.Text     (Text)
+import           Data.Vector   (Vector)
 import           Elm.Derive
+import           GHC.Generics  (Generic)
 
-data BlackCard = BlackCard Int deriving (Eq, Show)
+data BlackCard = BlackCard Int deriving (Eq, Generic, Show)
 
-data WhiteCard = WhiteCard Int deriving (Eq, Show)
+instance Hashable BlackCard
+
+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
@@ -30,6 +37,11 @@ data Opponent = Opponent
 
 data TableView
     = Proposing BlackCard [WhiteCard]
+    | Voting
+        BlackCard
+        [WhiteCard]    -- ^ My proposal
+        [[WhiteCard]]  -- ^ Proposals to vote for
+        (Maybe Int)    -- ^ My vote
     deriving (Show)
 
 data GameView = GameView