Submit votes

5 files changed, 95 insertions, 27 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 246748b..aa6194e 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -23,6 +23,9 @@ type Msg
     -- Card selection
     | SelectWhiteCard WhiteCard
     | ProposeWhiteCards
+    -- Voting
+    | SelectVote Int
+    | SubmitVote
 
 type alias Cards = {black : Array String, white : Array String}
 
@@ -31,6 +34,7 @@ type alias GameState =
     , view : GameView
     , changeMyName : String
     , selectedWhiteCards : List WhiteCard
+    , selectedVote : Maybe Int
     }
 
 type Model
@@ -107,7 +111,7 @@ cardIsSelected game card = List.member card <| selectedWhiteCards game
 viewTable : GameState -> Html Msg
 viewTable game = case game.view.table of
     Messages.Proposing c my -> Html.div [] <|
-        [ blackCard game.cards c <| selectedWhiteCards game
+        [ blackCard [] game.cards c <| selectedWhiteCards game
         , Html.button
             [ Html.Attributes.disabled <|
                 List.length my > 0 ||
@@ -117,13 +121,31 @@ 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
-        ] ++
+    Messages.Voting black proposals myProposal myVote -> Html.div [] <|
         [ Html.h2 [] [Html.text "Opponent proposals"]
         ] ++
-        List.map (blackCard game.cards black) proposals
+        List.indexedMap (\i proposal ->
+            let attrs =
+                    if i == myProposal then
+                        [Html.Attributes.class "mine"]
+                    else if Just i == myVote || Just i == game.selectedVote then
+                        [Html.Attributes.class "voted"]
+                    else
+                        [ Html.Events.onClick <| SelectVote i
+                        , Html.Attributes.class "votable"
+                        ] in
+            blackCard attrs game.cards black proposal) proposals ++
+        [ Html.button
+            [ Html.Attributes.disabled <|
+                (case myVote of
+                     Just _ -> True
+                     Nothing -> case game.selectedVote of
+                         Just _ -> False
+                         Nothing -> True)
+            , Html.Events.onClick SubmitVote
+            ]
+            [Html.text "Vote"]
+        ]
 
 intersperseWith : List a -> a -> List a -> List a
 intersperseWith values def list = case list of
@@ -141,12 +163,14 @@ blackCardBlanks : Cards -> BlackCard -> Int
 blackCardBlanks cards c = List.length (blackCardContent cards c) - 1
 
 capitalizeFirst : List String -> List String
-capitalizeFirst l = case l of
-    x :: xs -> (String.toUpper (String.left 1 x) ++ String.dropLeft 1 x) :: xs
-    _ -> l
+capitalizeFirst = List.indexedMap <| \i x -> if i == 0
+    then String.toUpper (String.left 1 x) ++ String.dropLeft 1 x
+    else x
 
-blackCard : Cards -> BlackCard -> List WhiteCard -> Html a
-blackCard cards black whites =
+blackCard
+    : List (Html.Attribute a) -> Cards -> BlackCard -> List WhiteCard
+    -> Html a
+blackCard attrs cards black whites =
     let blackParts = blackCardContent cards black
         whiteParts = List.map (whiteCardContent cards) whites |>
             case blackParts of
@@ -155,7 +179,8 @@ blackCard cards black whites =
         blank txt = Html.span
             [Html.Attributes.class "blank"]
             [Html.text txt] in
-    Html.div [Html.Attributes.class "card", Html.Attributes.class "black"] <|
+    Html.div
+        (List.map Html.Attributes.class ["card", "black"] ++ attrs) <|
     intersperseWith (List.map blank whiteParts) (blank "") <|
     List.map Html.text blackParts
 
@@ -198,6 +223,7 @@ update msg model = case msg of
                             , view = gameView
                             , changeMyName = gameView.myName
                             , selectedWhiteCards = []
+                            , selectedVote = Nothing
                             }
                         , Cmd.none
                         )
@@ -237,6 +263,22 @@ update msg model = case msg of
             )
         _ -> (model, Cmd.none)
 
+    SelectVote i -> case model of
+        Game game -> case game.view.table of
+            Messages.Voting _ _ _ Nothing ->
+                (Game {game | selectedVote = Just i}, Cmd.none)
+            _ -> (model, Cmd.none)
+        _ -> (model, Cmd.none)
+
+    SubmitVote -> case model of
+        Game game -> case game.selectedVote of
+            Just vote ->
+                ( Game {game | selectedVote = Nothing}
+                , send <| Messages.SubmitVote vote
+                )
+            _ -> (model, Cmd.none)
+        _ -> (model, Cmd.none)
+
 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 3979587..40a04a2 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -78,13 +78,13 @@ jsonEncOpponent  val =
 
 type TableView  =
     Proposing BlackCard (List WhiteCard)
-    | Voting BlackCard (List WhiteCard) (List (List WhiteCard)) (Maybe Int)
+    | Voting BlackCard (List (List WhiteCard)) Int (Maybe Int)
 
 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 (jsonDecWhiteCard))) (Json.Decode.index 2 (Json.Decode.list (Json.Decode.list (jsonDecWhiteCard)))) (Json.Decode.index 3 (Json.Decode.maybe (Json.Decode.int)))))
+            , ("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)))))
             ]
     in  decodeSumObjectWithSingleField  "TableView" jsonDecDictTableView
 
@@ -92,7 +92,7 @@ jsonEncTableView : TableView -> Value
 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]))
+                    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]))
     in encodeSumObjectWithSingleField keyval val
 
 
@@ -153,12 +153,14 @@ jsonEncServerMessage  val =
 type ClientMessage  =
     ChangeMyName String
     | ProposeWhiteCards (List WhiteCard)
+    | SubmitVote Int
 
 jsonDecClientMessage : Json.Decode.Decoder ( ClientMessage )
 jsonDecClientMessage =
     let jsonDecDictClientMessage = Dict.fromList
             [ ("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)))
             ]
     in  decodeSumObjectWithSingleField  "ClientMessage" jsonDecDictClientMessage
 
@@ -167,6 +169,7 @@ jsonEncClientMessage  val =
     let keyval v = case v of
                     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))
     in encodeSumObjectWithSingleField keyval val
 
 
diff --git a/client/style.css b/client/style.css
index 8552c63..4a134c6 100644
--- a/client/style.css
+++ b/client/style.css
@@ -12,6 +12,19 @@ html {
   background: black;
 }
 
+.votable {
+  cursor: pointer;
+}
+
+.mine {
+  background: #444444;
+  color: #dddddd;
+}
+
+.voted {
+  background: #003300;
+}
+
 .white {
   color: black;
   background: white;
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