hanabi-dealer-0.15.1.1: Game/Hanabi/Client.hs
{-# LANGUAGE DeriveGeneric, RecordWildCards, OverloadedStrings, ExtendedDefaultRules, MultiParamTypeClasses, CPP #-}
module Game.Hanabi.Client(client,
#if !defined ghcjs_HOST_OS && !defined IOS
clientApp,
#endif
Game.Hanabi.Msg.Options(..), Game.Hanabi.Msg.defaultOptions, mkDS) where
import Game.Hanabi hiding (main, rule)
import qualified Game.Hanabi(rule)
import Game.Hanabi.Msg
import Data.Aeson hiding (Success)
import GHC.Generics hiding (K1, from)
import Data.Bool
import Data.Char(isSpace, isLower, toLower)
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Maybe(fromJust, isNothing, isJust)
import Data.List(sort, sortBy, intersperse, transpose, isPrefixOf)
import Data.Function(on)
import Miso hiding (Fail, on)
import Miso.String (MisoString)
import qualified Miso.String as S
import Miso.Subscription.History(getCurrentURI)
import Network.URI -- maybe this can conflict #define URI
import Control.Monad.IO.Class(liftIO)
import System.IO(hPutStrLn, stderr)
import System.Random
import Control.Concurrent
#ifdef DEBUG
import Debug.Trace
#endif
#ifdef ghcjs_HOST_OS
import Game.Hanabi.FFI
client :: Game.Hanabi.Msg.Options -> IO ()
client options = clientJSM options
#else
{-
When building with GHC,
1. miso has to be built with --flags="jsaddle" option;
2. the resulting executable does not work with Konqueror---use Firefox. (Cf. https://github.com/aveltras/arohi-skeleton/issues/1)
-}
# ifdef IOS
import Language.Javascript.JSaddle.WKWebView as JSaddle
client :: Game.Hanabi.Msg.Options -> IO ()
client options = JSaddle.run $ clientJSM options
# else
import Language.Javascript.JSaddle.WebSockets
import Network.Wai.Handler.Warp
import Network.Wai
import Network.WebSockets(defaultConnectionOptions)
{- This doesn't work.
client :: Game.Hanabi.Msg.Options -> IO ()
client options = runSettings (setPort 8080 (setTimeout 3600 defaultSettings)) $ clientApp options -- Maybe the port number should be taken from options, and it should be correctly set.
clientApp :: Game.Hanabi.Msg.Options -> Application
clientApp options request respond = do
app <- jsmToApp $ clientJSM options
app request respond
-}
client :: Game.Hanabi.Msg.Options -> IO ()
client options = runSettings (setPort 8080 (setTimeout 3600 defaultSettings)) =<< clientApp options -- Maybe the port number should be taken from options, and it should be correctly set.
clientApp :: Game.Hanabi.Msg.Options -> IO Application
clientApp = jsmToApp . clientJSM
jsmToApp :: JSM () -> IO Application
jsmToApp f = jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
# endif
#endif
-- Miso's implementation of WebSockets uses global IORef.
-- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs
clientJSM :: Game.Hanabi.Msg.Options -> JSM ()
clientJSM options = do thisURI <- getCurrentURI
let query = parseURIQuery thisURI
wsScheme | uriScheme thisURI == "https:" = "wss:"
| otherwise = "ws:"
wsURI = URL $ S.pack $ wsScheme ++ maybe uri (\_ -> "//localhost:8720") (lookup "localhost" query)
defStr = maybe "via WebSocket" id $ lookup "strategy" query
langStr = maybe "en" id $ lookup "lang" query
lang | "ja" `isPrefixOf` map toLower langStr = Ja
| otherwise = En
mvStr <- liftIO newMVarStrategy
liftIO $ hPutStrLn stderr "Preloading algorithms.... This should not take long on the client Javascript. Please contact the author if it does."
constrAssoc <- liftIO $ mapM sequenceA [ (name, crs $ lazy options) | (name, Just crs) <- strategies options]
liftIO $ hPutStrLn stderr "Done."
startApp App{
model = Model{tboxval = Message "available", players = [S.pack defStr], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, received = [CreateGame], shownHistory = defaultShownHistory, showVerbosity = False, verbosity = verbose,
language = lang, contrast = Colorful, play = True, localStrategy = mvStr, local = False, initialDeck = [], lastMoves = [], preset = False, forceLocal = False, numRepeats = 1, scores = []},
update = updateModel constrAssoc,
view = appView strNames $ version options,
#ifdef ghcjs_HOST_OS
subs = [ websocketSub wsURI protocols HandleWebSocket, windowBottomSub ViewMore Id ],
#else
# ifdef ALL
subs = [ websocketSub wsURI protocols HandleWebSocket ],
# else
subs = [],
# endif
#endif
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 WSURI
uri = WSURI
#else
-- uri = URL "//133.54.228.39:8720"
uri = "//localhost:8720"
#endif
protocols = Protocols []
parseURIQuery :: URI -> [(String,String)]
parseURIQuery = parseQ . drop 1 . uriQuery
parseQ str
= case span (/='&') str of
(tk,[]) -> [parseField tk]
(tk,_:dr) -> parseField tk : parseQ dr
parseField str
= case span (/='=') str of
(tk,dr) -> (decodeString tk, decodeString $ drop 1 dr)
decodeString = map decoS . unEscapeString
decoS '+' = ' '
decoS c = c
{- 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 :: [(String, (IO (DynamicStrategy IO)))] -> Action -> Model -> Effect Action Model
updateModel _ (HandleWebSocket (WebSocketMessage (Message m))) model
| not $ local model -- ignore the message while playing locally. (There might be a better option, but at least any confusion should be avoided.)
= noEff model{ received = {- take lenHistory $ -} sortRecent $ suppressCG $ decodeMsg m : received model }
updateModel _ (SendMessage msg@(Message str)) model = model{shownHistory=defaultShownHistory, showVerbosity=False} <# -- connect uri protocols >>
if forceLocal model || local model
then case reads $ S.unpack str of
[(m,str)] -> liftIO $ do
putMVar (mvMov $ localStrategy model) m
msg <- takeMVar (mvMsg $ localStrategy model)
return $ ProcMsg msg
_ | str == "available" -> return Id -- Just ignore when trying to send "available" but it is local yet.
| otherwise -> return $ ProcMsg $ Str $ S.unpack str ++ " could not parse as a Move."
else send msg >> return Id
updateModel _ (SendMove mov) model = model{shownHistory=defaultShownHistory, showVerbosity=False} <# -- connect uri protocols >>
if forceLocal model || local model
then liftIO $ do
putMVar (mvMov $ localStrategy model) mov
msg <- takeMVar (mvMsg $ localStrategy model)
return $ ProcMsg msg
else send (Message $ S.pack $ show mov) >> return Id
updateModel _ (UpdateTBoxVal m) model = noEff model{ tboxval = Message m }
updateModel _ (From mbn) model = noEff model{from = mbn}
updateModel _ IncreasePlayers model = noEff model{players = take 9 $ head (players model) : players model}
updateModel _ DecreasePlayers model = noEff model{players = case players model of
_n:ns@(_:_:_) -> ns
_n:ns@(_:_) | play model -> ns
ns -> ns
}
updateModel _ (UpdatePlayer ix pl) model = noEff model{players = snd $ replaceNth ix pl $ players model}
updateModel _ (UpdateRule r) model = noEff model{rule=makeRuleValid r}
updateModel _ (UpdateVerbosity v) model = noEff model{verbosity = v}
updateModel _ (UpdateDeck ds) model = noEff $ case reads $ S.unpack ds of [(d, rs)] | all isSpace rs -> model{initialDeck = d}
_ -> model
updateModel _ (UpdateNumRepeats ds) model = noEff $ case reads $ S.unpack ds of [(d, rs)] | all isSpace rs -> model{numRepeats = d}
_ -> model
updateModel _ ViewMore model = noEff model{shownHistory = shownHistory model + historyUnit}
updateModel _ ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model}
updateModel _ ToggleLanguage model = noEff model{language = if language model == En then Ja else En}
updateModel _ ToggleContrast model = noEff model{contrast = if contrast model == Colorful then BW else Colorful}
updateModel _ TogglePlay model | play model && length (players model) < 2 = noEff model{play = False, players = head (players model) : players model}
| otherwise = noEff model{play = not $ play model}
updateModel _ TogglePreset model = noEff model{preset = not $ preset model}
updateModel _ ToggleForcePlayingLocally model = noEff model{forceLocal = not $ forceLocal model}
updateModel cassoc ObserveLocally model = model <# liftIO (
let mbplayers = [ (lookup uname cassoc, uname) | name <- reverse $ players model, let uname = S.unpack name ]
in case dropWhile (isJust . fst) mbplayers of
(_noth,uname):_ -> return $ ProcMsg $ Str $ "The strategy \"" ++ uname ++ "\" cannot be used in the local Javascript mode. Connect to the internet and try again."
[] -> do
playerList <- mapM (fromJust . fst) mbplayers
gen <- newGen
let (playOrder,g) = orderPlayers (from model) gen playerList
shuffled | preset model && sort (cardBag $ rule model) == sort (initialDeck model) = initialDeck model -- sort (cardBag $ rule model) could be memoized if necessary.
| otherwise = fst $ createDeck (rule model) g
(fs,_) <-
#ifdef DEBUG
trace ("The deck is "++show shuffled) $
#endif
startFromCards (GS (length playerList) (rule model)) [] playOrder shuffled
return $ WriteLocalResult shuffled fs
)
updateModel _ (WriteLocalResult initDeck fs@(eg,sts,mvs)) model
| numRepeats model > 1 = model{scores = newScores, received = Str "running the next game..." : gameresult, numRepeats = pred $ numRepeats model}
<# return ObserveLocally
| otherwise = model{scores = newScores, received = CreateGame : gameresult}
<# return (SendMessage $ Message "available")
where gameresult = Scores newScores : PrettyEndGame initDeck (Just fs) : zipWith Watch (tail sts) (iterate (drop 1) $ drop 1 mvs) ++ received model
newScores = case sts of [] -> scores model -- not sure if this is possible
st:_ -> egToInt st eg : scores model
updateModel cassoc PlayLocally model = model{local=True} <# liftIO (
let mbplayers = [ (lookup uname cassoc, uname) | name <- reverse $ players model, let uname = S.unpack name ]
in case dropWhile (isJust . fst) mbplayers of
(_noth,uname):_ -> return $ ProcMsg $ Str $ "The strategy \"" ++ uname ++ "\" cannot be used in the local Javascript mode. Connect to the internet and try again."
[] -> do
playerList <- mapM (fromJust . fst) mbplayers
let thePlayerList = mkDS "local strategy" (localStrategy model) : playerList
gen <- newGen
let (playOrder,g) = orderPlayers (from model) gen thePlayerList
shuffled | preset model && sort (cardBag $ rule model) == sort (initialDeck model) = initialDeck model -- sort (cardBag $ rule model) could be memoized if necessary.
| otherwise = fst $ createDeck (rule model) g
forkIO $
#ifdef DEBUG
trace ("The deck is "++show shuffled) $
#endif
do (fs,_) <-
startFromCardsToEnd (GS (length thePlayerList) (rule model)) [] playOrder shuffled
-- putMVar (mvMsg $ localStrategy model) $ PrettyEndGame shuffled $ Just fs
-- observeEndGame shuffled fs (localStrategy model)
return ()
msg <- takeMVar (mvMsg $ localStrategy model)
return $ ProcMsg msg
)
updateModel _ (ProcMsg msg@(PrettyEndGame shuffled (Just fs@(eg,sts,mvs)))) model = model{local=False, received = CreateGame : Scores newScores : msg : received model, initialDeck = shuffled, lastMoves = mvs, scores = newScores} <# return (SendMessage $ Message "available")
where newScores = case sts of [] -> scores model
st:_ -> egToInt st eg : scores model
updateModel _ (ProcMsg msg@(WhatsUp _ _ _)) model = noEff model{received = msg : received model}
updateModel _ (ProcMsg msg) model = model{received = msg : received model} <# liftIO (do
msg <- takeMVar (mvMsg $ localStrategy model)
return $ ProcMsg msg
)
#ifdef DEBUG
updateModel _ (HandleWebSocket act) model = noEff model{received = Str (show act) : received model }
#endif
updateModel _ _ model = noEff model
-- Both CreateGame and PrettyAvailable have the "Create a Game" UI. Since CreateGame can work offline, sometimes CreateGame is printed before PrettyAvailable is printed. That looks redundant when online, so in such cases CreateGame is removed when PrettyAvailable is received.
suppressCG :: [Msg] -> [Msg]
suppressCG (pr@(PrettyAvailable _) : CreateGame : rest) = pr : rest
suppressCG (pr@(PrettyAvailable _) : PrettyAvailable _ : rest) = pr : rest -- this line makes the state less informative, but makes the UI more sophisticated
suppressCG xs = xs
-- sortRecent works around the situation where old msg comes later.
sortRecent :: [Msg] -> [Msg]
sortRecent ms = case span isWU1 ms of
([], _) -> ms
(wu1s,drs) -> let
sortedTups@((t,_):_) = sortBy (flip compare `on` fst) [ (turn $ publicView pv, wu1) | wu1@(WhatsUp1 pv _) <- wu1s ]
sortedWU1s = map snd sortedTups
in case drs of wu@(WhatsUp _ (pv:_) _):rest | turn (publicView pv) >= t -> wu:sortedWU1s++rest
eg@(PrettyEndGame _ (Just (_, st:_, _))):rest | turn (publicState st) >= t -> eg:sortedWU1s++rest
_ -> sortedWU1s ++ drs
-- I guess there is a language extension for this....
isWU1 (WhatsUp1 _ _) = True
isWU1 _ = False
instance ToJSON Message
instance FromJSON Message
newtype Message = Message MisoString
deriving (Eq, Show, Generic)
data Action
= HandleWebSocket (WebSocket Message)
| SendMessage Message
| SendMove Move
| UpdateTBoxVal MisoString
| From (Maybe Int)
| IncreasePlayers
| DecreasePlayers
| UpdatePlayer Int MisoString
| UpdateRule Rule
| UpdateVerbosity Verbosity
| ViewMore
| ToggleVerbosity
| ToggleLanguage
| ToggleContrast
| TogglePlay
| ObserveLocally
| WriteLocalResult [Card] (EndGame, [State], [Move])
| PlayLocally
| ProcMsg Msg
| TogglePreset
| ToggleForcePlayingLocally
| UpdateDeck MisoString
| UpdateNumRepeats MisoString
| Id
data Model = Model {
tboxval :: Message
, players :: [MisoString] -- REVERSED list of players other than this client
, from :: Maybe Int
, rule :: Rule
, received :: [Msg]
, shownHistory :: Int
, showVerbosity :: Bool
, verbosity :: Verbosity
, language :: Language
, contrast :: Contrast
, play :: Bool
, localStrategy :: MVarStrategy
, local :: Bool
, initialDeck :: [Card]
, lastMoves :: [Move]
, preset :: Bool
, forceLocal :: Bool
, numRepeats :: Int
, scores :: [Int]
} deriving (Show, Eq)
data Language = En | Ja deriving (Show, Eq)
data Contrast = Colorful | BW deriving (Show, Eq)
type VLC = (Verbosity, Language, Contrast)
defaultShownHistory, historyUnit :: Int
defaultShownHistory = 10
historyUnit = 10
appView :: [MisoString] -> String -> Model -> View Action
appView strategies versionInfo mdl@Model{..} = div_ [] [
span_ [style_ $ M.fromList [("font-size","2vmin")]] [
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.)"]
, case received of WhatsUp _ _ _ : _ -> checkLocal mdl $ span_ [emphasize contrast] [text $ strBan language]
Invalid : _ -> checkLocal mdl $ span_ [emphasize contrast] [text $ strInvalid language]
PrettyAvailable _ : _ -> span_ [style_ $ M.fromList [("float","right"),("margin","auto 1ch")]] [text " Online server mode "]
CreateGame : _ -> javascriptMode
_ -> checkLocal mdl $ span_ [] []
, span_ [style_ $ M.fromList [("float","right"),("font-weight", "bold")]] [
button_ [ onClick ToggleLanguage, margin1ch ] [ text $ if language==En then "日本語" else "English" ]
, button_ [ onClick ToggleContrast, margin1ch ] [ text $ if language==En then if contrast==Colorful then "Black/White" else "Colorful"
else if contrast==Colorful then "白黒" else "カラー"]
]
, span_ [style_ $ M.fromList [("float","right"),("margin","auto 1ch")]] [
button_ [ onClick ToggleVerbosity, id_ "verbutton" ] [ text $ if showVerbosity then "^" else "v" ]
, label_ [for_ "verbutton"] [text $ strVerbOpt language ]
]
, if showVerbosity then span_ [style_ $ M.fromList [("clear","both"), ("float","right")]] [renderVerbosity (verbosity,language)] else span_[][]
]
, span_ [style_ $ M.fromList [("clear","both"), ("font-size","1.8vmin"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo]
-- , hr_ []
, div_ [style_ $ M.fromList [("clear","both")]] $ take shownHistory $ map (renderMsg strategies (verbosity,language,contrast) mdl) received
, div_ [] $ if null $ drop shownHistory received then [] else [
hr_ []
, input_ [ type_ "checkbox", id_ "showhist", onClick ViewMore, checked_ False] -- This should be replaced with a button.
, label_ [for_ "showhist"] [text "Show more history"]
]
]
checkLocal mdl sp | local mdl = span_ [] [sp, javascriptMode]
| otherwise = sp
javascriptMode = span_ [style_ $ M.fromList [("float","right"),("margin","auto 1ch")]] [text " Offline Javascript mode "]
emphasize cont = style_ $ M.fromList $ maybeColor cont "#FF4444" [("text-align","center"),("font-weight", "bold")]
strVerbOpt En = "verbosity options"
strVerbOpt Ja = "表示オプション"
renderVerbosity :: (Verbosity, Language) -> View Action
renderVerbosity vl@(v,_) = div_ [] [
mkChx span_ vl strBeginner (\b -> if b then verbose else v) (==verbose),
mkChx span_ vl strExpert (\b -> if b then quiet else v) (==quiet),
hr_ [],
mkChx div_ vl strUnhintedCritical (\b -> v{warnCritical=b}) warnCritical,
mkChx div_ vl strUseless (\b -> v{markUseless=b}) markUseless,
mkChx div_ vl strPlayable (\b -> v{markPlayable=b}) markPlayable,
mkChx div_ vl strObviouslyUseless (\b -> v{markObviouslyUseless=b}) markObviouslyUseless,
mkChx div_ vl strObviouslyPlayable (\b -> v{markObviouslyPlayable=b}) markObviouslyPlayable,
mkChx div_ vl strChop (\b -> v{markChops=b}) markChops,
mkChx div_ vl strDD (\b -> v{warnDoubleDrop=b}) warnDoubleDrop,
mkChx div_ vl strHints (\b -> v{markHints=b}) markHints,
mkChx div_ vl strPos (\b -> v{markPossibilities=b}) markPossibilities
]
strBeginner En = "beginner"
strBeginner Ja = "カモ"
strExpert En = "expert"
strExpert Ja = "鬼"
strUnhintedCritical En = "mark unhinted critical cards"
strUnhintedCritical Ja = "危険牌に印"
strUseless En = "mark useless cards"
strUseless Ja = "不要牌に印"
strPlayable En = "mark playable cards"
strPlayable Ja = "安牌に印"
strObviouslyUseless En = "mark useless cards without looking at the cards"
strObviouslyUseless Ja = "公然の不要牌に印"
strObviouslyPlayable En = "mark playable cards without looking at the cards"
strObviouslyPlayable Ja = "公然の安牌に印"
strChop En ="shade the chop card"
strChop Ja = "捨て牌候補に印"
strDD En = "warn possible double-dropping"
strDD Ja = "合わせ打ち警報"
strHints En = "mark hints. Just check this, because there is an unfixed misfeature."
strHints Ja = "めんどくさくてバグを放置しているのでここはチェック入れとけ"
strPos En = "mark possibilities"
strPos Ja = "過去のヒントに基づき可能な色と数を表示"
mkChx divspan (verb,lang) labelf update access = divspan [] [
input_ [ type_ "checkbox", id_ idName, onClick (UpdateVerbosity $ update $ not $ access verb), checked_ $ access verb ],
label_ [ for_ idName ] [text label]
]
where idName = S.filter (not.isSpace) label
label = labelf lang
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
strInvalid En = "Invalid move!"
strInvalid Ja = "その手はムリ!"
maybeColor Colorful col = (("color", col):)
maybeColor BW _ = id
renderMsg :: [MisoString] -> VLC -> Model -> Msg -> View Action
renderMsg _ _ _ (Str xs) = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]]
renderMsg _ (_,l,c) _ Invalid = div_ [style_ $ M.fromList (maybeColor c "#FF4444" [("text-align","center"), ("font-weight", "bold")])] [hr_ [], text $ strInvalid l]
-- Using red instead of black should be OK, but anyway it says "Black/White".
renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms
renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m
renderMsg _ _ _ (PrettyEndGame initDeck Nothing) = p_ [style_ $ M.fromList [("font-size", "2vw")]] [
text $ S.pack $ prettyMbEndGame Nothing ++ "By the way, the initial deck was ",
span_ [style_ $ M.fromList [("font-family", "monospace"), ("font-size", "1.5vw")]] [ text $ S.pack $ shows initDeck "."]
]
renderMsg _ verb _ (PrettyEndGame initDeck (Just tup)) = renderEndGame verb initDeck tup -- pre_ [] [ text $ S.pack $ prettyEndGame initDeck tup]
renderMsg _ vl@(_,l,_) _ (Watch st []) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [
hr_ [],
renderSt vl (ithPlayerFromTheLastI18N l) st,
hr_ []
]
renderMsg _ vl@(_,l,_) _ (Watch st (mv:_)) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [
hr_ [],
renderTrial vl (publicState st) (const "") undefined (Game.Hanabi.view st) mv,
hr_ [],
renderSt vl (ithPlayerFromTheLastI18N l) st,
hr_ []
]
renderMsg strategies (_,lang,_) mdl (PrettyAvailable games)
= div_ [style_ $ M.fromList [("overflow","auto"), ("font-size", "2vw")]] [
hr_ [],
table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $
caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available", font2vw] [text $ S.pack "refresh"]] :
tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] :
map renderAvailable games,
renderCreateGame True strategies lang mdl,
hr_ []
]
renderMsg strategies (_,lang,_) mdl CreateGame = renderCreateGame False strategies lang mdl
renderMsg _ (_,lang,_) _ PlayAgain = div_ [] [
text $ strAskAgain lang,
button_ [onClick $ SendMessage $ Message "Yes"] [text $ strAgain lang],
button_ [onClick $ SendMessage $ Message "No"] [text $ strLeave lang]
]
renderMsg strategies opt mdl msg = renderMsg strategies opt mdl $ Str $ prettyMsg verbose msg
strAskAgain En = "Play with the same member again? Adaptive strategies (if any) may have learned your play style (to some extent)"
strAskAgain Ja = "同じメンツでまた打ちますか？学習するプレーヤーだと多少プレースタイルを学習しているかも？（10回位打たんとイマイチかもしれんが）"
strAgain En = "Play again"
strAgain Ja = "ぜひ！"
strLeave En = "Leave and let them forget your play style"
strLeave Ja = "もうええわ"
strShuffle En = "shuffle players on startup"
strShuffle Ja = "ランダムに場決め"
strPlayers En = "Players"
strPlayers Ja = "メンツ"
strRules En = "Rules"
strRules Ja = "ルール"
strPreset En = "preset deck"
strPreset Ja = "積み込み"
strTurn0 En = "Turn 0"
strTurn0 Ja = "親"
strYou En = "You"
strYou Ja = "あなた"
renderCreateGame :: Bool -> [MisoString] -> Language -> Model -> View Action
renderCreateGame online strategies lang mdl
= div_ [style_ $ M.fromList [{- ("border-style","solid"), -} ("display","inline-block"), ("font-size", "2vw")]] $ [
table_ [solid] $ caption_ [textProp "text-align" "left", textProp "margin-left" "auto"] [ -- Seemingly these styles do not work.
text $ strPlayers lang,
button_ [onClick IncreasePlayers, font2vw] [text $ S.pack "+"],
button_ [onClick DecreasePlayers, font2vw] [text $ S.pack "-"],
span_ [style_ $ M.fromList [("float","right")]] [
input_ [lem, type_ "radio", id_ "shuffle", onClick (From Nothing), checked_ $ from mdl == Nothing],
label_ [for_ "shuffle"] [text $ strShuffle lang]
]
] :
-- table_ [solid] $
[ tr_ [] [td_ [solid] [x], td_ [] (if n>=0 then [input_ [lem, type_ "radio", id_ iD, onClick (From $ Just n), checked_ $ from mdl == Just n],
label_ [for_ iD] [text $ strTurn0 lang]]
else [])]
| (n,x) <- zip [if play mdl then 0 else -1 ..] $ you : reverse (zipWith (renderPlayer strategies) [0..] (players mdl))
, let iD = S.pack $ "radio"++show n ]
-- x ++ [tr_ [] [td_ [] [], td_ [] [input_ [type_ "radio", id_ "shuffle", onClick (From Nothing), checked_ $ from mdl == Nothing],
-- label_ [for_ "shuffle"] [text "shuffle the player list before the game"]]]]
,
-- div_ [] [text $ "Rules"],
-- div_ [] [input_ [type_ "text", onInput (UpdateRule . head . (++[rl]) . map fst . reads . S.unpack), value_ $ S.pack $ show rl, style_ $ M.fromList [("width","70%")]]],
let mkTR list label updater access = tr_ [] [
td_ [] [text label],
td_ [] [
input_ $ list ++ [type_ "text", onInput (UpdateRule . updater . head . (++[access rl]) . map fst . reads . S.unpack), (if null list then value_ else placeholder_) $ S.pack $ show $ access rl]
]
]
mkTRd label updater access options = tr_ [] [
td_ [] [text label],
td_ [] [
dropdownLiteral options (UpdateRule . updater) (access rl)
]
]
gs = GS{numPlayers = length (players mdl) + if play mdl then 1 else 0,
Game.Hanabi.rule = rl}
in
table_ [style_ $ M.fromList [("margin","1%"),("border-style","solid")]] $ [ -- Use "1% auto" instead in order to centralize.
caption_ [] [text $ strRules lang],
mkTRd (strLives lang) (\n -> rl{numBlackTokens=n}) numBlackTokens [1 .. 9],
mkTRd (strColors lang) (\n -> rl{numColors=n}) numColors [1 .. 6],
mkTRd (strProlong lang) (\n -> rl{prolong=n, earlyQuit=earlyQuit rl || n}) prolong [False,True],
mkTRd (strEarlyQuit lang) (\n -> rl{earlyQuit=n}) earlyQuit [False,True],
-- mkTR [] "funPlayerHand" (\n -> rl{funPlayerHand=n}) funPlayerHand
mkTRd (strHandSize lang) (setHandSize gs) (const (handSize gs)) [1 .. 9]
] ++
if numColors rl == 6 then [
mkTR [list_ "numMulticolors"] (strRainbow lang) (\n -> rl{numMulticolors=n}) numMulticolors
] else [],
datalist_ [id_ "numMulticolors"] [option_ [value_ "[1, 1, 1, 1, 1]"] [text "[1, 1, 1, 1, 1]"], option_ [value_ "[3, 2, 2, 2, 1]"] [text "[3, 2, 2, 2, 1]"]],
span_ [] $
input_ [ lem, type_ "checkbox", id_ "preset", onClick TogglePreset, checked_ $ preset mdl ] :
label_ [for_ "preset"] [text $ strPreset lang] : -- [if preset mdl then text "preset deck" else s_ [] [text "preset deck"]] :
if preset mdl || not (null $ initialDeck mdl) then [input_ [type_ "text", onInput UpdateDeck, font2vw, (if preset mdl then value_ else placeholder_) $ S.pack $ show $ initialDeck mdl]] else [],
span_ [margin1ch] $
input_ [ lem, type_ "checkbox", id_ "forceLocal", onClick ToggleForcePlayingLocally, checked_ $ forceLocal mdl ] :
label_ [for_ "forceLocal"] [text "Force playing locally"] :
if play mdl then [] else
text ", repeating " :
input_ [type_ "text", onInput UpdateNumRepeats, (if forceLocal mdl then value_ else placeholder_) $ S.pack $ show $ numRepeats mdl]:
[text " times"]
,
button_ [onClick $
if not online || forceLocal mdl -- && all (not . isWS . S.unpack) (players mdl)
then if play mdl then PlayLocally else ObserveLocally
else SendMessage $ Message $ S.pack $ (case from mdl of Just n | play mdl -> "from " ++ shows n " "
| otherwise -> "observe " ++ shows n " "
Nothing | play mdl -> "shuffle "
| otherwise -> "observe ") ++ show rl ++ (if preset mdl then shows (initialDeck mdl) . (';':) else id) (concat (intersperse "," $ map S.unpack $ reverse $ players mdl)),
style_ $ M.fromList [("float","right"),("font-size","1.8vw")]
] [text $ strButsu lang]
]
where you = span_[][
input_ [ lem, type_ "checkbox", id_ "you", onClick TogglePlay, checked_ $ play mdl]
, label_ [for_ "you"] [(if play mdl then span_ else s_) [] [text $ strYou lang]]
]
rl = rule mdl
margin1ch = style_ $ M.fromList [("margin","auto 1ch")] -- 1 ch is the width of `0'.
font2vw = style_ $ M.fromList [("font-size","1.8vw")]
lem = style_ $ M.fromList [("width","1.5vw"),("height","1.5vw")]
strButsu En = "create a game"
strButsu Ja = "打つ"
strLives En = "Number of lives"
strLives Ja = "💓の数。チャイ"
strColors En = "Number of colors"
strColors Ja = "色数"
strProlong En = "Continue the game after the pile is exhausted"
strProlong Ja = "流局なし。白黒つくまでとことんやる"
strEarlyQuit En = "Quit the game when no more score is possible"
strEarlyQuit Ja = "それ以上の点が無理なら途中流局"
strHandSize En = "Hand size"
strHandSize Ja = "手札の数"
strRainbow En = "Numbers of M1 .. M5. Note that they are not implemented as multicolors yet."
strRainbow Ja = "虹色の数。いろんな色になるようには（まだ）実装していないので注意。(ただの1色)"
renderPlayer :: [MisoString] -> Int -> MisoString -> View Action
--renderPlayer _ i p = text p
renderPlayer strategies i p = dropdown strategies (UpdatePlayer i) p
dropdown :: [MisoString] -> (MisoString->Action) -> MisoString -> View Action
dropdown options action selected = select_ [onChange action, font2vw] [option_ [ value_ p, selected_ $ selected==p] [text p] | p <- options ]
dropdownLiteral :: (Read a, Show a) => [a] -> (a -> Action) -> a -> View Action
dropdownLiteral options action selected = dropdown (map (S.pack . show) options) (action . read . S.unpack) (S.pack $ show selected)
dropdownBool :: (Bool -> Action) -> Bool -> View Action
dropdownBool = dropdownLiteral [False,True]
-- but in most cases booleans should be selected by check boxes.
renderAvailable :: (Int, (Int, Int)) -> View Action
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 :: Attribute action
solid = style_ $ M.fromList [("border-style","solid")]
renderWhatsUp :: VLC -> String -> [PrivateView] -> [Move] -> View Action
renderWhatsUp verb@(_,lang,_) name views@(v:_) moves = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [
-- hr_ [],
-- text $ S.pack $ strBan lang,
hr_ [],
renderRecentEvents verb (publicView v) (ithPlayerI18N lang "あなたの") views moves,
hr_ [style_ $ M.fromList [("padding","0"),("margin","0")]],
-- text $ S.pack $ "Algorithm: " ++ name,
renderPV verb v
]
strBan En = "Your turn."
strBan Ja = "あなたの手番"
ithPlayerI18N En _ _ i = ithPlayer undefined i
ithPlayerI18N Ja self _ i = iterate (++"下家の") self !! i
ithPlayerFromTheLastI18N En n j = ithPlayerFromTheLast n j
ithPlayerFromTheLastI18N Ja n j = iterate (++"上家の") "最後の手番の人の" !! (n-j-1)
strHand En = " hand:"
strHand Ja = "手札:"
showMove En (Hint n e) = "Tell "++map toLower (ithPlayer 0 n) ++ ' ' : either show (showRank En) e
showMove Ja (Hint n e) = ithPlayerI18N Ja "自分の" 0 n ++ either ((:[]) . showColor Ja) (showRank Ja) e ++ "を教える。"
showMove En (Drop i) = "Drop the " ++ ith' i ++ " card" -- " from the left (0-origin)"
showMove Ja (Drop i) = {- "左から" ++ -} shows i "番目のカードを捨てる。" -- "（0から数えて）"
showMove En (Play i) = "Play the " ++ ith' i ++ " card" -- " from the left (0-origin)"
showMove Ja (Play i) = {- "左から" ++ -} shows i "番目のカードを打ち上げる。" --"（0から数えて）"
ith' 1 = "1st "
-- ith' n = ith n
ith' 2 = "2nd "
ith' 3 = "3rd "
ith' i = shows i "th "
renderWhatsUp1 :: VLC -> PrivateView -> Move -> View Action
renderWhatsUp1 verb@(_,_,c) v m = div_ [style_ $ M.fromList [("background-color", "#555555"),("color","#000000"),("font-size", "1.8vmin")]] [
hr_ [],
renderTrial verb (publicView v) (const "") undefined v m,
hr_ [],
renderPV verb v
]
renderEndGame :: VLC -> [Card] -> (EndGame, [State], [Move]) -> View Action
renderEndGame verb@(_,lang,c) initDeck (eg,sts@(st:_),mvs)
= div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [
hr_ [],
renderRecentEvents verb (publicState st) (ithPlayerFromTheLastI18N lang) (map Game.Hanabi.view sts) mvs,
hr_ [],
h1_ [style_ $ M.fromList [("background-color", forceWhite c "#FF0000"),("color","#000000"),("font-size", "5vmax")]] [text $ S.pack $ strEndGame lang eg],
hr_ [],
renderSt verb (ithPlayerFromTheLastI18N lang) st,
hr_ [],
span_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [
text $ S.pack $ strInitialDeck lang,
div_ [style_ $ M.fromList [("font-family", "monospace"), ("font-size", "1.5vw")]] [
text $ S.pack $ show initDeck
],
span_ [] (if length histories > 9 then [text $ strMoveHist lang,
div_ [style_ $ M.fromList [("font-family", "monospace"), ("font-size", "1.5vw")]] [ text $ S.pack $ tail (foldr showsMoves "." $ transpose histories) ]
]
else []),
hr_ []
]
]
where histories = chopEvery (numPlayers $ gameSpec $ publicState st) $ reverse mvs
showsMoves :: [Move] -> ShowS
showsMoves mvs rest = ",\n" ++ filter (\c -> not (isLower c || c == 'H')) (foldr shows rest mvs)
forceColor mono BW _col = mono
forceColor _mono Colorful col = col
forceWhite = forceColor "#FFFFFF"
forceBlack = forceColor "#000000"
strEndGame En eg = show eg
strEndGame Ja Perfect = "やったね！ パーフェクト！"
strEndGame Ja (Soso n) = "流局。"++show n++"点。"
strEndGame Ja Failure = "チョンボ！"
strInitialDeck En = "By the way, the initial deck was "
strInitialDeck Ja = "なお、最初の山は"
strMoveHist En = " and the move histories are "
strMoveHist Ja = "これに対し、以下の手が打たれました。"
chopEvery n xs = case splitAt n xs of ([], _) -> []
(tk,dr) -> tk : chopEvery n dr
strMove En = " move: "
strMove Ja = "一手: "
renderTrial :: VLC -> PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action
renderTrial verb@(_,l,_) pub ithP i v m = (if l==Ja then span_ [style_ $ M.fromList [("margin", "1em")]] else div_ []) [
text $ S.pack $ ithP i ++ strMove l ++ {- replicate (length (ithP 2) - length (ithP i)) ' ' ++ -} showMove l m ++ " ("++shows m ")"
, span_ [] $ showResults l renderRevealed res
]
where res = result $ publicView v
renderRevealed = renderCardInline verb pub $ revealed res
showResults En rev (Discard _) = [text ", which revealed ", rev, text ". "]
showResults En rev (Success _) = [text ", which succeeded revealing ", rev, text ". "]
showResults En rev (Fail _) = [text ", which failed revealing ", rev, text ". "]
showResults Ja rev (Discard _) = [span_ [style_ $ M.fromList [("margin", "1em")]] [rev, text "捨て！ "]]
showResults Ja rev (Success _) = [span_ [style_ $ M.fromList [("margin", "1em")]] [rev, text "通し！ "]]
showResults Ja rev (Fail _) = [span_ [style_ $ M.fromList [("margin", "1em")]] [rev, text "通らず！ "]]
showResults _ rev _ = [text ". "]
strBot En = "← Bottom deck"
strBot Ja = "← 海底"
strLasZimo En = "Be ready for the bottom deck"
strLasZimo Ja = "ラスヅモかも"
strDeck En = "deck: "
strDeck Ja = "山: "
strPlayed En = "played "
strPlayed Ja = "打上済"
strDropped En = "dropped: "
strDropped Ja = "捨て牌: "
renderPI :: VLC -> PublicInfo -> View Action
renderPI verb@(_,l,cont) pub
= div_ [style_ $ M.fromList [("font-size", "2.5vmin"),("padding","0"),("margin","0")]] [
text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck pub ++ "Lives: " ++ show (lives pub),
span_ [style_ $ M.fromList [("font-size","1.5em"),("color",forceBlack cont "#FF0000")]] [text $ S.pack (concat $ replicate (lives pub) "💓"{-"♥"-})], -- In html, heart is ♥ or ♥ and info is ⓘ but they show up literally when used here.
span_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (numBlackTokens (Game.Hanabi.rule $ gameSpec pub) - lives pub) "💔")],
span_ [] [
text $ S.pack $ ", Hints: " ++ show (hintTokens pub),
span_ [style_ $ M.fromList [("font-size","1.3em"),("color",forceBlack cont "#008800")]] [text $ S.pack (concat $ replicate (hintTokens pub) "ⓘ")],
s_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (8 - hintTokens pub) "ⓘ")]
],
text $ S.pack $ ";",
div_ [style_ $ M.fromList [("padding", "0"),("margin","0")]] [
text $ strDeck l,
case deadline pub of -- Nothing -> span_ [style_ $ M.fromList [("width","30px"),("color","#FFFFFF"),("background-color","#000000")]] $ map (text . S.pack) $ replicate (pileNum pub) "__|"
Nothing -> span_ [style_ $ M.fromList [("font-size","0.65em")]] $ map (text . S.pack) $ replicate (pileNum pub) "🂠 "
Just dl -> span_ [style_ $ M.fromList [("font-size","1.5em")]] [ text . S.pack $ take dl "🕛🕚🕙🕘🕗🕖🕕🕔🕓🕒🕑🕐" ],
if prolong $ Game.Hanabi.rule $ gameSpec pub then span_ [] [] else
case pileNum pub of 1 -> span_ [style_ $ M.fromList (maybeColor cont "#FF0000" [("font-weight", "bold")])] [text $ strBot l]
n | n>1 && n <= numPlayers (gameSpec pub) -> span_ [style_ $ M.fromList (maybeColor cont "#777700" [("font-weight", "bold")])] [text $ strLasZimo l]
| otherwise -> span_ [] []
],
div_ [style_ $ M.fromList [("padding", "0"),("margin","0")]] [
text $ strPlayed l,
span_ (if achievable - current >= pileNum pub then [style_ $ M.fromList (maybeColor cont "#FF0000" [("font-weight", "bold")])] else [])
[text $ S.pack $ "(" ++ shows current " / " ++ shows achievable ")"],
text $ S.pack ": ",
-- span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verb pub $ C c k | k <- [K1 .. playedMax] ] ++ map (text . S.pack) (replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX")
span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", inlineFontSize l)]] $ [ span_ [] $ text (S.pack " ") : renderCardsInline verb pub c [K1 .. playedMax] : map (text . S.pack) (replicate (possible - fromEnum playedMax) "_" ++ replicate (5 - possible) "X")
| c <- colors pub
, let playedMax = achievedRank pub c
possible = fromEnum $ bestPossibleRank pub c
]
],
div_ [style_ $ M.fromList [("padding", "0"),("margin","0")]] [
text $ strDropped l,
-- span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci, n) <- IM.toList $ discarded pub ],
span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", inlineFontSize l)]] $ [ span_ [] [text (S.pack " "), renderCardsInline verb pub c (replicate n r)] | c <- colors pub, r <- [K1 .. maxBound], let n = discarded pub $ C c r, n>0 ]
]
]
where current = currentScore pub
achievable = seeminglyAchievableScore pub
-- renderCardsInline is a compact version of renderCardInline that prints the color letter only once.
renderCardsInline :: VLC -> PublicInfo -> Color -> [Rank] -> View Action
renderCardsInline vl@(_,l,cont) pub c ns = span_ [style_ $ M.fromList [("color", forceWhite cont $ colorStr $ Just c),("background-color","#000000"),("padding", "0"),("margin","0")]] $ span_ [] [text $ S.pack [showColor l c]] : map (rankStrInline vl pub c) ns
rankStrInline (v,l,_) pub c n = cardStrInline v pub (C c n) $ showRank l n
renderCardInline :: VLC -> PublicInfo -> Card -> View Action
renderCardInline (v,l,cont) pub c = span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", inlineFontSize l),("color", forceWhite cont $ colorStr $ Just $ color c),("background-color","#000000"),("padding", "0"),("margin","0")]] [cardStrInline v pub c $ showColor l (color c) : showRank l (rank c)]
inlineFontSize En = "3vmin"
inlineFontSize Ja = "4vmin"
showColor En c = head (show c)
showColor Ja White = '白'
showColor Ja Yellow = '黃'
showColor Ja Red = '赤'
showColor Ja Green = '緑'
showColor Ja Blue = '青'
showRank En r = show $ fromEnum r
showRank Ja K1 = "🀙"
showRank Ja K2 = "🀚"
showRank Ja K3 = "🀛"
showRank Ja K4 = "🀜"
showRank Ja K5 = "🀝"
showBack En = '_'
showBack Ja = '🀫'
cardStrInline v pub c xs = (if useless then s_ else span_) [style] [
-- text $ S.pack $ show c
span_ [] [text $ S.pack xs]
]
where style = style_ $ M.fromList [
("font-weight", if useless then "100"
else if critical then "bold" else "normal"),
("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal")]
critical = warnCritical v && isCritical pub c
useless = markUseless v && isUseless pub c
renderRecentEvents :: VLC -> PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action
renderRecentEvents verb pub ithP vs@(v:_) ms = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] $ reverse $ zipWith3 (renderTrial verb pub $ ithP nump) [pred nump, nump-2..0] vs ms
where nump = numPlayers $ gameSpec $ publicView v
renderPV :: VLC -> PrivateView -> View Action
renderPV v@(_,l,_) pv@PV{publicView=pub} = div_ [] [
renderPI v pub,
div_ [] (
-- div_ [] [text $ S.pack $ "Your hand:"] :
-- renderCards v pub [ Nothing | _ <- yourHand] yourHand :
renderHand v pv (const $ strYour l) 0 [ Nothing | _ <- yourHand] yourHand :
-- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length yourHand] ]
(zipWith3 (renderHand v pv (ithPlayerI18N l "あなたの" $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ annotations pub))
)
]
where yourHand = head (annotations pub)
strYour En = "Your "
strYour Ja = "あなたの"
renderSt :: VLC -> (Int -> Int -> String) -> State -> View Action
renderSt verb ithP st@St{publicState=pub} = div_ [] $
renderPI verb pub :
zipWith3 (renderHand verb (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (annotations pub)
renderHand :: VLC -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Annotation] -> View Action
renderHand vl@(_,l,_) pv ithPnumP i mbcards anns = div_ [] [
div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [text $ S.pack $ ithPnumP i ++ strHand l],
renderHand' vl pv i mbcards anns
-- renderCards v pub (map Just cards) hl
]
renderHand' :: VLC -> PrivateView -> Int -> [Maybe Card] -> [Annotation] -> View Action
renderHand' v pv pli mbcards anns =
table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"){- , ("height","48px") -}]] (zipWith3 (renderCard v pv pli anns) [0..] mbcards anns)]
renderCard :: VLC -> PrivateView -> Int -> [Annotation] -> Index -> Maybe Card -> Annotation -> View Action
renderCard vl@(v,l,cont) pv pli anns i mbc ann@Ann{marks=tup@(mc,mk), possibilities=ptup} = td_ [style_ $ M.fromList [
("text-align","center"),
("width", S.pack $ shows cardWidth "vmin"),
("color", forceWhite cont $ colorStr $ fmap color mbc),
("font-family", "monospace"),
("-webkit-touch-callout", "none"),
("-webkit-user-select", "none"),
("-khtml-user-select", "none"),
("-moz-user-select", "none"),
("-ms-user-select", "none"),
("user-select", "none")
]] [ -- ("font-size", S.pack $ shows (cardWidth - cardWidth `div` 10) "vmin")]] [
maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i), style_ $ M.fromList [("width", S.pack $ shows cardWidth "vmin"),
("font-size", S.pack $ shows (cardWidth / 5) "vmin" -- "0.3em"
)] ] [ text (S.pack $ strPlay l) ]) (const $ span_[][]) mbc,
div_ [style_ $ M.fromList $ (if isNothing mbc then (("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ann && i `elem` chopSet then "#880000" else
if markChops v && i `elem` chopSet then "#888888" else "#000000") :) else id) [{- ("height", S.pack $ shows (cardWidth / 2) "vmin"), -} ("font-family", "serif"), ("font-size", S.pack $ shows (if isNothing mbc then cardWidth / 3 else cardWidth * (4/9)) "vmin")]] [ -- "1.2em")]] [
cardStr vl pv pli mbc ann
],
(if useless then s_ [] . (:[]) else id) $ div_ [style_ $ M.fromList $ ("text-align","center") : ("font-size", S.pack $ shows (cardWidth / 3) "vmin") : myStyle] [text $ S.pack $ if markHints v then maybe '_' (showColor l) mc : ' ' : [maybe (showBack l) (head . showRank l) mk] else "_ "++[showBack l] ],
maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'd':show i), style_ $ M.fromList [("width", S.pack $ shows cardWidth "vmin"),
("font-size", S.pack $ shows (cardWidth / 5) "vmin" -- "0.3em"
)] ] [ text (S.pack $ strDrop l) ]) (const $ span_[][]) mbc,
if markPossibilities v then div_ [style_ $ M.fromList [("font-size", S.pack $ shows (cardWidth / 7) "vmin" -- "0.3em"
)]] [text $ S.pack $ showColorPossibilities $ qitsToColorPossibilities ptup, -- br_[],
text $ S.pack $ showRankPossibilities $ qitsToRankPossibilities ptup] else span_[][]
] where
pub = publicView pv
cardWidth = (case l of En -> 90
Ja -> 80) / fromIntegral (handSize $ gameSpec pub)
(useless,myStyle) = (markObviouslyUseless v && isObviouslyUseless pub ptup,
[ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub anns) then "#888888" else "#000000"),
("font-weight", if useless then "100" else "normal"),
("font-style", if markObviouslyPlayable v && isObviouslyPlayable pub ptup then "oblique" else "normal")]
)
chopSet = concat $ take 1 $ definiteChopss pv anns
strPlay En = "play"
strPlay Ja = "勝負!"
strDrop En = "drop"
strDrop Ja = "捨て"
{-
renderCards :: Verbosity -> PrivateView -> [Maybe Card] -> [Marks] -> View Action
renderCards v pv@PV{publicView=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 pv mbc ann
]
| (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
]
]
-}
strBack En = "? ?"
strBack Ja = "🀫"
cardStr :: VLC -> PrivateView -> Int -> Maybe Card -> Annotation -> View Action
-- Not sure which style is better.
#ifdef BUTTONSONCARDS
cardStr (v,l,cont) pv@PV{publicView=pub} pli mbc ann@Ann{marks=tup} = case mbc of
Nothing -> (if useless then s_ else span_) [style] [text $ S.pack $ strBack l]
where style = style_ $ M.fromList [-- ("width","30px"),
("text-align","center"),
("font-family", if critical then "sans-serif" else "serif"),
("font-weight", if useless then "100"
else if critical then "bold" else "normal"),
("font-style", if markPlayable v && isDefinitelyPlayable pv ann then "oblique" else "normal")]
critical = warnCritical v && isDefinitelyCritical pv ann
useless = markUseless v && isDefinitelyUseless pv ann
Just c -> (if useless then s_ else 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 $ rank c), style][text $ S.pack $ show $ fromEnum $ rank c]
]
where style = style_ $ M.fromList [
("font-family", if critical then "sans-serif" else "serif"),
("font-weight", if useless then "100"
else if critical then "bold" else "normal"),
("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal"), ("background-color","#000000"),("color", forceWhite cont $ colorStr $ fmap color mbc)]
#else
cardStr (v,l,cont) pv@PV{publicView=pub} pli mbc ann@Ann{marks=tup} = case mbc of
Nothing -> (if useless then s_ else span_) [style] [text $ S.pack $ strBack l]
where style = style_ $ M.fromList [-- ("width","30px"),
("text-align","center"),
("font-family", if critical then "sans-serif" else "serif"),
("font-weight", if useless then "100"
else if critical then "bold" else "normal"),
("font-style", if markPlayable v && isDefinitelyPlayable pv ann then "oblique" else "normal")]
critical = warnCritical v && isDefinitelyCritical pv ann
useless = markUseless v && isDefinitelyUseless pv ann
Just c -> (if useless then s_ else span_) [style] [
-- text $ S.pack $ show c
span_ [ -- style_ $ M.fromList [("font-size","1.3em")],
onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c)] [text $ S.pack [showColor l $ color c]],
text " ",
span_ [ -- style_ $ M.fromList [("font-size","1.3em")],
onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ rank c)][text $ S.pack $ showRank l $ rank c]
]
where style = style_ $ M.fromList [-- ("width","30px"),
("font-family", if critical then "sans-serif" else "serif"),
("font-weight", if useless then "100"
else if critical then "bold" else "normal"),
("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal"), ("background-color","#000000"),("color", forceWhite cont $ colorStr $ fmap color mbc)]
#endif
critical = warnCritical v && tup==(Nothing,Nothing) && isCritical pub c
useless = markUseless v && isUseless pub c
colorStr :: Maybe Color -> MisoString
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"
data MVarStrategy = MVS {mvMsg :: MVar Msg, mvMov :: MVar Move} deriving Eq
instance Strategy MVarStrategy IO where
strategyName _ = return "local player"
move pvs@(pv:_) mvs mvstr@(MVS mvmsg mvmov) = do
putMVar mvmsg $ WhatsUp "local player" pvs mvs
mov <- getMoveUntilSuccess pv mvstr
return (mov, mvstr)
observe (v:_) (m:_) (MVS mvmsg _) = putMVar mvmsg $ WhatsUp1 v m
observeEndGame d eh mvstr@(MVS mvmsg _) = do
putMVar mvmsg $ PrettyEndGame d $ Just eh
return mvstr
getMoveUntilSuccess pv mvstr@(MVS mvmsg mvmov) = do
m <- takeMVar mvmov
if isMoveValid pv m then return m else do putMVar mvmsg Invalid
getMoveUntilSuccess pv mvstr
newMVarStrategy = do
mvmsg <- newEmptyMVar
mvmov <- newEmptyMVar
return $ MVS mvmsg mvmov
instance Show MVarStrategy where
showsPrec p _ = ("MVarStrategy "++)