diff options
| -rw-r--r-- | black.txt | 1 | ||||
| -rw-r--r-- | client/src/Client.elm | 61 | ||||
| -rw-r--r-- | client/src/Messages.elm | 12 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 25 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 7 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 4 |
6 files changed, 68 insertions, 42 deletions
@@ -1,3 +1,4 @@ +I link to think about \BLANK and \BLANK. # These are the old cards I copied. A crypto conference is never complete without \BLANK. A recent laboratory study shows that undergrads have 50\% less sex after being exposed to \BLANK. diff --git a/client/src/Client.elm b/client/src/Client.elm index 178e406..9639ec9 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -30,7 +30,7 @@ type alias GameState = { cards : Cards , view : GameView , changeMyName : String - , selectedWhiteCard : Maybe WhiteCard + , selectedWhiteCards : List WhiteCard } type Model @@ -89,26 +89,27 @@ view model = case model of (\c -> whiteCard game.cards c (cardIsSelected game c)) game.view.hand) -selectedWhiteCard : GameState -> Maybe WhiteCard -selectedWhiteCard game = case game.view.table of - Messages.Proposing _ (Just my) -> Just my - _ -> game.selectedWhiteCard +tableBlackCard : GameState -> Maybe BlackCard +tableBlackCard game = case game.view.table of + Messages.Proposing b _ -> Just b + +selectedWhiteCards : GameState -> List WhiteCard +selectedWhiteCards game = case game.view.table of + Messages.Proposing _ (x :: xs) -> x :: xs + _ -> game.selectedWhiteCards cardIsSelected : GameState -> WhiteCard -> Bool -cardIsSelected game card = selectedWhiteCard game == Just card +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 <| case selectedWhiteCard game of - Nothing -> [] - Just wc -> [wc] + [ blackCard game.cards c <| selectedWhiteCards game , Html.button - [ Html.Attributes.disabled <| case my of - Just _ -> True - _ -> case selectedWhiteCard game of - Nothing -> True - Just _ -> False + [ Html.Attributes.disabled <| + List.length my > 0 || + List.length (selectedWhiteCards game) /= + blackCardBlanks game.cards c , Html.Events.onClick ProposeWhiteCards ] [Html.text "Propose"] @@ -122,8 +123,15 @@ intersperseWith values def list = case list of [] -> x :: def :: intersperseWith values def (y :: t) v :: vs -> x :: v :: intersperseWith vs def (y :: t) +blackCardContent : Cards -> BlackCard -> List String +blackCardContent cards (Messages.BlackCard idx) = + String.split "\\BLANK" <| Maybe.withDefault "" <| Array.get idx cards.black + +blackCardBlanks : Cards -> BlackCard -> Int +blackCardBlanks cards c = List.length (blackCardContent cards c) - 1 + blackCard : Cards -> BlackCard -> List WhiteCard -> Html a -blackCard cards (Messages.BlackCard idx) whites = +blackCard cards black whites = let blank mbWhite = Html.span [Html.Attributes.class "blank"] <| case mbWhite of @@ -131,9 +139,7 @@ blackCard cards (Messages.BlackCard idx) whites = Just w -> [Html.text <| whiteCardContent cards w] in Html.div [Html.Attributes.class "card", Html.Attributes.class "black"] <| intersperseWith (List.map (\c -> blank (Just c)) whites) (blank Nothing) <| - List.map Html.text <| - String.split "\\BLANK" <| Maybe.withDefault "" <| - Array.get idx cards.black + List.map Html.text <| blackCardContent cards black whiteCardContent : Cards -> WhiteCard -> String whiteCardContent cards (Messages.WhiteCard idx) = @@ -173,7 +179,7 @@ update msg model = case msg of { cards = {black = Array.empty, white = Array.empty} , view = gameView , changeMyName = gameView.myName - , selectedWhiteCard = Nothing + , selectedWhiteCards = [] } , Cmd.none ) @@ -194,15 +200,22 @@ update msg model = case msg of _ -> (model, Cmd.none) SelectWhiteCard card -> case model of - Game game -> (Game {game | selectedWhiteCard = Just card}, Cmd.none) + Game game -> + let cards = case List.member card game.selectedWhiteCards of + True -> List.filter (\c -> c /= card) game.selectedWhiteCards + False -> List.take + (case tableBlackCard game of + Nothing -> 0 + Just c -> blackCardBlanks game.cards c - 1) + game.selectedWhiteCards ++ + [card] in + (Game {game | selectedWhiteCards = cards}, Cmd.none) _ -> (model, Cmd.none) ProposeWhiteCards -> case model of Game game -> - ( Game {game | selectedWhiteCard = Nothing} - , case game.selectedWhiteCard of - Nothing -> Cmd.none - Just c -> send <| Messages.ProposeWhiteCards c + ( Game {game | selectedWhiteCards = []} + , send <| Messages.ProposeWhiteCards game.selectedWhiteCards ) _ -> (model, Cmd.none) diff --git a/client/src/Messages.elm b/client/src/Messages.elm index b38fbd5..11c34ca 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -77,16 +77,16 @@ jsonEncOpponent val = type TableView = - Proposing BlackCard (Maybe WhiteCard) + Proposing BlackCard (List WhiteCard) jsonDecTableView : Json.Decode.Decoder ( TableView ) jsonDecTableView = - Json.Decode.lazy (\_ -> Json.Decode.map2 Proposing (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.maybe (jsonDecWhiteCard)))) + Json.Decode.lazy (\_ -> Json.Decode.map2 Proposing (Json.Decode.index 0 (jsonDecBlackCard)) (Json.Decode.index 1 (Json.Decode.list (jsonDecWhiteCard)))) jsonEncTableView : TableView -> Value jsonEncTableView (Proposing v1 v2) = - Json.Encode.list identity [jsonEncBlackCard v1, (maybeEncode (jsonEncWhiteCard)) v2] + Json.Encode.list identity [jsonEncBlackCard v1, (Json.Encode.list jsonEncWhiteCard) v2] @@ -145,13 +145,13 @@ jsonEncServerMessage val = type ClientMessage = ChangeMyName String - | ProposeWhiteCards WhiteCard + | ProposeWhiteCards (List WhiteCard) 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 (jsonDecWhiteCard))) + , ("ProposeWhiteCards", Json.Decode.lazy (\_ -> Json.Decode.map ProposeWhiteCards (Json.Decode.list (jsonDecWhiteCard)))) ] in decodeSumObjectWithSingleField "ClientMessage" jsonDecDictClientMessage @@ -159,7 +159,7 @@ jsonEncClientMessage : ClientMessage -> Value jsonEncClientMessage val = let keyval v = case v of ChangeMyName v1 -> ("ChangeMyName", encodeValue (Json.Encode.string v1)) - ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue (jsonEncWhiteCard v1)) + ProposeWhiteCards v1 -> ("ProposeWhiteCards", encodeValue ((Json.Encode.list jsonEncWhiteCard) v1)) in encodeSumObjectWithSingleField keyval val diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 9c2d2e4..bb734a1 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -17,8 +17,9 @@ module Cafp.Game ) where import Cafp.Messages +import Debug.Trace import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), - (^?), _2) + (^?), _1, _2) import Control.Lens.TH (makeLenses, makePrisms) import Control.Monad (guard) import qualified Data.HashMap.Strict as HMS @@ -30,7 +31,7 @@ import qualified Data.Vector as V type PlayerId = Int data Table - = TableProposing BlackCard (HMS.HashMap PlayerId WhiteCard) + = TableProposing BlackCard (HMS.HashMap PlayerId [WhiteCard]) deriving (Show) data Game = Game @@ -62,6 +63,10 @@ joinGame game = leaveGame :: PlayerId -> Game -> Game leaveGame pid = over gamePlayers $ HMS.delete pid +blackCardBlanks :: Cards -> BlackCard -> Int +blackCardBlanks cards (BlackCard c) = + maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c + validWhiteCard :: Cards -> WhiteCard -> Bool validWhiteCard cards (WhiteCard c) = let len = V.length $ cardsWhite cards in c >= 0 && c < len @@ -70,14 +75,20 @@ processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of ChangeMyName name -> game & gamePlayers . ix pid .~ name - ProposeWhiteCards c - -- Bad card proposed. - | not $ validWhiteCard (game ^. gameCards) c -> game + ProposeWhiteCards cs + -- Bad card(s) proposed. + | any (not . validWhiteCard (game ^. gameCards)) 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 -> trace + ("bad length " ++ show (length cs) ++ + " expected " ++ show (blackCardBlanks (game ^. gameCards) b)) + game -- TODO: Check that the card is in the hand of the player. | otherwise -> - game & gameTable . _TableProposing . _2 . at pid .~ Just c + game & gameTable . _TableProposing . _2 . at pid .~ Just cs gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = @@ -91,7 +102,7 @@ gameViewForPlayer self game = table = case game ^. gameTable of TableProposing black proposals -> - Proposing black (HMS.lookup self proposals) in + Proposing black . fromMaybe [] $ HMS.lookup self proposals in GameView { gameViewOpponents = opponents , gameViewMyName = name diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 13b1f6b..3a99672 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -113,9 +113,10 @@ syncRoom room = do (game, sinks) <- atomically $ (,) <$> STM.readTVar (roomGame room) <*> STM.readTVar (roomSinks room) - warning $ "New state: " ++ show game - for_ (HMS.toList sinks) $ \(pid, sink) -> - sink . Aeson.encode . SyncGameView $ gameViewForPlayer pid game + for_ (HMS.toList sinks) $ \(pid, sink) -> do + let view = gameViewForPlayer pid game + warning $ "New state: " ++ show view + sink . Aeson.encode $ SyncGameView view wsApp :: Server -> WS.ServerApp wsApp server pc = case routePendingConnection pc of diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index dc17168..1b37380 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -29,7 +29,7 @@ data Opponent = Opponent } deriving (Show) data TableView - = Proposing BlackCard (Maybe WhiteCard) + = Proposing BlackCard [WhiteCard] deriving (Show) data GameView = GameView @@ -48,7 +48,7 @@ data ServerMessage data ClientMessage = ChangeMyName Text - | ProposeWhiteCards WhiteCard -- TODO: Needs to be a list? + | ProposeWhiteCards [WhiteCard] deriving (Show) deriveBoth defaultOptions ''BlackCard |