hanabi-dealer-0.3.2.0: Game/Hanabi/Client.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE CPP #-}
module Game.Hanabi.Client(client, Game.Hanabi.Msg.Options(..), Game.Hanabi.Msg.defaultOptions, mkDS) where
import Game.Hanabi hiding (main, rule)
import Game.Hanabi.Msg
import Data.Aeson hiding (Success)
import GHC.Generics hiding (K1)
import Data.Bool
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Maybe(fromJust)
import Data.List(intersperse)
import Miso hiding (Fail)
import Miso.String (MisoString)
import qualified Miso.String as S
#ifdef IOS
import Language.Javascript.JSaddle.WKWebView as JSaddle
runApp :: JSM () -> IO ()
runApp = JSaddle.run
#else
import Language.Javascript.JSaddle.Warp as JSaddle
runApp :: JSM () -> IO ()
runApp = JSaddle.run 8080 -- 8720
#endif
-- Miso's implementation of WebSockets uses global IORef.
-- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs
client :: Game.Hanabi.Msg.Options -> IO ()
client options = runApp $ startApp App{
model = Model{tboxval = Message "available", players = ["via WebSocket"], rule = defaultRule, received = [], fullHistory = False},
update = updateModel,
view = appView strNames $ version options,
subs = [ websocketSub uri protocols HandleWebSocket ],
events = defaultEvents,
initialAction = Id,
-- initialAction = SendMessage $ Message "available", -- Seemingly sending as initialAction does not work, even if connect is executed before send.
mountPoint = Nothing}
where strNames = "via WebSocket" : [ S.pack name | (name, _) <- strategies options ]
#ifdef URI
uri = URL URI
#else
-- uri = URL "ws://133.54.228.39:8720"
uri = URL "ws://localhost:8720"
#endif
protocols = Protocols []
{- At last, I chose to hide the history by default.
lenHistory = 400
-- A better approach might be
-- 1. to send the history to a separate frame after the endgame
-- 2. to memoize renderMsg
-- Also, `observe' should not send to the current player.
-}
updateModel :: Action -> Model -> Effect Action Model
updateModel (HandleWebSocket (WebSocketMessage (Message m))) model
= noEff model{ received = {- take lenHistory $ -} decodeMsg m : received model }
updateModel (SendMessage msg) model = model{fullHistory=False} <# (-- connect uri protocols >>
send msg >> return Id)
updateModel (UpdateTBoxVal m) model = noEff model{ tboxval = Message m }
updateModel IncreasePlayers model = noEff model{players = take 9 $ "via WebSocket" : players model}
updateModel DecreasePlayers model = noEff model{players = case players model of {n:ns@(_:_) -> ns; ns -> ns}}
updateModel (UpdatePlayer ix pl) model = noEff model{players = snd $ replaceNth ix pl $ players model}
updateModel (UpdateRule r) model | isRuleValid r = noEff model{rule=r}
updateModel Toggle model = noEff model{fullHistory = not $ fullHistory model}
#ifdef DEBUG
updateModel (HandleWebSocket act) model = noEff model{received = Str (show act) : received model }
#endif
updateModel _ model = noEff model
instance ToJSON Message
instance FromJSON Message
newtype Message = Message MisoString
deriving (Eq, Show, Generic)
data Action
= HandleWebSocket (WebSocket Message)
| SendMessage Message
| UpdateTBoxVal MisoString
| IncreasePlayers
| DecreasePlayers
| UpdatePlayer Int MisoString
| UpdateRule Rule
| Toggle
| Id
data Model = Model {
tboxval :: Message
, players :: [MisoString]
, rule :: Rule
, received :: [Msg]
, fullHistory :: Bool
} deriving (Show, Eq)
lenShownHistory = 10
appView :: [MisoString] -> String -> Model -> View Action
appView strategies versionInfo mdl@Model{..} = div_ [] [
input_ [ type_ "text", placeholder_ "You can also use your keyboard.", size_ "25", onInput UpdateTBoxVal, onEnter (SendMessage tboxval) ]
, button_ [ onClick (SendMessage tboxval) ] [ text (S.pack "Send to the server") ]
-- x , span_ [style_ $ M.fromList [("font-size","10px")]] [text $ S.pack "(Use this line if you prefer the keyboard interface.)"]
, span_ [style_ $ M.fromList [("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo]
-- , hr_ []
, div_ [style_ $ M.fromList [("clear","both")]] ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbose mdl) received)
, div_ [] $ if null $ drop lenShownHistory received then [] else [
hr_ []
, input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory]
, label_ [for_ "showhist"] [text "Show full history"]
]
]
onEnter :: Action -> Attribute Action
onEnter action = onKeyDown $ bool Id action . (== KeyCode 13)
{-
#ifdef AESON
prettyDecode :: MisoString -> MisoString
prettyDecode str = case decode $ S.fromMisoString str of Nothing -> str
Just msg -> S.toMisoString $ encode $ prettyMsg verbose msg
#else
prettyDecode :: MisoString -> MisoString
prettyDecode str = case reads $ S.fromMisoString str of [] -> str
[(msg,_)] -> S.toMisoString $ prettyMsg verbose msg
#endif
render :: MisoString -> View Action
render str = case decode str' of Nothing -> text $ S.fromMisoString str
Just msg -> renderMsg verbose msg
where str' = S.fromMisoString str
-}
decodeMsg :: MisoString -> Msg
#ifdef AESON
decodeMsg str = case decode $ S.fromMisoString str of Nothing -> Str $ S.fromMisoString str
Just msg -> msg
#else
decodeMsg str = case reads $ S.fromMisoString str of [] -> Str $ S.fromMisoString str
[(msg,_)] -> msg
#endif
renderMsg :: [MisoString] -> Verbosity -> Model -> Msg -> View Action
renderMsg _ _ _ (Str xs) = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]]
renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms
renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m
renderMsg _ _ _ (PrettyEndGame Nothing) = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing]
renderMsg _ _ _ (PrettyEndGame (Just tup)) = renderEndGame tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup]
renderMsg strategies _ mdl (PrettyAvailable games)
= div_ [style_ $ M.fromList [("overflow","auto")]] [
hr_ [],
table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $
caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available"] [text $ S.pack "refresh"]] :
tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] :
map renderAvailable games,
div_ [] [
input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]],
div_ [] [
button_ [onClick IncreasePlayers] [text $ S.pack "+"],
button_ [onClick DecreasePlayers] [text $ S.pack "-"],
span_ [] $ intersperse (text ",") $ zipWith (renderPlayer strategies) [0..] $ players mdl,
button_ [onClick $ SendMessage $ Message $ S.pack $ "create " ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ players mdl)] [text $ S.pack "create a game"]
]
]
]
renderPlayer :: [MisoString] -> Int -> MisoString -> View Action
--renderPlayer _ i p = text p
renderPlayer strategies i p = select_ [onChange $ UpdatePlayer i] [ option_ [value_ p', selected_ $ p==p'] [text p'] | p' <- strategies ]
renderAvailable (gameid, (missing, total))
= tr_ [onClick $ SendMessage $ Message $ S.pack $ "attend "++show gameid] [ td_ [solid] [text $ S.pack str] | str <- [show gameid, show missing, show total] ]
solid = style_ $ M.fromList [("border-style","solid")]
renderWhatsUp verb name views@(v:_) moves = div_ [] [
hr_ [],
text $ S.pack "Your turn.",
hr_ [],
renderRecentEvents (publicView v) ithPlayer views moves,
hr_ [],
text $ S.pack $ "Algorithm: " ++ name,
renderPV verb v
]
renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action
renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000")]] [
hr_ [],
renderTrial (publicView v) (const "") undefined v m,
hr_ [],
renderPV verb v
]
renderEndGame :: (EndGame, [State], [Move]) -> View Action
renderEndGame (eg,sts@(st:_),mvs)
= div_ [] [
hr_ [],
renderRecentEvents (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs,
hr_ [],
h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000")]] [text $ S.pack $ show eg],
hr_ [],
renderSt ithPlayerFromTheLast st,
hr_ []
]
renderTrial :: PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action
renderTrial pub ithP i v m = div_ [] [
text $ S.pack $ ithP i ++ " move: " ++ {- replicate (length (ithP 2) - length (ithP i)) ' ' ++ -} show m
, case result $ publicView v of Discard c -> showResults c ", which revealed "
Success c -> showResults c ", which succeeded revealing "
Fail c -> showResults c ", which failed revealing "
_ -> text $ S.pack ""
]
where showResults c xs = span_ [] [
xs
-- , renderHand' verbose pub [Just c] [(Nothing,Nothing)]
, renderCardInline verbose pub c
, text $ S.pack "."
]
renderPI pub
{- This was too verbose
= let
showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), "
showDeck 1 = "1 card at the deck, "
showDeck n = shows n " cards at the deck, "
in "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n"
-}
= let
showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left), "
showDeck 1 = "Deck: 1, "
showDeck n = "Deck: " ++ shows n ", "
in div_ [] [
text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";",
div_ [] [
text $ S.pack $ "played:",
span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verbose pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ],
text $ S.pack "|"
],
div_ [] [
text $ S.pack $ "dropped: ",
span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verbose pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ],
text $ S.pack "|"
]
]
renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr verbose pub 0 (Just c) (Nothing,Nothing)]
renderRecentEvents :: PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action
renderRecentEvents pub ithP vs@(v:_) ms = div_ [] $ reverse $ zipWith3 (renderTrial pub $ ithP nump) [pred nump, nump-2..0] vs ms
where nump = numPlayers $ gameSpec $ publicView v
renderPV :: Verbosity -> PrivateView -> View Action
renderPV v pv@PV{publicView=pub} = div_ [] [
renderPI pub,
div_ [] (
-- div_ [] [text $ S.pack $ "My hand:"] :
-- renderCards v pub [ Nothing | _ <- myHand] myHand :
renderHand v pub (const "My") 0 [ Nothing | _ <- myHand] myHand :
-- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]
(zipWith3 (renderHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub)
)
]
where myHand = head (givenHints pub)
renderSt ithP st@St{publicState=pub} = div_ [] $
renderPI pub :
zipWith3 (renderHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub)
renderHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderHand v pub ithPnumP i mbcards hl = div_ [] [
div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"],
renderHand' v pub i mbcards hl
-- renderCards v pub (map Just cards) hl
]
renderHand' :: Verbosity -> PublicInfo -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderHand' v pub pli mbcards hl =
table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pub pli) [0..] mbcards hl)]
renderCard :: Verbosity -> PublicInfo -> Int -> Index -> Maybe Card -> (Maybe Color, Maybe Number) -> View Action
renderCard v pub pli i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"),
("color", colorStr $ fmap color mbc)]] [
maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc,
div_ [] [
cardStr v pub pli mbc tup
],
div_ [] [text $ S.pack $ if markHints v then maybe '_' (head . show) mc : [maybe '_' (head . show . fromEnum) mk] else "__" ],
maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'd':show i) ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc
]
{-
renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action
renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [
tr_ [style_ $ M.fromList [("background-color","#000000")]]
[
td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [
cardStr v pub mbc tup
]
| (mbc,tup) <- zip mbcs tups
],
tr_ [style_ $ M.fromList [("background-color","#000000")]]
[
td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [
text $ S.pack $ if markHints v then maybe ' ' (head . show) mc : [maybe ' ' (head . show . fromEnum) mk] else ""
]
| (mbc,(mc,mk)) <- zip mbcs tups
]
]
-}
-- Not sure which style is better.
#ifdef BUTTONSONCARDS
cardStr v pub pli mbc tup = case mbc of
Nothing -> span_ [] [text $ S.pack "??"]
Just c -> span_ [] [
-- text $ S.pack $ show c
button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c), style] [text $ S.pack $ take 1 $ show $ color c],
button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c), style][text $ S.pack $ show $ fromEnum $ number c]
]
where style = style_ $ M.fromList [
("font-weight", if markUseless v && isUseless pub c then "100"
else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),
("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal"), ("background-color","#000000"),("color", colorStr $ fmap color mbc)]
#else
cardStr v pub pli mbc tup = case mbc of
Nothing -> span_ [] [text $ S.pack "??"]
Just c -> span_ [style_ $ M.fromList [-- ("width","30px"),
("font-weight", if markUseless v && isUseless pub c then "100"
else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),
("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal")]] [
-- text $ S.pack $ show c
span_ [style_ $ M.fromList [("font-size","20px")],
onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c)] [text $ S.pack $ take 1 $ show $ color c],
span_ [style_ $ M.fromList [("font-size","20px")],
onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c)][text $ S.pack $ show $ fromEnum $ number c]
]
#endif
colorStr Nothing = "#00FFFF"
colorStr (Just White) = "#FFFFFF"
colorStr (Just Yellow) = "#FFFF00"
colorStr (Just Red) = "#FF4444"
colorStr (Just Green) = "#44FF44"
colorStr (Just Blue) = "#8888FF"
colorStr (Just Multicolor) = "#FF00FF"