aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-30 22:07:37 +0200
committerJasper Van der Jeugt2020-07-30 22:07:37 +0200
commitc92c0f65c733c9aba5c56313a4bc313a299e1230 (patch)
treec5bb44d969ac2b91e664e1235b00278cdece11d7
parentab1267a757bcc997f05cc9babe2d1fb9bb681ce4 (diff)
Some logic
-rw-r--r--client/src/Client.elm12
-rw-r--r--client/src/Messages.elm22
-rw-r--r--server/lib/Cafp/Game.hs22
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs1
-rw-r--r--server/lib/Cafp/Messages.hs8
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