{-# 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 "++)