diff options
Diffstat (limited to '')
| -rw-r--r-- | client/src/Client.elm | 66 | ||||
| -rw-r--r-- | client/src/Messages.elm | 9 | ||||
| -rw-r--r-- | client/style.css | 13 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 31 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 3 |
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 |