aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--black.txt1
-rw-r--r--client/src/Client.elm61
-rw-r--r--client/src/Messages.elm12
-rw-r--r--server/lib/Cafp/Game.hs25
-rw-r--r--server/lib/Cafp/Main/Server.hs7
-rw-r--r--server/lib/Cafp/Messages.hs4
6 files changed, 68 insertions, 42 deletions
diff --git a/black.txt b/black.txt
index 0c886bd..622edfc 100644
--- a/black.txt
+++ b/black.txt
@@ -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