aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--client/src/Client.elm66
-rw-r--r--client/src/Messages.elm9
-rw-r--r--client/style.css13
-rw-r--r--server/lib/Cafp/Game.hs31
-rw-r--r--server/lib/Cafp/Messages.hs3
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