diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # Revision history for hanabi-dealer + ## 0.5.0.0 -- 2020-02-05 + + * implement possibility marks which represent what colors and what numbers are possible for each card + + * introduce utility functions using the information of possibilities, and redesign the set of utilities + + * implement isDoubleDrop and warnDoubleDrop + + * enable customizing verbosity from the client + + * support Warp as the WebSocket server + + * add the jsaddle flag + ## 0.4.0.1 -- 2020-01-29 * fix the bug of the endgame behavior that crept in during the switch to 0.4.0.0 diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -11,12 +11,13 @@ -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), -- ** The Cards - Card(..), Color(..), Number(..), Marks, cardToInt, intToCard, readsColorChar, readsNumberChar, + Card(..), Color(..), Number(..), Marks, Possibilities, cardToInt, intToCard, readsColorChar, readsNumberChar, -- * Utilities -- ** Hints - isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, isObviouslyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, invisibleBag, chops, chopss, + isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, + isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, obviousChopss, definiteChopss, isDoubleDrop, -- ** Minor ones - what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth, shuffle) where + what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random @@ -24,9 +25,11 @@ import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust) -import Data.List(isPrefixOf, group) +import Data.List(isPrefixOf, group, zipWith4) import System.IO import Data.Dynamic +import Data.Bits hiding (rotate) +import Numeric(showIntAtBase, showOct) import GHC.Generics hiding (K1) @@ -155,12 +158,14 @@ -- Negative hints should also be implemented, but they should be kept separate from givenHints, -- in order to guess the behavior of algorithms that do not use such information. + , possibilities :: [[Possibilities]] , result :: Result -- ^ The result of the last move. This info may be separated from 'PublicInfo' in future. } deriving (Read, Show, Eq, Generic) -- | 'Marks' is the type synonym representing the hint trace of a card. type Marks = (Maybe Color, Maybe Number) +type Possibilities = (Int, Int) -- | the best achievable rank for each color. bestPossibleRank :: PublicInfo -> Color -> Number @@ -195,33 +200,70 @@ isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub --- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks at other players' hand and decides if the card is surely playable. -isObviouslyPlayable :: PrivateView -> Marks -> Bool -isObviouslyPlayable pv = iOP (invisibleBag pv) (publicView pv) +-- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks into the color/number possibilities of the card and decides if the card is surely playable. +isObviouslyPlayable :: PublicInfo -> Possibilities -> Bool +isObviouslyPlayable pub (pc,pn) = all (\card -> (nonPublic pub IM.! cardToInt card) == 0 || isPlayable pub card) + [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] +-- | In addition to 'isObviouslyPlayable', 'isDefinitelyPlayable' also looks at other players' hand and decides if the card is surely playable. +{- This is a weaker version not looking into the possibilities. +isDefinitelyPlayable :: PrivateView -> Marks -> Bool +isDefinitelyPlayable pv = iOP (invisibleBag pv) (publicView pv) +-} +isDefinitelyPlayable :: PrivateView -> Marks -> Possibilities -> Bool +isDefinitelyPlayable pv (Just c, Just n) _ = isPlayable (publicView pv) $ C c n -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. +isDefinitelyPlayable pv _ (pc,pn) = all (\card -> (invisibleBag pv IM.! cardToInt card) == 0 || isPlayable (publicView pv) card) + [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] + + iOP bag pub (Just c, Just n) = isPlayable pub $ C c n -iOP bag pub (Nothing,Just n) = all (isPlayable pub) [ card | color <- colors pub, let card = C color n, (bag IM.! cardToInt card) > 0 ] +iOP bag pub (Nothing,Just n) = all (\card -> (bag IM.! cardToInt card) == 0 || isPlayable pub card) [ C color n | color <- colors pub ] iOP _ _ _ = False -- | 'isMoreObviouslyUseless' looks at the publicly available current info and decides if the card is surely useless. -isObviouslyUseless :: PublicInfo -> Marks -> Bool -isObviouslyUseless pub (Just c, Just n) = isUseless pub $ C c n -isObviouslyUseless pub (Just c, Nothing) = bestPossibleRank pub c == achievedRank pub c -isObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub -isObviouslyUseless pub (Nothing, Nothing) = False +isMoreObviouslyUseless :: PublicInfo -> Marks -> Bool +isMoreObviouslyUseless pub (Just c, Just n) = isUseless pub $ C c n +isMoreObviouslyUseless pub (Just c, Nothing) = bestPossibleRank pub c == achievedRank pub c +isMoreObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub +isMoreObviouslyUseless pub (Nothing, Nothing) = False +isObviouslyUseless :: PublicInfo -> Possibilities -> Bool +isObviouslyUseless pub (pc,pn) = all (\card@(C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n || (nonPublic pub IM.! cardToInt (C c n)) == 0 ) + [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] + +isDefinitelyUseless :: PrivateView -> Marks -> Possibilities -> Bool +isDefinitelyUseless pv (Just c, Just n) _ = isUseless (publicView pv) $ C c n -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. +isDefinitelyUseless pv _ (pc,pn) = all (\card@(C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n || (invisibleBag pv IM.! cardToInt card) == 0 ) + [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] + where pub = publicView pv + +{- This is a weaker version not looking into the possibilities. +isDefinitelyUseless :: PrivateView -> Marks -> Bool +isDefinitelyUseless pv (Just c, Just n) = isUseless (publicView pv) $ C c n +isDefinitelyUseless pv (Just c, Nothing) = all ((==0) . (invisibleBag pv IM.!) . cardToInt . C c . toEnum) [ succ $ fromEnum $ achievedRank (publicView pv) c .. fromEnum $ bestPossibleRank (publicView pv) c ] +isDefinitelyUseless pv (Nothing, Just n) = all (\c -> n <= achievedRank (publicView pv) c || bestPossibleRank (publicView pv) c < n || (invisibleBag pv IM.! cardToInt (C c n)) == 0 ) $ colors $ publicView pv +isDefinitelyUseless pv (Nothing, Nothing) = all (\c -> all ((==0) . (invisibleBag pv IM.!) . cardToInt . C c . toEnum) [ succ $ fromEnum $ achievedRank (publicView pv) c .. fromEnum $ bestPossibleRank (publicView pv) c ]) $ colors $ publicView pv +-} +-- In fact, invisibleBag should be included in PrivateView for efficiency of isDefinitelyUseless, etc., but should not be sent via WebSocket. This is the matter of Read and Show (or ToJSON and FromJSON). + + -- | @'choppiri' marks@ = [unmarked last, unmarked second last, ...]. This is "beginner players' idea of chops". choppiri :: [Marks] -> [(Index, Marks)] choppiri = reverse . filter (not . isHinted . snd) . zip [0..] --- | In addition to 'choppiri', 'chopss' considers 'isObviouslyUseless'. Since "from which card to drop among obviously-useless cards" depends on conventions, cards with the same uselessness are wrapped in a list within the ordered list. -chopss :: PublicInfo -> [Marks] -> [[(Index, Marks)]] -chopss pub hls = (if null useless then id else (useless :)) $ map (:[]) (choppiri hls) - where useless = filter (isObviouslyUseless pub . snd) (zip [0..] hls) --- | 'chops' is the flattened version of 'chopss' -chops :: PublicInfo -> [Marks] -> [(Index, Marks)] -chops pub hls = concat $ map reverse $ chopss pub hls +-- | In addition to 'choppiri', 'definiteChopss' and 'obviousChopss' consider 'isDefinitelyUseless' and 'isObviouslyUseless' respectively. Since "from which card to drop among obviously-useless cards" depends on conventions, cards with the same uselessness are wrapped in a list within the ordered list. +definiteChopss :: PrivateView -> [Marks] -> [Possibilities] -> [[Index]] +definiteChopss pv hls ps = (if null useless then id else (useless :)) $ map ((:[]) . fst) (choppiri hls) + where useless = map fst $ filter (uncurry (isDefinitelyUseless pv) . snd) (zip [0..] $ zip hls ps) +obviousChopss :: PublicInfo -> [Marks] -> [Possibilities] -> [[Index]] +obviousChopss pub hls ps = (if null useless then id else (useless :)) $ map ((:[]) . fst) (choppiri hls) + where useless = map fst $ filter (isObviouslyUseless pub . snd) (zip [0..] ps) +-- | 'chops' is the flattened version of 'obviousChopss' +chops :: PublicInfo -> [Marks] -> [Possibilities] -> [Index] +chops pub hls ps = concat $ map reverse $ obviousChopss pub hls ps +isDoubleDrop pv (Discard c) [i] (pc,pn) | isCritical (publicView pv) c = color c `elem` colorPossibilities pc && number c `elem` numberPossibilities pn && (invisibleBag pv IM.! cardToInt c) > 0 +isDoubleDrop _pv _lastresult _chopset _ps = False colors :: PublicInfo -> [Color] colors pub = take (numColors $ rule $ gameSpec pub) [minBound .. maxBound] @@ -250,56 +292,95 @@ , handsPV :: [[Card]] -- ^ Other players' hands. [next player's hand, second next player's hand, ...] -- This is based on the viewer's viewpoint (unlike 'hands' which is based on the current player's viewpoint), -- and the view history @[PrivateView]@ must be from the same player's viewpoint (as the matter of course). - } deriving (Read, Show, Eq, Generic) --- | 'invisibleBag' returns the bag of unknown cards (which are either in the pile or in the player's hand and not fully hinted). -invisibleBag :: PrivateView - -> IM.IntMap Int -- ^ @'Card' -> Int@ -invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ [ C c n | (Just c, Just n) <- head $ givenHints $ publicView pv ] : handsPV pv + , invisibleBag :: IM.IntMap Int -- ^ @'Card' -> Int@. 'invisibleBag' is the bag of unknown cards (which are either in the pile or in the player's hand and not fully hinted). + } deriving (Generic) -- ToDo: Instance for Generic should also be specialized for efficiency. +instance Show PrivateView where + showsPrec p (PV pub h _) = showsPrec p (pub,h) +instance Read PrivateView where + readsPrec p str = [ (mkPV pub hs, rest) | ((pub,hs), rest) <- readsPrec p str ] +instance Eq PrivateView where + PV pub1 hs1 _ == PV pub2 hs2 _ = (pub1,hs1) == (pub2,hs2) +-- | 'mkPV' is the constructor of PrivateView. +mkPV pub hs = PV pub hs $ foldr (IM.update (Just . pred)) (nonPublic pub) $ map cardToInt $ concat $ [ C c n | (Just c, Just n) <- head $ givenHints pub ] : hs + prettyPV :: Verbosity -> PrivateView -> String prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n" - ++ concat (replicate (length myHand) " __") ++ "\n" --- ++ concat [ if markObviouslyPlayable v && isObviouslyPlayable pv h then " _^" else " __" | h <- myHand ] ++"\n" - ++ concat (replicate (length myHand) "|**") ++ "|\n" - ++ (if markHints v then showHintLine myHand else "") + ++ concat (replicate (length myHand) $ wrap "+--+") ++ "\n" +-- ++ concat [ if markObviouslyPlayable v && isDefinitelyPlayable pv h then " _^" else " __" | h <- myHand ] ++"\n" + ++ concat (replicate (length myHand) $ wrap "|**|") ++ "\n" + ++ (if markHints v then showHintLine wrap myHand else "") -- x ++ concat (replicate (length myHand) " ~~") ++ "\n" -- x ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ] - ++ concat [ '+':(if markChops v && d `elem` map fst (concat $ take 1 $ chopss pub myHand) then ('X':) else shows d) - (if markObviouslyUseless v && isObviouslyUseless pub h then "." else - if markObviouslyPlayable v && isObviouslyPlayable pv h then "^" else "-") | (d,h) <- zip [0..] myHand ] + ++ concat [ wrap $ + '+':(if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet p && d `elem` chopSet then ('D':) else + if markChops v && d `elem` chopSet then ('X':) else shows d) + (if markObviouslyUseless v && isDefinitelyUseless pv h p then ".+" else + if markObviouslyPlayable v && isDefinitelyPlayable pv h p then "^+" else "-+") | (d,h,p) <- zip3 [0..] myHand myPos ] - ++ concat (zipWith3 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) $ tail $ givenHints pub) + ++"\n" + ++ (if markPossibilities v then showPosLines $ head $ possibilities pub else "") + ++ concat (zipWith4 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) (tail $ givenHints pub) (tail $ possibilities pub))++"\n" where myHand = head (givenHints pub) -prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) $ givenHints pub) -verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markChops=True} -prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> String -prettyHand v pub ithPnumP i cards hl = "\n\n" ++ ithPnumP i ++ " hand:\n" + myPos = head (possibilities pub) + wrap xs | markPossibilities v = " "++xs++" " + | otherwise = xs + chopSet = concat $ take 1 $ definiteChopss pv myHand myPos +prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith4 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) (givenHints pub) (possibilities pub)) +verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markPossibilities=True,markChops=True,warnDoubleDrop=True} +prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> [Possibilities] -> String +prettyHand v pub ithPnumP i cards hl ps = "\n\n" ++ ithPnumP i ++ " hand:\n" -- ++ concat (replicate (length cards) " __") ++ " \n" - ++ concat [ if markUseless v && isUseless pub card then " .." + ++ concat [ wrap $ + if markUseless v && isUseless pub card then "+..+" else case (warnCritical v && tup==(Nothing,Nothing) && isCritical pub card, markPlayable v && isPlayable pub card) of - (True, True) -> " !^" - (True, False) -> " !!" - (False,True) -> " _^" - (False,False) -> " __" + (True, True) -> "+!^+" + (True, False) -> "+!!+" + (False,True) -> "+-^+" + (False,False) -> "+--+" | (card, tup) <- zip cards hl ] ++"\n" - ++ concat [ '|':show card | card <- cards ] ++"|\n" - ++ (if markHints v then showHintLine hl else "") + ++ concat [ wrap $ '|':shows card "|" | card <- cards ] ++"\n" + ++ (if markHints v then showHintLine wrap hl else "") -- x ++ concat (replicate (length cards) "+--") - ++ concat [ '+':(if markChops v && map fst (take 1 $ chops pub hl) == [d] then ('X':) else ('-':)) - (if markObviouslyUseless v && isObviouslyUseless pub h then "." else - if markObviouslyPlayable v && isMoreObviouslyPlayable pub h then "^" else "-") | (d,h) <- zip [0..] hl ] + ++ concat [ wrap $ + '+':(if markChops v && d `elem` (concat $ take 1 $ obviousChopss pub hl ps) then ('X':) else ('-':)) + (if markObviouslyUseless v && isObviouslyUseless pub h then ".+" else + if markObviouslyPlayable v && isObviouslyPlayable pub h then "^+" else "-+") | (d,h) <- zip [0..] ps ]++"\n" + ++ (if markPossibilities v then showPosLines ps else "") + where wrap xs | markPossibilities v = " "++xs++" " + | otherwise = {- take 3 -} xs -showHintLine :: [Marks] -> String -showHintLine hl = '|' : concat [ maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n" +showHintLine :: (String -> String) -> [Marks] -> String +showHintLine wrapper hl = concat [ wrapper $ '|' : maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n" +showPosLines :: [Possibilities] -> String +showPosLines ps = concat [ ' ' : showColorPossibilities cs | (cs,_) <- ps] ++ "\n" + ++ concat [ showNumberPossibilities ns ++" " | (_,ns) <- ps] + +showColorPossibilities = reverse . showPossibilities ' ' colorkeys +showNumberPossibilities = reverse . showPossibilities ' ' "54321 " +colorkeys = map (head . show) [maxBound, pred maxBound .. minBound::Color] -- colorkeys == "MBGRYW", but I just prefer to make this robust to changes in the order. +showPossibilities _ [] pos = [] +showPossibilities blank (x:xs) pos = (if odd pos then x else blank) : showPossibilities blank xs (pos `div` 2) + +colorPossibilities :: Int -> [Color] -- The result is in the reverse order but I do not care. +colorPossibilities = concat . showPossibilities [] (map (:[]) [maxBound, pred maxBound .. minBound]) +numberPossibilities :: Int -> [Number] -- The result is in the reverse order but I do not care. +numberPossibilities = concat . showPossibilities [] (map (:[]) [K5,K4 .. K1]) + + + -- | 'Verbosity' is the set of options used by verbose 'Strategy's data Verbosity = V { warnCritical :: Bool -- ^ mark unhinted critical cards with "!!" ("!^" if it is playable and markPlayable==True.) - , markUseless :: Bool -- ^ mark useless cards with ".." + , markUseless :: Bool -- ^ mark useless cards with "..". , markPlayable :: Bool -- ^ mark playable cards with "_^". ("!^" if it is unhinted critical and warnCritical==True.) , markObviouslyUseless :: Bool -- ^ mark useless cards with "_." based on the hint marks. , markObviouslyPlayable :: Bool -- ^ mark playable cards with "_^" based on the hint marks. , markChops :: Bool -- ^ mark the chop card(s) with "X". All obviously-useless cards will be marked, if any. - , markHints :: Bool -- ^ mark hints. + , warnDoubleDrop:: Bool -- ^ mark the chop card with "D" when dropping it is double-dropping. + , markHints :: Bool -- ^ mark hints. + , markPossibilities :: Bool -- ^ mark more detailed hints based on the positive/negative hint history. + -- markPossibilities == True && markHints == False is a reasonable choice, though markHints should still be informative for guessing other players' behavior. } deriving (Read, Show, Eq, Generic) @@ -320,8 +401,7 @@ ++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n" view :: State -> PrivateView -view st = PV {publicView = publicState st, - handsPV = tail $ hands st} +view st = mkPV (publicState st) (tail $ hands st) main = selfplay defaultGS @@ -536,6 +616,7 @@ hintTokens = 8, deadline = Nothing, givenHints = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (Nothing, Nothing), + possibilities = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (unknown gs), result = None }, pile = stack, @@ -549,6 +630,8 @@ [ (C i k, n) | i <- [White .. pred Multicolor], (k,n) <- numAssoc ] ++ [ (C Multicolor k, n) | (k, n) <- zip [K1 ..K5] (numMulticolors rule) ] cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ] cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ] +unknown :: GameSpec -> Possibilities +unknown gs = (64 - bit (6 - numColors (rule gs)), 31) shuffle :: RandomGen g => [c] -> g -> ([c], g) shuffle xs = shuf [] xs $ length xs @@ -578,10 +661,12 @@ -- only used by Drop and Play (nth, droppedHand) = pickNth (index mv) playersHand where playersHand = head $ hands st (_ , droppedHint) = pickNth (index mv) playersHint where playersHint = head $ givenHints pub - (nextHand,nextHint,nextPile, nextPileNum) = case pile st of [] -> (droppedHand, droppedHint, [], 0) - d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, ps, pred $ pileNum pub) + (_ , droppedPos) = pickNth (index mv) playersPos where playersPos = head $ possibilities pub + (nextHand,nextHint,nextPos,nextPile, nextPileNum) = case pile st of [] -> (droppedHand, droppedHint, droppedPos, [], 0) + d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, unknown gS : droppedPos, ps, pred $ pileNum pub) nextHands = nextHand : tail (hands st) nextHints = nextHint : tail (givenHints pub) + nextPoss = nextPos : tail (possibilities pub) nextDeadline = case deadline pub of Nothing | nextPileNum==0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS | otherwise -> Nothing Just i -> Just $ pred i @@ -593,6 +678,7 @@ turn = succ $ turn pub, hintTokens = succ $ hintTokens pub, givenHints = nextHints, + possibilities = nextPoss, deadline = nextDeadline, result = Discard nth}} prc (Play i) | failure = let newst@St{publicState=newpub} = prc (Drop i) in newst{publicState=newpub{hintTokens = hintTokens pub, lives = pred $ lives pub, result = Fail nth}} @@ -604,12 +690,14 @@ turn = succ $ turn pub, hintTokens = if hintTokens pub < 8 && number nth == K5 then succ $ hintTokens pub else hintTokens pub, givenHints = nextHints, + possibilities = nextPoss, deadline = nextDeadline, result = Success nth}} where failure = not $ isPlayable pub nth prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub, turn = succ $ turn pub, givenHints = snd $ updateNth hintedpl newHints (givenHints pub), + possibilities = snd $ updateNth hintedpl newPoss (possibilities pub), deadline = case deadline pub of Nothing -> Nothing Just i -> Just $ pred i, result = None}} @@ -617,11 +705,19 @@ zipper (C ir ka) (mi,mk) = case eik of Left i | i==ir -> (Just i, mk) Right k | k==ka -> (mi, Just k) _ -> (mi, mk) + newPoss hs = zipWith zipperPos (hands st !! hintedpl) hs + zipperPos (C ir ka) (c,n) = case eik of Left i | i == ir -> (bit ibit, n) + |otherwise-> (clearBit c ibit, n) + where ibit = 5 - fromEnum i + Right k | k == ka -> (c, bit kbit) + |otherwise-> (c, clearBit n kbit) + where kbit = 5 - fromEnum k + -- | @'rotate' num@ rotates the first person by @num@ (modulo the number of players). rotate :: Int -> State -> State rotate num st@(St{publicState=pub@PI{gameSpec=gS}}) = st{hands = rotateList $ hands st, - publicState = pub{givenHints = rotateList $ givenHints pub}} + publicState = pub{givenHints = rotateList $ givenHints pub, possibilities = rotateList $ possibilities pub}} where rotateList xs = case splitAt (num `mod` numPlayers gS) xs of (tk,dr) -> dr++tk -- | 'EndGame' represents the game score, along with the info of how the game ended. diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -1,5 +1,5 @@ \begin{code} -{-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-} -- Do not forget -threaded! -- @@ -46,6 +46,13 @@ import Snap.Http.Server.Config import Snap.Http.Server import Data.ByteString.UTF8(fromString) +#else +# ifdef WARP +import Network.Wai.Handler.WebSockets +import Network.Wai.Handler.Warp as Warp +import Network.Wai(responseLBS) +import Network.HTTP.Types(status400) +# endif #endif #ifdef AESON @@ -97,11 +104,14 @@ mv <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) let params = Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"} #ifdef SNAP - httpServe (setPort (port options) defaultConfig) $ runWebSocketsSnap + httpServe (setPort (port options) defaultConfig) $ runWebSocketsSnap $ loop params #else - runServer "127.0.0.1" (port options) +# ifdef WARP + Warp.run (port options) $ websocketsOr defaultConnectionOptions (loop params) $ \_ resp -> resp $ responseLBS status400 [] "Not a WebSocket request." +# else + runServer "127.0.0.1" (port options) $ loop params +# endif #endif - $ loop params data Params g = Params{gen :: g, mvTIDToMVH :: MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))), @@ -184,6 +194,7 @@ wordsBy pred xs = case break pred xs of (tk, []) -> [tk] (tk,_:dr) -> tk : wordsBy pred dr isWS = (`elem` ["0", "WS", "via WebSocket"]) + interpret :: RandomGen g => Maybe Verbosity -> String -> Params g -> IO () interpret mbVerb inp params diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -12,10 +12,11 @@ import Data.Aeson hiding (Success) import GHC.Generics hiding (K1, from) import Data.Bool +import Data.Char(isSpace) import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(fromJust, isNothing) -import Data.List(intersperse) +import Data.List(intersperse, zipWith4) import Miso hiding (Fail) import Miso.String (MisoString) @@ -38,7 +39,7 @@ client :: Game.Hanabi.Msg.Options -> IO () client options = runApp $ startApp App{ - model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False}, + model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose}, update = updateModel, view = appView strNames $ version options, subs = [ websocketSub uri protocols HandleWebSocket ], @@ -65,7 +66,7 @@ updateModel :: Action -> Model -> Effect Action Model updateModel (HandleWebSocket (WebSocketMessage (Message m))) model = noEff model{ received = {- take lenHistory $ -} decodeMsg m : received model } -updateModel (SendMessage msg) model = model{fullHistory=False} <# (-- connect uri protocols >> +updateModel (SendMessage msg) model = model{fullHistory=False, showVerbosity=False} <# (-- connect uri protocols >> send msg >> return Id) updateModel (UpdateTBoxVal m) model = noEff model{ tboxval = Message m } updateModel (From mbn) model = noEff model{from = mbn} @@ -73,7 +74,9 @@ updateModel DecreasePlayers model = noEff model{players = case players model of {n:ns@(_:_) -> ns; ns -> ns}} updateModel (UpdatePlayer ix pl) model = noEff model{players = snd $ replaceNth ix pl $ players model} updateModel (UpdateRule r) model | isRuleValid r = noEff model{rule=r} +updateModel (UpdateVerbosity v) model = noEff model{verbosity = v} updateModel Toggle model = noEff model{fullHistory = not $ fullHistory model} +updateModel ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model} #ifdef DEBUG updateModel (HandleWebSocket act) model = noEff model{received = Str (show act) : received model } #endif @@ -94,7 +97,9 @@ | DecreasePlayers | UpdatePlayer Int MisoString | UpdateRule Rule + | UpdateVerbosity Verbosity | Toggle + | ToggleVerbosity | Id data Model = Model { @@ -104,6 +109,8 @@ , rule :: Rule , received :: [Msg] , fullHistory :: Bool + , showVerbosity :: Bool + , verbosity :: Verbosity } deriving (Show, Eq) lenShownHistory = 10 @@ -112,16 +119,42 @@ input_ [ type_ "text", placeholder_ "You can also use your keyboard.", size_ "25", onInput UpdateTBoxVal, onEnter (SendMessage tboxval) ] , button_ [ onClick (SendMessage tboxval) ] [ text (S.pack "Send to the server") ] -- x , span_ [style_ $ M.fromList [("font-size","10px")]] [text $ S.pack "(Use this line if you prefer the keyboard interface.)"] - , span_ [style_ $ M.fromList [("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo] + + , 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")]] ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbose mdl) received) + , div_ [style_ $ M.fromList [("clear","both")]] ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbosity mdl) received) , div_ [] $ if null $ drop lenShownHistory received then [] else [ hr_ [] , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory] , label_ [for_ "showhist"] [text "Show full history"] ] ] +renderVerbosity :: Verbosity -> View Action +renderVerbosity v = div_ [] [ + mkChx v "mark unhinted critical cards" (\b -> v{warnCritical=b}) warnCritical, + mkChx v "mark useless cards" (\b -> v{markUseless=b}) markUseless, + mkChx v "mark playable cards" (\b -> v{markPlayable=b}) markPlayable, + mkChx v "mark useless cards without looking at the cards" (\b -> v{markObviouslyUseless=b}) markObviouslyUseless, + mkChx v "mark playable cards without looking at the cards" (\b -> v{markObviouslyPlayable=b}) markObviouslyPlayable, + mkChx v "shade the chop card(s)" (\b -> v{markChops=b}) markChops, + mkChx v "warn possible double-dropping"(\b -> v{warnDoubleDrop=b}) warnDoubleDrop, + mkChx v "mark hints" (\b -> v{markHints=b}) markHints, + mkChx v "mark possibilities" (\b -> v{markPossibilities=b}) markPossibilities + ] + +mkChx verb label update access = div_ [] [ + 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) {- @@ -153,7 +186,7 @@ renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m renderMsg _ _ _ (PrettyEndGame Nothing) = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing] -renderMsg _ _ _ (PrettyEndGame (Just tup)) = renderEndGame tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup] +renderMsg _ verb _ (PrettyEndGame (Just tup)) = renderEndGame verb tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup] renderMsg strategies _ mdl (PrettyAvailable games) = div_ [style_ $ M.fromList [("overflow","auto")]] [ hr_ [], @@ -177,17 +210,26 @@ -- 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 label updater access = tr_ [] [ td_ [] [text label], td_ [] [ input_ [type_ "text", onInput (UpdateRule . updater . head . (++[access $ rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ access $ rule mdl] ] + ] + mkTRd label updater access options = tr_ [] [ + td_ [] [text label], + td_ [] [ + dropdownLiteral options (UpdateRule . updater) (access $ rule mdl) + ] ] in table_ [solid] [ caption_ [] [text "Rules"], - mkTR "Number of lives" (\n -> (rule mdl){numBlackTokens=n}) numBlackTokens, - mkTR "Number of colors" (\n -> (rule mdl){numColors=n}) numColors, - mkTR "Continue the game after the pile is exhausted" (\n -> (rule mdl){prolong=n}) prolong, + 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], mkTR "numMulticolors" (\n -> (rule mdl){numMulticolors=n}) numMulticolors, mkTR "funPlayerHand" (\n -> (rule mdl){funPlayerHand=n}) funPlayerHand ], @@ -198,9 +240,17 @@ ] renderPlayer :: [MisoString] -> Int -> MisoString -> View Action --renderPlayer _ i p = text p -renderPlayer strategies i p = select_ [onChange $ UpdatePlayer i] [ option_ [value_ p', selected_ $ p==p'] [text p'] | p' <- strategies ] +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 = dropdownLiteral [False,True] +-- but in most cases booleans should be selected by check boxes. + renderAvailable (gameid, (missing, total)) = tr_ [onClick $ SendMessage $ Message $ S.pack $ "attend "++show gameid] [ td_ [solid] [text $ S.pack str] | str <- [show gameid, show missing, show total] ] solid = style_ $ M.fromList [("border-style","solid")] @@ -209,7 +259,7 @@ hr_ [], text $ S.pack "Your turn.", hr_ [], - renderRecentEvents (publicView v) ithPlayer views moves, + renderRecentEvents verb (publicView v) ithPlayer views moves, hr_ [], text $ S.pack $ "Algorithm: " ++ name, renderPV verb v @@ -217,25 +267,25 @@ renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000")]] [ hr_ [], - renderTrial (publicView v) (const "") undefined v m, + renderTrial verb (publicView v) (const "") undefined v m, hr_ [], renderPV verb v ] -renderEndGame :: (EndGame, [State], [Move]) -> View Action -renderEndGame (eg,sts@(st:_),mvs) +renderEndGame :: Verbosity -> (EndGame, [State], [Move]) -> View Action +renderEndGame verb (eg,sts@(st:_),mvs) = div_ [] [ hr_ [], - renderRecentEvents (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs, + renderRecentEvents verb (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs, hr_ [], h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000")]] [text $ S.pack $ show eg], hr_ [], - renderSt ithPlayerFromTheLast st, + renderSt verb ithPlayerFromTheLast st, hr_ [] ] -renderTrial :: PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action -renderTrial pub ithP i v m = div_ [] [ +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 " @@ -245,10 +295,10 @@ where showResults c xs = span_ [] [ xs -- , renderHand' verbose pub [Just c] [(Nothing,Nothing)] - , renderCardInline verbose pub c + , renderCardInline verb pub c , text $ S.pack "." ] -renderPI pub +renderPI verb pub {- This was too verbose = let showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), " @@ -265,64 +315,70 @@ div_ [] [ text $ S.pack $ "played:", - span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verbose pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ], + span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verb pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ], text $ S.pack "|" ], div_ [] [ text $ S.pack $ "dropped: ", - span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verbose pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ], + span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ], text $ S.pack "|" ] ] -renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr verbose pub 0 (Just c) (Nothing,Nothing)] +renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr v pub 0 (Just c) (Nothing,Nothing)] -renderRecentEvents :: PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action -renderRecentEvents pub ithP vs@(v:_) ms = div_ [] $ reverse $ zipWith3 (renderTrial pub $ ithP nump) [pred nump, nump-2..0] vs ms +renderRecentEvents :: Verbosity -> PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action +renderRecentEvents verb pub ithP vs@(v:_) ms = div_ [] $ 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 pub, + renderPI v pub, div_ [] ( -- div_ [] [text $ S.pack $ "My hand:"] : -- renderCards v pub [ Nothing | _ <- myHand] myHand : - renderHand v pv (const "My") 0 [ Nothing | _ <- myHand] myHand : + renderHand v pv (const "My") 0 [ Nothing | _ <- myHand] myHand (head $ possibilities pub) : -- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ] - (zipWith3 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub) + (zipWith4 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ givenHints pub) (tail $ possibilities pub)) ) ] where myHand = head (givenHints pub) -renderSt ithP st@St{publicState=pub} = div_ [] $ - renderPI pub : - zipWith3 (renderHand verbose (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub) +renderSt verb ithP st@St{publicState=pub} = div_ [] $ + renderPI verb pub : + zipWith4 (renderHand verb (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub) (possibilities pub) -renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Marks] -> View Action -renderHand v pv ithPnumP i mbcards hl = div_ [] [ +renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action +renderHand v pv ithPnumP i mbcards hl ps = div_ [] [ div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"], - renderHand' v pv i mbcards hl + renderHand' v pv i mbcards hl ps -- renderCards v pub (map Just cards) hl ] -renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Marks] -> View Action -renderHand' v pv pli mbcards hl = - table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pv pli hl) [0..] mbcards hl)] +renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action +renderHand' v pv pli mbcards hl ps = + table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith4 (renderCard v pv pli hl ps) [0..] mbcards hl ps)] -renderCard :: Verbosity -> PrivateView -> Int -> [Marks] -> Index -> Maybe Card -> Marks -> View Action -renderCard v pv pli hl i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"), - ("color", colorStr $ fmap color mbc)]] [ +renderCard :: Verbosity -> PrivateView -> Int -> [Marks] -> [Possibilities] -> Index -> Maybe Card -> Marks -> Possibilities -> View Action +renderCard v pv pli hl ps i mbc tup@(mc,mk) ptup@(pc,pn) = td_ [style_ $ M.fromList [("width","4em"), + ("color", colorStr $ fmap color mbc)]] [ maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc, div_ [] [ cardStr v pub pli mbc tup ], div_ [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) ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc + maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'd':show i) ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc, + if markPossibilities v then div_ [style_ $ M.fromList [("font-size","0.8em")]] [text $ S.pack $ showColorPossibilities pc, br_[], text $ S.pack $ showNumberPossibilities pn] else span_[][] ] where pub = publicView pv - myStyle = style_ $ M.fromList [ ("background-color",if markChops v && i `elem` map fst (concat $ take 1 $ chopss pub hl) then "#888888" else "#000000"), - ("font-weight", if markObviouslyUseless v && isObviouslyUseless pub tup then "100" else "normal"), - ("font-style", if markObviouslyPlayable v && (if isNothing mbc then isObviouslyPlayable pv else isMoreObviouslyPlayable pub) tup then "oblique" else "normal")] + myStyle | isNothing mbc = style_ $ M.fromList [ ("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ptup && i `elem` chopSet then "#880000" else + if markChops v && i `elem` chopSet then "#888888" else "#000000"), + ("font-weight", if markObviouslyUseless v && isDefinitelyUseless pv tup ptup then "100" else "normal"), + ("font-style", if markObviouslyPlayable v && isDefinitelyPlayable pv tup ptup then "oblique" else "normal")] + | otherwise = style_ $ M.fromList [ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub hl ps) then "#888888" else "#000000"), + ("font-weight", if markObviouslyUseless v && isObviouslyUseless pub ptup then "100" else "normal"), + ("font-style", if markObviouslyPlayable v && isObviouslyPlayable pub ptup then "oblique" else "normal")] + chopSet = concat $ take 1 $ definiteChopss pv hl ps {- renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [ diff --git a/hanabi-dealer.cabal b/hanabi-dealer.cabal --- a/hanabi-dealer.cabal +++ b/hanabi-dealer.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.0.1 +version: 0.5.0.0 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -58,6 +58,9 @@ Default: False Flag SNAP Description: Use Snap instead of runServer. + Default: False +Flag WARP + Description: Use Warp instead of runServer. Default: True FLAG TFRANDOM Description: Use tf-random instead of random. @@ -69,6 +72,10 @@ FLAG TH Description: Use template-haskell just for obtaining the compilation time. Default: True +Flag jsaddle + Description: Build the client with JSaddle even when compiling with GHC. + (Package miso must have been built with --flags="jsaddle".) + Default: False library -- Modules exported by the library. @@ -90,7 +97,7 @@ -- Base language which the package is written in. default-language: Haskell2010 - if impl(ghcjs) || flag(server) + if impl(ghcjs) || flag(jsaddle) || flag(server) exposed-modules: Game.Hanabi.VersionInfo other-modules: Game.Hanabi.Msg -- cpp-options: -DCABAL @@ -109,10 +116,14 @@ if flag(SNAP) build-depends: unix >=2.7 && <2.8, websockets-snap >=0.10 && <0.11, snap-server >=1.1 && <1.2, abstract-par >=0.3 && <0.4, monad-par >=0.3 && <0.4 cpp-options: -DSNAP - if impl(ghcjs) + else + if flag(WARP) + build-depends: wai-websockets, warp, wai, http-types + cpp-options: -DWARP + if impl(ghcjs) || flag(jsaddle) exposed-modules: Game.Hanabi.Client ghcjs-options: -dedupe -O - build-depends: base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time + build-depends: base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time >=1.6 if flag(official) cpp-options: -DURI="ws://133.54.228.39:8720" @@ -135,16 +146,20 @@ if flag(SNAP) build-depends: unix >=2.7 && <2.8, websockets-snap >=0.10 && <0.11, snap-server >=1.1 && <1.2, abstract-par >=0.3 && <0.4, monad-par >=0.3 && <0.4 cpp-options: -DSNAP + else + if flag(WARP) + build-depends: wai-websockets, warp, wai, http-types + cpp-options: -DWARP executable client main-is: client.hs other-modules: Game.Hanabi.Msg, Game.Hanabi.Client, Game.Hanabi.VersionInfo, Game.Hanabi.Strategies.SimpleStrategy - if !impl(ghcjs) + if !impl(ghcjs) && !flag(jsaddle) buildable: False else ghcjs-options: -dedupe -O cpp-options: -DCABAL - build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time, hanabi-dealer + build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time >=1.6, hanabi-dealer default-language: Haskell2010 if flag(official) cpp-options: -DURI="ws://133.54.228.39:8720"