Some logic

5 files changed, 53 insertions, 12 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 5c6d167..194fd80 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -72,11 +72,17 @@ view model = case model of
                 [Html.text "change"]
             ]
         ] ++
-        (case game.view.blackCard of
-            Nothing -> []
-            Just c -> [blackCard game.cards c]) ++
+        [viewTable game.cards game.view.table] ++
         (List.map (whiteCard game.cards) game.view.hand)
 
+viewTable : Cards -> Messages.TableView -> Html a
+viewTable cards (Messages.Proposing c my) = Html.div [] <|
+    [ blackCard cards c
+    ] ++
+    (case my of
+        Nothing -> []
+        Just mc -> [whiteCard cards mc])
+
 blackCard : Cards -> Messages.BlackCard -> Html a
 blackCard cards (Messages.BlackCard idx) =
     let blank = Html.span [Html.Attributes.class "blank"] [] in
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 15a0d1c..69d0eff 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -56,19 +56,33 @@ jsonEncCards  val =
 
 
 
+type TableView  =
+    Proposing BlackCard (Maybe 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))))
+
+
+jsonEncTableView : TableView -> Value
+jsonEncTableView (Proposing v1 v2) =
+    Json.Encode.list identity [jsonEncBlackCard v1, (maybeEncode (jsonEncWhiteCard)) v2]
+
+
+
 type alias GameView  =
    { opponents: (List String)
    , myName: String
-   , blackCard: (Maybe BlackCard)
+   , table: TableView
    , hand: (List WhiteCard)
    }
 
 jsonDecGameView : Json.Decode.Decoder ( GameView )
 jsonDecGameView =
-   Json.Decode.succeed (\popponents pmyName pblackCard phand -> {opponents = popponents, myName = pmyName, blackCard = pblackCard, hand = phand})
+   Json.Decode.succeed (\popponents pmyName ptable phand -> {opponents = popponents, myName = pmyName, table = ptable, hand = phand})
    |> required "opponents" (Json.Decode.list (Json.Decode.string))
    |> required "myName" (Json.Decode.string)
-   |> fnullable "blackCard" (jsonDecBlackCard)
+   |> required "table" (jsonDecTableView)
    |> required "hand" (Json.Decode.list (jsonDecWhiteCard))
 
 jsonEncGameView : GameView -> Value
@@ -76,7 +90,7 @@ jsonEncGameView  val =
    Json.Encode.object
    [ ("opponents", (Json.Encode.list Json.Encode.string) val.opponents)
    , ("myName", Json.Encode.string val.myName)
-   , ("blackCard", (maybeEncode (jsonEncBlackCard)) val.blackCard)
+   , ("table", jsonEncTableView val.table)
    , ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand)
    ]
 
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index 740eac5..3a67ef6 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -27,16 +27,26 @@ import qualified Data.Text           as T
 
 type PlayerId = Int
 
+data Table
+    = TableProposing BlackCard (HMS.HashMap PlayerId WhiteCard)
+    deriving (Show)
+
 data Game = Game
     { _gameCards        :: !Cards
-    , _gamePlayers      :: !(HMS.HashMap Int Text)
+    , _gamePlayers      :: !(HMS.HashMap PlayerId Text)
+    , _gameTable        :: !Table
     , _gameNextPlayerId :: !Int
     } deriving (Show)
 
 makeLenses ''Game
 
 newGame :: Cards -> Game
-newGame cards = Game cards HMS.empty 1
+newGame cards = Game
+    { _gameCards        = cards
+    , _gamePlayers      = HMS.empty
+    , _gameTable        = TableProposing (BlackCard 0) HMS.empty
+    , _gameNextPlayerId = 1
+    }
 
 joinGame :: Game -> (PlayerId, Game)
 joinGame game =
@@ -57,10 +67,14 @@ processClientMessage pid msg game = case msg of
 gameViewForPlayer :: PlayerId -> Game -> GameView
 gameViewForPlayer self game =
     let opponents = map snd . HMS.toList . HMS.delete self $ game ^. gamePlayers
-        name = fromMaybe "" $ game ^. gamePlayers . at self in
+        name = fromMaybe "" $ game ^. gamePlayers . at self
+
+        table = case game ^. gameTable of
+            TableProposing black proposals ->
+                Proposing black (HMS.lookup self proposals) in
     GameView
         { gameViewOpponents = opponents
         , gameViewMyName    = name
-        , gameViewBlackCard = Just $ BlackCard 0
+        , gameViewTable     = table
         , gameViewHand      = [WhiteCard x | x <- [0 .. 9]]
         }
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 7900b1c..677bc5c 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -13,6 +13,7 @@ main = putStrLn $ makeElmModule "Messages"
     [ DefineElm (Proxy :: Proxy BlackCard)
     , DefineElm (Proxy :: Proxy WhiteCard)
     , DefineElm (Proxy :: Proxy Cards)
+    , DefineElm (Proxy :: Proxy TableView)
     , DefineElm (Proxy :: Proxy GameView)
     , DefineElm (Proxy :: Proxy ServerMessage)
     , DefineElm (Proxy :: Proxy ClientMessage)
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index 219efb4..de0ae26 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -3,6 +3,7 @@ module Cafp.Messages
     ( BlackCard (..)
     , WhiteCard (..)
     , Cards (..)
+    , TableView (..)
     , GameView (..)
     , ServerMessage (..)
     , ClientMessage (..)
@@ -20,10 +21,14 @@ data Cards = Cards
     , cardsWhite :: [Text]
     } deriving (Show)
 
+data TableView
+    = Proposing BlackCard (Maybe WhiteCard)
+    deriving (Show)
+
 data GameView = GameView
     { gameViewOpponents :: [Text]
     , gameViewMyName    :: Text
-    , gameViewBlackCard :: Maybe BlackCard
+    , gameViewTable     :: TableView
     , gameViewHand      :: [WhiteCard]
     } deriving (Show)
 
@@ -41,6 +46,7 @@ data ClientMessage
 deriveBoth defaultOptions ''BlackCard
 deriveBoth defaultOptions ''WhiteCard
 deriveBoth (defaultOptionsDropLower 5) ''Cards
+deriveBoth defaultOptions ''TableView
 deriveBoth (defaultOptionsDropLower 8) ''GameView
 deriveBoth defaultOptions ''ServerMessage
 deriveBoth defaultOptions ''ClientMessage