aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/src/Client.elm14
-rw-r--r--client/src/Messages.elm39
-rw-r--r--client/style.css13
-rw-r--r--server/lib/Cafp/Game.hs6
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs4
-rw-r--r--server/lib/Cafp/Main/Server.hs4
-rw-r--r--server/lib/Cafp/Messages.hs13
7 files changed, 75 insertions, 18 deletions
diff --git a/client/src/Client.elm b/client/src/Client.elm
index efd97fb..41871e9 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -70,16 +70,22 @@ view model = case model of
] ++
(case game.view.blackCard of
Nothing -> []
- Just c -> [blackCard c])
+ Just c -> [blackCard c]) ++
+ (List.map whiteCard game.view.hand)
-blackCard : String -> Html a
-blackCard string =
+blackCard : Messages.BlackCard -> Html a
+blackCard (Messages.BlackCard string) =
let blank = Html.span [Html.Attributes.class "blank"] [] in
- Html.div [Html.Attributes.class "black"] <|
+ Html.div [Html.Attributes.class "card", Html.Attributes.class "black"] <|
List.intersperse blank <|
List.map Html.text <|
String.split "\\BLANK" string
+whiteCard : Messages.WhiteCard -> Html a
+whiteCard (Messages.WhiteCard string) = Html.div
+ [Html.Attributes.class "card", Html.Attributes.class "white"]
+ [Html.text string]
+
subscriptions : Model -> Sub Msg
subscriptions model = webSocketIn WebSocketIn
diff --git a/client/src/Messages.elm b/client/src/Messages.elm
index 77b3830..d2c2716 100644
--- a/client/src/Messages.elm
+++ b/client/src/Messages.elm
@@ -8,25 +8,56 @@ import Dict exposing (Dict)
import Set exposing (Set)
+type BlackCard =
+ BlackCard String
+
+jsonDecBlackCard : Json.Decode.Decoder ( BlackCard )
+jsonDecBlackCard =
+ Json.Decode.lazy (\_ -> Json.Decode.map BlackCard (Json.Decode.string))
+
+
+jsonEncBlackCard : BlackCard -> Value
+jsonEncBlackCard (BlackCard v1) =
+ Json.Encode.string v1
+
+
+
+type WhiteCard =
+ WhiteCard String
+
+jsonDecWhiteCard : Json.Decode.Decoder ( WhiteCard )
+jsonDecWhiteCard =
+ Json.Decode.lazy (\_ -> Json.Decode.map WhiteCard (Json.Decode.string))
+
+
+jsonEncWhiteCard : WhiteCard -> Value
+jsonEncWhiteCard (WhiteCard v1) =
+ Json.Encode.string v1
+
+
+
type alias GameView =
{ opponents: (List String)
, myName: String
- , blackCard: (Maybe String)
+ , blackCard: (Maybe BlackCard)
+ , hand: (List WhiteCard)
}
jsonDecGameView : Json.Decode.Decoder ( GameView )
jsonDecGameView =
- Json.Decode.succeed (\popponents pmyName pblackCard -> {opponents = popponents, myName = pmyName, blackCard = pblackCard})
+ Json.Decode.succeed (\popponents pmyName pblackCard phand -> {opponents = popponents, myName = pmyName, blackCard = pblackCard, hand = phand})
|> required "opponents" (Json.Decode.list (Json.Decode.string))
|> required "myName" (Json.Decode.string)
- |> fnullable "blackCard" (Json.Decode.string)
+ |> fnullable "blackCard" (jsonDecBlackCard)
+ |> required "hand" (Json.Decode.list (jsonDecWhiteCard))
jsonEncGameView : GameView -> Value
jsonEncGameView val =
Json.Encode.object
[ ("opponents", (Json.Encode.list Json.Encode.string) val.opponents)
, ("myName", Json.Encode.string val.myName)
- , ("blackCard", (maybeEncode (Json.Encode.string)) val.blackCard)
+ , ("blackCard", (maybeEncode (jsonEncBlackCard)) val.blackCard)
+ , ("hand", (Json.Encode.list jsonEncWhiteCard) val.hand)
]
diff --git a/client/style.css b/client/style.css
index fd26c52..6cd9f5d 100644
--- a/client/style.css
+++ b/client/style.css
@@ -2,11 +2,20 @@ html {
font-size: 18px;
}
+.card {
+ padding: 18px;
+ border-radius: 18px;
+}
+
.black {
color: white;
background: black;
- padding: 18px;
- border-radius: 18px;
+}
+
+.white {
+ color: black;
+ background: white;
+ border: 2px solid black;
}
.blank {
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs
index a083e57..ad33368 100644
--- a/server/lib/Cafp/Game.hs
+++ b/server/lib/Cafp/Game.hs
@@ -26,8 +26,8 @@ import qualified Data.Text as T
type PlayerId = Int
data Cards = Cards
- { _cardsBlack :: [T.Text]
- , _cardsWhite :: [T.Text]
+ { _cardsBlack :: [BlackCard]
+ , _cardsWhite :: [WhiteCard]
} deriving (Show)
data Game = Game
@@ -50,7 +50,6 @@ joinGame game =
, game & gameNextPlayerId %~ succ & gamePlayers %~ HMS.insert pid name
)
-
leaveGame :: PlayerId -> Game -> Game
leaveGame pid = over gamePlayers $ HMS.delete pid
@@ -67,4 +66,5 @@ gameViewForPlayer self game =
{ gameViewOpponents = opponents
, gameViewMyName = name
, gameViewBlackCard = game ^? gameCards . cardsBlack . ix 0
+ , gameViewHand = take 10 $ game ^. gameCards . cardsWhite
}
diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs
index 9c72027..51376a5 100644
--- a/server/lib/Cafp/Main/GenerateElmTypes.hs
+++ b/server/lib/Cafp/Main/GenerateElmTypes.hs
@@ -10,7 +10,9 @@ import Elm.Module
main :: IO ()
main = putStrLn $ makeElmModule "Messages"
- [ DefineElm (Proxy :: Proxy GameView)
+ [ DefineElm (Proxy :: Proxy BlackCard)
+ , DefineElm (Proxy :: Proxy WhiteCard)
+ , DefineElm (Proxy :: Proxy GameView)
, DefineElm (Proxy :: Proxy ServerMessage)
, DefineElm (Proxy :: Proxy ClientMessage)
]
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index eae887e..3edf039 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -46,8 +46,8 @@ data Server = Server
readCards :: IO Cards
readCards = Cards
- <$> fmap T.lines (T.readFile "assets/black.txt")
- <*> fmap T.lines (T.readFile "assets/white.txt")
+ <$> fmap (map BlackCard . T.lines) (T.readFile "assets/black.txt")
+ <*> fmap (map WhiteCard . T.lines) (T.readFile "assets/white.txt")
newServer :: IO Server
newServer = Server <$> readCards <*> atomically (STM.newTVar HMS.empty)
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index 3e345f2..542189f 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE TemplateHaskell #-}
module Cafp.Messages
- ( GameView (..)
+ ( BlackCard (..)
+ , WhiteCard (..)
+ , GameView (..)
, ServerMessage (..)
, ClientMessage (..)
) where
@@ -8,10 +10,15 @@ module Cafp.Messages
import Data.Text (Text)
import Elm.Derive
+data BlackCard = BlackCard Text deriving (Show)
+
+data WhiteCard = WhiteCard Text deriving (Show)
+
data GameView = GameView
{ gameViewOpponents :: [Text]
, gameViewMyName :: Text
- , gameViewBlackCard :: Maybe Text
+ , gameViewBlackCard :: Maybe BlackCard
+ , gameViewHand :: [WhiteCard]
} deriving (Show)
data ServerMessage
@@ -24,6 +31,8 @@ data ClientMessage
= ChangeMyName Text
deriving (Show)
+deriveBoth defaultOptions ''BlackCard
+deriveBoth defaultOptions ''WhiteCard
deriveBoth (defaultOptionsDropLower 8) ''GameView
deriveBoth defaultOptions ''ServerMessage
deriveBoth defaultOptions ''ClientMessage
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-31 21:19:58 +0000