diff options
| -rw-r--r-- | client/src/Client.elm | 12 | ||||
| -rw-r--r-- | client/src/Messages.elm | 22 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 22 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/GenerateElmTypes.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 8 |
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 |