aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--client/src/Client.elm8
-rw-r--r--client/src/Messages.elm15
-rw-r--r--server/cafp.cabal1
-rw-r--r--server/lib/Cafp/Game.hs50
-rw-r--r--server/lib/Cafp/Messages.hs24
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