diff options
| -rw-r--r-- | client/src/Client.elm | 8 | ||||
| -rw-r--r-- | client/src/Messages.elm | 15 | ||||
| -rw-r--r-- | server/cafp.cabal | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 50 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 24 |
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 |