Multiple \BLANK in black cards

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