{-# 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) import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(fromJust, isNothing) import Data.List(sort, intersperse, transpose) import Miso hiding (Fail) 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.Random import Control.Concurrent #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 wsURI = maybe uri (\_ -> URL "ws://localhost:8720") $ lookup "localhost" query defStr = maybe "via WebSocket" id $ lookup "strategy" query mvStr <- liftIO newMVarStrategy 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, play = True, localStrategy = mvStr, local = False, initialDeck = [], lastMoves = [], preset = False}, update = updateModel options, 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 = URL WSURI #else -- uri = URL "ws://133.54.228.39:8720" uri = URL "ws://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 :: Game.Hanabi.Msg.Options -> Action -> Model -> Effect Action Model updateModel _ (HandleWebSocket (WebSocketMessage (Message m))) model = noEff model{ received = {- take lenHistory $ -} suppressCG $ decodeMsg m : received model } updateModel _ (SendMessage msg@(Message str)) model = model{shownHistory=defaultShownHistory, showVerbosity=False} <# -- connect uri protocols >> if 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 _ -> return $ ProcMsg $ 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 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 _ ViewMore model = noEff model{shownHistory = shownHistory model + historyUnit} updateModel _ ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model} 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 opt ObserveLocally model = model <# liftIO (do let constructor algIx = fromJust $ lookup algIx $ strategies opt playerList <- mapM (constructor . S.unpack) $ reverse $ players model 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,_) <- startFromCards (GS (length playerList) (rule model)) [] playOrder shuffled return $ WriteLocalResult shuffled fs ) updateModel _ (WriteLocalResult initDeck fs@(_,sts,mvs)) model = model{received = CreateGame : PrettyEndGame initDeck (Just fs) : zipWith Watch (tail sts) (iterate (drop 1) $ drop 1 mvs) ++ received model} <# return (SendMessage $ Message "available") updateModel opt PlayLocally model = model{local=True} <# liftIO (do let constructor algIx = fromJust $ lookup algIx $ strategies opt playerList <- mapM (constructor . S.unpack) $ reverse $ players model 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 $ do (fs,_) <- startFromCards (GS (length thePlayerList) (rule model)) [] playOrder shuffled putMVar (mvMsg $ localStrategy model) $ PrettyEndGame shuffled $ Just fs msg <- takeMVar (mvMsg $ localStrategy model) return $ ProcMsg msg ) updateModel _ (ProcMsg msg@(PrettyEndGame shuffled (Just fs@(_,_,mvs)))) model = model{local=False, received = CreateGame : msg : received model, initialDeck = shuffled, lastMoves = mvs} <# return (SendMessage $ Message "available") 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 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 | TogglePlay | ObserveLocally | WriteLocalResult [Card] (EndGame, [State], [Move]) | PlayLocally | ProcMsg Msg | TogglePreset | UpdateDeck 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 , play :: Bool , localStrategy :: MVarStrategy , local :: Bool , initialDeck :: [Card] , lastMoves :: [Move] , preset :: Bool } deriving (Show, Eq) defaultShownHistory, historyUnit :: Int defaultShownHistory = 10 historyUnit = 10 appView :: [MisoString] -> String -> Model -> View Action appView strategies versionInfo mdl@Model{..} = div_ [] [ input_ [ type_ "text", placeholder_ "You can also use your keyboard.", size_ "25", onInput UpdateTBoxVal, onEnter (SendMessage tboxval) ] , button_ [ onClick (SendMessage tboxval) ] [ text (S.pack "Send to the server") ] -- x , span_ [style_ $ M.fromList [("font-size","10px")]] [text $ S.pack "(Use this line if you prefer the keyboard interface.)"] , span_ [style_ $ M.fromList [("float","right")]] [ button_ [ onClick ToggleVerbosity, id_ "verbutton" ] [ text $ if showVerbosity then "^" else "v" ] , label_ [for_ "verbutton"] [text "verbosity options" ] ] , if showVerbosity then span_ [style_ $ M.fromList [("clear","both"), ("float","right")]] [renderVerbosity verbosity] else span_[][] , span_ [style_ $ M.fromList [("clear","both"), ("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo] -- , hr_ [] , div_ [style_ $ M.fromList [("clear","both")]] $ take shownHistory $ map (renderMsg strategies verbosity 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"] ] ] renderVerbosity :: Verbosity -> View Action renderVerbosity v = div_ [] [ mkChx span_ v "beginner" (\b -> if b then verbose else v) (==verbose), mkChx span_ v "expert" (\b -> if b then quiet else v) (==quiet), hr_ [], mkChx div_ v "mark unhinted critical cards" (\b -> v{warnCritical=b}) warnCritical, mkChx div_ v "mark useless cards" (\b -> v{markUseless=b}) markUseless, mkChx div_ v "mark playable cards" (\b -> v{markPlayable=b}) markPlayable, mkChx div_ v "mark useless cards without looking at the cards" (\b -> v{markObviouslyUseless=b}) markObviouslyUseless, mkChx div_ v "mark playable cards without looking at the cards" (\b -> v{markObviouslyPlayable=b}) markObviouslyPlayable, mkChx div_ v "shade the chop card(s)" (\b -> v{markChops=b}) markChops, mkChx div_ v "warn possible double-dropping"(\b -> v{warnDoubleDrop=b}) warnDoubleDrop, mkChx div_ v "mark hints" (\b -> v{markHints=b}) markHints, mkChx div_ v "mark possibilities" (\b -> v{markPossibilities=b}) markPossibilities ] mkChx divspan verb label 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 onEnter :: Action -> Attribute Action onEnter action = onKeyDown $ bool Id action . (== KeyCode 13) {- #ifdef AESON prettyDecode :: MisoString -> MisoString prettyDecode str = case decode $ S.fromMisoString str of Nothing -> str Just msg -> S.toMisoString $ encode $ prettyMsg verbose msg #else prettyDecode :: MisoString -> MisoString prettyDecode str = case reads $ S.fromMisoString str of [] -> str [(msg,_)] -> S.toMisoString $ prettyMsg verbose msg #endif render :: MisoString -> View Action render str = case decode str' of Nothing -> text $ S.fromMisoString str Just msg -> renderMsg verbose msg where str' = S.fromMisoString str -} decodeMsg :: MisoString -> Msg #ifdef AESON decodeMsg str = case decode $ S.fromMisoString str of Nothing -> Str $ S.fromMisoString str Just msg -> msg #else decodeMsg str = case reads $ S.fromMisoString str of [] -> Str $ S.fromMisoString str [(msg,_)] -> msg #endif renderMsg :: [MisoString] -> Verbosity -> Model -> Msg -> View Action renderMsg _ _ _ (Str xs) = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]] renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m renderMsg _ _ _ (PrettyEndGame 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 _ verb _ (Watch st []) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [] ] renderMsg _ verb _ (Watch st (mv:_)) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], renderTrial verb (publicState st) (const "") undefined (Game.Hanabi.view st) mv, hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [] ] renderMsg strategies _ mdl (PrettyAvailable games) = div_ [style_ $ M.fromList [("overflow","auto")]] [ hr_ [], table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $ caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available"] [text $ S.pack "refresh"]] : tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] : map renderAvailable games, renderCreateGame True strategies mdl, hr_ [] ] renderMsg strategies _ mdl CreateGame = renderCreateGame False strategies mdl renderCreateGame :: Bool -> [MisoString] -> Model -> View Action renderCreateGame online strategies mdl = div_ [style_ $ M.fromList [{- ("border-style","solid"), -} ("display","inline-block")]] $ [ table_ [solid] $ caption_ [textProp "text-align" "left", textProp "margin-left" "auto"] [ -- Seemingly these styles do not work. text "Players", button_ [onClick IncreasePlayers] [text $ S.pack "+"], button_ [onClick DecreasePlayers] [text $ S.pack "-"], input_ [type_ "radio", id_ "shuffle", onClick (From Nothing), checked_ $ from mdl == Nothing], label_ [for_ "shuffle"] [text "shuffle on startup"] ] : -- table_ [solid] $ [ tr_ [] [td_ [solid] [x], td_ [] (if n>=0 then [input_ [type_ "radio", id_ iD, onClick (From $ Just n), checked_ $ from mdl == Just n], label_ [for_ iD] [text "Turn 0"]] 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 . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, 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 $ rule mdl]) . map fst . reads . S.unpack), (if null list then value_ else placeholder_) $ S.pack $ show $ access $ rule mdl] ] ] mkTRd label updater access options = tr_ [] [ td_ [] [text label], td_ [] [ dropdownLiteral options (UpdateRule . updater) (access $ rule mdl) ] ] gs = GS{numPlayers = length (players mdl) + if play mdl then 1 else 0, Game.Hanabi.rule = rule mdl} in table_ [style_ $ M.fromList [("margin","1%"),("border-style","solid")]] $ [ -- Use "1% auto" instead in order to centralize. caption_ [] [text "Rules"], mkTRd "Number of lives" (\n -> (rule mdl){numBlackTokens=n}) numBlackTokens [1 .. 9], mkTRd "Number of colors" (\n -> (rule mdl){numColors=n}) numColors [1 .. 6], mkTRd "Continue the game after the pile is exhausted" (\n -> (rule mdl){prolong=n}) prolong [False,True], mkTRd "Quit the game when no more score is possible" (\n -> (rule mdl){earlyQuit=n}) earlyQuit [False,True], -- mkTR [] "funPlayerHand" (\n -> (rule mdl){funPlayerHand=n}) funPlayerHand mkTRd "Hand size" (setHandSize gs) (const (handSize gs)) [1 .. 9] ] ++ if numColors (rule mdl) == 6 then [ mkTR [list_ "numMulticolors"] "Numbers of M1 .. M5" (\n -> (rule mdl){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_ [ type_ "checkbox", id_ "preset", onClick TogglePreset, checked_ $ preset mdl ] : label_ [for_ "preset"] [text "preset deck"] : -- [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, (if preset mdl then value_ else placeholder_) $ S.pack $ show $ initialDeck mdl]] else [], button_ [onClick $ if not online && 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 (rule mdl) ++ (if preset mdl then shows (initialDeck mdl) . (';':) else id) (concat (intersperse "," $ map S.unpack $ reverse $ players mdl)), style_ $ M.fromList [("float","right")] ] [text $ S.pack "create a game"] ] where you = span_[][ input_ [ type_ "checkbox", id_ "you", onClick TogglePlay, checked_ $ play mdl] , label_ [for_ "you"] [if play mdl then text "You" else s_ [] [text "You"]] ] 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] [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 :: Verbosity -> String -> [PrivateView] -> [Move] -> View Action renderWhatsUp verb name views@(v:_) moves = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], text $ S.pack "Your turn.", hr_ [], renderRecentEvents verb (publicView v) ithPlayer views moves, hr_ [], -- text $ S.pack $ "Algorithm: " ++ name, renderPV verb v ] renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000"),("font-size", "1.8vmin")]] [ hr_ [], renderTrial verb (publicView v) (const "") undefined v m, hr_ [], renderPV verb v ] renderEndGame :: Verbosity -> [Card] -> (EndGame, [State], [Move]) -> View Action renderEndGame verb initDeck (eg,sts@(st:_),mvs) = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [ hr_ [], renderRecentEvents verb (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs, hr_ [], h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000"),("font-size", "5vmin")]] [text $ S.pack $ show eg], hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [], span_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [ text $ S.pack $ "By the way, the initial deck was ", div_ [style_ $ M.fromList [("font-family", "monospace"), ("font-size", "1.5vw")]] [ text $ S.pack $ show initDeck ], span_ [] (if length histories > 9 then [text " and the move histories are ", 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) chopEvery n xs = case splitAt n xs of ([], _) -> [] (tk,dr) -> tk : chopEvery n dr renderTrial :: Verbosity -> PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action renderTrial verb pub ithP i v m = div_ [] [ text $ S.pack $ ithP i ++ " move: " ++ {- replicate (length (ithP 2) - length (ithP i)) ' ' ++ -} show m , case result $ publicView v of Discard c -> showResults c ", which revealed " Success c -> showResults c ", which succeeded revealing " Fail c -> showResults c ", which failed revealing " _ -> text $ S.pack "" ] where showResults c xs = span_ [] [ xs -- , renderHand' verbose pub [Just c] [(Nothing,Nothing)] , renderCardInline verb pub c , text $ S.pack "." ] renderPI :: Verbosity -> PublicInfo -> View Action renderPI verb pub = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [ text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck pub ++ "Lives: " ++ show (lives pub), span_ [style_ $ M.fromList [("font-size","1.5em"),("color","#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","#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_ [] [ text $ S.pack $ "deck: ", 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 [("color", "#FF0000"), ("font-weight", "bold")]] [text "← Bottom deck"] n | n>1 && n <= numPlayers (gameSpec pub) -> span_ [style_ $ M.fromList [("color", "#777700"), ("font-weight", "bold")]] [text "Be ready for the bottom deck"] | otherwise -> span_ [] [] ], div_ [] [ text $ S.pack "played ", span_ (if achievable - current >= pileNum pub then [style_ $ M.fromList [("color", "#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", "3vmin")]] $ [ 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 ] ++ [text $ S.pack "|"] ], div_ [] [ text $ S.pack $ "dropped: ", -- 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", "3vmin")]] $ [ 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 ] ++ [text $ S.pack "|"] ] ] where current = currentScore pub achievable = seeminglyAchievableScore pub -- renderCardsInline is a compact version of renderCardInline that prints the color letter only once. renderCardsInline :: Verbosity -> PublicInfo -> Color -> [Rank] -> View Action renderCardsInline v pub c ns = span_ [style_ $ M.fromList [("color", colorStr $ Just c),("background-color","#000000")]] $ span_ [] [text $ S.pack $ take 1 $ show c] : map (rankStrInline v pub c) ns rankStrInline v pub c n = cardStrInline v pub (C c n) $ show $ fromEnum n renderCardInline :: Verbosity -> PublicInfo -> Card -> View Action renderCardInline v pub c = span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "4vmin"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStrInline v pub c $ head (show $ color c) : show (fromEnum $ rank c)] 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 :: Verbosity -> 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 :: Verbosity -> PrivateView -> View Action renderPV v 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 "Your") 0 [ Nothing | _ <- yourHand] yourHand : -- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length yourHand] ] (zipWith3 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ annotations pub)) ) ] where yourHand = head (annotations pub) renderSt :: Verbosity -> (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 :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Annotation] -> View Action renderHand v pv ithPnumP i mbcards anns = div_ [] [ div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [text $ S.pack $ ithPnumP i ++ " hand:"], renderHand' v pv i mbcards anns -- renderCards v pub (map Just cards) hl ] renderHand' :: Verbosity -> 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 :: Verbosity -> PrivateView -> Int -> [Annotation] -> Index -> Maybe Card -> Annotation -> View Action renderCard v pv pli anns i mbc ann@Ann{marks=tup@(mc,mk), possibilities=ptup@(pc,pn)} = td_ [style_ $ M.fromList [("text-align","center"), ("width", S.pack $ shows cardWidth "vmin"), ("color", colorStr $ fmap color mbc), ("font-family", "monospace") -- , ]] [ -- ("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 "play") ]) (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 v pub pli mbc tup ], (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 '_' (head . show) mc : ' ' : [maybe '_' (head . show . fromEnum) mk] else "_ _" ], 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 "drop") ]) (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 pc, -- br_[], text $ S.pack $ showRankPossibilities pn] else span_[][] ] where pub = publicView pv cardWidth = 90 / 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 {- renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [ tr_ [style_ $ M.fromList [("background-color","#000000")]] [ td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [ cardStr v pub mbc tup ] | (mbc,tup) <- zip mbcs tups ], tr_ [style_ $ M.fromList [("background-color","#000000")]] [ td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [ text $ S.pack $ if markHints v then maybe ' ' (head . show) mc : [maybe ' ' (head . show . fromEnum) mk] else "" ] | (mbc,(mc,mk)) <- zip mbcs tups ] ] -} cardStr :: Verbosity -> PublicInfo -> Int -> Maybe Card -> (Maybe Color, Maybe Rank) -> View Action -- Not sure which style is better. #ifdef BUTTONSONCARDS cardStr v pub pli mbc tup = case mbc of Nothing -> span_ [] [text $ S.pack "??"] 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", colorStr $ fmap color mbc)] #else cardStr v pub pli mbc tup = case mbc of Nothing -> div_ [style_ $ M.fromList [("text-align","center")]] [text $ S.pack "? ?"] 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 $ take 1 $ show $ 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 $ show $ fromEnum $ 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")] #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 mvmov) = putMVar mvmsg $ WhatsUp1 v m getMoveUntilSuccess pv mvstr@(MVS mvmsg mvmov) = do m <- takeMVar mvmov if isMoveValid pv m then return m else do putMVar mvmsg $ Str "invalid move" getMoveUntilSuccess pv mvstr newMVarStrategy = do mvmsg <- newEmptyMVar mvmov <- newEmptyMVar return $ MVS mvmsg mvmov instance Show MVarStrategy where showsPrec p _ = ("MVarStrategy "++)