hanabi-dealer 0.11.0.2 → 0.15.1.1
raw patch · 23 files changed
+2953/−645 lines, 23 filesdep +MagicHaskellerdep +QuickCheckdep +arraydep ~basedep ~misodep ~randomnew-component:exe:hanabibat
Dependencies added: MagicHaskeller, QuickCheck, array, parallel, splitmix, transformers
Dependency ranges changed: base, miso, random, time, websockets
Files
- ChangeLog.md +26/−0
- Game/Hanabi.hs +292/−226
- Game/Hanabi/Backend.lhs +59/−23
- Game/Hanabi/Client.hs +462/−179
- Game/Hanabi/FFI.hs +2/−0
- Game/Hanabi/Msg.hs +19/−11
- Game/Hanabi/Strategies.hs +81/−0
- Game/Hanabi/Strategies/AdaptiveLMC.hs +415/−0
- Game/Hanabi/Strategies/AppendDSL.hs +364/−0
- Game/Hanabi/Strategies/EndGameLite.hs +112/−0
- Game/Hanabi/Strategies/EndGameOld.hs +56/−0
- Game/Hanabi/Strategies/EndGameSearch.hs +17/−15
- Game/Hanabi/Strategies/LazyMC.hs +363/−0
- Game/Hanabi/Strategies/MCSearch.hs +217/−0
- Game/Hanabi/Strategies/SimpleStrategy.hs +113/−52
- Game/Hanabi/Strategies/StatefulStrategy.hs +49/−28
- Game/Hanabi/Strategies/Stateless.hs +8/−8
- all.hs +2/−15
- batch.hs +159/−0
- client.hs +5/−18
- examples/exampleStrategy.lhs +31/−22
- hanabi-dealer.cabal +98/−32
- server.hs +3/−16
ChangeLog.md view
@@ -1,5 +1,31 @@ # Revision history for hanabi-dealer + ## 0.15.1.0 -- 2022-03-08++ ## 0.14.0.1 -- 2021-11-05++ * fix the bug of Stateful using the context of the last game++ ## 0.14.0.0 -- 2021-10-31++ * improve and parallelize AdaptiveLMC++ * support Japanese GUI++ * slightly extend data Msg++ ## 0.13.1.0 --++ * add AdaptiveLMC + AppendDSL strategy, that uses MagicHaskeller and is enabled with the MHLMC flag++ * change the implementation and the protocol of possibilities to bitvector-based for efficiency++ ## 0.12.1 -- 2021-05-26++ * add Monte-Carlo and LazyMC strategies++ * add some utilities for strategies+ ## 0.11.0.2 -- 2021-01-30 * EndGameLite falls back when there is a contradiction
Game/Hanabi.hs view
@@ -1,11 +1,16 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, DeriveGeneric, RecordWildCards, RankNTypes #-}+-- #define DEBUG+#if defined DEBUG || defined TEST+#else+{-# LANGUAGE Safe #-}+#endif module Game.Hanabi( -- * Functions for Dealing Games- main, selfplay, start, createGame, startFromCards, createGameFromCards, run, createDeck,- prettyEndGame, isMoveValid, checkEndGame, help,+ main, selfplay, startToEnd, createGame, startFromCardsToEnd, createGameFromCards, run, createDeck, proceed, rotate, start, startFromCards,+ prettyEndGame, prettyDeckEndGame, isMoveValid, checkEndGame, help, -- * Datatypes -- ** The Class of Strategies- Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, Replay(..),+ Strategies(..), Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, Replay(..), -- ** Audience Peeker, peek, -- ** The Game Specification@@ -13,27 +18,27 @@ -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), discarded, -- ** The Cards and Annotations- Card(..), Color(..), Rank(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsRankChar, colorToBitPos, rankToBitPos,+ Card(..), Color(..), Rank(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsRankChar, colorToBitPos, rankToBitPos, colorToQit, rankToQit, qitsToColorPossibilities, qitsToRankPossibilities, qitPosToCard, CardTo4, -- * Utilities -- ** Hints isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, seeminglyAchievableScore, moreStrictlyAchievableScore, achievableScore, definitely, obviously,- isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMoveOld, EndGameOld(..), EndGameMirrorOld(..), egmo, EndGameLite(..), egl, EndGameMirrorLite(..), egml,- tryMove, (|||), ifA,+ isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isObviouslyUncritical, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, keptCards, critical, isDefinitelyInconsistent, isObviouslyInconsistent,+ -- ** Other building blocks for strategies+ (|++), mkRule, tryMove, (|||), ifA,+ validMoves, effectiveMoves, stateToStateHistory, possibleStates, sampleState, egToInt, egToNum, viewStates, proceeds, runSilently, -- ** Legacy functions and types- givenHints, possibilities_until_Ver0720, Number, readsNumberChar, numberToBitPos, showNumberPossibilities,+ givenHints, Number, readsNumberChar, numberToBitPos, showNumberPossibilities, -- ** Minor ones- what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showRankPossibilities, showTrial, showDeck, cardBag) where+ what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, prettyPV, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showRankPossibilities, showTrial, showDeck, cardBag, debugPeek, showHistory, showHistory') where -- module Hanabi where-import qualified Data.Map as M import System.Random import Control.Applicative((<*>))-import Control.Monad(when)+import Control.Monad import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper)-import Data.Maybe(fromJust)-import Data.List(isPrefixOf, group, maximumBy, delete, sort)-import Data.Function(on)+import Data.Maybe+import Data.List(isPrefixOf, group) import System.IO import Data.Dynamic import Data.Bits hiding (rotate)@@ -41,6 +46,16 @@ import GHC.Generics hiding (K1) +#ifdef TEST+import Test.QuickCheck((==>))+#endif++#ifdef DEBUG+import Debug.Trace+#endif++infixr 5 |++ -- same as (++)+ data Rank = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) data Color = White | Yellow | Red | Green | Blue | Multicolor deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)@@ -69,9 +84,20 @@ cardToInt c = fromEnum (color c) * succ (fromEnum (maxBound::Rank)) + fromEnum (rank c) -- cardToQitPos is a variant of cardToInt whose value is less than 32. Since the Empty rank is never used for a card, there is no reason to use cardToInt, but it exists mainly for backward compatibility. -- cardToQitPos c = fromEnum (color c) * fromEnum (maxBound::Rank) + pred (fromEnum $ rank c)-cardToQitPos c = pred (fromEnum $ rank c) * (succ $ fromEnum (maxBound :: Color)) + fromEnum (color c) -- This is preferred over the above for efficient implementation of bestPossibleRank.+cardToQitPos c = pred (fromEnum $ rank c) * maxNumColors + fromEnum (color c) -- This is preferred over the above for efficient implementation of bestPossibleRank. intToCard :: Int -> Card intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Rank)) of (c,k) -> C (toEnum c) (toEnum k)+qitPosToCard i = case i `divMod` maxNumColors of (r,c) ->+#ifdef DEBUG+ (if r>=5 then trace ("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!qitPosToCard: r = "++show r ++ ", and i = "++shows i "") else id) $+#endif+ C (toEnum c) (succ $ toEnum r)+maxNumColors = succ $ fromEnum (maxBound :: Color) -- maxNumColors = 6+colorToQit :: Color -> CardTo4+colorToQit c = 0x3003003003003 `shiftL` (fromEnum c * 2)+rankToQit :: Rank -> CardTo4+rankToQit r = 0xFFF `shiftL` (pred (fromEnum r) * (maxNumColors*2))+ type Index = Int -- starts from 0 data Move = Drop {index::Index} -- ^ drop the card (0-origin)@@ -180,9 +206,9 @@ deleteACard c ct4 = ct4 - bit (cardToQitPos c * 2) insertACard :: Card -> CardTo4 -> CardTo4 insertACard c ct4 = ct4 + bit (cardToQitPos c * 2)--- something like @fmap abs@-absCardTo4 :: CardTo4 -> CardTo4-absCardTo4 ct4 = (ct4 .&. 0x5555555555555555) .|. ((ct4.&. 0x2AAAAAAAAAAAAAAA ) `shiftR` 1)+-- something like @fmap sgn@+sgnCardTo4 :: CardTo4 -> CardTo4+sgnCardTo4 ct4 = (ct4 .|. (ct4 `shiftR` 1)) .&.0x5555555555555555 cardTo4ToList :: CardTo4 -> [Card] cardTo4ToList ct4 = ctl ct4 [ C i k | k <- [K1 .. K5], i <- [White .. Multicolor] ] ctl 0 _ = []@@ -194,7 +220,7 @@ , currentScore :: Int , nextToPlay :: CardTo4 -- ^ 3(4) or 11(2) if the card is playable (ignoring whether it is extinct or not), and 0(4) or 00(2) otherwise. , kept :: CardTo4 -- ^ The multiset of not-discarded cards, packed into Int64.-+ , useless :: CardTo4 -- ^ The multiset of useless cards, packed into Int64 , nonPublic :: CardTo4 -- ^ The multiset of Cards that have not been revealed to the public. -- This does not include cards whose Color and Rank are both revealed. --@@ -211,8 +237,6 @@ givenHints :: PublicInfo -> [[Marks]] givenHints = map (map marks) . annotations-possibilities_until_Ver0720 :: PublicInfo -> [[Possibilities]]-possibilities_until_Ver0720 = map (map possibilities) . annotations -- | 'Marks' is the type synonym representing the hint trace of a card. type Marks = (Maybe Color, Maybe Rank)@@ -228,7 +252,7 @@ data Annotation = Ann {ixDeck :: Int -- ^ Index in the initial deck , marks :: Marks -- ^ The Rank and Color hints given to the card.- , possibilities :: Possibilities}+ , possibilities :: CardTo4} deriving (Eq, Generic) instance Show Annotation where showsPrec p (Ann i ms ps) = showsPrec p (i,ms,ps)@@ -273,17 +297,32 @@ -- | isUseless pi card means either the card is already played or it is above the bestPossibleRank. isUseless :: PublicInfo -> Card -> Bool+isUseless pub card = lookupCardTo4 (useless pub) card /= 0+{- naive implementation: isUseless pub card = rank card <= achievedRank pub (color card) -- the card is already played || rank card > bestPossibleRank pub (color card)+-} -- | A critical card is a useful card and the last card that has not been dropped. -- -- Unmarked critical card on the chop should be marked. isCritical :: PublicInfo -> Card -> Bool+isCritical pub card = lookupCardTo4 (criticalOnes pub) card /= 0+-- isCritical pub card = lookupCardTo4 (critical pub) card /= 0 -- This should be the same as the above, but should be less efficient unless memoized.+{- naive version: isCritical pub card = not (isUseless pub card) && keptCards pub card == 1+-}+critical :: PublicInfo -> CardTo4+critical pub = ones .|. (ones `shiftL` 1) -- This could also be memoized to PublicInfo.+ where ones = criticalOnes pub+criticalOnes pub = complement (useless pub) .&. kpt .&. (complement kpt `shiftR` 1) .&. 0x555555555555555+ where kpt = kept pub isPlayable :: PublicInfo -> Card -> Bool+isPlayable pub card = lookupCardTo4 (nextToPlay pub) card /= 0+{- naive implementation: isPlayable pub card = pred (rank card) == achievedRank pub (color card)+-} isHinted :: Marks -> Bool isHinted = not . (==(Nothing, Nothing))@@ -298,29 +337,40 @@ isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub -obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> Possibilities -> Bool-obviously predicate pub pos@(pc,pn) = all (predicate pub) $ cardTo4ToList $ absCardTo4 $ possibilitiesQits pos .&. nonPublic pub+obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> CardTo4 -> Bool+obviously predicate pub pos = all (predicate pub) $ cardTo4ToList $ sgnCardTo4 $ pos .&. nonPublic pub {- obviously predicate pub (pc,pn) = all (\card -> (nonPublicCards pub card) == 0 || predicate pub card) [ C color number | color <- colorPossibilities pc, number <- rankPossibilities pn ] -}-obviouslyQits :: (PublicInfo -> CardTo4) -> PublicInfo -> Possibilities -> Bool-obviouslyQits predicate pub pos = (possibilitiesQits pos .&. nonPublic pub .&. complement (predicate pub)) == 0+obviouslyQits :: (PublicInfo -> CardTo4) -> PublicInfo -> CardTo4 -> Bool+obviouslyQits predicate pub pos = (pos .&. nonPublic pub .&. complement (predicate pub)) == 0 -- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks into the color/rank possibilities of the card and decides if the card is surely playable.-isObviouslyPlayable :: PublicInfo -> Possibilities -> Bool+isObviouslyPlayable :: PublicInfo -> CardTo4 -> Bool isObviouslyPlayable = obviouslyQits nextToPlay -isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool+isObviouslyUnplayable :: PublicInfo -> CardTo4 -> Bool isObviouslyUnplayable = obviouslyQits (complement . nextToPlay) definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Annotation -> Bool definitely predicate pv ann = all (predicate pv) $ possibleCards pv ann definitelyQits :: (PrivateView -> CardTo4) -> PrivateView -> Annotation -> Bool-definitelyQits predicate pv Ann{marks = (Just c, Just n)} = predicate pv `testBit` (cardToQitPos (C c n) * 2) -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.-definitelyQits predicate pv Ann{possibilities = pos@(pc,pn)} = (possibilitiesQits pos .&. invisibleBag pv .&. complement (predicate pv)) == 0+--definitelyQits predicate pv Ann{marks = (Just c, Just n)} = predicate pv `testBit` (cardToQitPos (C c n) * 2) -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.+definitelyQits predicate pv Ann{marks = (Just c, Just n),possibilities = pos} = (pos .&. complement (predicate pv)) == 0 -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.+definitelyQits predicate pv Ann{possibilities = pos} = (pos .&. invisibleBag pv .&. complement (predicate pv)) == 0 +-- | @isDefinitelyInconsistent pv ann@ checks if @ann@ is consistent with @invisibleBag pv@ (to some extent).+-- This kind of check is sometimes necessary for 'definitelyQits' (and those which use it) to work correctly when using a guessed Annotation,+-- because @definitelyQits pred pv ann@ assumes @possibilities ann .&. invisibleBag pv /= 0@.+isDefinitelyInconsistent :: PrivateView -> Annotation -> Bool+isDefinitelyInconsistent = definitelyQits (const 0) +-- | @isobviouslyInconsistent@ is like 'isDefinitelyInconsistent', but only uses public info.+-- Although the latter is more accurate, this is desired for disclosing your policy in the long run.+isObviouslyInconsistent :: PublicInfo -> CardTo4 -> Bool+isObviouslyInconsistent = obviouslyQits (const 0)+ -- | 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@@ -334,16 +384,22 @@ -- | Unlike 'isDefinitelyUseless', 'isDefinitelyUnciritical' does not care whether the card is the last one or not. 'isDefinitelyUncritical' is, in other words, safe to drop. isDefinitelyUncritical :: PrivateView -> Annotation -> Bool-isDefinitelyUncritical = definitely (\pv -> not . isCritical (publicView pv))+isDefinitelyUncritical = definitelyQits (complement . critical . publicView)+-- isDefinitelyUncritical = definitely (\pv -> not . isCritical (publicView pv)) +isObviouslyUncritical :: PublicInfo -> CardTo4 -> Bool+isObviouslyUncritical = obviouslyQits (complement . critical)+-- isObviouslyUncritical = obviously (\pub -> not . isCritical pub)+ -- | If all of your cards are marked and not safe to drop, and you do not have enough hint token, one option is to drop a card that can be uncritical. (You can then assign them a priority order.) -- [NB: Maybe this is not a good idea. E.g. when the other player draws the last W2 to fully-marked [R5,G5,B5,Y5], we usually mark 2 to give up a 5, but if the player does not guess the intention and resort the above option, W2 is dropped.] isDefinitelyCritical :: PrivateView -> Annotation -> Bool-isDefinitelyCritical = definitely (\pv -> isCritical $ publicView pv)+isDefinitelyCritical = definitelyQits (critical . publicView)+--isDefinitelyCritical = definitely (isCritical . publicView) possibleCards :: PrivateView -> Annotation -> [Card] possibleCards pv Ann{marks = (Just c, Just n)} = [C c n] -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.-possibleCards pv Ann{possibilities = pos@(pc,pn)} = cardTo4ToList $ absCardTo4 $ possibilitiesQits pos .&. invisibleBag pv+possibleCards pv Ann{possibilities = pos} = cardTo4ToList $ sgnCardTo4 $ pos .&. invisibleBag pv where pub = publicView pv iOP :: CardTo4 -> PublicInfo -> (Maybe Color, Maybe Rank) -> Bool@@ -358,11 +414,13 @@ isMoreObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub isMoreObviouslyUseless _ (Nothing, Nothing) = False -isObviouslyUseless :: PublicInfo -> Possibilities -> Bool-isObviouslyUseless = obviously (\pub (C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n)+isObviouslyUseless :: PublicInfo -> CardTo4 -> Bool+isObviouslyUseless = obviouslyQits useless+--isObviouslyUseless = obviously (\pub (C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n) isDefinitelyUseless :: PrivateView -> Annotation -> Bool-isDefinitelyUseless = definitely (\pv -> isUseless (publicView pv))+isDefinitelyUseless = definitelyQits (useless . publicView)+--isDefinitelyUseless = definitely (\pv -> isUseless (publicView pv)) {- This is a weaker version not looking into the possibilities. isDefinitelyUseless :: PrivateView -> Marks -> Bool@@ -380,11 +438,11 @@ -- | 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 -> [Annotation] -> [[Index]]-definiteChopss pv anns = (if null useless then id else (useless :)) $ map (:[]) $ filter (`notElem` useless) $ map fst (choppiri $ map marks anns)- where useless = map fst $ filter (isDefinitelyUseless pv . snd) (zip [0..] anns)+definiteChopss pv anns = (if null uselesses then id else (uselesses :)) $ map (:[]) $ filter (`notElem` uselesses) $ map fst (choppiri $ map marks anns)+ where uselesses = map fst $ filter (isDefinitelyUseless pv . snd) (zip [0..] anns) obviousChopss :: PublicInfo -> [Annotation] -> [[Index]]-obviousChopss pub anns = (if null useless then id else (useless :)) $ map (:[]) $ filter (`notElem` useless) $ map fst (choppiri $ map marks anns)- where useless = map fst $ filter (isObviouslyUseless pub . snd) (zip [0..] $ map possibilities anns)+obviousChopss pub anns = (if null uselesses then id else (uselesses :)) $ map (:[]) $ filter (`notElem` uselesses) $ map fst (choppiri $ map marks anns)+ where uselesses = map fst $ filter (isObviouslyUseless pub . snd) (zip [0..] $ map possibilities anns) -- | 'chops' is the flattened version of 'obviousChopss' chops :: PublicInfo -> [Annotation] -> [Index] chops pub anns = concat $ map reverse $ obviousChopss pub anns@@ -392,12 +450,9 @@ isDoubleDrop :: PrivateView -> Result -> [Index] -> Annotation -> Bool isDoubleDrop _pv None _chopset _anns = False isDoubleDrop _pv (Success _) _chopset _anns = False-isDoubleDrop pv@PV{publicView=pub} lastResult [_i] Ann{possibilities=(pc,pn)} = not (any ((==(Just color, Just rank)).marks) myAnns) && -- This pattern captures: the last player discards B1; I have a card which is hinted as B and 1; I don't know where the third B1 is.+isDoubleDrop pv@PV{publicView=pub} lastResult [_i] Ann{possibilities=pos} = not (any ((==(Just color, Just rank)).marks) myAnns) && -- This pattern captures: the last player discards B1; I have a card which is hinted as B and 1; I don't know where the third B1 is. -- This can be improved to check whether any card other than the chop is obviously the just-dropped card or not, by looking at the Possibilities.- isCritical pub c &&- color `elem` colorPossibilities pc &&- rank `elem` rankPossibilities pn &&- invisibleBagCards pv c > 0+ lookupCardTo4 (critical pub .&. pos .&. invisibleBag pv) c > 0 where myAnns = head $ annotations pub c@C{..} = revealed lastResult isDoubleDrop _pv _lastresult _chopset _anns = False@@ -428,6 +483,11 @@ ifA :: (PrivateView -> Bool) -> (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move ifA pred at af = (\pv t f -> if pred pv then t else f) <*> at <*> af +(|++) :: [Move] -> [Move] -> [Move]+xs |++ ys = take 1 xs ++ ys+mkRule :: PrivateView -> [Move] -> Maybe Move -> Maybe Move+mkRule pv = mplus . listToMaybe . filter (isMoveValid pv)+ -- | 'Result' is the result of the last move. data Result = None -- ^ Hinted or at the beginning of the game | Discard {revealed::Card} | Success {revealed::Card} | Fail {revealed::Card} deriving (Read, Show, Eq, Generic)@@ -461,54 +521,19 @@ where myHand = head $ hands st -- | stateToStateHistory deduces the state history from the 'PublicState' history, the 'Move' history, and the current 'State'. stateToStateHistory :: [PublicInfo] -> [Move] -> State -> [State]-stateToStateHistory [] [] st = [st]-stateToStateHistory (pi:pis) (mv:mvs) st = st : stateToStateHistory pis mvs (rotate (-1) $ recede pi mv st)+stateToStateHistory = stateToStateHistory' 1+stateToStateHistory' i [] [] st = [st]+stateToStateHistory' i (pi:pis) (mv:mvs) st = st : stateToStateHistory' (succ i) pis mvs (recede (rotatePI (-i) pi) mv $ rotate (-1) st) --- | @'EGS' f p ps@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when the deck size is @f@ or below @f@.--- @move pvs mvs (EGO f p ps)@ may cause an error if @p@ can choose an invalid move.-data EndGameOld p ps = EGO {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps} -instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameOld p ps) m where- strategyName ms = return "EndGameOld"- move pvs@(pv:_) mvs str@(EGO f p ps) | f (publicView pv) = do (defaultMove, _) <- move pvs mvs p- m <- endGameMoveOld pvs mvs (ps, [EGO f p ps]) $ defaultMove : delete defaultMove (validMoves pv)- return (m,str)- | otherwise = do (m,_) <- move pvs mvs p- return (m,str)---- | 'EndGameMirrorStrategy' assumes that other players think in the same way as itself during endgame.--- @move pvs mvs (EGMO (EGO f p ps))@ may cause an error if @p@ can choose an invalid move.-data EndGameMirrorOld p = EGMO (EndGameOld p [EndGameMirrorOld p])-egmo :: (PublicInfo -> Bool) -- ^ from when to start the endgame search- -> p -- ^ the default strategy used until endgame- -> Int -- ^ number of players, including the resulting player- -> EndGameMirrorOld p-egmo from p nump = egmo where egmo = EGMO (EGO from p $ replicate (pred nump) egmo)--instance (Monad m, Strategy p m) => Strategy (EndGameMirrorOld p) m where- strategyName ms = return "EndGameMirrorOld"- move pvs mvs (EGMO egs) = do (m, egs') <- move pvs mvs egs- return (m, EGMO egs')--endGameMoveOld :: (Monad m, Strategies ps m) =>- [PrivateView] -- ^ view history- -> [Move] -- ^ move history- -> ps- -> [Move] -- ^ move candidates. More promising moves appear earlier.- -> m Move-endGameMoveOld pvs@(pv:tlpvs) mvs ps candidates = do- let states = possibleStates pv- scores <- mapM (evalMove states (map publicView tlpvs) mvs ps) candidates- let asc = zip scores candidates- pub = publicView pv- achievable = moreStrictlyAchievableScore pub- -- ToDo: Also consider critical cards at the bottom deck.- return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc- Just k -> k -- Stop search when the best possible score is found.- validMoves :: PrivateView -> [Move]-validMoves pv@PV{publicView=pub@PI{gameSpec=gs,hintTokens=numHints},handsPV=tlHands}--- = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops $ mkPlay uselesses $ mkHints uselessHints [] -- exhaustive but still prioritized+validMoves = validMoves' True+-- | 'effectiveMoves' are valid moves that are effective at the end game.+effectiveMoves :: PrivateView -> [Move]+effectiveMoves = validMoves' False+validMoves' :: Bool -> PrivateView -> [Move]+validMoves' exhaustive pv@PV{publicView=pub@PI{gameSpec=gs,hintTokens=numHints},handsPV=tlHands}+ | exhaustive = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops $ mkPlay uselesses $ mkHints uselessHints [] -- exhaustive but still prioritized | pileNum pub == 0 = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops [] | numHints == 8 && lives pub > 1 = mkPlay (playables++others) $ mkHints usefulHints $ mkPlay uselesses [] | otherwise = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops $ take 1 $ mkHints uselessHints []@@ -526,122 +551,84 @@ (uselesses, usefuls) = span (\(ix,ann) -> isDefinitelyUseless pv ann) $ zip [0..] myAnn (playables, others) = span (\(ix,ann) -> isDefinitelyPlayable pv ann) usefuls chop:nochops = map (Drop . fst) $ reverse $ playables ++ others ++ uselesses-evalMove :: (Monad m, Strategies ps m) => [(State, Int)] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int-evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\(((eg,st:_,_),_),n) -> n * egToInt st eg)) $ mapM (\(st,n) -> fmap (\a->(a,n)) $ tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states --- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.-tryAMove :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> Move -> m ((EndGame, [State], [Move]),ps)-tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move!"- Just st -> let nxt = rotate 1 st- in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs- Just eg -> return ((eg, nxt:states, mov:mvs), strs) -type Probability = Integer---- | 'EndGameMirrorLite' assumes that other players think in the same way as itself during endgame.-data EndGameMirrorLite sp p = EGML (EndGameLite sp p [EndGameMirrorLite sp p])-egml :: (PublicInfo -> Bool) -- ^ from when to start the endgame search- -> sp -- ^ the recommended strategy used at endgame, in order to prioritize endgame search. This strategy is supposed to be lightweight.- -> p -- ^ the default strategy used until endgame- -> Int -- ^ number of players, including the resulting player- -> EndGameMirrorLite sp p-egml from sp p nump = egmo where egmo = EGML (egl from sp p $ replicate (pred nump) egmo)--instance (Monad m, Strategy sp m, Strategy p m) => Strategy (EndGameMirrorLite sp p) m where- strategyName ms = return "EndGameMirrorLite"- move pvs mvs (EGML egs) = do (m, egs') <- move pvs mvs egs- return (m, EGML egs')--egl f sp p ps = EGL f sp p ps M.empty---- | @'EGL' f sp p ps memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when @f@ returns True.--- The strategy @sp@ suggests a desired move in order to prioritize a promising strategy.-data EndGameLite sp p ps = EGL {fromWhenL::PublicInfo->Bool, suggestedStrategyL::sp, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Probability)])}-type Key = (Maybe Card, [Marks], [Move], [Card])--instance (Monad m, Strategy sp m, Strategy p m, Strategies ps m) => Strategy (EndGameLite sp p ps) m where- strategyName ms = return "EndGameLite"- move pvs mvs str@(EGL f sp p ps memory)- | f pub && not (null statess) = do -- null statess means that there is a contradiction. This can happen when using a PrivateView based on wrong assumption, such as using sontakuColorHint for preprocessing and actually the team mate is not exactly Stateless.- (_i, (mp,m)) <- endGameMoveLite statess pvs' mvs sp- return (m, EGL f sp p ps mp)- | otherwise = do (m,_) <- move pvs mvs p- return (m,str)- where statess = case M.lookup (resToMbC $ result $ publicView $ pvs !! pred numP, map marks $ head $ annotations pub, take (pred numP) mvs, map headC $ handsPV hdpv) memory of- Just (_,tups) -> tups- Nothing -> [ (stateToStateHistory (map publicView tlpvs) mvs state, ps, fromIntegral n) | (state, n) <- possibleStates hdpv ]- pvs'@(hdpv:tlpvs) = [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]- pub = publicView hdpv- numP = numPlayers $ gameSpec pub-endGameMoveLite :: (Monad m, Strategies ps m, Strategy p m) =>- [([State],ps,Probability)] -- ^ possible pairs of the state history and the internal memory states of other players' strategies- -> [PrivateView] -- ^ view history- -> [Move] -- ^ move history- -> p -- ^ default (recommended) strategy- -> m (Probability, (M.Map Key ([Move], [([State],ps,Probability)]), Move))-endGameMoveLite statess pvs@(pv:_) mvs p = do- (defaultMove, q) <- move pvs mvs p- let candidateMoves = defaultMove : delete defaultMove (validMoves pv)- tups <- mapM (evalMoveLite statess mvs q) candidateMoves- let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves- pub = publicView pv- achievable = sum [ n | (_,_,n) <- statess ] * fromIntegral (moreStrictlyAchievableScore pub)- -- ToDo: Also consider critical cards at the bottom deck.- return $ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc- Just k -> (achievable, k) -- Stop search when the best possible score is found.--evalMoveLite :: (Monad m, Strategies ps m, Strategy p m) => [([State], ps, Probability)] -> [Move] -> p -> Move -> m ( M.Map Key ([Move], [([State],ps,Probability)]) , Probability )-evalMoveLite statess@((st:_,_,_):_) mvs p mov = do- roundResults <- fmap concat $ mapM (\sts ->tryAMoveARound sts mvs mov) statess- let pub = publicState st- instantScore = sum [ egToNum s eg * n | ((Just eg, s:_, _), _, n) <- roundResults ]- roundResultMap = groupARound pub roundResults- if M.null roundResultMap then return (roundResultMap, instantScore) else do- let roundResults = M.elems roundResultMap- scores <- sequence [ fmap fst $ endGameMoveLite stss (viewStates sts) moves p | (moves, stss@((sts,_,_):_)) <- roundResults, not $ null stss ]- return (roundResultMap, instantScore + sum scores)-evalMoveLite [] _ _ _ = error "evalMoveLite []" -- This should not happen, because evalMoveLite is only called by endGameMoveLite, and @null statess@ is checked before every call of @endGameMoveLite statess@.+-- | 'sampleState' samples a 'State' from the given 'PrivateView', assuming the uniform distribution.+sampleState :: RandomGen g => PrivateView -> g -> ([State], g)+sampleState pv@PV{publicView=pub@PI{gameSpec=gs}} g =+ let (ts,gen) = possibleSample pv g+ in ([St{ publicState = pub+ , pile = zipWith (\c i -> (c, initAnn gs i)) deck [ (numberOfCards (rule $ gameSpec pub) - pileNum pub) ..]+ , hands = hand : handsPV pv } | (hand,deck) <- ts ]+ , gen)+possibleSample :: RandomGen g =>+ PrivateView+ -> g+ -> ([([Card] -- my hand+ , [Card] -- deck+ )], g) -- This could be MonadPlus instead of list.+possibleSample pv@PV{publicView=PI{annotations=anns:_}} = possibleSmpl anns (invisibleBag pv)+{-+possibleSmpl [] ct4 g = case sampleDeck ct4 g of (ds, gen) -> [(([],ds),gen)]+possibleSmpl (Ann{marks = (Just i, Just k)} : anns) ct4 g = [ ((C i k : hand, deck), gen) | ((hand, deck), gen) <- possibleSmpl anns ct4 g ]+possibleSmpl (Ann{possibilities = possi} : anns) ct4 g = [ ((card : hand, deck), gen) |+ let cond = possibilitiesQits possi .&. ct4,+ cond > 0, -- cond == 0 when there is a contradiction. In such cases, possibleSmpl must be retried. 確率的偏りはありそう。+ let (i, g') = sampleCT4 cond g,+ card = qitPosToCard $ i `shiftR` 1,+ ((hand, deck), gen) <- possibleSmpl anns (ct4 - bit i) g' ]+-}+possibleSmpl [] ct4 g = case sampleDeck ct4 g of (ds, gen) -> ([([],ds)],gen)+possibleSmpl (Ann{marks = (Just i, Just k)} : anns) ct4 g = ([ (C i k : hand, deck) | (hand, deck) <- ts ], gen)+ where (ts, gen) = possibleSmpl anns ct4 g+possibleSmpl (Ann{possibilities = possi} : anns) ct4 g = let cond = possi .&. ct4+ in if cond <=0 then ([], snd $ next g) else+ let (i, g') = sampleCT4 cond g+ card = qitPosToCard $ i `shiftR` 1+ (ts, gen) = possibleSmpl anns (ct4 - bit i) g'+ in ([ (card : hand, deck) | (hand, deck) <- ts ], gen) -groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Probability)] -> M.Map Key ([Move], [([State],ps,Probability)]) -- ToDo: IntMap could be used instead.-groupARound pub results = fmap procTip $ M.fromListWith (++) [ ( ( resToMbC $ result $ publicState $ stats !! pred numP,- map marks $ head $ annotations $ publicState st,- take (pred numP) movs,- map headC $ tail $ hands st ),- [r])- | r@((Nothing, stats@(st:_), movs), _, _) <- results ] where- procTip :: [((Maybe EndGame, [State],[Move]),ps,Probability)] -> ([Move], [([State],ps,Probability)])- procTip ts@(((_noth, _, mv), _, _) : _) = (mv, [ (stats, ps, n) | ((_nothing, stats, _), ps, n) <- ts ])- numP = numPlayers $ gameSpec pub--- total version of head, just in case of dealing with empty hand.-headC :: [Card] -> Card-headC = foldr const $ C Multicolor Empty+-- sampleDeck can be implemented using cardTo4ToList and shuffle, but I guess the following implementation is more efficient.+sampleDeck 0 g = ([], g)+sampleDeck ct4 g = (card:deck, gen) where+ (i, g') = sampleCT4 ct4 g+ card = -- if i>=60 then error ("sampleDeck: (ct4) = "++show (ct4)++ ", and i = "++show i) else+ qitPosToCard $ i `shiftR` 1+ (deck, gen) = sampleDeck (ct4 - bit i) g' +-- | sampleCT4 randomly draws a card from the given bag of cards, and returns QitPos*2.+sampleCT4 :: RandomGen g => CardTo4 -> g -> (Int, g)+sampleCT4 ct4 gen = let sum:bst = ct4ToBinSearchTree ct4+ (r, g) = randomR (1,sum) gen+ in -- trace ("sampleCT4: ct4 = 0x"++showHex ct4 ", sum = "++show sum++", and r = "++show r) $+ (lookupBST r 0 32 bst, g)+-- ct4ToBinSearchTree generates a binary search tree holding sum of children at each branch, represented as a list of bitvectors.+-- The BST may be re-generated (rather than updated) every time the CardTo4 is updated (by drawing a card), because the generation is almost as lightweight as updating.+ct4ToBinSearchTree :: CardTo4 -> [CardTo4] -- The list could be an array instead, if the speed really matters here.+ct4ToBinSearchTree x0 = let+ x5 = (x4 + (x4 `shiftR` 32)) .&. 0x00000000000000FF -- x5 = |00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0b bb bb bb| -- root node+ x4 = (x3 + (x3 `shiftR` 16)) .&. 0x000000FF000000FF -- x4 = |00 XX XX XX 00 XX XX XX 00 XX XX XX 00 bb bb bb|00 XX XX XX 00 XX XX XX 00 XX XX XX 00 bb bb bb|+ -- Depending on the algorithm, the (.&. 0x0000FFFF0000FFFF) can be omitted.+ x3 = (x2 + (x2 `shiftR` 8)) .&. 0x00FF00FF00FF00FF -- x3 = |00 0X XX XX 00 0b bb bb|00 0X XX XX 00 0b bb bb|00 0X XX XX 00 0b bb bb|00 0X XX XX 00 0b bb bb|+ -- Depending on the algorithm, the (.&. 0x00FF00FF00FF00FF) can be omitted.+ x2 = (x1 + (x1 `shiftR` 4)) .&. 0x0F0F0F0F0F0F0F0F -- x2 = |00 00 bb bb|00 00 bb bb|00 00 bb bb|00 00 bb bb|00 00 bb bb|00 00 bb bb|00 00 bb bb|00 00 bb bb|+ x1 = (x0 .&. 0x3333333333333333) + ((x0 `shiftR` 2) .&. 0x3333333333333333) -- x1 = |0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|0b bb|+ -- x0 = |bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb|bb| -- leaf nodes+ in [x5, x4, x3, x2, x1, x0]+lookupBST :: CardTo4 -> Int -> Int -> [CardTo4] -> Int+lookupBST _v begin 1 [] = begin+lookupBST val begin width (x:xs) | val <= lessum = lookupBST val begin nextWidth xs + | otherwise = lookupBST (val-lessum) (begin + width) nextWidth xs + where lessum = (x `shiftR` begin) .&. (bit width - 1)+ nextWidth = width `shiftR` 1+sumCT4 :: Integral i => CardTo4 -> i+sumCT4 = fromIntegral . head . ct4ToBinSearchTree -resToMbC :: Result -> Maybe Card-resToMbC None = Nothing-resToMbC r = Just $ revealed r+#ifdef TEST+prop_sampleDeck_sumCT4 = \i g -> i > 0 && i < 0x7FFFFFFFFFFFFFFF ==> length (fst $ sampleDeck i (mkStdGen g)) == sumCT4 (i::Int64)+#endif --- does not work for stateful monads including IO.-tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Probability) -> [Move] -> Move -> m [((Maybe EndGame, [State], [Move]),ps,Probability)]-tryAMoveARound (states@(state:_),strs,n) mvs mov = let sts = proceeds state mov- pilen = pileNum $ publicState state- numCases = case sts of -- [] -> error $ show mov ++ ": invalid move!" -- We should just silently ignore errorful strategy programs- sts@[st] | pilen>0 -> n * fromIntegral pilen -- The condition pilen>0 is necessary because even when pileNum == 0 there is one valid case.- sts -> n- in sequence $ do st <- sts- let nxt = rotate 1 st- return $ case checkEndGame $ publicState nxt of- Nothing -> fmap (\(e,p) -> (e,p,numCases)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs- Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, numCases) {--tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m ((Maybe EndGame, [State], [Move]),ps,Int)-tryAMoveARound (states@(st:_),strs,n) mvs mov = case proceed st mov of- Nothing -> error $ show mov ++ ": invalid move!"- Just st -> let nxt = rotate 1 st- in case checkEndGame $ publicState nxt of Nothing -> fmap (\(e,p) -> (e,p,n)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs- Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, n)--}-{- possibleStates :: PrivateView -> [(State, Int)] possibleStates pv@PV{publicView=pub@PI{gameSpec=gs}} = [(St{ publicState = pub@@ -672,10 +659,10 @@ possiblePerms :: [Annotation] -> CardTo4 -> [([Card],CardTo4,Int)] -- 最後のIntは場合の数。ただし、CardTo4での場合の数をちゃんと数えるなら数える必要はないはず。 possiblePerms [] cards = [([],cards,1)] possiblePerms (Ann{marks = (Just i, Just k)} : anns) cards = [ (C i k : hand, deck, n) | (hand, deck, n) <- possiblePerms anns cards ]-possiblePerms (Ann{possibilities = (pi, pk)} : anns) cards = [ (card : hand, deck, n*num) | (card@(C i k), rest, n) <- cardTo4ToAssocList cards, (pi .&. bit (colorToBitPos i)) * (pk .&. bit (rankToBitPos k)) /= 0, (hand, deck, num) <- possiblePerms anns rest ]+possiblePerms (Ann{possibilities = possi} : anns) cards = [ (card : hand, deck, n*num) | (card@(C i k), rest, n) <- cardTo4ToAssocList possi cards, (hand, deck, num) <- possiblePerms anns rest ] -cardTo4ToAssocList :: CardTo4 -> [(Card, CardTo4, Int)]-cardTo4ToAssocList ct4 = ctal 1 ct4 [ C i k | k <- [K1 .. K5], i <- [White .. Multicolor] ]+cardTo4ToAssocList :: CardTo4 -> CardTo4 -> [(Card, CardTo4, Int)]+cardTo4ToAssocList possi ct4 = ctal 1 (possi .&. ct4) [ C i k | k <- [K1 .. K5], i <- [White .. Multicolor] ] where ctal sub 0 _ = [] ctal sub n (c:cs) | num /= 0 = (c, ct4 - sub, num) : rest@@ -715,7 +702,7 @@ prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) (annotations pub)) verbose, quiet :: Verbosity verbose = V{warnCritical=True, markUseless=True, markPlayable=True, markObviouslyUseless=True, markObviouslyPlayable=True, markHints=True, markPossibilities=True, markChops=True, warnDoubleDrop=True}-quiet = V{warnCritical=False,markUseless=False,markPlayable=False,markObviouslyUseless=False,markObviouslyPlayable=False,markHints=False,markPossibilities=False,markChops=False,warnDoubleDrop=False}+quiet = V{warnCritical=False,markUseless=False,markPlayable=False,markObviouslyUseless=False,markObviouslyPlayable=False,markHints=True,markPossibilities=False,markChops=False,warnDoubleDrop=False} -- temporarily make markHints=True prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Annotation] -> String prettyHand v pub ithPnumP i cards anns = "\n\n" ++ ithPnumP i ++ " hand:\n" -- ++ concat (replicate (length cards) " __") ++ " \n"@@ -742,9 +729,9 @@ 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 [ showRankPossibilities ns ++" " | (_,ns) <- ps]+showPosLines :: [CardTo4] -> String+showPosLines ps = concat [ ' ' : showColorPossibilities (qitsToColorPossibilities ct4) | ct4 <- ps] ++ "\n"+ ++ concat [ showRankPossibilities (qitsToRankPossibilities ct4) ++" " | ct4 <- ps] showColorPossibilities, showRankPossibilities :: Int -> String showColorPossibilities = reverse . showPossibilities ' ' colorkeys@@ -787,6 +774,32 @@ i5 = i1 .|. (i4 `shiftL` 13) in i5 .&. 0x800800800800800 +qitsToPossibilities :: CardTo4 -> (Int,Int)+qitsToPossibilities ct4 = (qitsToColorPossibilities ct4, qitsToRankPossibilities ct4)++qitsToColorPossibilities :: CardTo4 -> Int+qitsToColorPossibilities ct4 = let c24 = ct4 .|. (ct4 `shiftR` 24) .|. (ct4 `shiftR` 48)+ c12 = c24 .|. (c24 `shiftR` 12)+ ixixixixixi = c12 .|. (c12 `shiftR` 1)+ in fromIntegral $ qcp ixixixixixi+qcp c = (c .&. 1) `shiftL` 5 .|. (c .&. 4) `shiftL` 2 .|. (c .&. 16) `shiftR` 1 .|. (c .&. 64) `shiftR` 4 .|. (c .&. 256) `shiftR` 7 .|. (c .&. 1024) `shiftR` 10++qitsToRankPossibilities :: CardTo4 -> Int+qitsToRankPossibilities ct4 = let r4 = ct4 .|. (ct4 `shiftR` 4) .|. (ct4 `shiftR` 8)+ r2 = r4 .|. (r4 `shiftR` 2)+ r1 = r2 .|. (r2 `shiftR` 1)+ in fromIntegral $ qrp $ r1 .&. 0x1001001001001+qrp r = ((r `shiftL` 4) .|. (r `shiftR` 9) .|. (r `shiftR` 22) .|. (r `shiftR` 35) .|. (r `shiftR` 48)) .&. 31++#ifdef TEST+prop_posQitPos (c,r) = c>0 && r>0 && c<64 && r <32 ==> qitsToPossibilities (possibilitiesQits (c,r)) == (c,r)++-- The following should not always be true, because Qits is more descriptive than Possibilities.+noprop_qitPosQit ct4 = ct4>0 && ct4 <0x1000000000000000 ==> let c3 = ((ct4 .&. 0x555555555555555) .|. ((ct4 .&. 0xAAAAAAAAAAAAAAA) `shiftR` 1)) * 3+ in possibilitiesQits (qitsToPossibilities ct4) == c3++#endif+ -- | '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 "..".@@ -853,6 +866,9 @@ replicate 80 '!' : map (surround $ replicate 38 ' ' ++"!!") (lines $ prettySt ithPlayerFromTheLast st) ++ [ replicate 80 '!' ]+prettyDeckEndGame [] eh = prettyEndGame eh+prettyDeckEndGame d eh = prettyEndGame eh ++ "By the way, the initial deck was " ++ shows d ".\n"+ surround :: [a] -> [a] -> [a] surround ys xs = let len = length xs len2 =len `div` 2@@ -864,18 +880,29 @@ peek st (mv:_) = putStrLn $ replicate 20 '-' ++ '\n' : showTrial (const "") undefined (view st) mv ++ '\n' : replicate 20 '-' ++ '\n' : prettySt ithPlayerFromTheLast st+debugPeek st mvs = print st >> peek st mvs -- | 'start' creates and runs a game. This is just the composition of 'createGame' and 'run'.-start :: (RandomGen g, Monad m, Strategies ps m) =>+start, startToEnd :: (RandomGen g, Monad m, Strategies ps m) => GameSpec -> [Peeker m] -> ps -> g -> m (((EndGame, [State], [Move]), ps), g) start gs audience players gen = let (st, g) = createGame gs gen in fmap (\e -> (e,g)) $ run audience [st] [] players-startFromCards :: (Monad m, Strategies ps m) =>+startToEnd gs audience players gen = do+ let (shuffled, g) = createDeck (rule gs) gen+ t <- startFromCardsToEnd gs audience players shuffled+ return (t, g)+startFromCards, startFromCardsToEnd ::+ (Monad m, Strategies ps m) => GameSpec -> [Peeker m] -> ps -> [Card] -> m ((EndGame, [State], [Move]), ps) startFromCards gs audience players shuffled = let st = createGameFromCards gs shuffled in run audience [st] [] players+startFromCardsToEnd gs aud pls d = do ~(result@(eg,sts@(st:_),mvs), pls') <- startFromCards gs aud pls d+ let myOffset = turn (publicState st)+-- broadcastEndGame d (eg, zipWith rotate [-myOffset, 1-myOffset ..] sts, mvs) pls'+ broadcastEndGame d (eg, map (rotate (-myOffset)) sts, mvs) pls'+ run :: (Monad m, Strategies ps m) => [Peeker m] -> [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) run audience states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in mapM_ (\p -> p st mvs) audience >> broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players@@ -894,7 +921,13 @@ class Monad m => Strategy p m where -- | 'strategyName' is just the name of the strategy. The designer of the instance should choose one. strategyName :: m p -> m String+ strategyName _ = return "an anonymous strategy" + -- | 'initialize' is supposed to be executed only once when the game server is started. Time-consuming computations that require execution only once should be put there, in order to avoid unnecessary downtime between games.+ initialize :: Bool -- ^ if True, initialize lazily, i.e., does not stop computation until the initialization finishes+ -> p -> m p+ initialize _ = return+ -- | 'move' is the heart of the strategy. It takes the history of observations and moves, and selects a 'Move'. -- Because the full history is available, your algorithm can be stateless, but still there is the option to design it in the stateful manner. move :: [PrivateView] -- ^ The history of 'PrivateView's, new to old.@@ -916,22 +949,28 @@ -- The next state can be the same as the current one unless the algorithm is learning on-line during the game. observe _pvs _moves st = return ((),st) -- The default does nothing. -}-+ observeEndGame :: [Card] -- ^ initial deck. [] when not available+ -> GameHistory -> p -> m p+ observeEndGame _ _ = return+type GameHistory = (EndGame, [State], [Move]) -- StrategyDict should be used instead of class Strategy, maybe. -- | 'StrategyDict' is a dictionary implementation of class 'Strategy'. It can be used instead if you like.-data StrategyDict m s = SD{sdName :: String, sdMove :: Mover s m, sdObserve :: Observer s m, sdState :: s}+data StrategyDict m s = SD{sdName :: String, sdInitialize :: Bool -> s -> m s, sdMove :: Mover s m, sdObserve :: Observer s m, sdObserveEndGame :: [Card] -> GameHistory -> s -> m s, sdState :: s} type Mover s m = [PrivateView] -> [Move] -> s -> m (Move, s) type Observer s m = [PrivateView] -> [Move] -> s -> m () mkSD :: (Monad m, Typeable s, Strategy s m) => String -> s -> StrategyDict m s-mkSD name s = SD{sdName=name, sdMove=move, sdObserve=observe, sdState=s}+mkSD name s = SD{sdName=name, sdInitialize=initialize, sdMove=move, sdObserve=observe, sdObserveEndGame=observeEndGame, sdState=s} instance Monad m => Strategy (StrategyDict m s) m where strategyName mp = do p <- mp return $ sdName p+ initialize l s = do nexts <- sdInitialize s l $ sdState s+ return $ s{sdState=nexts} move pvs mvs s = sdMove s pvs mvs (sdState s) >>= \ (m, nexts) -> return (m, s{sdState=nexts}) observe pvs mvs s = sdObserve s pvs mvs $ sdState s-+ observeEndGame d t s = do nexts <- sdObserveEndGame s d t $ sdState s+ return s{sdState=nexts} -- Should DynamicStrategy be limited to IO? type DynamicStrategy m = StrategyDict m Dynamic@@ -939,8 +978,10 @@ mkDS name s = mkDS' $ mkSD name s mkDS' :: (Monad m, Typeable s) => StrategyDict m s -> DynamicStrategy m mkDS' gs = SD{sdName = sdName gs,+ sdInitialize = \l dyn -> sdInitialize gs l (fromDyn dyn (error "mkDS': impossible")) >>= return . toDyn, sdMove = \pvs mvs dyn -> fmap (\(m,p)->(m, toDyn p)) $ sdMove gs pvs mvs (fromDyn dyn (error "mkDS': impossible")), sdObserve = \pvs mvs dyn -> sdObserve gs pvs mvs (fromDyn dyn (error "mkDS': impossible")),+ sdObserveEndGame = \c e dyn -> fmap toDyn $ sdObserveEndGame gs c e (fromDyn dyn (error "mkDS': impossible")), sdState = toDyn $ sdState gs} @@ -955,6 +996,7 @@ class Strategies ps m where runARound :: ([State] -> [Move] -> m ()) -> [State] -> [Move] -> ps -> m ((Maybe EndGame, [State], [Move]), ps) broadcast :: [State] -> [Move] -> ps -> Int -> m ([State], Int)+ broadcastEndGame :: [Card] -> GameHistory -> ps -> m (GameHistory, ps) {- Abolished in order to avoid confusion due to overlapping instances. When necessary, use a singleton list instead. instance {-# OVERLAPS #-} (Strategy p1 m, Monad m) => Strategies p1 m where runARound states moves p = runATurn states moves p@@ -966,6 +1008,9 @@ _ -> return (tup, (p',ps)) broadcast states moves (p1,p2) offset = do (sts, ofs) <- broadcast states moves p1 offset broadcast sts moves p2 ofs+ broadcastEndGame cs eg (p1,p2) = do (gh, p1') <- broadcastEndGame cs eg p1+ (gh',p2') <- broadcastEndGame cs gh p2+ return (gh', (p1',p2')) instance (Strategy p m, Monad m) => Strategies [p] m where -- runARound hook states moves [] = return ((Nothing, states, moves), []) runARound _ _ _ [] = error "It takes at least one algorithm to play Hanabi!"@@ -977,7 +1022,10 @@ broadcast _ _ [] _ = error "It takes at least one algorithm to play Hanabi!" broadcast states moves [p] ofs = when (ofs/=0) (observe (viewStates states) moves p) >> return (map (rotate 1) states, pred ofs) broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (viewStates states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs)-+ broadcastEndGame cs t@(eg,sts,mvs) [p] = observeEndGame cs t p >>= \p' -> return ((eg, map (rotate 1) sts, mvs), [p'])+ broadcastEndGame cs t@(eg,sts,mvs) (p:ps) = do p' <- observeEndGame cs t p+ (gh, ps') <- broadcastEndGame cs (eg, map (rotate 1) sts, mvs) ps+ return (gh, p':ps') viewStates :: [State] -> [PrivateView] viewStates = map view . zipWith rotate [0..] @@ -1004,6 +1052,9 @@ return (mv, Verbose p' verb) observe _ [] _ = return () observe (v:_) (m:_) (Verbose _ verb) = liftIO $ putStrLn $ what'sUp1 verb v m+ observeEndGame d t p = do+ liftIO $ putStrLn $ prettyDeckEndGame d t+ return p what'sUp :: Verbosity -> String -> [PrivateView] -> [Move] -> String what'sUp verb name views@(v:_) moves = replicate 20 '-' ++ '\n' :@@ -1039,6 +1090,12 @@ ithPlayerFromTheLast :: Int -> Int -> String ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's" +showHistory pvs mvs+#ifdef DEBUG+ | length (tail pvs) /= length mvs = error "showHistory: obviously wrong history."+#endif+ | otherwise = concat $ zipWith (what'sUp1 verbose) pvs mvs+showHistory' pvs mvs = concat $ zipWith (what'sUp verbose "") (reverse pvs) $ reverse $ iterate tail mvs newtype Replay = Replay String deriving (Read, Show) instance (MonadIO m) => Strategy Replay m where@@ -1062,6 +1119,10 @@ move views@(v:_) moves vh = liftIO $ do hPutStrLn (hout vh) $ what'sUp (verbVH vh) "via handles" views moves mov <- repeatReadingAMoveUntilSuccess (hin vh) (hout vh) v return (mov, vh)+ observe (v:_) (m:_) vh = liftIO $ hPutStrLn (hout vh) $ what'sUp1 (verbVH vh) v m+ observeEndGame d eg vh = do+ liftIO $ hPutStrLn (hout vh) $ prettyDeckEndGame d eg+ return vh repeatReadingAMoveUntilSuccess :: Handle -> Handle -> PrivateView -> IO Move repeatReadingAMoveUntilSuccess hin hout v = do@@ -1079,6 +1140,7 @@ currentScore = 0, nextToPlay = 0xFFF, kept = pNEC,+ useless = 0, nonPublic = pNEC, turn = 0, lives = numBlackTokens $ rule gs,@@ -1106,8 +1168,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 -> [Card] cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ]-unknown :: GameSpec -> Possibilities-unknown gs = (64 - bit (6 - numColors (rule gs)), 31)+unknown :: GameSpec -> CardTo4+unknown gs = possibilitiesQits (64 - bit (6 - numColors (rule gs)), 31) shuffle :: RandomGen g => [c] -> g -> ([c], g) shuffle xs = shuf [] xs $ length xs@@ -1148,15 +1210,18 @@ d:ps -> (fst d : droppedHand, snd d : droppedAnn, ps, pred $ pileNum pub) nextHands = nextHand : tail (hands st) nextAnns = nextAnn : tail (annotations pub)- nextDeadline = case deadline pub of Nothing | nextPileNum==0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS+ nextDeadline = case deadline pub of Nothing | nextPileNum<=0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS | otherwise -> Nothing Just i -> Just $ pred i+ boom | keptCards pub nth == 1 = (0x3003003003003 `shiftL` (cardToQitPos nth * 2)) .|. useless pub+ | otherwise = useless pub in st{pile = nextPile, hands = nextHands, publicState = case mv of Drop _ -> pub{pileNum = nextPileNum, kept = deleteACard nth $ kept pub,+ useless = boom, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, hintTokens = succ $ hintTokens pub,@@ -1166,6 +1231,7 @@ Play i | failure -> pub{pileNum = nextPileNum, kept = deleteACard nth $ kept pub,+ useless = boom, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, lives = pred $ lives pub,@@ -1176,6 +1242,7 @@ pub{pileNum = nextPileNum, currentScore = succ $ currentScore pub, nextToPlay = ((nextToPlay pub .&. complement mask) .|. ((nextToPlay pub .&. mask) `shiftL` 12)) .&. 0xFFFFFFFFFFFFFFF,+ useless = 3 `shiftL` (cardToQitPos nth * 2) .|. useless pub, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, hintTokens = if hintTokens pub < 8 && rank nth == K5 then succ $ hintTokens pub else hintTokens pub,@@ -1193,13 +1260,11 @@ Just i -> Just $ pred i, result = None}} where newAnns hs = zipWith zipper (hands st !! hintedpl) hs- zipper (C ir ka) ann@Ann{marks=(mi,mk),possibilities=(c,n)}- = case eik of Left i | i == ir -> ann{marks=(Just i, mk), possibilities = (bit ibit, n)}- |otherwise-> ann{possibilities = (clearBit c ibit, n)}- where ibit = colorToBitPos i- Right k | k == ka -> ann{marks=(mi, Just k), possibilities = (c, bit kbit)}- |otherwise-> ann{possibilities = (c, clearBit n kbit)}- where kbit = rankToBitPos k+ zipper (C ir ka) ann@Ann{marks=(mi,mk),possibilities=pos}+ = case eik of Left i | i == ir -> ann{marks=(Just i, mk), possibilities = pos .&. colorToQit i}+ |otherwise-> ann{possibilities = pos .&. complement (colorToQit i)}+ Right k | k == ka -> ann{marks=(mi, Just k), possibilities = pos .&. rankToQit k}+ |otherwise-> ann{possibilities = pos .&. complement (rankToQit k)} -- 'proceeds' is the variant of proceed that enumerates draw possibilities. This can be used to simulate the environment within a strategy. proceeds :: State -> Move -> [State]@@ -1211,9 +1276,10 @@ -- | @'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{annotations = rotateList $ annotations pub}}- where rotateList xs = case splitAt (num `mod` numPlayers gS) xs of (tk,dr) -> dr++tk+rotate num st@(St{publicState=pub}) = st{hands = rotateList pub num $ hands st,+ publicState = rotatePI num pub}+rotatePI num pub = pub{annotations = rotateList pub num $ annotations pub}+rotateList pub num xs = case splitAt (num `mod` numPlayers (gameSpec pub)) xs of (tk,dr) -> dr++tk -- | 'EndGame' represents the game score, along with the info of how the game ended. -- It is not just @Int@ in order to distinguish 'Failure' (disaster / no life) from @'Soso' 0@ (not playing any card), though @'Soso' 0@ does not look more attractive than 'Failure'.
Game/Hanabi/Backend.lhs view
@@ -25,8 +25,8 @@ import System.IO import System.IO.Error(isEOFError) import Control.Exception-import Data.Char(isSpace)-import Data.List(sort)+import Data.Char(isSpace, toLower, isAlpha)+import Data.List(sort, transpose, tails) import Data.Time import System.Console.GetOpt@@ -64,10 +64,11 @@ import Data.Aeson #endif -data Flag = Port Int -- x | Socket FilePath | Interactive+data Flag = Port Int | Lazy -- x | Socket FilePath | Interactive cmdOpts :: [OptDescr Flag] cmdOpts = [ Option ['p'] ["port-number"] (ReqArg (Port . toEnum . readOrErr msgp) "PORT_NUMBER") "use port number PORT_NUMBER"+ , Option ['l'] ["lazy"] (NoArg Lazy) "initialize lazily. This may cause the first game to take a prohibitive long time." ] where readOrErr msg xs = case reads xs of [(i,"")] | i>=0 -> i _ -> error msg@@ -88,7 +89,7 @@ procFlags = foldl procFlag procFlag :: Options -> Flag -> Options procFlag opt (Port i) = opt{port=i}-+procFlag opt Lazy = opt{lazy=True} server :: Options -> IO () server opt = do@@ -133,8 +134,13 @@ mkParams options = do g <- newGen mv <- newMVar (IntMap.empty::GameData)- return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"}+ hPutStrLn stderr "Preloading algorithms.... This may take some minutes depending on the set of strategies."+ constrAssoc <- mapM sequenceA [ (name, crs $ lazy options) | (name, Just crs) <- strategies options] +-- foldr seq (hPutStrLn stderr "Done.") $ map snd constrAssoc+ hPutStrLn stderr "Done."+ return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList constrAssoc, conn = error "Game.Hanabi.Backend.server: should not happen"}+ -- Well, this is not a loop any longer.... loop :: RandomGen g => Params g -> PendingConnection -> IO ()@@ -177,13 +183,15 @@ [(mvs,rest)] | all isSpace rest -> mvs _ -> str case reads mvstr of- [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else do sender conn "Invalid Move"+ [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else do sender conn Invalid repeatReadingAMoveUntilSuccess conn v- _ -> sender conn ("Parse error.\n"++help) >> repeatReadingAMoveUntilSuccess conn v- sender conn = sendTextData conn . endecodeX (verbVWS vh) . Str+ _ -> sender conn (Str ("Parse error.\n"++help)) >> repeatReadingAMoveUntilSuccess conn v+ sender conn = sendTextData conn . endecodeX (verbVWS vh) observe _ [] _ = return () observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m-+ observeEndGame d eg vh = do+ liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ PrettyEndGame d $ Just eg+ return vh watch :: Connection -> Maybe Verbosity -> State -> [Move] -> IO () watch conn mbVerb st mvs = sendTextData conn $ endecodeX mbVerb $ Watch st $ take 1 mvs@@ -217,7 +225,7 @@ sender = sendTextData (conn params) . endecodeX mbVerb . Str createR observe creater args = case reads args of [(rule,rest)] | isRuleValid rule -> createD observe creater rule rest _ -> createD observe creater defaultRule args- createD observe from rule args = case reads args of [(deck,';':rest)] | sort (cardBag rule) == sort deck -> create observe from rule deck args+ createD observe from rule args = case reads args of [(deck,';':rest)] | sort (cardBag rule) == sort deck -> create observe from rule deck rest | otherwise -> sender $ "Invalid deck!\ndeck = " ++ show deck _ -> create observe from rule [] args create :: Bool -> Maybe Int -> Rule -> [Card] -> String -> IO ()@@ -244,20 +252,47 @@ sender "starting the game\n" let playerList | observe = ixSs |otherwise= mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs- (playOrder,g) = orderPlayers from (gen params) playerList- shuffled | null deck = fst $ createDeck rule g+ newGame 1 [] (gen params) playerList mvFinalSituation+ where numAllies = length is+ newGame :: (RandomGen g) =>+ Int -> [Int] -> g -> [DynamicStrategy IO] -> MVar ([Card], Maybe (EndGame, [State], [Move])) -> IO ()+ newGame ntimes scores g0 playerList mvFinalSituation = do+ sender "starting the game\n"+ let (g1,g2) = split g0+ let (playOrder,g) = orderPlayers from g0 playerList+ shuffled | null deck = fst $ createDeck rule g1 | otherwise = deck+ tryTakeMVar mvFinalSituation eithFinalSituation <- try $ if observe then sender ("The initial deck is " ++ show shuffled) >>- startFromCards (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled- else startFromCards (GS (succ numAllies) rule) [] playOrder shuffled- finalSituation <- case eithFinalSituation of- Left e -> do hPutStrLn stderr $ displayException (e::SomeException)- return Nothing- Right (fs@(eg,sts,mvs),_) -> return $ Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, truncate mvs)+ startFromCardsToEnd (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled+ else startFromCardsToEnd (GS (succ numAllies) rule) [] playOrder shuffled+ let (finalMsg, newScores) = case eithFinalSituation of+ Left _e -> (Nothing, scores)+ Right (fs@(eg,sts@(st:_),mvs),_) -> (Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, mvs), egToInt st eg : scores) where truncate = take $ numPlayers $ gameSpec $ publicState $ head sts- sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalSituation- putMVar mvFinalSituation (shuffled, finalSituation)- where numAllies = length is+-- sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalMsg+-- putMVar mvFinalSituation (shuffled, finalMsg)+ case eithFinalSituation of+ Left e -> hPutStrLn stderr $ "Exception while playing: " ++ displayException (e::SomeException)+ Right (_,ps) -> do+ let continue n = newGame n newScores g2 ps mvFinalSituation+ sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalMsg+ sendTextData (conn params) $ endecodeX mbVerb $ Str $ prettyMsg undefined $ Scores newScores+ -- `Str $ prettyMsg undefined $' is unnecessary, but it will be there for a while just for compatibility (until Ver. 0.16 or 1.0).+ if ntimes > 1 then continue $ pred ntimes else do+ sendTextData (conn params) $ endecodeX mbVerb PlayAgain+ eithinp <- try $ receiveDataMessage $ conn params+ case eithinp of+ Left e -> hPutStrLn stderr $ "Exception while requesting an answer: " ++ displayException (e::SomeException)+ Right input -> do+ let inp = unpack $ fromDataMessage input+ sender (inp++" received.")+ case dropWhile (not . isAlpha) inp of+ c:cs | toLower c == 'n' -> return ()+ | c == 'r' -> case reads cs of [(num, _)] | num > 0 -> if num <= 100 then sender ("repeating "++show num++" times.") >> continue num+ else sender "The number must be at most 100." >> continue 1+ _ -> continue 1+ _ -> continue 1 _ -> sender "The arguments of the `create' command could not be parsed." in case lex inp of [("version", _)] -> sender $ "hanabi-dealer server " ++ versionString params@@ -277,8 +312,9 @@ case emptyMVHs of emvh:_ -> putMVar emvh (VWS (conn params) mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n" [] -> sender "The game already has enough number of players.\n"- (initialDeck, finalSituation) <- readMVar mvFinalSituation- sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame initialDeck finalSituation -- This could be from the viewpoint of this player.+ forever $ do+ (initialDeck, finalSituation) <- readMVar mvFinalSituation+ sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame initialDeck finalSituation -- This could be from the viewpoint of this player. _ -> sender "The arguments of the `attend' command could not be parsed." _ -> sender $ inp ++ " : command unknown\n" ++ commandHelp available :: Maybe Verbosity -> MVar GameData -> Connection -> IO ()
Game/Hanabi/Client.hs view
@@ -12,13 +12,14 @@ import Data.Aeson hiding (Success) import GHC.Generics hiding (K1, from) import Data.Bool-import Data.Char(isSpace, isLower)+import Data.Char(isSpace, isLower, toLower) import qualified Data.Map as M import qualified Data.IntMap as IM-import Data.Maybe(fromJust, isNothing)-import Data.List(sort, intersperse, transpose)+import Data.Maybe(fromJust, isNothing, isJust)+import Data.List(sort, sortBy, intersperse, transpose, isPrefixOf)+import Data.Function(on) -import Miso hiding (Fail)+import Miso hiding (Fail, on) import Miso.String (MisoString) import qualified Miso.String as S @@ -26,11 +27,17 @@ 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 @@ -80,12 +87,21 @@ 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+ 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, play = True, localStrategy = mvStr, local = False, initialDeck = [], lastMoves = [], preset = False},- update = updateModel options,+ 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 ],@@ -102,10 +118,10 @@ mountPoint = Nothing} where strNames = "via WebSocket" : [ S.pack name | (name, _) <- strategies options ] #ifdef WSURI-uri = URL WSURI+uri = WSURI #else--- uri = URL "ws://133.54.228.39:8720"-uri = URL "ws://localhost:8720"+-- uri = URL "//133.54.228.39:8720"+uri = "//localhost:8720" #endif protocols = Protocols [] @@ -130,20 +146,22 @@ -- 2. to memoize renderMsg -- Also, `observe' should not send to the current player. -}-updateModel :: Game.Hanabi.Msg.Options -> Action -> Model -> Effect Action Model+updateModel :: [(String, (IO (DynamicStrategy IO)))] -> Action -> Model -> Effect Action Model updateModel _ (HandleWebSocket (WebSocketMessage (Message m))) model- = noEff model{ received = {- take lenHistory $ -} suppressCG $ decodeMsg m : received 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 local model+ 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- _ -> return $ ProcMsg $ Str "Could not parse as a Move."+ _ | 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 local model+ if forceLocal model || local model then liftIO $ do putMVar (mvMov $ localStrategy model) mov msg <- takeMVar (mvMsg $ localStrategy model)@@ -162,37 +180,67 @@ 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 opt ObserveLocally model = model <# liftIO (do- let constructor algIx = fromJust $ lookup algIx $ strategies opt- playerList <- mapM (constructor . S.unpack) $ reverse $ players 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,_) <- startFromCards (GS (length playerList) (rule model)) [] playOrder shuffled+ (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@(_,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+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 $ do (fs,_) <- startFromCards (GS (length thePlayerList) (rule model)) [] playOrder shuffled- putMVar (mvMsg $ localStrategy model) $ PrettyEndGame shuffled $ Just fs+ 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@(_,_,mvs)))) model = model{local=False, received = CreateGame : msg : received model, initialDeck = shuffled, lastMoves = mvs} <# return (SendMessage $ Message "available")+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)@@ -203,6 +251,27 @@ #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 @@ -222,13 +291,17 @@ | 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 {@@ -240,61 +313,110 @@ , 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.)"] - , span_ [style_ $ M.fromList [("float","right")]] [+ , 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 "verbosity options" ]+ , label_ [for_ "verbutton"] [text $ strVerbOpt language ] ]- , if showVerbosity then span_ [style_ $ M.fromList [("clear","both"), ("float","right")]] [renderVerbosity verbosity] else span_[][]+ , if showVerbosity then span_ [style_ $ M.fromList [("clear","both"), ("float","right")]] [renderVerbosity (verbosity,language)] else span_[][]+ ] - , span_ [style_ $ M.fromList [("clear","both"), ("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo]+ , 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 mdl) received+ , 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"] ] ]-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),+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_ 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 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 label update access = divspan [] [+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) {-@@ -320,9 +442,16 @@ decodeMsg str = case reads $ S.fromMisoString str of [] -> Str $ S.fromMisoString str [(msg,_)] -> msg #endif+strInvalid En = "Invalid move!"+strInvalid Ja = "その手はムリ!" -renderMsg :: [MisoString] -> Verbosity -> Model -> Msg -> View Action+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")]] [@@ -330,42 +459,71 @@ 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")]] [+renderMsg _ vl@(_,l,_) _ (Watch st []) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [],- renderSt verb ithPlayerFromTheLast st,+ renderSt vl (ithPlayerFromTheLastI18N l) st, hr_ [] ]-renderMsg _ verb _ (Watch st (mv:_)) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [+renderMsg _ vl@(_,l,_) _ (Watch st (mv:_)) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [],- renderTrial verb (publicState st) (const "") undefined (Game.Hanabi.view st) mv,+ renderTrial vl (publicState st) (const "") undefined (Game.Hanabi.view st) mv, hr_ [],- renderSt verb ithPlayerFromTheLast st,+ renderSt vl (ithPlayerFromTheLastI18N l) st, hr_ [] ]-renderMsg strategies _ mdl (PrettyAvailable games)- = div_ [style_ $ M.fromList [("overflow","auto")]] [+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"] [text $ S.pack "refresh"]] :+ 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 mdl,+ renderCreateGame True strategies lang 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")]] $ [+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 "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"]- ] :+ 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_ [type_ "radio", id_ iD, onClick (From $ Just n), checked_ $ from mdl == Just n],- label_ [for_ iD] [text "Turn 0"]]+ [ 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 ]@@ -373,60 +531,88 @@ -- 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%")]]],+-- 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 $ rule mdl]) . map fst . reads . S.unpack), (if null list then value_ else placeholder_) $ S.pack $ show $ access $ rule mdl]+ 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 $ rule mdl)+ dropdownLiteral options (UpdateRule . updater) (access rl) ] ] gs = GS{numPlayers = length (players mdl) + if play mdl then 1 else 0,- Game.Hanabi.rule = rule mdl}+ Game.Hanabi.rule = rl} 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]+ 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 (rule mdl) == 6 then [- mkTR [list_ "numMulticolors"] "Numbers of M1 .. M5" (\n -> (rule mdl){numMulticolors=n}) numMulticolors+ 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_ [ 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 [],+ 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 && all (not . isWS . S.unpack) (players mdl)+ 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 (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"]+ | 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_ [ type_ "checkbox", id_ "you", onClick TogglePlay, checked_ $ play mdl]- , label_ [for_ "you"] [if play mdl then text "You" else s_ [] [text "You"]]+ 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] [option_ [ value_ p, selected_ $ selected==p] [text p] | p <- options ]+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)@@ -441,40 +627,61 @@ 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,+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 ]-renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action-renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000"),("font-size", "1.8vmin")]] [+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 :: Verbosity -> [Card] -> (EndGame, [State], [Move]) -> View Action-renderEndGame verb initDeck (eg,sts@(st:_),mvs)+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) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs,+ renderRecentEvents verb (publicState st) (ithPlayerFromTheLastI18N lang) (map Game.Hanabi.view sts) mvs, hr_ [],- h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000"),("font-size", "5vmin")]] [text $ S.pack $ show eg],+ h1_ [style_ $ M.fromList [("background-color", forceWhite c "#FF0000"),("color","#000000"),("font-size", "5vmax")]] [text $ S.pack $ strEndGame lang eg], hr_ [],- renderSt verb ithPlayerFromTheLast st,+ renderSt verb (ithPlayerFromTheLastI18N lang) st, hr_ [], span_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [- text $ S.pack $ "By the way, the initial deck was ",+ 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 " and the move histories are ",+ 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 []),@@ -484,76 +691,118 @@ 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--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 ""+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 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")]] [+ 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","#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.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","#008800")]] [text $ S.pack (concat $ replicate (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_ [] [- text $ S.pack $ "deck: ",+ 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 [("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"]+ 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_ [] [- text $ S.pack "played ",- span_ (if achievable - current >= pileNum pub then [style_ $ M.fromList [("color", "#FF0000"), ("font-weight", "bold")]] else [])+ 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", "3vmin")]] $ [ span_ [] $ text (S.pack " ") : renderCardsInline verb pub c [K1 .. playedMax] : map (text . S.pack) (replicate (possible - fromEnum playedMax) "_" ++ replicate (5 - possible) "X")+ 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_ [] [- text $ S.pack $ "dropped: ",+ 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", "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 ]+ 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 :: 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+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 pub c n = cardStrInline v pub (C c n) $ show $ fromEnum n+rankStrInline (v,l,_) pub c n = cardStrInline v pub (C c n) $ showRank l 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)]+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@@ -567,75 +816,88 @@ useless = markUseless v && isUseless pub c -renderRecentEvents :: Verbosity -> PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action+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 :: Verbosity -> PrivateView -> View Action-renderPV v pv@PV{publicView=pub} = div_ [] [+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 "Your") 0 [ 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 (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ annotations pub))+ (zipWith3 (renderHand v pv (ithPlayerI18N l "あなたの" $ 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+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 :: 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+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' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Annotation] -> View Action+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 :: 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"),+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", colorStr $ fmap color mbc),- ("font-family", "monospace") -- ,+ ("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 "play") ]) (const $ span_[][]) mbc,+ )] ] [ 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 v pub pli mbc tup+ 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 '_' (head . show) mc : ' ' : [maybe '_' (head . show . fromEnum) mk] else "_ _" ],+ (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 "drop") ]) (const $ span_[][]) mbc,+ )] ] [ 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 pc, -- br_[],- text $ S.pack $ showRankPossibilities pn] else span_[][]+ )]] [text $ S.pack $ showColorPossibilities $ qitsToColorPossibilities ptup, -- br_[],+ text $ S.pack $ showRankPossibilities $ qitsToRankPossibilities ptup] else span_[][] ] where pub = publicView pv- cardWidth = 90 / fromIntegral (handSize $ gameSpec pub)+ 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 -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action-renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [+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 pub mbc tup+ cardStr v pv mbc ann ] | (mbc,tup) <- zip mbcs tups ],@@ -648,11 +910,21 @@ ] ] -}-cardStr :: Verbosity -> PublicInfo -> Int -> Maybe Card -> (Maybe Color, Maybe Rank) -> View Action+strBack En = "? ?"+strBack Ja = "🀫"+cardStr :: VLC -> PrivateView -> Int -> Maybe Card -> Annotation -> View Action -- Not sure which style is better. #ifdef BUTTONSONCARDS-cardStr v pub pli mbc tup = case mbc of- Nothing -> span_ [] [text $ S.pack "??"]+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],@@ -662,23 +934,31 @@ ("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)]+ ("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 pub pli mbc tup = case mbc of- Nothing -> div_ [style_ $ M.fromList [("text-align","center")]] [text $ S.pack "? ?"]+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 $ take 1 $ show $ color c],+ 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 $ show $ fromEnum $ rank c]+ 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")]+ ("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@@ -698,10 +978,13 @@ 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+ 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 $ Str "invalid move"+ if isMoveValid pv m then return m else do putMVar mvmsg Invalid getMoveUntilSuccess pv mvstr newMVarStrategy = do mvmsg <- newEmptyMVar
Game/Hanabi/FFI.hs view
@@ -17,3 +17,5 @@ windowBottomSub action noAction sink = windowAddEventListener "scroll" $ \_e -> do b <- atTheBottom liftIO $ sink $ if b then action else noAction++-- foreign import javascript safe "var c=navigator.hardwareConcurrency; $r = c ? c : 1" getHardwareConcurrency :: IO Int -- Concurrency does not work at least with the current GHCJS.
Game/Hanabi/Msg.hs view
@@ -2,6 +2,7 @@ module Game.Hanabi.Msg where import Game.Hanabi import GHC.Generics+import Data.List(transpose, tails) import System.Random #ifdef TFRANDOM@@ -38,38 +39,45 @@ #endif -- WhatsUp and WhatsUp1 should be minimized after better clients are implemented. 効率上はminimizeすべきだが、テスト目的ではとりあえずこのままの方がやりやすい。-data Msg = Str String | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame [Card] (Maybe (EndGame, [State], [Move])) | Watch State [Move] | PrettyAvailable [(Int, (Int, Int))] | CreateGame deriving (Show, Read, Eq, Generic)+data Msg = Str String | Invalid | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame [Card] (Maybe (EndGame, [State], [Move])) | Watch State [Move] | PrettyAvailable [(Int, (Int, Int))] | CreateGame | PlayAgain | Scores [Int] deriving (Show, Read, Eq, Generic) prettyMsg :: Verbosity -> Msg -> String prettyMsg _ (Str xs) = xs+prettyMsg _ Invalid = "Invalid move!" prettyMsg verb (WhatsUp name ps ms) = what'sUp verb name ps ms prettyMsg verb (WhatsUp1 p m) = what'sUp1 verb p m-prettyMsg _ (PrettyEndGame cards tup) = prettyMbEndGame tup ++ "By the way, the initial deck was " ++ shows cards ".\n"+prettyMsg _ (PrettyEndGame cards tup) = prettyDeckMbEndGame cards tup prettyMsg _ (Watch st []) = prettySt ithPlayerFromTheLast st prettyMsg _ (Watch st (mv:_)) = replicate 20 '-' ++ '\n' : showTrial (const "") undefined (view st) mv ++ '\n' : replicate 20 '-' ++ '\n' : prettySt ithPlayerFromTheLast st prettyMsg _ (PrettyAvailable available) = unlines $ map prettyAvailableGame available+prettyMsg _ PlayAgain = "Play with the same member? Adaptive strategies (if any) may have learned your play style (to some extent) [Y/n]\n"+prettyMsg _ (Scores revScores) = "Scores so far: " ++ show (reverse revScores) +++ "\nThe number of Games: " ++ show numGames ++ ", Average: " ++ show (fromIntegral (sum revScores) / fromIntegral numGames) +++ if numGames >= 5 then "\nAverages of the last 5 games = " ++ show (reverse $ take (numGames - 4) $ map ((/5) . fromIntegral . sum) $ transpose $ take 5 $ tails revScores)+ else ""+ where numGames = length revScores+ prettyMbEndGame :: Maybe (EndGame, [State], [Move]) -> String-prettyMbEndGame Nothing = "Game ended abnormally, possibly by connection failure.\n"-prettyMbEndGame (Just tup) = prettyEndGame tup+prettyMbEndGame = prettyDeckMbEndGame []+prettyDeckMbEndGame :: [Card] -> Maybe (EndGame, [State], [Move]) -> String+prettyDeckMbEndGame _ Nothing = "Game ended abnormally, possibly by connection failure.\n"+prettyDeckMbEndGame d (Just tup) = prettyDeckEndGame d tup prettyAvailableGame :: (Int, (Int, Int)) -> String prettyAvailableGame (gameid, (missing, total)) = "Game ID " ++ shows gameid ": available " ++ shows missing " out of " ++ shows total "." --- 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 defaultOptions :: Options defaultOptions = Opt{version = error "The verion field should be set to Game.Hanabi.VersionInfo.versionInfo", port = 8720,- strategies = []+ strategies = [],+ lazy = False } data Options = Opt{ version :: String -- ^ the version string to be shown by the `version' command. -- This is supposed to be set to 'versionInfo', but can just be @""@ , port :: Int -- ^ the port number. This can be overridden by `-p' option.- , strategies :: [(String, IO (DynamicStrategy IO))] -- ^ the association list of the tuples of the strategy name and (the constructor for) the strategy.+ , strategies :: [(String, Maybe (Bool -> IO (IO (DynamicStrategy IO))))] -- ^ the association list of the tuples of the strategy name and (the constructor for) the strategy. Nothing is used if the strategy is not implemented by the current compiler (typically GHCJS), but can be executed by the server by handing the name.+ , lazy :: Bool -- ^ initialize lazily even if initialization takes time when the first game starts. } isWS :: String -> Bool
+ Game/Hanabi/Strategies.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleContexts, CPP #-}+module Game.Hanabi.Strategies(module Game.Hanabi.Strategies,+ module Game.Hanabi.Strategies.SimpleStrategy,+ module Game.Hanabi.Strategies.StatefulStrategy,+ module Game.Hanabi.Strategies.Stateless,+ module Game.Hanabi.Strategies.EndGameSearch,+ module Game.Hanabi.Strategies.MCSearch,+#ifdef MHLMC+ module Game.Hanabi.Strategies.AdaptiveLMC,+ module Game.Hanabi.Strategies.AppendDSL+#endif+ ) where++import Game.Hanabi.Strategies.SimpleStrategy hiding (main)+import Game.Hanabi.Strategies.StatefulStrategy hiding (main, lookupOn)+import Game.Hanabi.Strategies.Stateless hiding (main)+import Game.Hanabi.Strategies.EndGameSearch hiding (main)+import Game.Hanabi.Strategies.MCSearch(mcs)+import qualified Game.Hanabi.Strategies.LazyMC as LMC+#ifdef MHLMC+import Game.Hanabi.Strategies.AdaptiveLMC+import Game.Hanabi.Strategies.AppendDSL+#endif+import System.Random++import Data.Typeable+import Game.Hanabi(pileNum, DynamicStrategy, mkDS, Strategy(..)) -- (Replay(..))+++-- DynamicStrategyにする前にpreloadしないと、DynamicStrategyのinitializeが使われる。++type Constrs = Bool -> IO (IO (DynamicStrategy IO))+mkStr :: (String, String -> DynamicStrategy IO) -> (String, Maybe Constrs)+mkStr (xs, f) = (xs, Just $ preload (return $ f xs) return)+mkStrIO :: (String, String -> IO (DynamicStrategy IO)) -> (String, Maybe Constrs)+mkStrIO (xs, f) = (xs, Just $ preload (f xs) return)+mksd :: (Strategy t IO, Typeable t) => t -> String -> DynamicStrategy IO+mksd = flip mkDS+mksdIO :: (Strategy t IO, Typeable t) => IO t -> String -> IO (DynamicStrategy IO)+mksdIO iop s = fmap (mkDS s) iop++preload :: Strategy p m =>+ m p -- ^ constructor that should be executed only once that can take time,+ -- such as reading parameters from a file or maybe self-contained training+ -> (p -> m p) -- ^ constructor that require different behaviour at every game,+ -- such as setting RNG or creating network socket+ -> Bool -- ^ if True, initialize lazily, i.e., does not stop computation until the initialization finishes+ -> m (m p)+preload oneShot beforeTheGame lz = do p <- oneShot+ p' <- initialize lz p+ return (beforeTheGame p')++-- | 'predefinedStrategies' is the list of strategies included in this library, with some recommended parameters.+-- This value is subject to change in future versions, and adding strategies to this list is considered as extension rather than modification.+predefinedStrategies :: [(String, Maybe Constrs)]+predefinedStrategies = map mkStr [+ ("Stupid example strategy", mksd $ S False),+-- ("Example strategy with states", mksd $ sfs (S False)),+ ("Stateless implementation of the strategy with states", mksd $ SL $ S False),+ ("Strategy with states with aggressive positional drop", mksd $ sf),+ ("Strategy with end game search", mksd $ EG $ SL (S False)),+-- ("Strategy with end game search with aggressive positional drop", mksd $ EG $ sf),+-- ("Strategy with Monte Carlo search assuming Stateless with aggressive positional drop (light)", mksd $ lightmc),+ ("Strategy with Monte Carlo search assuming Stateless with aggressive positional drop", mksd $ mc),+ ("Lazy Monte Carlo search specialized to Stateful with aggressive positional drop", mksd $ lmc $ sf)+-- , ("Lazy Monte Carlo search specialized to Stateless with aggressive positional drop", mksd $ lmc $ sl)+ ]+#ifdef MHLMC+ ++ [mkStrIO ("Adaptive Lazy Monte Carlo without incremental learning",+ mksdIO $ mkAdaptiveLMC (PADSL (PALMC 0 AverageScore FromTheBeginning 800 False) 1 (ProgsPerDepth 20000)) instinct $ mkStdGen 54321012345)]+#else+ ++ [("Adaptive Lazy Monte Carlo without incremental learning", Nothing)]+#endif++lightmc = mcs (\pub -> pileNum pub < 8) 3000 (mkStdGen 1234567890) (SL $ S True) (SL $ S True) $ repeat $ SL $ S True+mc = mcs (\pub -> pileNum pub < 18) 6000 (mkStdGen 1234567890) (SL $ S True) (SL $ S True) $ repeat $ SL $ S True++lmc sf = LMC.lmcs LMC.AvoidZero 400 100 (mkStdGen 1234567890) sf sf [repeat sf]++sl = SL $ S True+sf = sfs $ S True
+ Game/Hanabi/Strategies/AdaptiveLMC.hs view
@@ -0,0 +1,415 @@+-- A specialized version of LazyMC.hs that supports a lot number of strategies.+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, RankNTypes, TupleSections, FlexibleContexts #-}++module Game.Hanabi.Strategies.AdaptiveLMC(AdaptiveLMC(..), ParamsALMC(..), Priority(..), CheckMode(..), mkMx, mkProbs) where+import System.Random+import Control.Monad(MonadPlus(..))+import Data.Functor.Identity+#ifdef TEST+import Test.QuickCheck hiding (shuffle, (.&.))+import Data.List(partition, maximumBy, delete, tails, permutations, transpose, sort)+#else+import Data.List(partition, maximumBy, delete, tails, permutations, transpose)+#endif+import Data.Bits hiding (rotate)+import Data.Function(on)+import Data.Array hiding (index)+import Data.Maybe(isNothing, isJust, fromJust, maybeToList)+import qualified Data.IntMap as IM+import Game.Hanabi++#ifdef MHLMC+import Control.Parallel(par, pseq)+import Control.Parallel.Strategies hiding (Strategy)+import GHC.Conc(numCapabilities)+#endif++-- from package MagicHaskeller+import Control.Monad.Search.Combinatorial++-- only used by the fallback.+import Game.Hanabi.Strategies.EndGameSearch+import Game.Hanabi.Strategies.EndGameLite(egml, egl, EndGameMirrorLite(..), EndGameLite(..))+import Game.Hanabi.Strategies.Stateless++#ifdef DEBUG+import Debug.Trace+#else+trace _ = id+#endif++#if !defined MHLMC+par = flip const+#endif++-- type FullState s = ([State], [s])+-- type BeliefState s = [(FullState s, Probability)]++-- mkPool is a function that helps the user to create the pool of strategies based on the list of lists of strategies that are annotated with the probability with which each list of strategies is selected.+mkProbs :: [Double] -> [Double]+mkProbs = tail . scanl (-) 1+mkMx :: [[s]] -> Matrix s+mkMx = Mx . (++repeat []) -- Matrix defined in package MagciHaskeller assumes an infinite stream of finite lists.++samplePairsOfStatesAndStrategies :: (RandomGen g, Strategy s Identity) => Int -> [Matrix s] -> [[Double]] -> [PrivateView] -> [Move] -> g -> [([State],[s])]+samplePairsOfStatesAndStrategies numC mxs probss pvs mvs gen = case split gen of (g1,g2) -> zip (sampleStatess numC pvs mvs g1) $ sampleStrategiess mxs probss g2++samplesFromArr :: (RandomGen g) => Array Int ss -> g -> [ss]+samplesFromArr arr g = [ arr ! ix | ix <- randomRs (bounds arr) g ]++sampleStrategiess :: (RandomGen g, Strategy s Identity) => [Matrix s] -> [[Double]] -> g -> [[s]]+sampleStrategiess mxs probss gen = transpose $ zipWith3 sampleStrategies mxs probss $ map snd $ iterate (split . fst) $ split gen++-- The Double here is not the probability of selecting the current array but that of going deeper. This decision is for efficiency. So, if the list is finite, it must end with @(some_array,0):[]@+sampleStrategies :: (RandomGen g, Strategy s Identity) => Matrix s -> [Double] -> g -> [s]+sampleStrategies mx probs = sampleStrategies' $ zip [ listArray (1, length ss) ss | ss <- unMx $ removeNils mx ] probs+sampleStrategies' :: (RandomGen g, Strategy s Identity) => [(Array Int s, Double)] -> g -> [s]+sampleStrategies' [] _ = []+sampleStrategies' ts gen = let+ (d,g1) = random gen+ (strs,_) = case dropWhile (\(_,prob) -> d<prob) ts of+ t:_ -> t+ [] -> last ts+ in case randomR (bounds strs) g1 of (i,g2) -> (strs!i) : sampleStrategies' ts g2 -- Make sure that @indices strs@ is not null when defining the pool!+++sampleStatess :: RandomGen g => Int -> [PrivateView] -> [Move] -> g -> [[State]]+#ifdef MHLMC+sampleStatess numC pvs moves g = concat $ para numC $ map (smplsts pvs moves) $ map snd $ iterate (split.fst) $ split g+#else+sampleStatess _ pvs@(pv:tlpvs) moves g = let (s,gen) = sampleState pv g in map (stateToStateHistory (map publicView tlpvs) moves) s ++ sampleStatess numC pvs moves gen+#endif++smplsts :: RandomGen g => [PrivateView] -> [Move] -> g -> [[State]]+smplsts pvs@(pv:tlpvs) moves g = map (stateToStateHistory (map publicView tlpvs) moves) $ fst $ sampleState pv g+++-- | 'nSampleStatess' is an eager alternative of sampleStatess.+-- 'nSampleStatess' is not desired because n can be very big and most of the samples would not be actually used, but there are RNGs without good split.+-- @take n $ sampleStatess pvs moves g@ should be used instead in most cases.+nSampleStatess :: RandomGen g =>+ Int -- ^ number of samples+ -> [PrivateView] -> [Move] -> g -> ([[State]],g)+nSampleStatess 0 pvs moves g = ([],g)+nSampleStatess n pvs@(pv:tlpvs) moves g = let (s,g') = sampleState pv g+ (ss,gen) = nSampleStatess (pred n) pvs moves g'+ in (map (stateToStateHistory (map publicView tlpvs) moves) s ++ ss, gen)++-- naive alternative+{-+eval :: (Monad m, Strategy s m) => [([State],[s])] -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Int+eval samples run = mapM (\ (sts, ps) -> run sts ps) samples >>= \tups -> return $ sum [ egToNum st eg | (eg,st:_,_) <- tups ]+-}+evals :: [([State],[s])] -> ([State]->[s]->(EndGame, [State], [Move])) -> [Int]+evals samples run = [ egToNum st eg | (sts,ps) <- samples, let (eg,st:_,_) = run sts ps ]++evalALittleQuick :: Int -> Int -> Int -> [Int] -> Int+evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar [] = sumSoFar+evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar (score:ss) | newPossibleMargin <= 0 = -1+ | otherwise = evalALittleQuick bestPossibleScore newPossibleMargin newSum ss+ where newSum = score + sumSoFar+ newPossibleMargin = bestPossibleMargin - bestPossibleScore + score++evalQuick :: Int -> Int -> Int -> [Int] -> Int+evalQuick bestPossibleMargin bestPossibleScore sumSoFar [] = sumSoFar+evalQuick bestPossibleMargin bestPossibleScore sumSoFar (score:ss)+ | bestPossibleMargin <= 0 = -1+ | otherwise = evalQuick (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (score + sumSoFar) ss++-- findBestMove finds the best move based on the average score.+findBestMove :: Int -> Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> (Int, Move) -> [Move] -> (Int, Move)+findBestMove numC achievable bestPossibleScore samples run best [] = best+findBestMove numC achievable bestPossibleScore samples run best@(bestSum, _) (m:ms) = let scores = evals samples $ run m+ sumScore = evalQuick (achievable-bestSum) bestPossibleScore 0 $ para numC scores+ in findBestMove numC achievable bestPossibleScore samples run (if sumScore > bestSum then (sumScore, m) else best) ms+#ifdef MHLMC+para numC = withStrategy $ parBuffer numC rpar+#else+para _ xs = xs+#endif++evalDecent :: Priority -> Int -> Int -> Int -> Int -> Int -> [Int] -> (Int, Int)+evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar [] = (numBest, sumSoFar)+evalDecent AvoidZero bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (0:ss) = (0, sumSoFar) -- Further computation is not worthy, but there has to be some valid value.+evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (score:ss)+ | bestPossibleNumMargin < 0 || (bestPossibleNumMargin == 0 && bestPossibleMargin <= 0) = (-1, -1)+ | score == bestPossibleScore = evalDecent pri bestPossibleNumMargin (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (succ numBest) (score + sumSoFar) ss+ | otherwise = evalDecent pri (pred bestPossibleNumMargin) (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore numBest (score + sumSoFar) ss++-- findBestMoveDecently is a variant of findBestMove that optimizes ( - <# of failure>, <# of perfect>, <average score>) in the lexicographical order.+findBestMoveDecently :: Int -> Priority -> Int -> Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> ((Int,Int), Move) -> [Move] -> ((Int,Int), Move)+findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run best [] = best+findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run best@(bestRes@(bestNum,bestSum), _) (m:ms) = let scores = evals samples $ run m+ sumScore = evalDecent pri (numSmpls-bestNum) (achievable-bestSum) bestPossibleScore 0 0 $ para numC scores+ in findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run (if sumScore > bestRes then (sumScore, m) else best) ms+++-- In effect, lmcs pri n rr g p ps === glmcs pri n rr g p [ [([p],1)] | p <- ps ]++-- flatlmcs numC pri cm n ov rr g p ps = glmcs numC pri cm n ov rr g p ps $ repeat $ 1 : repeat 0++-- glmcs numC pri cm n ov _rr g p ps probs = LMC (PALMC numC pri cm n ov) g p (map mkMx ps) (map mkProbs probs) mzero IM.empty [] undefined++data ParamsALMC = PALMC { numCap :: Int -- ^ numCapabilities. Unless this is positive, the value from -N RTS option is used.+ , priority :: Priority -- This could be (Int->Priority), changing as the number of games increases.+ , checkMode :: CheckMode+ , numSamplesLMC :: Int+ , overwriteMyRollout :: Bool -- ^ if True, overwrite rolloutStrategyLMC with the very first strategy of rolloutStrategiesLMC at the beginning of each game.+-- , rollbackRounds :: Int -- ^ after resampling, how many past rounds to check the consistency with the rollout policy. This is reset to 1 when @move@ is called in the beginning of game, and is not a config value any longer.+ }+ deriving (Eq, Show, Read)+data AdaptiveLMC g s = LMC { parameters :: ParamsALMC+ , rngLMC :: g+ , rolloutStrategyLMC :: s+ , rolloutStrategiesLMC :: [Matrix s]+ , priors :: [[Double]]+ , consistentSampleFullStatesLMC :: Matrix ([State],[s]) -- ^ stream of lists of sample full states that are consistent with the game environment and the conjectured teammate policies.+ , ixToCard :: IM.IntMap Card+ , fixedStateHistory :: [State]+ , lastTurn :: Int -- the last turn when move for this agent is executed. This should equal @turn pub - numPlayers (gameSpec pub)@ when move is called. This is useful for identifying who finalized the game within observeEndGame.+ , ready :: Bool -- ^ True when initialization is finished, ⊥ otherwise.+ }+data Priority = AverageScore -- ^ evaluate only by the average score+ | BestScoreRate -- ^ firstly consider the number of cases where the best possible score is achieved, and then consider the average score+ | AvoidZero -- ^ firstly avoid Failure and score 0, and then follow BestScoreRate. This is the recommendation if self-play of the rollout policy does not achieve 24 on average.+ deriving (Eq, Show, Read)+data CheckMode = FromTheBeginning -- ^ check the consistency of new samples against the full history of the current game. Costly, but exact when checking stateful sample strategies.+ | PartiallyObserved -- ^ check the consistency of new samples only against the part of history where unknown cards still exist. This should be enough when assuming that other players are stateless.+ deriving (Eq, Show, Read)+annotationToCT4 :: PrivateView -> Annotation -> (Int, CardTo4)+annotationToCT4 pv ann = (ixDeck ann, case marks ann of (Just _, Just _) -> possibilities ann+ _ -> possibilities ann .&. invisibleBag pv)+{-+updateIxToCT4 :: Int -> [PrivateView] -> IM.IntMap CardTo4 -> IM.IntMap CardTo4+updateIxToCT4 numP pvs@(pv:_) i2ct4 = let lastResult = result $ pvs !! pred numP+-}++annotationToMbCard :: PrivateView -> Annotation -> [(Int, Card)]+annotationToMbCard pv ann = case marks ann of (Just c, Just r) -> [(ixDeck ann, C c r)]+ _ | bit trz == pos -> [(ixDeck ann, qitPosToCard $ trz `div` 2)]+ | otherwise -> []+ where pos = possibilities ann .&. invisibleBag pv+ trz = countTrailingZeros pos++-- updateIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card -> IM.IntMap Card+-- updateIxToCard numP pvs mvs i2c = roundToIxToCard numP pvs mvs `union` i2c+roundToIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card+roundToIxToCard numP pvs@(pv:_) mvs = let+ myRevealed = case drop (pred numP) pvs of+ PV{publicView=PI{result=lastResult}} : myLastPV : _ ->+ case lastResult of+ None -> []+ _ -> [(ixDeck $ head (annotations $ publicView myLastPV) !! index myLastMove, revealed lastResult)]+ where myLastMove = mvs !! pred numP -- mvs is only used here, for extracting the index of the last move.+ _ -> []+ myAnns = head $ annotations $ publicView pv+ in IM.fromList $ myRevealed ++ (myAnns >>= annotationToMbCard pv) -- fromAscList could be used for the second list with adequate specification.++instance (RandomGen g, Monad m, Strategy s Identity) => Strategy (AdaptiveLMC g s) m where+ strategyName ms = return "AdaptiveLMC"+ initialize True p = ready p `par` return p+ initialize False p = ready p `pseq` return p+ observeEndGame iniDeck gh@(eg, state:states, moves) lmc@(LMC (PALMC numC pri cm num ov) gen p mxs probss _cMx i2c fsh lt ready)+ | lt < numP = return lmc -- If the game ends before my turn comes, do nothing, (Something can still be learned, but that is not worthy of coding.)+ | otherwise = -- trace ("lt = "++show lt) $+ do+ let q | ov = head $ concat $ unMx $ head filteredMxs+ | otherwise = runIdentity $ observeEndGame iniDeck gh p+ return $ LMC (PALMC numC pri cm num ov) gen q filteredMxs probss mzero IM.empty [] (-1) ready+ where -- ni2c = IM.fromList $ zip [0..] iniDeck+ pub = publicState state+ numP = numPlayers (gameSpec pub)+ predLenFsh | null fsh = -1+ | otherwise = turn $ publicState $ last fsh+ nonrotatedDeltas = map unzip $ take (turn pub - predLenFsh) $ tails $ zip (zipWith rotate [1..] states) moves+ arrOfsPvsMvs = accumArray (flip (:)) [] (0, pred numP) [ (offset, (map view $ map (rotate offset) sts, mvs)) | (sts@(st:_), mvs) <- nonrotatedDeltas, let offset = (turn (publicState st) - lt) `mod` numP ] :: Array Int [([PrivateView], [Move])]++ filteredMxs = zipWith filtMx mxs [1..pred numP]++ -- This @filtMx@ is the same as that in @move@.+ -- filtMx :: Matrix x -> Int -> Matrix x+ filtMx mx offset = let hists = arrOfsPvsMvs ! offset in removeLeadingNils $ fps hists mx+ where fps hists mx = mx >>= \prog -> foldr ($) (return prog) $ map (pred prog) hists+ where -- pred :: s -> ([PrivateView], [Move]) -> Bool+ pred str (pvs, mv:mvs) | fst (runIdentity $ move pvs mvs str) == mv = id+ | otherwise = delay+++ move pvs@(pv:_) mvs str@(LMC palmc@(PALMC numC pri cm num ov) gen p mxs probss checkedMx i2c fsh lt ready)+ {-+ | turn pub < numP || null newcss = do+ let (g3,g4) = split g2+ let (newrr, newMxs) = if turn pub >= numP then (succ rr,+ take (pred numP) $ (+ map (\mx -> case mx of+ Mx (a:b:vs) | fst (randomR (1, length a) g3) * 2 < limit -- The random number is used to make sure roughly most of the programs are tried at least once.+ -> Mx $ (b ++ a) : vs+ _ -> mx)+ filteredMxs))+ else (1, filteredMxs)+ let (m, q) = trace "!!!!!!!!!!!!!Fall Back!!!!!!!!!!!!!!!!!!!!!" $+ runIdentity $ move pvs mvs p+ return (m, LMC pri num newrr g4 sp q newMxs probss (take num alternativeStatess) ni2c nfsh ready)+ -}+ | otherwise = do+#ifdef DEBUG+ (sq,(_i, m)) <- trace ("mcMove") $+ trace ("length samples = " ++ show (length $ take num newcss)) $+#else+ (sq, m) <-+#endif+ mcMove numC pri num (take num newcss) p pvs' mvs++ return (m, LMC palmc g2 sq filteredMxs probss (Mx $ newlyCheckedMx ++ repeat []) ni2c nfsh (turn pub) ready)+ where+ (ni2c, fsh') | turn pub < numP = (IM.empty, [])+ | otherwise = (roundToIxToCard numP pvs mvs `IM.union` i2c, fsh)+ lenfsh = length fsh'+ rpvs = drop lenfsh $ reverse $ tail pvs+ cardss = map fromJust $ takeWhile isJust [ mapM (flip IM.lookup ni2c . ixDeck) $ head $ annotations $ publicView pv | pv <- rpvs ]+ nonrotatedPartialStates = zipWith (\(PV{publicView=pub, handsPV=hpv}) myHand -> St{publicState=pub, hands=myHand:hpv}) rpvs cardss+ nfsh = reverse nonrotatedPartialStates ++ fsh'+ lenFshDelta = length nonrotatedPartialStates+-- nrpss = take lenFshDelta $ tails nfsh :: [[State]]+ predLenDelta = turn pub - lenFshDelta - lenfsh+ deltas = map unzip $ take lenFshDelta $ tails $ zip nfsh $ drop predLenDelta mvs :: [([State], [Move])] -- NB: length mvs == turn pub, though length pvs == succ (turn pub)+++ arrOfsPvsMvs = accumArray (flip (:)) [] (0, pred numP) [ (offset, (map (view . rotate offset) sts, mvs)) | (sts@(st:_), mvs) <- deltas, let offset = (turn (publicState st) - turn pub) `mod` numP ] :: Array Int [([PrivateView], [Move])]++ filteredMxs = zipWith filtMx mxs [1..pred numP]++ -- filtMx :: Matrix x -> Int -> Matrix x+ filtMx mx offset = let hists = arrOfsPvsMvs ! offset in removeLeadingNils $ fps hists mx+ where fps hists mx = mx >>= \prog -> foldr ($) (return prog) $ map (pred prog) hists+ where -- pred :: s -> ([PrivateView], [Move]) -> Bool+ pred str (pvs, mv:mvs) | fst (runIdentity $ move pvs mvs str) == mv = id+ | otherwise = delay+++ -- newcss :: [([State],[s])]+ newcss = concat newlyCheckedMx++ (tk,m:_) = splitAt (pred numP) mvs+ moves = m : reverse tk+ revPVs = reverse $ take numP pvs+ agree pv1 pv2 = ((==) `on` (nonPublic . publicView)) pv1 pv2 &&+ ((==) `on` (map (take 1) . handsPV)) pv1 pv2 &&+ ((==) `on` (map marks . head . annotations . publicView)) pv1 pv2+ viewChecked = do+ ~(lststs@(lastState:_), lstps) <- checkedMx+ states <- Mx $ (:repeat[]) $ take 1 $+ foldl (\statss (i,rpv,mov) -> statss >>= \stats@(stat:_) -> map (:stats) (map (rotate 1) $ filter (\st -> isNothing (checkEndGame $ publicState st) && agree rpv (view $ rotate (-i) st)) $ proceeds stat mov)) [lststs] $ zip3 [0..] revPVs moves+ return (states, lstps)+ checkedCss | turn pub < numP = mzero+ | otherwise = do+ (states, lstps) <- viewChecked+ checkMoves numP numP tailsMoves lstps states++ tailsMoves = tails mvs+++ (tkSamples, drSamples) = splitAt num $ samplePairsOfStatesAndStrategies numC filteredMxs probss pvs mvs g1+ phase1 = do (sts,ps) <- Mx $ tkSamples : repeat []+ checkMoves ({- rr*numP `min` -} turns) numP tailsMoves ps sts+ ph1Depth = succ $ length $ takeWhile null $ unMx phase1+ -- newlyCheckedMx :: Matrix ([State],[s])+ newlyCheckedMx = head $ dropWhile ((<num) . length . concat) $ map (take ph1Depth . unMx) $ scanl mplus (checkedCss `mplus` phase1) $ para numC $ map (uncurry $ flip $ checkMoves turns numP tailsMoves) drSamples+ -- Samples that were not checked within this turn should be abandoned, because the space of possible states is narrowed in the next turn, and most of them can be useless, so newly sampling in the next turn is more efficient.+ turns = case cm of FromTheBeginning -> turn pub+ PartiallyObserved -> succ predLenDelta++ pvs'@(hdpv:tlpvs) = pvs -- [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]+ pub = publicView hdpv+ numP = numPlayers $ gameSpec pub++ (g1,g2) = split gen+ alternativeStatess = [ (states, take (pred numP) strs) | (states, strs) <- samplePairsOfStatesAndStrategies numC filteredMxs probss pvs mvs g1 ]+++ limit = 10000++removeLeadingNils :: Matrix a -> Matrix a+removeLeadingNils (Mx xss) = Mx $ dropWhile null xss++removeNils (Mx xss) = Mx $ filter (not . null) xss+++mcMove :: (Monad m, Strategy p Identity) =>+ Int+ -> Priority+ -> Int -- ^ number of samples + -> [([State],[p])] -- ^ possible sample pairs of the state history and the internal memory states of other players' strategies+ -> p -- ^ rollout strategy for the player+ -> [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+#ifdef DEBUG+ -> m (p, ((Bool,Int,Int), Move))+#else+ -> m (p, Move)+#endif+mcMove numC pri numSmpls smpls p pvs@(pv:_) mvs = do+ let (defaultMove, sq) = runIdentity $ move pvs mvs p+ let candidateMoves = defaultMove : delete defaultMove (validMoves pv)+ let pub = publicView pv+ bestPossibleScore = fromIntegral $ moreStrictlyAchievableScore pub+ achievable = bestPossibleScore * fromIntegral numSmpls+#ifdef DEBUG+-- This is the naive alternative.+ let asc = case pri of AvoidZero ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)+ in ((all (/=0) scores, length $ filter (==bestPossibleScore) scores, sum scores), m)+ ) candidateMoves :: [((Bool,Int,Int), Move)]+ BestScoreRate ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)+ in ((True, length $ filter (==bestPossibleScore) scores, sum scores), m)+ ) candidateMoves+ AverageScore ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)+ in ((True, fromIntegral numSmpls, sum scores), m)+ ) candidateMoves+ achi = (True, fromIntegral numSmpls, achievable)++++ if trace "if any" $+ any ((>achi) . fst) asc then error ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) else+ trace ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) $+ return $+ (sq,+ trace ("defaultMove = "++show defaultMove++", and the result seems "++show (maximumBy (compare `on` fst) $ reverse asc)) $+ case lookup achi asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc+ Just k -> (achi, k) -- Stop search when the best possible score is found.+ )+#else+ let best = case pri of AverageScore -> snd $ findBestMove numC achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[sq]) m) (-1, error "findBestMove: not found: should be undefined" defaultMove) candidateMoves+ _ -> snd $ findBestMoveDecently numC pri numSmpls achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[sq]) m) ((0,-1), error "findBestMoveDecently: not found: should be undefined" defaultMove) candidateMoves+ return (sq, best)+#endif+++-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.+tryAMove :: (Monad m, Strategy s m) => [State] -> [Move] -> [s] -> Move -> m ((EndGame, [State], [Move]),[s])+tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move in tryAMove"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs+ Just eg -> return ((eg, nxt:states, mov:mvs), strs)++checkMoves :: (Strategy s Identity) => Int -> Int -> [[Move]] -> [s] -> [State] -> Matrix ([State], [s])+checkMoves turns numP tailsMoves ps states =+ let+ statess = reverse $ take turns $ tails states+ mvss = reverse $ take (pred turns) tailsMoves+ pnp = pred numP+ (b,qs) = checkMvs numP (length mvss) statess mvss ps -- !!! Exactly speaking, ps should be rotated when @length mvss /= pred turns@ !!!!!!!!!+ in b $ return (states, take pnp qs)+checkMvs :: (Strategy s Identity) => Int -> Int -> [[State]] -> [[Move]] -> [s] -> (Matrix a -> Matrix a, [s])+checkMvs _ 0 _ _ qs = (id, qs)+checkMvs numP n (sts:stss) (ms:mss) (p:ps)+ | n `mod` numP == 0 || null ms = checkMvs numP (pred n) stss mss (p:ps) -- skip the check if it is in the player's own turn, or it is the first turn.+ | otherwise = let+ (mv,q) = runIdentity $ move (viewStates sts) (tail ms) p+ (restb, rest) = checkMvs numP (pred n) stss mss $ ps ++ [q]+ delayer | mv == (head ms) = id+ | otherwise = delay+ in (delayer . restb, rest) -- Once mv /= head ms, the remaining part would not be computed.
+ Game/Hanabi/Strategies/AppendDSL.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, RecordWildCards, CPP #-}+module Game.Hanabi.Strategies.AppendDSL where+import Game.Hanabi hiding (main)+import System.Random+import Data.List(sortOn, tails)+import Data.Maybe(fromJust)+import Data.Bits+import Control.Monad(liftM2, mplus, mzero)+import Data.Functor.Identity+import Data.Array(bounds)++import Game.Hanabi.Strategies.SimpleStrategy(Simple(S))+import Game.Hanabi.Strategies.StatefulStrategy+import Game.Hanabi.Strategies.AdaptiveLMC+import MagicHaskeller+import MagicHaskeller.ProgGenSF(mkTrieOptSFIO)+import MagicHaskeller.ProgramGenerator hiding (tails)+import MagicHaskeller.MyCheck++-- import GHC.Conc(numCapabilities)+import System.IO(stderr, hPutStrLn)+import Control.Concurrent(rtsSupportsBoundThreads, getNumCapabilities, setNumCapabilities)+-- import Game.Hanabi.FFI(getHardwareConcurrency)++data BigTable = BT { markUnhintedCritical :: Maybe Move,+ keep21 :: Maybe Move,+ colorMarkUnmarkedPlayable :: Maybe Move -- ^ Mark the color of a (not obviously) playable card+ -- if it is not marked yet+ -- but be cautious not to color-mark newer cards.+ -- refrain marking if I have a playable card with the same color+ , colorMarkNumberMarkedPlayable :: Maybe Move -- ^ Mark the color if a (not obviously) playable card is only rank-marked,+ -- but refrain marking if I have a playable card with the same color+ , colorMarkPlayable5 :: Maybe Move,+ removeDuplicate :: Maybe Move,+ numberMarkPlayable :: Maybe Move -- ^ Mark the rank if a (not obviously) playable card is not rank-marked,+ -- but refrain marking if I have a playable card with the same color.+ , numberMarkPlayable5 :: Maybe Move,++ numberMarkUselessIfInformative :: Maybe Move,+ numberMarkUncriticalIfInformative :: Maybe Move,+ colorMarkUselessIfInformative :: Maybe Move,+ colorMarkUncriticalIfInformative :: Maybe Move,++ numberMarkUnmarked :: Maybe Move,+ numberMarkNumberUnmarked :: Maybe Move,+ colorMarkColorUnmarked :: Maybe Move,+ pass :: Maybe Move,+ hailMary :: Maybe Move,+ playPlayable :: Maybe Move -- ^ Play a playable card. Prioritize those that are not publicly playable.+ , playPlayable5 :: Maybe Move,+ dropUselessCard :: Maybe Move,+ dropSafe :: Maybe Move,+ dropPossiblyUncritical :: Maybe Move,+ makePositionalDrop :: Maybe Move,+ dropChopUnlessDoubleDrop :: Maybe Move,+ noDeck :: Bool,+ spareDeck :: Bool,+ enoughDeck :: Bool,+ livesBT :: Int,+ hintsBT :: Int+ }++bt = $(p [| (markUnhintedCritical :: BigTable -> Maybe Move,+ keep21 :: BigTable -> Maybe Move,+ colorMarkUnmarkedPlayable :: BigTable -> Maybe Move+ , colorMarkNumberMarkedPlayable :: BigTable -> Maybe Move+ , colorMarkPlayable5 :: BigTable -> Maybe Move,+ removeDuplicate :: BigTable -> Maybe Move,+ numberMarkPlayable :: BigTable -> Maybe Move+ , numberMarkPlayable5 :: BigTable -> Maybe Move,+ numberMarkUselessIfInformative :: BigTable -> Maybe Move,+ numberMarkUncriticalIfInformative :: BigTable -> Maybe Move,+ colorMarkUselessIfInformative :: BigTable -> Maybe Move,+ colorMarkUncriticalIfInformative :: BigTable -> Maybe Move,++ numberMarkUnmarked :: BigTable -> Maybe Move,+ numberMarkNumberUnmarked :: BigTable -> Maybe Move,+ colorMarkColorUnmarked :: BigTable -> Maybe Move,+ pass :: BigTable -> Maybe Move,+ hailMary :: BigTable -> Maybe Move,+ playPlayable :: BigTable -> Maybe Move+ , playPlayable5 :: BigTable -> Maybe Move,+ dropUselessCard :: BigTable -> Maybe Move,+ dropSafe :: BigTable -> Maybe Move,+ dropPossiblyUncritical :: BigTable -> Maybe Move,+ makePositionalDrop :: BigTable -> Maybe Move,+ dropChopUnlessDoubleDrop :: BigTable -> Maybe Move,+ noDeck :: BigTable -> Bool,+ spareDeck :: BigTable -> Bool,+ enoughDeck :: BigTable -> Bool,+ livesBT :: BigTable -> Int,+ hintsBT :: BigTable -> Int+ ) |])+++prepare :: [PrivateView] -> [Move] -> BigTable+prepare (pv:pvs) mvs = let+ pub = publicView pv+ nextPlayersHand = head $ handsPV pv ::[Card]+ nextPlayersAnns = annotations pub !! 1+ nextPlayer = zip3 [0..] nextPlayersHand nextPlayersAnns+ myAnns = head $ annotations pub+ myHand = zip [0..] myAnns+ numHand = length myAnns+ colorHint pl = Hint pl . Left . color+ rankHint pl = Hint pl . Right . rank+ isMarked = isHinted . marks+ isUnmarked = not . isMarked+ nextPlayersUnmarked = filter (isUnmarked . getAnn) nextPlayer+ getAnn (_,_,ann) = ann+ getCard (_,c,_) = c+ nitchimo anns = length (filter (\ann -> isMarked ann && not (isObviouslyUncritical pub (possibilities ann) || isObviouslyPlayable pub (possibilities ann))) anns)+ isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ])+ || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just _)}) <- nextPlayer, color c == col ]+ isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer.+ markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new.+ lenUnhintedNon2 = length [ t | t@(_, c@(C _ n), _) <- nextPlayersUnmarked, n/=K2 || isUseless pub c ]+ havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ]+ numberMarkIfInformative cond = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _,Nothing),possibilities=p}) <- nextPlayer, not $ cond pub p, cond pub (p .&. rankToQit (rank d)) ]+ colorMarkIfInformative cond = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing,Just _),possibilities=p}) <- reverse nextPlayer, not $ cond pub p, cond pub (p .&. colorToQit (color d)),+ isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.+ sndlastUnusualChop = drop 1 $ concat $ map reverse $ obviousChopss sndlastpub sndlastAnns+ lastpub = publicView (head pvs)+ lastAnns = last (annotations lastpub)+ sndlastpub = publicView (head $ tail pvs)+ sndlastAnns = last $ init (annotations sndlastpub)+ + dropChop = [ Drop i | i:_ <- definiteChopss pv myAnns ]++ current = currentScore pub+ achievable = seeminglyAchievableScore pub+ continue = prolong (Game.Hanabi.rule $ gameSpec pub)++ mr xs = mkRule pv xs Nothing+ in BT {+ markUnhintedCritical = mr [ if isColorMarkable (color te) then colorHint 1 te else rankHint 1 te | (_ix, te, _) <- reverse nextPlayersUnmarked, isCritical pub te ],+ keep21 = mr [ rankHint 1 te | (_ix, te@(C c k), _) <- reverse nextPlayersUnmarked, k <= K2, keptCards pub te <= 2, not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ],+ colorMarkUnmarkedPlayable = mr [ colorHint 1 d | (i,d,ann) <- markCandidates, -- Mark the color ff a (not obviously) playable card+ isUnmarked ann, -- if it is not marked yet+ isNewestOfColor i d, -- but be cautious not to color-mark newer cards.+ not $ havePlayableCardWithTheSameColor $ color d ], -- refrain marking if I have a playable card with the same color+ colorMarkNumberMarkedPlayable = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked.+ not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color+ ],+ colorMarkPlayable5 = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just K5)}) <- markCandidates ],+ removeDuplicate = mr [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- reverse myHand ],+ m `elem` [ m' | (_, Ann{marks=m'}) <- xs ]+ ],+ numberMarkPlayable = mr [ rankHint 1 d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked.+ not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color+ ],+ numberMarkPlayable5 = mr [ Hint 1 $ Right K5 | (_, C _ K5, Ann{marks=(_, Nothing)}) <- markCandidates ],++ numberMarkUselessIfInformative = numberMarkIfInformative isObviouslyUseless,+ numberMarkUncriticalIfInformative = numberMarkIfInformative isObviouslyUncritical,+ colorMarkUselessIfInformative = colorMarkIfInformative isObviouslyUseless,+ colorMarkUncriticalIfInformative = colorMarkIfInformative isObviouslyUncritical,++ numberMarkUnmarked = mr [ rankHint 1 d | (_,d,_) <- nextPlayersUnmarked, not $ isUseless pub d ],+ numberMarkNumberUnmarked = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ],+ colorMarkColorUnmarked = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p,+ isNewestOfColor i d ], -- but be cautious not to color-mark newer cards.+ pass = case span (\(_,_,ann) -> isMarked ann) nextPlayer of (tk,dr) -> mr $ [ rankHint 1 d | (_,d,_) <- tk, rank d `notElem` [ rank c | (_,c,_) <- dr ] ]+ ++ [ colorHint 1 d | (_,d,_) <- tk, color d `notElem` [ color c | (_,c,_) <- dr ] ],+++ hailMary = mr $ case filter (not . isDefinitelyUnplayable pv . snd) myHand of ts -> map (Play . fst) ts,+++ playPlayable = mr $ case span (isObviouslyPlayable pub . possibilities . snd) $ filter (isDefinitelyPlayable pv . snd) myHand of (ob,nob) -> map (Play . fst) $ nob++ob, -- Play a playable card. Prioritize those that are not publicly playable.+ playPlayable5 = mr [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ],+ dropUselessCard = mr [ Drop i | (i,ann@Ann{possibilities=p}) <- reverse myHand, isDefinitelyUseless pv ann && isMarked ann || isObviouslyUseless pub p ],+ dropSafe = mr [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ],+ dropPossiblyUncritical = mr [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ],++ makePositionalDrop = let+ chops = concat $ map reverse $ obviousChopss pub myAnns+ hints = hintTokens pub+ discarded (Discard _) = True+ discarded (Fail _) = True+ discarded _ = False+ in case mvs of -- This assumes the last teammate marks a critical card if there is.+ Hint _ (Right _) : _ -> Nothing -- refrain if the last move was rank-mark in order to avoid dropping a critical card. This condition can be relaxed.+-- Drop i : _ | not $ isDefinitelyUseless (head pvs) $ lastAnns !! i -> id -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.+ mv : _ | discarded (result pub) && not (isDefinitelyUseless pv $ lastAnns !! index mv) -> Nothing -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.+ _ : Drop i : _ | i `elem` sndlastUnusualChop -> Nothing -- avoid consecutive positional drop. This condition can be relaxed.+ _ | hints >= 2 && hints <= 6 && turn pub >= 7 && not (null chops)+ -> mr [Drop i | ( (i,card,Ann{possibilities=p}), mann) <- zip nextPlayer myAnns,+ isUnmarked mann, not (isDefinitelyCritical pv mann || isDefinitelyPlayable pv mann),+ head chops /= i, isPlayable pub card, not $ isObviouslyPlayable pub p]+ | otherwise -> Nothing,++ dropChopUnlessDoubleDrop = case mvs of+ _ : Drop i : _ | i `elem` sndlastUnusualChop -> Nothing -- avoid dropping after positional drop. This condition can be relaxed.+ _ -> mr [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ],++ noDeck = not (continue || 0 < pileNum pub),+ spareDeck = continue || achievable - current < pileNum pub + 2,+ enoughDeck = continue || achievable - current < pileNum pub,+ livesBT = lives pub,+ hintsBT = hintTokens pub+ }+iF :: Bool -> a -> a -> a+iF a b c = if a then b else c+other = $(p [|(iF :: (->) Bool (Maybe Move -> Maybe Move -> Maybe Move),+ mplus :: Maybe Move -> Maybe Move -> Maybe Move,+ 0::Int,1::Int,2::Int,3::Int,4::Int,5::Int,6::Int,7::Int,8::Int, (<=) :: Int->Int->Bool+-- , hintTokens :: PublicInfo -> Int+-- , lives :: PublicInfo -> Int+ )|])++wrap :: (BigTable -> Maybe Move) -> [PrivateView] -> [Move] -> Move+wrap = \fun pvs@(pv:_) mvs -> fromJust $ fun (prepare pvs mvs) `mplus` mkRule pv ([Hint 1 $ Right n | n <- [K1 .. K5]] ++ [ Drop i | i <- [4,3..0] ] ++ [Play 0]) Nothing+-- wrapper = $(p [| wrapper :: (BigTable -> Maybe Move -> Maybe Move) -> [PrivateView] -> [Move] -> Move |])++++instinct = (bt ++ other -- ++ $(p [| (,) :: Int -> (BigTable -> Maybe Move -> Maybe Move) -> (Int, BigTable -> Maybe Move -> Maybe Move)|])+ ) : replicate 94 []++{-+common :: Common+common = initCommon options{tv1=True,nrands=repeat 20,MagicHaskeller.LibTH.timeout=Just 20000} $ concat instinct+instinctDyn = map (map (primitiveToDynamic $ tcl common)) instinct+-}+++-- mkPgInstinct :: IO ProgGen+-- mkPgInstinct = mkPGXOptIO options{tv1=False,nrands=repeat 20,timeout=Just 20000} [] [] instinct []++mkPgInst :: (RandomGen g, Strategies ps Identity) =>+ [[Primitive]] -> GameSpec -> ps -> g -> IO ProgGenSF+mkPgInst inst gs ps g = mkPGXOptsExt (\tcl -> [("Move", $(dynamic [|tcl|] [| compare :: Move -> Move -> Ordering |]))] : repeat [])+ (\tcl -> [("Move", $(dynamic [|tcl|] [| arbitraryMove gs :: Gen Move |])),+ ("BigTable", $(dynamic [|tcl|] [| arbitraryBTs :: Gen BigTable |]))+ ] : repeat [])+ (\tcl -> [("Move", $(dynamic [|tcl|] [| coarbitraryMove :: Move -> Gen x -> Gen x |]))] : repeat [])+ mkTrieOptSFIO options{tv0=True,nrands=repeat 20,timeout=Nothing} [] [] inst []+ where arbitraryBTs = Gen $ \s gen -> case randomR (0,s*50) gen of (i,_) -> shuffledBTss !! i+ (g1,g2) = split g+ btss = runIdentity $ generateBTss gs ps g1+ shuffledBTss = shuffleEvery50Games g2 btss++arbitraryMove :: GameSpec -> Gen Move+arbitraryMove gs@GS{numPlayers=np, rule=rl} = do+ b <- arbitraryR (0,2)+ case b::Int of 0 -> fmap Drop $ arbitraryR (0, pred $ funPlayerHand rl !! (np + 2))+ 1 -> fmap Play $ arbitraryR (0,4)+ 2 -> liftM2 Hint (arbitraryR (1, pred np)) (arbitraryEither (fmap toEnum $ arbitraryR (0, pred $ numColors rl)) (fmap toEnum $ arbitraryR (1,5)))++coarbitraryMove :: Coarb Move b+coarbitraryMove (Drop i) = coarbitraryBool True . coarbitraryBool True . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2)+coarbitraryMove (Play i) = coarbitraryBool True . coarbitraryBool False . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2)+coarbitraryMove (Hint p (Left c)) = coarbitraryBool False . coarbitraryBool True . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) where i = fromEnum c+coarbitraryMove (Hint p (Right r)) = coarbitraryBool False . coarbitraryBool False . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) where i = fromEnum r++-- This is written for general monads, but since the generated [BigTable] is infinite, the monad should be Identity or IO through unsafeInterleaveIO or so.+generateBTss :: (RandomGen g, Monad m, Strategies ps m) =>+ GameSpec -> ps -> g -> m [[BigTable]]+generateBTss gs ps gen = do (((_, sts, mvs), qs), g) <- start gs [] ps gen+ btss <- generateBTss gs qs g+ return $ zipWith prepare (tails $ viewStates sts) (tails mvs) : btss+shuffleEvery50Games :: RandomGen g =>+ g -> [[BigTable]] -> [BigTable]+shuffleEvery50Games g0 xss = case splitAt 50 xss of (tk,dr) -> case shuffle (concat tk) g0 of (bts,g1) -> bts ++ shuffleEvery50Games g1 dr++#ifdef DEBUG+data Sless = Sl String ([PrivateView] -> [Move] -> Move)+instance Monad m => Strategy Sless m where+ strategyName m = m >>= \ (Sl name _) -> return $ "Stateless " ++ name+ move pvs mvs sl@(Sl n f) = return (f pvs mvs, sl)+#else+data Sless = Sl ([PrivateView] -> [Move] -> Move)+instance Monad m => Strategy Sless m where+ strategyName ms = return "Stateless strategy"+ move pvs mvs sl@(Sl f) = return (f pvs mvs, sl)+#endif++-- example simple strategy that can be used for debugging+simpleSl :: Sless+simpleSl = Sl+#ifdef DEBUG+ "simple"+#endif+ $ wrap $ \bt -> markUnhintedCritical bt `mplus` colorMarkUnmarkedPlayable bt `mplus` playPlayable bt `mplus` dropUselessCard bt `mplus` dropChopUnlessDoubleDrop bt `mplus` dropSafe bt++testSl :: Sless+testSl = Sl+#ifdef DEBUG+ "simple"+#endif+ $ wrap $ \bt -> markUnhintedCritical bt `mplus` playPlayable bt `mplus` dropChopUnlessDoubleDrop bt++simpleInstinct :: [[Primitive]]+simpleInstinct = $(p [| (mplus :: Maybe Move -> Maybe Move -> Maybe Move,+ markUnhintedCritical :: BigTable -> Maybe Move,+ colorMarkUnmarkedPlayable :: BigTable -> Maybe Move,+ playPlayable :: BigTable -> Maybe Move,+ dropUselessCard :: BigTable -> Maybe Move,+ dropChopUnlessDoubleDrop :: BigTable -> Maybe Move,+ dropSafe :: BigTable -> Maybe Move+ ) |]) : replicate 94 []+verySimpleInstinct :: [[Primitive]]+verySimpleInstinct = $(p [| (\bt -> markUnhintedCritical bt `mplus` colorMarkUnmarkedPlayable bt `mplus` playPlayable bt `mplus` dropUselessCard bt `mplus` dropChopUnlessDoubleDrop bt `mplus` dropSafe bt) :: BigTable -> Maybe Move |]) : replicate 94 []++data MHLimit = Infinite -- ^ no limit+ | Depth Int -- ^ bound by the depth. Safe option when the cardinality of the set of possible programs is unknown.+ | MaxNumProgs Int -- ^ bound by the number of programs. Maybe good for incremental learning.+ | ProgsPerDepth Int -- ^ (just for backward compatibility)+ deriving (Eq, Show, Read)+data ParamsADSL = PADSL { paramsALMC :: ParamsALMC+ , probToStay :: Double+ , mhLimit :: MHLimit+ } deriving (Eq, Show, Read)+mkAdaptiveLMC :: RandomGen g =>+ ParamsADSL -> [[Primitive]] -> g -> IO (AdaptiveLMC g (Stateful Sless))+mkAdaptiveLMC PADSL{..} inst gen = do+ numC <- getNumCapabilities +-- hPutStrLn stderr $ "rtsSupportsBoundThreads = "++shows rtsSupportsBoundThreads ", and current numCapabilities = " ++ show numC+ newNumC <- if rtsSupportsBoundThreads then do+ nnc <- if numCap paramsALMC > 0 then return $ numCap paramsALMC else+ return numC -- if numC > 1 then return numC else fmap (\c -> succ c `div` 2) getHardwareConcurrency -- If it is set to more than 1, respect it. Otherwise, ceiling (hardwareConcurrency/2) may be a good default. + setNumCapabilities nnc+ return nnc+ else return 1 -- GHCJS fails when setNumCapabilities is executed.+ let (g1,g2) = split gen+ pg <- mkPgInst inst defaultGS [sfs $ S True] g1+ let progss = everythingF pg False :: Every (BigTable -> Maybe Move) -- = [[(TH.Exp, (Int, BigTable -> Maybe Move))]]++-- let genStrss = map (\progs -> [ (e, SF {guessColorToPlay = testBit n 0, guessPositionalDrop = testBit n 1, baseStrategy = Sl f, []}) | (e,(n,f)) <- progs, n<4 ]) progss :: [[(TH.Exp, Stateful Sless)]]+ let genStrss = map (\progs -> [ SF {guessColorToPlay = c, guessPositionalDrop = p,+#ifdef DEBUG+ baseStrategy = Sl (pprint e) $ wrap f,+#else+ baseStrategy = Sl $ wrap f,+#endif+ anns=[]} | (e,f) <- progs, c<-[False,True], p <- [False,True] ]) progss :: [[Stateful Sless]]++ let suggested = sfs $ Sl+#ifdef DEBUG+ "suggested"+#endif+ $ \ps ms -> fst $ runIdentity $ move ps ms $ S True++ let dropped = dropWhile null genStrss+ strMx = case mhLimit of+ Infinite -> dropped+ Depth d -> filter (not.null) $ take d dropped+ MaxNumProgs mnp -> filter (not.null) $ take (length $ takeWhilePlus (<mnp) $ scanl1 (+) $ map length dropped) dropped+ ProgsPerDepth ppd -> filter (not.null) $ takeWhilePlus ((<ppd) . length) dropped+ let probs = mkProbs $ iterate (*(1-probToStay)) probToStay+-- #ifdef DEBUG+-- hPrint stderr $ "length strPool = " ++ show (length strPool)+-- #endif+ return $ LMC { parameters=paramsALMC{numCap=newNumC}+ , rngLMC=g2+ , rolloutStrategyLMC = suggested+ , rolloutStrategiesLMC = repeat $ mkMx strMx+ , priors = repeat probs+ , consistentSampleFullStatesLMC=mzero+ , lastTurn = -1+ , ready = null (last strMx) `seq` True}++takeWhilePlus pred xs = case span pred xs of (tk, dr) -> tk ++ foldr (\d _->[d]) [] dr
+ Game/Hanabi/Strategies/EndGameLite.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Game.Hanabi.Strategies.EndGameLite(EndGameLite(..), egl, EndGameMirrorLite(..), egml, tryAMoveARound) where+import Game.Hanabi+import qualified Data.Map as M+import Data.List(maximumBy, delete)+import Data.Function(on)++type Probability = Integer++-- | 'EndGameMirrorLite' assumes that other players think in the same way as itself during endgame.+data EndGameMirrorLite sp p = EGML (EndGameLite sp p [EndGameMirrorLite sp p])+egml :: (PublicInfo -> Bool) -- ^ from when to start the endgame search+ -> sp -- ^ the recommended strategy used at endgame, in order to prioritize endgame search. This strategy is supposed to be lightweight.+ -> p -- ^ the default strategy used until endgame+ -> Int -- ^ number of players, including the resulting player+ -> EndGameMirrorLite sp p+egml from sp p nump = egmo where egmo = EGML (egl from sp p $ replicate (pred nump) egmo)++instance (Monad m, Strategy sp m, Strategy p m) => Strategy (EndGameMirrorLite sp p) m where+ strategyName ms = return "EndGameMirrorLite"+ move pvs mvs (EGML egs) = do (m, egs') <- move pvs mvs egs+ return (m, EGML egs')++egl f sp p ps = EGL f sp p ps M.empty++-- | @'EGL' f sp p ps memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when @f@ returns True.+-- The strategy @sp@ suggests a desired move in order to prioritize a promising strategy.+data EndGameLite sp p ps = EGL {fromWhenL::PublicInfo->Bool, suggestedStrategyL::sp, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Probability)])}+type Key = (Maybe Card, [Marks], [Move], [Card])++instance (Monad m, Strategy sp m, Strategy p m, Strategies ps m) => Strategy (EndGameLite sp p ps) m where+ strategyName ms = return "EndGameLite"+ move pvs mvs str@(EGL f sp p ps memory)+ | f pub && not (null statess) = do -- null statess means that there is a contradiction. This can happen when using a PrivateView based on wrong assumption, such as using sontakuColorHint for preprocessing and actually the team mate is not exactly Stateless.+ (_i, (mp,m)) <- endGameMoveLite statess pvs' mvs sp+ return (m, EGL f sp p ps mp)+ | otherwise = do (m,_) <- move pvs mvs p+ return (m,str)+ where statess = case M.lookup (resToMbC $ result $ publicView $ pvs !! pred numP, map marks $ head $ annotations pub, take (pred numP) mvs, map headC $ handsPV hdpv) memory of+ Just (_,tups) -> tups+ Nothing -> [ (stateToStateHistory (map publicView tlpvs) mvs state, ps, fromIntegral n) | (state, n) <- possibleStates hdpv ]+ pvs'@(hdpv:tlpvs) = [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]+ pub = publicView hdpv+ numP = numPlayers $ gameSpec pub+endGameMoveLite :: (Monad m, Strategies ps m, Strategy p m) =>+ [([State],ps,Probability)] -- ^ possible pairs of the state history and the internal memory states of other players' strategies+ -> [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+ -> p -- ^ default (recommended) strategy+ -> m (Probability, (M.Map Key ([Move], [([State],ps,Probability)]), Move))+endGameMoveLite statess pvs@(pv:_) mvs p = do+ (defaultMove, q) <- move pvs mvs p+ let candidateMoves = defaultMove : delete defaultMove (effectiveMoves pv)+ tups <- mapM (evalMoveLite statess mvs q) candidateMoves+ let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves+ pub = publicView pv+ achievable = sum [ n | (_,_,n) <- statess ] * fromIntegral (moreStrictlyAchievableScore pub)+ -- ToDo: Also consider critical cards at the bottom deck.+ return $ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc+ Just k -> (achievable, k) -- Stop search when the best possible score is found.++evalMoveLite :: (Monad m, Strategies ps m, Strategy p m) => [([State], ps, Probability)] -> [Move] -> p -> Move -> m ( M.Map Key ([Move], [([State],ps,Probability)]) , Probability )+evalMoveLite statess@((st:_,_,_):_) mvs p mov = do+ roundResults <- fmap concat $ mapM (\sts ->tryAMoveARound sts mvs mov) statess+ let pub = publicState st+ instantScore = sum [ egToNum s eg * n | ((Just eg, s:_, _), _, n) <- roundResults ]+ roundResultMap = groupARound pub roundResults+ if M.null roundResultMap then return (roundResultMap, instantScore) else do+ let roundResults = M.elems roundResultMap+ scores <- sequence [ fmap fst $ endGameMoveLite stss (viewStates sts) moves p | (moves, stss@((sts,_,_):_)) <- roundResults, not $ null stss ]+ return (roundResultMap, instantScore + sum scores)+evalMoveLite [] _ _ _ = error "evalMoveLite []" -- This should not happen, because evalMoveLite is only called by endGameMoveLite, and @null statess@ is checked before every call of @endGameMoveLite statess@.++groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Probability)] -> M.Map Key ([Move], [([State],ps,Probability)]) -- ToDo: IntMap could be used instead.+groupARound pub results = fmap procTip $ M.fromListWith (++) [ ( ( resToMbC $ result $ publicState $ stats !! pred numP,+ map marks $ head $ annotations $ publicState st,+ take (pred numP) movs,+ map headC $ tail $ hands st ),+ [r])+ | r@((Nothing, stats@(st:_), movs), _, _) <- results ] where+ procTip :: [((Maybe EndGame, [State],[Move]),ps,Probability)] -> ([Move], [([State],ps,Probability)])+ procTip ts@(((_noth, _, mv), _, _) : _) = (mv, [ (stats, ps, n) | ((_nothing, stats, _), ps, n) <- ts ])+ numP = numPlayers $ gameSpec pub+-- total version of head, just in case of dealing with empty hand.+headC :: [Card] -> Card+headC = foldr const $ C Multicolor Empty+++resToMbC :: Result -> Maybe Card+resToMbC None = Nothing+resToMbC r = Just $ revealed r++-- does not work for stateful monads including IO.+tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Probability) -> [Move] -> Move -> m [((Maybe EndGame, [State], [Move]),ps,Probability)]+tryAMoveARound (states@(state:_),strs,n) mvs mov = let sts = proceeds state mov+ pilen = pileNum $ publicState state+ numCases = case sts of -- [] -> error $ show mov ++ ": invalid move!" -- We should just silently ignore errorful strategy programs+ sts@[st] | pilen>0 -> n * fromIntegral pilen -- The condition pilen>0 is necessary because even when pileNum == 0 there is one valid case.+ sts -> n+ in sequence $ do st <- sts+ let nxt = rotate 1 st+ return $ case checkEndGame $ publicState nxt of+ Nothing -> fmap (\(e,p) -> (e,p,numCases)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs+ Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, numCases)+{-+tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m ((Maybe EndGame, [State], [Move]),ps,Int)+tryAMoveARound (states@(st:_),strs,n) mvs mov = case proceed st mov of+ Nothing -> error $ show mov ++ ": invalid move!"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> fmap (\(e,p) -> (e,p,n)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs+ Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, n)+-}
+ Game/Hanabi/Strategies/EndGameOld.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Game.Hanabi.Strategies.EndGameOld(endGameMoveOld, EndGameOld(..), EndGameMirrorOld(..), egmo) where+import Game.Hanabi+import Data.List(maximumBy, delete)+import Data.Function(on)++-- | @'EGS' f p ps@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when the deck size is @f@ or below @f@.+-- @move pvs mvs (EGO f p ps)@ may cause an error if @p@ can choose an invalid move.+data EndGameOld p ps = EGO {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps}++instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameOld p ps) m where+ strategyName ms = return "EndGameOld"+ move pvs@(pv:_) mvs str@(EGO f p ps) | f (publicView pv) = do (defaultMove, _) <- move pvs mvs p+ m <- endGameMoveOld pvs mvs (ps, [EGO f p ps]) $ defaultMove : delete defaultMove (effectiveMoves pv)+ return (m,str)+ | otherwise = do (m,_) <- move pvs mvs p+ return (m,str)++-- | 'EndGameMirrorStrategy' assumes that other players think in the same way as itself during endgame.+-- @move pvs mvs (EGMO (EGO f p ps))@ may cause an error if @p@ can choose an invalid move.+data EndGameMirrorOld p = EGMO (EndGameOld p [EndGameMirrorOld p])+egmo :: (PublicInfo -> Bool) -- ^ from when to start the endgame search+ -> p -- ^ the default strategy used until endgame+ -> Int -- ^ number of players, including the resulting player+ -> EndGameMirrorOld p+egmo from p nump = egmo where egmo = EGMO (EGO from p $ replicate (pred nump) egmo)++instance (Monad m, Strategy p m) => Strategy (EndGameMirrorOld p) m where+ strategyName ms = return "EndGameMirrorOld"+ move pvs mvs (EGMO egs) = do (m, egs') <- move pvs mvs egs+ return (m, EGMO egs')++endGameMoveOld :: (Monad m, Strategies ps m) =>+ [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+ -> ps+ -> [Move] -- ^ move candidates. More promising moves appear earlier.+ -> m Move+endGameMoveOld pvs@(pv:tlpvs) mvs ps candidates = do+ let states = possibleStates pv+ scores <- mapM (evalMove states (map publicView tlpvs) mvs ps) candidates+ let asc = zip scores candidates+ pub = publicView pv+ achievable = moreStrictlyAchievableScore pub+ -- ToDo: Also consider critical cards at the bottom deck.+ return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc+ Just k -> k -- Stop search when the best possible score is found.+evalMove :: (Monad m, Strategies ps m) => [(State, Int)] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int+evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\(((eg,st:_,_),_),n) -> n * egToInt st eg)) $ mapM (\(st,n) -> fmap (\a->(a,n)) $ tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states++-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.+tryAMove :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> Move -> m ((EndGame, [State], [Move]),ps)+tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move!"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs+ Just eg -> return ((eg, nxt:states, mov:mvs), strs)
Game/Hanabi/Strategies/EndGameSearch.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, CPP #-} module Game.Hanabi.Strategies.EndGameSearch where import Game.Hanabi hiding (main)+import Game.Hanabi.Strategies.EndGameLite+import Game.Hanabi.Strategies.EndGameOld import Game.Hanabi.Strategies.Stateless hiding (main) import Game.Hanabi.Strategies.SimpleStrategy hiding (main) import System.Random@@ -10,27 +12,27 @@ -- A strategy with endgame search #ifdef EXACT-data EndGameSearch = EG | EGS (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless]))-mkEG :: Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless])+data EndGameSearch = EG Stateless | EGS Stateless (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless]))+mkEG :: Stateless -> Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless]) #else-data EndGameSearch = EG | EGS (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless]))-mkEG :: Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless])+data EndGameSearch = EG Stateless | EGS Stateless (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless]))+mkEG :: Stateless -> Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless]) #endif-mkEG nump =+mkEG fb nump = -- assumeOthersAre SL SL -- searchExhaustivelyLite SL #ifdef EXACT- searchExhaustivelyLite $ assumeOthers SL $ searchExhaustivelyLite SL -- This is more exact, but sometimes prohibitively time-consuming.+ searchExhaustivelyLite $ assumeOthers fb $ searchExhaustivelyLite fb -- This is more exact, but sometimes prohibitively time-consuming. #else- searchExhaustivelyLite $ assumeOthers SL SL+ searchExhaustivelyLite $ assumeOthers fb $ SL $ S False #endif -- searchExhaustively SL -- assumeOthersAreSL SL -- searchExhaustively $ assumeOthersAreSL SL where searchExhaustivelyLite :: s -> EndGameMirrorLite Stateless s- searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) SL fallback nump- assumeOthers fallback other = egl (\pub -> pileNum pub <= 1) SL fallback $ replicate (pred nump) other+ searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) (SL $ S False) fallback nump+ assumeOthers fallback other = egl (\pub -> pileNum pub <= 1) (SL $ S False) fallback $ replicate (pred nump) other searchExhaustively fallback = egmo (\pub -> pileNum pub == 0) fallback nump assumeOthersAreSL fallback = EGO (\pub -> pileNum pub <= 1 && hintTokens pub <= 2) fallback $ replicate (pred nump) SL -- assumeOthersAreSL fallback = EGO (\pub -> pileNum pub <=2 && hintTokens pub <= 4) fallback $ replicate (pred nump) SL@@ -38,11 +40,11 @@ instance (Monad m) => Strategy EndGameSearch m where strategyName ms = return "EndGame"- move pvs@(pv:_) mvs EG = do (m, e') <- move (sontakuColorHint pvs mvs) mvs $ mkEG $ numPlayers $ gameSpec $ publicView pv- return (m, EGS e')- move pvs@(pv:_) mvs (EGS e) = do (m, e') <- move (sontakuColorHint pvs mvs) mvs e- return (m, if pileNum (publicView pv) > 1 then EG else EGS e')+ move pvs@(pv:_) mvs (EG pd) = do (m, e') <- move (sontakuColorHint pvs mvs) mvs $ mkEG pd $ numPlayers $ gameSpec $ publicView pv+ return (m, EGS pd e')+ move pvs@(pv:_) mvs (EGS pd e) = do (m, e') <- move (sontakuColorHint pvs mvs) mvs e+ return (m, if pileNum (publicView pv) > 1 then EG pd else EGS pd e') main = do g <- newStdGen- ((eg,_),_) <- start defaultGS [] ([EG], [stdio]) g -- Play it with standard I/O (human player).--- ((eg,_),_) <- start defaultGS [peek] [EG, EG] g -- Play it with itself.+ ((eg,_),_) <- start defaultGS [] ([EG $ SL $ S False], [stdio]) g -- Play it with standard I/O (human player).+-- ((eg,_),_) <- start defaultGS [peek] [EG False, EG False] g -- Play it with itself. putStrLn $ prettyEndGame eg
+ Game/Hanabi/Strategies/LazyMC.hs view
@@ -0,0 +1,363 @@+-- The old LazyMC.hs is moved to NaiveLazyMC.hs. Also note that LazyMC.LotsOfComments was for NaiveLazyMC.hs+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, RankNTypes, TupleSections, FlexibleContexts #-}++module Game.Hanabi.Strategies.LazyMC(LazyMC(..), lmcs, glmcs, flatlmcs, Priority(..), mkPool) where+import System.Random+import Control.Monad(MonadPlus(..))+import Data.Functor.Identity+#ifdef TEST+import Test.QuickCheck hiding (shuffle, (.&.))+import Data.List(partition, maximumBy, delete, tails, permutations, transpose, sort)+#else+import Data.List(partition, maximumBy, delete, tails, permutations, transpose)+#endif+import Data.Bits hiding (rotate)+import Data.Function(on)+import Data.Array hiding (index)+import Data.Maybe(isNothing, isJust, fromJust, maybeToList)+import qualified Data.IntMap as IM+import Game.Hanabi++-- only used by the fallback.+import Game.Hanabi.Strategies.EndGameSearch+import Game.Hanabi.Strategies.EndGameLite(egml, egl, EndGameMirrorLite(..), EndGameLite(..))+import Game.Hanabi.Strategies.Stateless++#ifdef DEBUG+import Debug.Trace+#else+trace _ = id+#endif++-- type FullState s = ([State], [s])+-- type BeliefState s = [(FullState s, Probability)]++-- mkPool is a function that helps the user to create the pool of strategies based on the list of lists of strategies that are annotated with the probability with which each list of strategies is selected.+mkPool :: [([s],Double)] -> [(Array Int s, Double)]+mkPool ts = zip [ listArray (1, length ss) ss | (ss,_) <- ts ] ps+ where probs = map snd ts+ _:ps = scanl (-) 1 probs+++samplePairsOfStatesAndStrategies :: (RandomGen g, Strategy s Identity) => Either (Array Int [s]) [[(Array Int s, Double)]] -> [PrivateView] -> [Move] -> g -> [([State],[s])]+samplePairsOfStatesAndStrategies pool pvs mvs gen = case split gen of (g1,g2) -> zip (sampleStatess pvs mvs g1) $ case pool of Left pss -> samplesFromArr pss g2+ Right tss -> sampleStrategiess tss g2++samplesFromArr :: (RandomGen g) => Array Int ss -> g -> [ss]+samplesFromArr arr g = [ arr ! ix | ix <- randomRs (bounds arr) g ]++sampleStrategiess :: (RandomGen g, Strategy s Identity) => [[(Array Int s, Double)]] -> g -> [[s]]+sampleStrategiess tss gen = transpose $ zipWith sampleStrategies tss $ map snd $ iterate (split . fst) $ split gen++-- The Double here is not the probability of selecting the current array but that of going deeper. This decision is for efficiency. So, if the list is finite, it must end with @(some_array,0):[]@+sampleStrategies :: (RandomGen g, Strategy s Identity) => [(Array Int s, Double)] -> g -> [s]+sampleStrategies [] _ = []+sampleStrategies ts gen = let (d,g1) = random gen+ (strs,_) = case dropWhile (\(_,prob) -> d<prob) ts of+ t:_ -> t+ [] -> last ts+ in case randomR (bounds strs) g1 of (i,g2) -> (strs!i) : sampleStrategies ts g2 -- Make sure that @indices strs@ is not null when defining the pool!+++sampleStatess :: RandomGen g => [PrivateView] -> [Move] -> g -> [[State]]+sampleStatess pvs@(pv:tlpvs) moves g = let (s,gen) = sampleState pv g in map (stateToStateHistory (map publicView tlpvs) moves) s ++ sampleStatess pvs moves gen++-- | 'nSampleStatess' is an eager alternative of sampleStatess.+-- 'nSampleStatess' is not desired because n can be very big and most of the samples would not be actually used, but there are RNGs without good split.+-- @take n $ sampleStatess pvs moves g@ should be used instead in most cases.+nSampleStatess :: RandomGen g =>+ Int -- ^ number of samples+ -> [PrivateView] -> [Move] -> g -> ([[State]],g)+nSampleStatess 0 pvs moves g = ([],g)+nSampleStatess n pvs@(pv:tlpvs) moves g = let (s,g') = sampleState pv g+ (ss,gen) = nSampleStatess (pred n) pvs moves g'+ in (map (stateToStateHistory (map publicView tlpvs) moves) s ++ ss, gen)++-- naive alternative+{-+eval :: (Monad m, Strategy s m) => [([State],[s])] -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Int+eval samples run = trace ("entered eval. length samples = " ++ show (length samples)) $+ mapM (\ (sts, ps) -> trace "running" $+ run sts ps) samples >>= \tups -> return $ sum [ egToNum st eg | (eg,st:_,_) <- tups ]+-}+evals :: [([State],[s])] -> ([State]->[s]->(EndGame, [State], [Move])) -> [Int]+evals samples run = [ egToNum st eg | (sts,ps) <- samples, let (eg,st:_,_) = run sts ps ]++evalALittleQuick :: Int -> Int -> Int -> [Int] -> Int+evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar [] = sumSoFar+evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar (score:ss) | newPossibleMargin <= 0 = -1+ | otherwise = evalALittleQuick bestPossibleScore newPossibleMargin newSum ss+ where newSum = score + sumSoFar+ newPossibleMargin = bestPossibleMargin - bestPossibleScore + score++evalQuick :: Int -> Int -> Int -> [Int] -> Int+evalQuick bestPossibleMargin bestPossibleScore sumSoFar [] = sumSoFar+evalQuick bestPossibleMargin bestPossibleScore sumSoFar (score:ss)+ | bestPossibleMargin <= 0 = -1+ | otherwise = evalQuick (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (score + sumSoFar) ss++-- findBestMove finds the best move based on the average score.+findBestMove :: Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> (Int, Move) -> [Move] -> (Int, Move)+findBestMove achievable bestPossibleScore samples run best [] = best+findBestMove achievable bestPossibleScore samples run best@(bestSum, _) (m:ms) = let scores = evals samples $ run m+ sumScore = evalQuick (achievable-bestSum) bestPossibleScore 0 scores+ in findBestMove achievable bestPossibleScore samples run (if sumScore > bestSum then (sumScore, m) else best) ms++evalDecent :: Priority -> Int -> Int -> Int -> Int -> Int -> [Int] -> (Int, Int)+evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar [] = (numBest, sumSoFar)+evalDecent AvoidZero bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (0:ss) = (0, sumSoFar) -- Further computation is not worthy, but there has to be some valid value.+evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (score:ss)+ | bestPossibleNumMargin < 0 || (bestPossibleNumMargin == 0 && bestPossibleMargin <= 0) = (-1, -1)+ | score == bestPossibleScore = evalDecent pri bestPossibleNumMargin (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (succ numBest) (score + sumSoFar) ss+ | otherwise = evalDecent pri (pred bestPossibleNumMargin) (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore numBest (score + sumSoFar) ss++-- findBestMoveDecently is a variant of findBestMove that optimizes ( - <# of failure>, <# of perfect>, <average score>) in the lexicographical order.+findBestMoveDecently :: Priority -> Int -> Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> ((Int,Int), Move) -> [Move] -> ((Int,Int), Move)+findBestMoveDecently pri numSmpls achievable bestPossibleScore samples run best [] = best+findBestMoveDecently pri numSmpls achievable bestPossibleScore samples run best@(bestRes@(bestNum,bestSum), _) (m:ms) = let scores = evals samples $ run m+ sumScore = evalDecent pri (numSmpls-bestNum) (achievable-bestSum) bestPossibleScore 0 0 scores+ in findBestMoveDecently pri numSmpls achievable bestPossibleScore samples run (if sumScore > bestRes then (sumScore, m) else best) ms+++-- In effect, lmcs pri n rr g sp p ps === glmcs pri n rr g sp p [ [([p],1)] | p <- ps ]++flatlmcs pri n rr g sp p pss = glmcs pri n rr g sp p [ [(ps,1)] | ps <- pss ]++glmcs pri n rr g sp p ps = LMC pri n rr g sp p (Right $ map mkPool ps) [] IM.empty [] undefined++lmcs pri n rr g sp p pss = LMC pri n rr g sp p (Left $ listArray (0, pred $ length pss) pss) [] IM.empty [] True+--lmcs pri n rr g sp p ps = LMC pri n rr g sp p (Right [ mkPool [([p],1)] | p <- ps ]) [] -- This should be equivalent to the above.++data LazyMC g sp s = LMC { priority :: Priority+ , numSamplesLMC :: Int+ , rollbackRounds :: Int -- ^ after resampling, how many past rounds to check the consistency with the rollout policy. This is reset to 1 when @move@ is called in the beginning of game, and is not a config value any longer.+ , rngLMC :: g+ , suggestedStrategyLMC :: sp+ , rolloutStrategyLMC :: s+ , rolloutStrategiesLMC :: Either (Array Int [s]) [[(Array Int s,Double)]]+ , consistentSampleFullStatesLMC :: [([State],[s])] -- ^ list of sample full states that are consistent with the game environment and the conjectured teammate policies.+ , ixToCard :: IM.IntMap Card+ , fixedStateHistory :: [State]+ , ready :: Bool -- ^ True when initialization is finished, ⊥ otherwise.+ }+data Priority = AverageScore -- ^ evaluate only by the average score+ | BestScoreRate -- ^ firstly consider the number of cases where the best possible score is achieved, and then consider the average score+ | AvoidZero -- ^ firstly avoid Failure and score 0, and then follow BestScoreRate. This is the recommendation if self-play of the rollout policy does not achieve 24 on average.+++annotationToCT4 :: PrivateView -> Annotation -> (Int, CardTo4)+annotationToCT4 pv ann = (ixDeck ann, case marks ann of (Just _, Just _) -> possibilities ann+ _ -> possibilities ann .&. invisibleBag pv)+{-+updateIxToCT4 :: Int -> [PrivateView] -> IM.IntMap CardTo4 -> IM.IntMap CardTo4+updateIxToCT4 numP pvs@(pv:_) i2ct4 = let lastResult = result $ pvs !! pred numP+-}++annotationToMbCard :: PrivateView -> Annotation -> [(Int, Card)]+annotationToMbCard pv ann = case marks ann of (Just c, Just r) -> [(ixDeck ann, C c r)]+ _ | bit trz == pos -> [(ixDeck ann, qitPosToCard $ trz `div` 2)]+ | otherwise -> []+ where pos = possibilities ann .&. invisibleBag pv+ trz = countTrailingZeros pos++-- updateIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card -> IM.IntMap Card+-- updateIxToCard numP pvs mvs i2c = roundToIxToCard numP pvs mvs `union` i2c+roundToIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card+roundToIxToCard numP pvs@(pv:_) mvs = let+ myRevealed = case drop (pred numP) pvs of+ PV{publicView=PI{result=lastResult}} : myLastPV : _ ->+ case lastResult of+ None -> []+ _ -> [(ixDeck $ head (annotations $ publicView myLastPV) !! index myLastMove, revealed lastResult)]+ where myLastMove = mvs !! pred numP -- mvs is only used here, for extracting the index of the last move.+ _ -> []+ myAnns = head $ annotations $ publicView pv+ in IM.fromList $ myRevealed ++ (myAnns >>= annotationToMbCard pv) -- fromAscList could be used for the second list with adequate specification.++instance (RandomGen g, Monad m, Strategy sp m, Strategy s Identity) => Strategy (LazyMC g sp s) m where+ strategyName ms = return "LazyMC"++ initialize True p = return p+ initialize False p = ready p `seq` return p++ move pvs@(pv:_) mvs str@(LMC pri num rr gen sp p ps css i2c fsh ready)+ | turn pub < numP || null newcss = do+ let (g3,g4) = split g2+ let (newrr, newPS) = case filteredPS of+ Right tss | turn pub >= numP -> (succ rr,+ Right $ take (pred numP) $ (+ map (\ts -> case ts of+ ((a,d):(b,e):vs) | fst (randomR (bounds a) g3) * 2 < limit -- The random number is used to make sure roughly most of the programs are tried at least once.+ -> (listArray (1, snd (bounds a) + snd (bounds b)) $ elems b ++ elems a, e) : vs+ _ -> ts)+ tss)+ ++ error "nanka takusann tukawareteru")+ _ -> (1, filteredPS)+-- let (m, EGML q) = trace "!!!!!!!!!!!!!Fall Back!!!!!!!!!!!!!!!!!!!!!" $ -- use this version with end game search for more fun.+-- runIdentity $ move (sontakuColorHint pvs mvs) mvs $ egml (\pub -> pileNum pub == 0) p (egl (\pub -> pileNum pub <= 1) p p $ either (!0) (map ((!1).fst.head)) newPS) numP+-- return (m, LMC pri num newrr g4 sp p newPS $ take num alternativeStatess)+ let (m, q) = -- trace "!!!!!!!!!!!!!Fall Back!!!!!!!!!!!!!!!!!!!!!" $+ runIdentity $ move pvs mvs p+ return (m, LMC pri num newrr g4 sp q newPS (take num alternativeStatess) ni2c nfsh ready)+ | otherwise = do+#ifdef DEBUG+ (sq,(_i, m)) <- trace ("mcMove") $+ trace ("length samples = " ++ show (length $ take num newcss)) $+#else+ (sq, m) <-+#endif+ mcMove pri num (take num newcss) p pvs' mvs sp+ return (m, LMC pri num (succ rr) g2 sq p filteredPS (take num newcss) ni2c nfsh ready)+ where+ (ni2c, fsh') | turn pub < numP = (IM.empty, [])+ | otherwise = (roundToIxToCard numP pvs mvs `IM.union` i2c, fsh)+ lenfsh = length fsh'+ rpvs = drop lenfsh $ reverse $ tail pvs+ cardss = map fromJust $ takeWhile isJust [ mapM (flip IM.lookup ni2c . ixDeck) $ head $ annotations $ publicView pv | pv <- rpvs ]+ nonrotatedPartialStates = zipWith (\(PV{publicView=pub, handsPV=hpv}) myHand -> St{publicState=pub, hands=myHand:hpv}) rpvs cardss+ nfsh = reverse nonrotatedPartialStates ++ fsh'+ lenFshDelta = length nonrotatedPartialStates+ deltas = map unzip $ take lenFshDelta $ tails $ zip nfsh $ drop (turn pub - lenFshDelta - lenfsh) mvs :: [([State], [Move])]++ arrOfsPvsMvs = accumArray (flip (:)) [] (0, pred numP) [ (offset, (map (view . rotate offset) sts, mvs)) | (sts@(st:_), mvs) <- deltas, let offset = (turn (publicState st) - turn pub) `mod` numP ] :: Array Int [([PrivateView], [Move])]++ filteredPS = case ps of Right tss -> Right $ zipWith filtPS tss [1..pred numP]+ _ -> ps+ -- filtPS :: [(Array Int s, Double)] -> Int -> [(Array Int s, Double)]+ filtPS ts offset = let hists = arrOfsPvsMvs ! offset in filter (not . null . elems . fst) $ map (fps hists) ts+ where fps hists (ar, prob) = let strs = filter (\str -> all (pred str) hists) $ elems ar in (listArray (1, length strs) strs, prob)+ where -- pred :: s -> ([PrivateView], [Move]) -> Bool+ pred str (pvs, mv:mvs) = fst (runIdentity $ move pvs mvs str) == mv++++++++ newcss = map snd $ filteredCss ++ filter fst (take limit newlyCheckedCss)+ lenFCss = length filteredCss+ (tk,m:_) = splitAt (pred numP) mvs+ moves = m : reverse tk+ revPVs = reverse $ take numP pvs+ agree pv1 pv2 = ((==) `on` (nonPublic . publicView)) pv1 pv2 &&+ ((==) `on` (map (take 1) . handsPV)) pv1 pv2 &&+ ((==) `on` (map marks . head . annotations . publicView)) pv1 pv2+ checkView samples = -- [(fst checkMoved, ({- states -}stateToStateHistory (map publicView tlpvs) mvs stNow, snd $ snd checkMoved)) |+ [ checkMoved |+++ tup@(lststs@(lastState:_), lstps) <- samples,++ states@(stNow:_) <- take 1 $ foldl (\statss (i,rpv,mov) -> statss >>= \stats@(stat:_) -> map (:stats) (map (rotate 1) $ filter (\st -> isNothing (checkEndGame $ publicState st) && agree rpv (view $ rotate (-i) st)) $ proceeds stat mov)) [lststs] $ zip3 [0..] revPVs moves+-- stNow <- take 1 $ foldl (\statss (i,rpv,mov) -> statss >>= \stat -> (map (rotate 1) $ filter (\st -> isNothing (checkEndGame $ publicState st) && agree rpv (view $ rotate (-i) st)) $ proceeds stat mov)) [lastState] $ zip3 [0..] revPVs moves++ , let checkMoved = checkMoves 1 numP tailsMoves lstps states++ ]+ tailsMoves = tails mvs+ checkedCss = checkView css+ filteredCss = filter fst $ checkedCss+ newlyCheckedCss = [ checkMoves rr numP tailsMoves strs states | (states, strs) <- samplePairsOfStatesAndStrategies filteredPS pvs mvs g1 ] -- This recedes rr rounds!!!!!!!!!+ {- a slightly inefficient version+ newlyCheckedCss = checkView [ (drop numP states, take (pred numP) ps) | states <- sampleStatess pvs mvs g1 ]+-}+++ pvs'@(hdpv:tlpvs) = pvs -- [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]+ pub = publicView hdpv+ numP = numPlayers $ gameSpec pub++ (g1,g2) = split gen+ alternativeStatess = [ (states, take (pred numP) strs) | (states, strs) <- samplePairsOfStatesAndStrategies filteredPS pvs mvs g1 ]+++ limit = 10000+-- limit = 10000 -- product [1 .. sumCT4 $ invisibleBag pv]+++++++-- seeIf theSt st = view st == view theSt && hands st == hands theSt+seeIf theSt@St{publicState=thePub} st@St{publicState=pub} = thePub{annotations=[]} == pub{annotations=[]} && hands st == hands theSt && ((==) `on` (map (map (\a -> (marks a, possibilities a))) . annotations)) pub thePub+++mcMove :: (Monad m, Strategy sp m, Strategy s Identity) =>+ Priority+ -> Int -- ^ number of samples + -> [([State],[s])] -- ^ possible sample pairs of the state history and the internal memory states of other players' strategies+ -> s -- ^ rollout strategy for the player+ -> [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+ -> sp -- ^ default (recommended) lightweight strategy+#ifdef DEBUG+ -> m (sp, ((Bool,Int,Int), Move))+#else+ -> m (sp, Move)+#endif+mcMove pri numSmpls smpls p pvs@(pv:_) mvs sp = do+ (defaultMove, sq) <- move pvs mvs sp+ let candidateMoves = defaultMove : delete defaultMove (validMoves pv)+ let pub = publicView pv+ bestPossibleScore = fromIntegral $ moreStrictlyAchievableScore pub+ achievable = bestPossibleScore * fromIntegral numSmpls+#ifdef DEBUG+-- This is the naive alternative.+ let asc = case pri of AvoidZero ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[p]) m)+ in ((all (/=0) scores, length $ filter (==bestPossibleScore) scores, sum scores), m)+ ) candidateMoves :: [((Bool,Int,Int), Move)]+ BestScoreRate ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[p]) m)+ in ((True, length $ filter (==bestPossibleScore) scores, sum scores), m)+ ) candidateMoves+ AverageScore ->+ map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[p]) m)+ in ((True, fromIntegral numSmpls, sum scores), m)+ ) candidateMoves+ achi = (True, fromIntegral numSmpls, achievable)++++ if trace "if any" $+ any ((>achi) . fst) asc then error ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) else+ trace ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) $+ return $+ (sq,+ trace ("defaultMove = "++show defaultMove++", and the result seems "++show (maximumBy (compare `on` fst) $ reverse asc)) $+ case lookup achi asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc+ Just k -> (achi, k) -- Stop search when the best possible score is found.+ )+#else+ let best = case pri of AverageScore -> snd $ findBestMove achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[p]) m) (-1, error "findBestMove: not found: should be undefined" defaultMove) candidateMoves+ _ -> snd $ findBestMoveDecently pri numSmpls achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[p]) m) ((0,-1), error "findBestMoveDecently: not found: should be undefined" defaultMove) candidateMoves+ return (sq, best)+#endif+++-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.+tryAMove :: (Monad m, Strategy s m) => [State] -> [Move] -> [s] -> Move -> m ((EndGame, [State], [Move]),[s])+tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move in tryAMove"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> -- trace "runSilently" $+ runSilently (nxt:states) (mov:mvs) strs+ Just eg -> return ((eg, nxt:states, mov:mvs), strs)++checkMoves :: (Strategy s Identity) => Int -> Int -> [[Move]] -> [s] -> [State] -> (Bool, ([State], [s]))+checkMoves rounds numP tailsMoves ps states =+ let turns = rounds * numP+ statess = reverse $ take turns $ tails states+ mvss = reverse $ take (pred turns) tailsMoves+ pnp = pred numP+ (b,qs) = checkMvs numP (length mvss) statess mvss ps -- !!! Exactly speaking, ps should be rotated when @length mvss /= pred turns@ !!!!!!!!!+ in (b, (states, take pnp qs))+checkMvs :: (Strategy s Identity) => Int -> Int -> [[State]] -> [[Move]] -> [s] -> (Bool, [s])+checkMvs _ 0 _ _ qs = (True, qs)+checkMvs numP n (sts:stss) (ms:mss) (p:ps)+ | n `mod` numP == 0 || null ms = checkMvs numP (pred n) stss mss (p:ps) -- skip the check if it is in the player's own turn, or it is the first turn.+ | otherwise = let+ (mv,q) = runIdentity $ move (viewStates sts) (tail ms) p+ (restb, rest) = checkMvs numP (pred n) stss mss $ ps ++ [q]+ in (mv == (head ms) && restb, rest) -- Once mv /= head ms, the remaining part would not be computed.
+ Game/Hanabi/Strategies/MCSearch.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, RankNTypes, TupleSections #-}+module Game.Hanabi.Strategies.MCSearch(MCSearch(..), mcs) where+import System.Random+import Control.Monad(zipWithM, MonadPlus(..))+#ifdef DEBUG+import Debug.Trace+#endif+#ifdef TEST+import Test.QuickCheck hiding (shuffle)+import Data.List(maximumBy, delete, tails, permutations, sort)+#else+import Data.List(maximumBy, delete, tails, permutations)+#endif+import Data.Function(on)+import Data.Array hiding (index)+import Data.Maybe(isNothing)+import Game.Hanabi++type BeliefState s = [([State], [s], Probability)]++-- naive alternative+eval :: (Monad m, Strategy s m) => Bool -> BeliefState s -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Probability+eval False samples run = mapM (\ (sts, ps, _) -> run sts ps) samples >>= \tups -> return $ sum [ egToNum st eg | (eg,st:_,_) <- tups ]+eval True samples run = mapM (\ (sts, ps, prob) -> fmap (,prob) $ run sts ps) samples >>= \tups -> return $ sum [ egToNum st eg * prob | ((eg,st:_,_), prob) <- tups ]++-- slightly naive alternative+{-+evalALittleQuick :: (Monad m, Strategy s m) => Bool -> Probability -> Probability -> Probability -> Probability -> BeliefState s -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Probability+evalALittleQuick weighted bestPossibleScore bestPossibleSum bestSumSoFar sumSoFar [] run = return sumSoFar+evalALittleQuick weighted bestPossibleScore bestPossibleSum bestSumSoFar sumSoFar ((sts,ps,prob):ss) run = do+ ~(eg, st:_, _) <- run sts ps+ let weight | weighted = prob+ | otherwise = 1 -- Specializing to this case should not contribute to the efficiency, because the @run@ part IS the bottleneck.+ let newSum = egToNum st eg * weight + sumSoFar+ newRemainingSum = bestPossibleSum - bestPossibleScore * weight+ if bestSumSoFar < newSum + newRemainingSum then evalALittleQuick weighted bestPossibleScore newRemainingSum bestSumSoFar newSum ss run else return (-1)+-}+evalALittleQuick :: (Monad m, Strategy s m) => Bool -> Probability -> Probability -> Probability -> BeliefState s -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Probability+evalALittleQuick weighted bestPossibleScore bestPossibleMargin sumSoFar [] run = return sumSoFar+evalALittleQuick weighted bestPossibleScore bestPossibleMargin sumSoFar ((sts,ps,prob):ss) run = do+ ~(eg, st:_, _) <- run sts ps+ let weight | weighted = prob+ | otherwise = 1 -- Specializing to this case should not contribute to the efficiency, because the @run@ part IS the bottleneck.+ let score = egToNum st eg+ newSum = score * weight + sumSoFar+ newPossibleMargin = bestPossibleMargin - (bestPossibleScore - score) * weight+ if newPossibleMargin>0 then evalALittleQuick weighted bestPossibleScore newPossibleMargin newSum ss run else return (-1)++evalQuick :: (Monad m, Strategy s m) => Bool -> Probability -> Probability -> Probability -> BeliefState s -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Probability+evalQuick weighted bestPossibleMargin bestPossibleScore sumSoFar [] run = return sumSoFar+evalQuick weighted bestPossibleMargin bestPossibleScore sumSoFar ((sts,ps,prob):ss) run+ | bestPossibleMargin <= 0 = return (-1)+ | otherwise = do ~(eg, st:_, _) <- run sts ps+ let score = egToNum st eg+ weight | weighted = prob+ | otherwise = 1 -- Specializing to this case should not contribute to the efficiency, because the @run@ part IS the bottleneck.+ evalQuick weighted (bestPossibleMargin - (bestPossibleScore-score)*weight) bestPossibleScore (score*weight + sumSoFar) ss run++findBestMove :: (Monad m, Strategy s m) => Bool -> Probability -> Probability -> BeliefState s -> (Move -> [State]->[s]->m (EndGame, [State], [Move])) -> (Probability, Move) -> [Move] -> m (Probability, Move)+findBestMove weighted achievable bestPossibleScore samples run best [] = return best+findBestMove weighted achievable bestPossibleScore samples run best@(bestSum, _) (m:ms) = do+ -- sumScore <- evalALittleQuick weighted bestPossibleScore (achievable-bestSum) 0 samples (run m) -- a little naive+ sumScore <- evalQuick weighted (achievable-bestSum) bestPossibleScore 0 samples (run m)+ findBestMove weighted achievable bestPossibleScore samples run (if sumScore > bestSum then (sumScore, m) else best) ms++enumerate :: BeliefState s -> BeliefState s+enumerate bs = [ (s{pile=cards}:ss, ps, n) | (s:ss,ps,n) <- bs, cards <- permutations $ pile s ]++-- The "Probability" in the returned "BeliefState" does not mean anything.+mkSamples :: (RandomGen g) => Int -> BeliefState s -> g -> (BeliefState s, g)+mkSamples numSamples beliefstate gen = samples numCases numSamples (listArray (1, length beliefAcc) beliefAcc) gen+ where beliefAcc = scanl1 (\(_,_,m) (ss,ps,n) -> (ss,ps,m+n)) beliefstate+ (_,_,numCases) = last beliefAcc+samples :: (RandomGen g) => Probability -> Int -> Array Int ([State], [s], Probability) -> g -> (BeliefState s, g)+samples numCases 0 _ gen = ([], gen)+samples numCases numSamples beliefAcc gen = let (r, g1) = randomR (1, numCases) gen+ (sts,ps,n) = binSearchOn (\(_,_,m) -> m) beliefAcc r+ (sts',g2) = case sts of [] -> ([], g1) -- should not happen+ s:ss -> (s{pile=cards}:ss, g2)+ where (cards,g2) = shuffle (pile s) g1+ (tups, g3) = samples numCases (pred numSamples) beliefAcc g2+ in ((sts',ps,n):tups, g3)++#ifdef TEST+prop_binSearchOn fun xs val = not (null xs) && val >= 1 ==> let ys = sort xs in val > fun (last ys) ||+ binSearchOn fun (listArray (1, length ys) ys) val == head (dropWhile (<val) ys)+#endif+#ifdef DEBUG+#else+trace _ = id+#endif++binSearchOn :: (a -> Probability) -> Array Int a -> Probability -> a+binSearchOn fun arr val = bso (bounds arr)+ where bso (l,r) | l == r = arr ! l+ | otherwise = bso $ if fun (arr ! m) < val then (succ m, r) else (l, m)+ where m = (l+r) `div` 2+++mcs f n g sp p ps = MCS f n g sp p ps []++-- | @'MCS' f c sp p [s] memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @[s]@ when @f@ returns True.+-- The strategy @sp@ suggests a desired move in order to prioritize a promising strategy, and is used as the rollout strategy, too.+-- @c@ or @rolloutCond@ is used to decide when to start rollout, such as @\start end -> turn end - turn start > 1@.+data MCSearch g sp s = MCS { fromWhenMC::PublicInfo->Bool+ , rolloutSampleTurns :: Int -- ^ (number of rollout samples) x ((number of cards at the deck) + (number of players))+ , rolloutRNG :: g, suggestedStrategyMC::sp, rolloutStrategy::s, rolloutStrategies::[s], beliefState :: [([State],[s],Probability)]}++instance (RandomGen g, Monad m, Strategy sp m, Strategy s m) => Strategy (MCSearch g sp s) m where+ strategyName ms = return "MCSearch"+ move pvs@(pv:_) mvs str@(MCS f num gen sp p ps bs)+ | f pub = do statess <- case splitAt (pred numP) mvs of+ (tk,m:_) | not $ null bs -> do+ let moves = m : reverse tk++ let filteredbs = [+ (tup, ({- reverse states ++ lststs -} states, lstps {- ここが違うので、statelessじゃないと正しく動かない -}, prob))+ | tup@(lststs@(lastState:_), lstps, prob) <- bs++ , states@(guessedSt:_) <- foldl (\statss mov -> statss >>= \stats@(stat:_) -> map (:stats) (map (rotate 1) $ proceeds stat mov)) [lststs] moves+ , let guessedPV = view guessedSt+ , isNothing $ checkEndGame $ publicView guessedPV -- The game should not have ended, and -- Note that earlyQuit will change this result.+ -- guessedPV == pv, which can be checked just by checking if+ , ((==) `on` (nonPublic . publicView)) guessedPV pv -- the revealed sets agree,+ , ((==) `on` (map (take 1) . handsPV)) guessedPV pv -- the newest (or leftmost) cards agree, and+ , ((==) `on` (map marks . head . annotations . publicView)) guessedPV pv -- the marks on my hand agree.+ ]+ let mvss = reverse $ take (pred numP) $ tails mvs+ resultss <- mapM (checkMoves numP mvss) filteredbs+ let filtRes = concat resultss++ return $ if null filtRes then+-- trace "using filteredbs"+ map snd filteredbs -- error "null filtRes"+ else -- trace "filtRes"+ filtRes++ _ -> -- trace "bottom" $+ return alternativeStatess+ if null statess then do+ (m,q) <- move pvs mvs p+ return (m, MCS f num gen sp q ps alternativeStatess)+ else do+ (sq,(_i, m),g2) <- mcMove (num `div` (pileNum pub + numP)) gen statess p pvs' mvs sp+ return (m, MCS f num g2 sq p ps statess)+ | otherwise = do (m,q) <- move pvs mvs p+ return (m, MCS f num gen sp q ps alternativeStatess)+ where pvs'@(hdpv:tlpvs) = pvs -- [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]+ pub = publicView hdpv+ numP = numPlayers $ gameSpec pub+ alternativeStatess = [ (stateToStateHistory (map publicView tlpvs) mvs state, take (pred numP) ps, fromIntegral n) | (state, n) <- possibleStates hdpv ]++-- seeIf theSt st = view st == view theSt && hands st == hands theSt -- これだとixDeckの違いを反映してしまう。+seeIf theSt@St{publicState=thePub} st@St{publicState=pub} = thePub{annotations=[]} == pub{annotations=[]} && hands st == hands theSt && ((==) `on` (map (map (\a -> (marks a, possibilities a))) . annotations)) pub thePub+++++mcMove :: (RandomGen g, Monad m, Strategy sp m, Strategy s m) =>+ Int -- ^ number of samples for rollout+ -> g -- ^ RandomGen used for rollout+ -> [([State],[s],Probability)] -- ^ possible pairs of the state history and the internal memory states of other players' strategies+ -> s -- ^ rollout strategy+ -> [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+ -> sp -- ^ default (recommended) strategy+ -> m (sp, (Probability, Move), g) -- Probabilityはスコアだけどいらんといえばいらん。+mcMove num gen statess p pvs@(pv:_) mvs sp = do+ (defaultMove, sq) <- move pvs mvs sp+ let candidateMoves = defaultMove : delete defaultMove (validMoves pv)+ let pub = publicView pv+ numPermutations = product [1 .. fromIntegral $ pileNum pub]+ numStates = fromIntegral (length statess) * numPermutations+ exhaustive = numStates <= fromIntegral num -- If the number of distinct states is less or equal to the number of samples, exhaustive enumeration should be done instead of Monte-Carlo evaluation.+ (smpls, g1) | exhaustive = (enumerate statess, g1)+ | otherwise = mkSamples num statess gen+ bestPossibleScore = fromIntegral $ moreStrictlyAchievableScore pub+ achievable | exhaustive = bestPossibleScore * sum [prob | (_,_,prob) <- statess] * numPermutations+ | otherwise = bestPossibleScore * fromIntegral num+ -- ToDo: Also consider critical cards at the bottom deck.+#ifdef DEBUG+-- This is the naive alternative.+ scores <- mapM (\m -> eval exhaustive smpls (\sts ps -> fmap fst $ tryAMove sts mvs (ps++[p]) m)) candidateMoves+ let asc = zip scores candidateMoves :: [(Probability, Move)]+ if any ((>achievable) . fst) asc then error ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achievable = "++show achievable) else+ trace ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achievable = "++show achievable) $+ return $+ (sq,+ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc+ Just k -> (achievable, k) -- Stop search when the best possible score is found.+ , g1)+#else+ best <- findBestMove exhaustive achievable bestPossibleScore smpls (\m sts ps -> fmap fst $ tryAMove sts mvs (ps++[p]) m) (-1, error "findBestMove: not found") candidateMoves+ return (sq, best, g1)+#endif+++-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.+tryAMove :: (Monad m, Strategy s m) => [State] -> [Move] -> [s] -> Move -> m ((EndGame, [State], [Move]),[s])+tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move in tryAMove"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs+ Just eg -> return ((eg, nxt:states, mov:mvs), strs)++type Probability = Integer++checkMoves :: (Monad m, Strategy s m, MonadPlus l) => Int -> [[Move]] -> (([State], [s], p),([State], [s], p)) -> m (l ([State], [s], p))+checkMoves numP mvss ((_, ps, _), (states, _, x)) = do+ let statess = reverse $ take numP $ tails states+ mbqs <- checkMvs statess mvss ps+ return $ fmap (\qs -> (states, qs, x)) mbqs+checkMvs :: (Monad m, Strategy s m, MonadPlus l) => [[State]] -> [[Move]] -> [s] -> m (l [s])+checkMvs (sts:stss) ((m:ms):mss) (p:ps) = do (mv,q) <- move (viewStates sts) ms p+ if mv /= m then return mzero else do+ mbqs <- checkMvs stss mss ps+ return $ fmap (q:) mbqs+checkMvs _ _ _ = return $ return []
Game/Hanabi/Strategies/SimpleStrategy.hs view
@@ -4,10 +4,10 @@ import System.Random import Data.Maybe(isNothing) import Data.List(sortOn, tails)-import Data.Bits(bit)+import Data.Bits(bit, (.&.)) --- An example of a simple and stupid strategy.-data Simple = S+-- Was an example of a simple and stupid strategy.+data Simple = S {aggressivePositionalDrop :: Bool} instance Monad m => Strategy Simple m where strategyName ms = return "Stupid example strategy"@@ -19,80 +19,141 @@ myAnns = head $ annotations pub myHand = zip [0..] myAnns numHand = length myAnns+ colorHint pl = Hint pl . Left . color+ rankHint pl = Hint pl . Right . rank+ isMarked = isHinted . marks+ isUnmarked = not . isMarked+ nextPlayersUnmarked = filter (isUnmarked . getAnn) nextPlayer+ getAnn (_,_,ann) = ann++ nitchimo anns = length (filter (\ann -> isMarked ann && not (isObviouslyUncritical pub (possibilities ann) || isObviouslyPlayable pub (possibilities ann))) anns) isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ])- || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just num)}) <- nextPlayer, color c == col ]+ || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just _)}) <- nextPlayer, color c == col ] isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer. markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new.- markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ rank te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ]- keep2 = take 1 [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ]- unhintedNon2 = [ t | t@(_, c@(C _ n), ann) <- nextPlayer, n/=K2 || isUseless pub c, not $ isHinted $ marks ann ]- colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked+ markUnhintedCritical = mr [ if isColorMarkable (color te) then colorHint 1 te else rankHint 1 te | (_ix, te, _) <- reverse nextPlayersUnmarked, isCritical pub te ]+-- keep2 = mr [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ]+ keep21 = mr [ rankHint 1 te | (_ix, te@(C c k), _) <- reverse nextPlayersUnmarked, k <= K2, keptCards pub te <= 2, not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ]+ unhintedNon2 = [ t | t@(_, c@(C _ n), _) <- nextPlayersUnmarked, n/=K2 || isUseless pub c ]+ colorMarkUnmarkedPlayable = mr [ colorHint 1 d | (i,d,ann) <- markCandidates, -- Mark the color ff a (not obviously) playable card+ isUnmarked ann, -- if it is not marked yet isNewestOfColor i d, -- but be cautious not to color-mark newer cards. not $ havePlayableCardWithTheSameColor $ color d ] -- refrain marking if I have a playable card with the same color- colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked.+ colorMarkNumberMarkedPlayable = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ]- removeDuplicate = take 1 [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- myHand ],+ colorMarkPlayable5 = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just K5)}) <- markCandidates ]+ removeDuplicate = mr [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- reverse myHand ], m `elem` [ m' | (_, Ann{marks=m'}) <- xs ] ]- numberMarkPlayable = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked.+ numberMarkPlayable = mr [ rankHint 1 d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ]+ numberMarkPlayable5 = mr [ Hint 1 $ Right K5 | (_, C _ K5, Ann{marks=(_, Nothing)}) <- markCandidates ] havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ]- numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ rankToBitPos (rank d)) ]- colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{possibilities=p@(_, pn)}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ colorToBitPos (color d), pn),++ numberMarkIfInformative cond = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _,Nothing),possibilities=p}) <- nextPlayer, not $ cond pub p, cond pub (p .&. rankToQit (rank d)) ]+ numberMarkUselessIfInformative = numberMarkIfInformative isObviouslyUseless+ numberMarkUncriticalIfInformative = numberMarkIfInformative isObviouslyUncritical+ colorMarkIfInformative cond = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing,Just _),possibilities=p}) <- reverse nextPlayer, not $ cond pub p, cond pub (p .&. colorToQit (color d)), isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.- numberMarkUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]- numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]- colorMarkColorUnmarked = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p,+ colorMarkUselessIfInformative = colorMarkIfInformative isObviouslyUseless+ colorMarkUncriticalIfInformative = colorMarkIfInformative isObviouslyUncritical++ numberMarkUnmarked = mr [ rankHint 1 d | (_,d,_) <- nextPlayersUnmarked, not $ isUseless pub d ]+ numberMarkNumberUnmarked = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]+ colorMarkColorUnmarked = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.- playPlayable5 = take 1 [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ]- dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,ann) <- reverse myHand, isDefinitelyUseless pv ann ]- dropSafe = take 1 [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ]- dropPossiblyUncritical = take 1 [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ]- sontakuColorMark = case mvs of -- When the last move is color mark,- Hint 1 (Left c) : _ | isDefinitelyUseless pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.+ pass = mr $ case span (\(_,_,ann) -> isMarked ann) nextPlayer of (tk,dr) -> [ rankHint 1 d | (_,d,_) <- tk, rank d `notElem` [ rank c | (_,c,_) <- dr ] ]+ ++ [ colorHint 1 d | (_,d,_) <- tk, color d `notElem` [ color c | (_,c,_) <- dr ] ]+ hailMary | lives pub < 2 = id+ | otherwise = mr $ case filter (not . isDefinitelyUnplayable pv . snd) myHand of ts -> map (Play . fst) ts+ playPlayable = mr $ case span (isObviouslyPlayable pub . possibilities . snd) $ filter (isDefinitelyPlayable pv . snd) myHand of (ob,nob) -> map (Play . fst) $ nob++ob -- Play a playable card. Prioritize those that are not publicly playable.+ playPlayable5 = mr [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ]+ dropUselessOrDuplicate = dropUselessCard . removeDuplicate+ dropUselessCard = mr [ Drop i | (i,ann@Ann{possibilities=p}) <- reverse myHand, isDefinitelyUseless pv ann && isMarked ann || isObviouslyUseless pub p ]+ dropSafe = mr [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ]+ dropPossiblyUncritical = mr [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ]+ sontakuColorMark = mr $ case mvs of -- When the last move is color mark,+ Hint 1 (Left c) : _ -- x | isDefinitelyUseless pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.+ -- The above pattern is unnecessary, and it can be mistakenly interpreted as positional drop if there are other useless cards. | isDefinitelyUnplayable pv (myAnns!!i) -> [] -- If the first color-marked is unplayable for now, ignore it. | otherwise -> [Play i] -- Otherwise, it means "Play!"- where i = length $ takeWhile ((/=Just c) . fst . marks) $ head $ annotations $ publicView pv -- (This should also be rewritten using list comprehension.)+ where i = length $ takeWhile ((/=Just c) . fst . marks) myAnns -- (This should also be rewritten using list comprehension.) _ -> []- sontakuPositionalDrop = case mvs of+ sontakuPositionalDrop = mr $ case mvs of Drop i : _ | i `notElem` unusualChops || length myAnns <= i -> [] -- It is not a positional drop if nothing is unusual or the corresponding card does not exist. | not $ isDefinitelyUnplayable pv (myAnns!!i) -> [Play i] | otherwise -> [Drop i] -- if by no means it is playable, it means "drop it" (unless there are 8 hints), even if isDefinitelyCritical.- where lastpub = publicView (head pvs)- lastAnns = last (annotations lastpub)- unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns+ where unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns _ -> []- dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ]- dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myAnns ]+ makePositionalDrop = mr $ case mvs of -- This assumes the last teammate marks a critical card if there is.+ Hint _ (Right _) : _ -> [] -- refrain if the last move was rank-mark in order to avoid dropping a critical card. This condition can be relaxed.+-- Drop i : _ | not $ isDefinitelyUseless (head pvs) $ lastAnns !! i -> [] -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.+ mv : _ | discarded (result pub) && not (isDefinitelyUseless pv $ lastAnns !! index mv) -> [] -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.+ _ : Drop i : _ | i `elem` sndlastUnusualChop -> [] -- avoid consecutive positional drop. This condition can be relaxed.+ _ | hints >= 2 && hints <= 6 && turn pub >= 7 && not (null chops)+ -> [Drop i | ( (i,card,Ann{possibilities=p}), mann) <- zip nextPlayer myAnns,+ isUnmarked mann, not (isDefinitelyCritical pv mann || isDefinitelyPlayable pv mann),+ head chops /= i, isPlayable pub card, not $ isObviouslyPlayable pub p]+ | otherwise -> []+ where chops = concat $ map reverse $ obviousChopss pub myAnns+ hints = hintTokens pub+ discarded (Discard _) = True+ discarded (Fail _) = True+ discarded _ = False++ dropChopUnlessDoubleDrop = mr $ case mvs of+ _ : Drop i : _ | i `elem` sndlastUnusualChop -> [] -- avoid dropping after positional drop. This condition can be relaxed.+ _ -> [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ]+ sndlastUnusualChop = drop 1 $ concat $ map reverse $ obviousChopss sndlastpub sndlastAnns+ lastpub = publicView (head pvs)+ lastAnns = last (annotations lastpub)+ sndlastpub = publicView (head $ tail pvs)+ sndlastAnns = last $ init (annotations sndlastpub)+ + dropChop = mr [ Drop i | i:_ <- definiteChopss pv myAnns ]+ current = currentScore pub achievable = seeminglyAchievableScore pub- noDeck = pileNum pub == 0 && not (prolong (Game.Hanabi.rule $ gameSpec pub))- enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub- mov = head $ filter (isMoveValid pv) $- sontakuPositionalDrop- ++ (if noDeck then playPlayable5 else markUnhintedCritical)- ++ (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else [])- ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ if length unhintedNon2 >= 2 then keep2 else [] else []) -- Do one of these only when there are spare hint tokens.- ++ (if noDeck then markUnhintedCritical else playPlayable5)- ++ (if enoughDeck then removeDuplicate ++ dropUselessCard else []) -- Drop a useless card unless endgame is approaching.- ++ take 1 [ Play i | (i,ann) <- myHand, isDefinitelyPlayable pv ann ] -- Play a playable card- ++ sontakuColorMark -- guess the meaning of the last move, and believe it.- ++ dropChopUnlessDoubleDrop- ++ colorMarkUnmarkedPlayable ++ colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ dropUselessCard ++ keep2- ++ colorMarkUselessIfInformative- ++ numberMarkUselessIfInformative- ++ colorMarkColorUnmarked ++ numberMarkNumberUnmarked- ++ numberMarkUnmarked- ++ [Hint 1 $ Right n | n <- [K1 .. K5]]- ++ dropSafe -- drop the oldest 'safe to drop' card- ++ dropChop+ continue = prolong (Game.Hanabi.rule $ gameSpec pub)+ noDeck = not (continue || 0 < pileNum pub)+ spareDeck = continue || achievable - current < pileNum pub + 2+ enoughDeck = continue || achievable - current < pileNum pub++ mr = mkRule pv+ Just mov = (\f -> f Nothing) $+-- sontakuPositionalDrop . -- StatefulStrategy does the sontaku more flexibly.+ (if noDeck then playPlayable else markUnhintedCritical)+ . (if aggressivePositionalDrop s && enoughDeck then makePositionalDrop else id)+ . (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else id)+ . colorMarkPlayable5 . numberMarkPlayable5+ . (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable . numberMarkPlayable . if length unhintedNon2 >= 2 then keep21 else id else id) -- Do one of these only when there are spare hint tokens.+ . (if noDeck then hailMary . markUnhintedCritical else playPlayable5)+ . (if enoughDeck then (if nitchimo nextPlayersAnns >= 4 then colorMarkUselessIfInformative . numberMarkUselessIfInformative . colorMarkUncriticalIfInformative . numberMarkUncriticalIfInformative else id) .+ dropUselessOrDuplicate else id) -- Drop a useless card unless endgame is approaching.+ . playPlayable+ . sontakuColorMark -- guess the meaning of the last move, and believe it.+ . (if enoughDeck then dropChopUnlessDoubleDrop else id)+ . colorMarkUnmarkedPlayable . colorMarkNumberMarkedPlayable . numberMarkPlayable . keep21+ . (if spareDeck then dropUselessOrDuplicate . dropChopUnlessDoubleDrop else id)+ . colorMarkUselessIfInformative+ . numberMarkUselessIfInformative+ . (if spareDeck && nitchimo myAnns >= 5 then dropSafe else id)+ . colorMarkColorUnmarked+ . numberMarkNumberUnmarked+ . numberMarkUnmarked+ . pass+ . dropUselessOrDuplicate .+ dropChopUnlessDoubleDrop+ . dropSafe -- drop the oldest 'safe to drop' card+ . dropChop+ . mr ([Hint 1 $ Right n | n <- [K1 .. K5]] -- ++ dropPossiblyUncritical -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical.- ++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> fmap fromEnum mb) myHand ]+ ++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> mb) myHand ] ++ [Play 0]) in return (mov, s) main = do g <- newStdGen--- ((eg,_),_) <- start defaultGS [] ([S],[stdio]) g -- Play it with standard I/O (human player).- ((eg,_),_) <- start defaultGS [peek] [S,S] g -- Play it with itself.+ ((eg,_),_) <- start defaultGS [] ([S False],[stdio]) g -- Play it with standard I/O (human player).+-- ((eg,_),_) <- start defaultGS [peek] [S False, S False] g -- Play it with itself. putStrLn $ prettyEndGame eg
Game/Hanabi/Strategies/StatefulStrategy.hs view
@@ -4,42 +4,63 @@ import Game.Hanabi.Strategies.SimpleStrategy import System.Random import Data.Maybe(isNothing)-import Data.List(sortOn)-import Data.Bits(bit, (.&.))+import Data.List(sortOn, tails)+import Data.Bits(bit, (.&.), complement) import qualified Data.IntMap as IM -- An example of a strategy with state.-newtype Stateful = SF [Annotation]+data Stateful s = SF {guessColorToPlay::Bool, guessPositionalDrop::Bool, baseStrategy::s, anns::[Annotation]}+sfs smpl = SF True True smpl [] lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a] lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]--instance Monad m => Strategy Stateful m where- strategyName ms = return "Stateful strategy"- move (pv:pvs) mvs (SF lastGuess) = let- consistentGuess = [ case lookupOn ixDeck realAnn $ hintedAnns ++ lastGuess of- guessedAnn:_ | narrowedPos /= 0 -> realAnn{possibilities = (fst realPos, narrowedPos)}- where narrowedPos = snd realPos .&. snd (possibilities guessedAnn)- realPos = possibilities realAnn+instance (Monad m, Strategy s m) => Strategy (Stateful s) m where+ strategyName ms = ms >>= \sf -> strategyName (return $ baseStrategy sf) >>= \name -> return ("Stateful strategy of "++name)+ move pvs@(pv:tlpvs) mvs (SF ctp pd s lastGuess) = let+ numP = numPlayers $ gameSpec pub+ pub = publicView pv+ lG | turn pub < numP = []+ | otherwise = lastGuess+ consistentGuesses = [ [ case lookupOn ixDeck realAnn $ (if ctp then colorToPlay numP pvs mvs else []) ++ (if pd then positionalDrop numP pvs mvs else []) ++ lG of+ Ann{possibilities=guessedPos}:_ | not $ isObviouslyInconsistent pub newPos -> newAnn+ where newAnn = realAnn{possibilities = newPos}+ newPos = realPos .&. guessedPos _ -> realAnn- | realAnn <- myAnns ]+ | realAnn@Ann{possibilities=realPos} <- anns ]+ | anns <- annotations pub ]+ in move (pv{publicView=pub{annotations=consistentGuesses}} : tlpvs) mvs s >>= \(mov, s') -> return (mov, SF ctp pd s' $ concat consistentGuesses) - hintedColors = [ c | (p, Hint q (Left c)) <- zip [1..] $ take (numPlayers $ gameSpec pub) mvs,- p==q,- not $ or [ isObviouslyPlayable pub m | Ann{marks=(Just i, _),possibilities=m} <- myAnns, c==i ] -- Exclude if there is a playable card with the color.- ]- hintedAnns = [ ann{possibilities = (fst $ possibilities ann, newNumberPos)}- | c <- hintedColors,- let i = length $ takeWhile ((/=Just c) . fst . marks) myAnns- ann = myAnns !! i- newNumberPos = bit $ rankToBitPos (succ $ achievedRank pub c), -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.- not $ isDefinitelyUnplayable pv ann,- newNumberPos .&. snd (possibilities ann) /= 0 ]- pub = publicView pv- myAnns = head $ annotations pub- in move (pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : pvs) mvs S >>= \(mov,S) -> return (mov, SF consistentGuess)+colorToPlay numP pvs mvs = [ focusedAnn{possibilities = rankToQit (succ $ achievedRank pub hintedColor)} -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.+ | (p, pv, Hint q (Left hintedColor)) <- zip3 [1..] pvs $ take numP mvs,+ let pub = publicView pv,+ let ix = (q-p) `mod` numP+ anns = annotations pub !! ix+ cards = (repeat undefined:handsPV pv) !! ix,+ let hintedTups@((focusedAnn,focusedCard):_) = [ tup | tup@(Ann{marks=(Just i, _)}, _) <- zip anns cards, hintedColor==i ],+ not $ any (isObviouslyPlayable pub . possibilities . fst) hintedTups, -- Exclude if there is a playable card with the color.+ if p==q then not $ isDefinitelyUnplayable pv focusedAnn else isPlayable pub focusedCard -- Exclude if the focused card is definitely unplayable.+ ] +positionalDrop numP pvs mvs = concat $ zipWith3 (positionalDrop' numP) [0,-1..1-numP] (tails pvs) mvs+positionalDrop' numP rot (pv:lastpv:_) mv = case mv of+ Drop i | i `notElem` unusualChops || length anns <= i -> [] -- It is not a positional drop if nothing is unusual or the corresponding card does not exist.+ | if rot==0 then not (isDefinitelyUnplayable pv focused)+ else isPlayable pub (hand !! i) -> [focused{possibilities=nextToPlay pub}]+ | otherwise -> [focused{possibilities = complement $ critical pub}] -- Suggest dropping the card by telling that it is not critical when almost everything is marked.+ where pub = publicView pv+ lastpub = publicView lastpv+ unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns+ lastAnns = annotations lastpub !! (pred rot `mod` numP)+ anns = annotations pub !! player+ hand = handsPV pv !! pred player+ player = rot `mod` numP+ focused = anns!!i+ _ -> []++++ main = do g <- newStdGen- ((eg,_),_) <- start defaultGS [] ([SF[]],[stdio]) g -- Play it with standard I/O (human player).--- ((eg,_),_) <- start defaultGS [peek] [SF[],SF[]] g -- Play it with itself.+ ((eg,_),_) <- start defaultGS [] ([sfs (S False)],[stdio]) g -- Play it with standard I/O (human player).+-- ((eg,_),_) <- start defaultGS [peek] [sfs (S False), sfs (S False)] g -- Play it with itself. putStrLn $ prettyEndGame eg
Game/Hanabi/Strategies/Stateless.hs view
@@ -9,7 +9,7 @@ import qualified Data.IntMap as IM -- A stateless implementation of Stateful-data Stateless = SL+data Stateless = SL Simple lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a] lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]@@ -20,8 +20,8 @@ guessedAnn:_ -> guessedAnn _ -> realAnn | realAnn <- myAnns ]- hintedAnns = [ ann{possibilities = (currentColPos, newNumberPos)}- | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=(currentColPos, currentNumPos)} <- myAnns+ hintedAnns = [ ann{possibilities = narrowedPos}+ | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=currentPos} <- myAnns , (p,pvInQ,c) <- take 1 [ (p,pvq,c) | (p, pvq, Hint q (Left d)) <- zip3 [1..] pvs mvs, c==d && p `mod` numPlayers (gameSpec pub) == q ] , let pubInQ = publicView pvInQ@@ -29,20 +29,20 @@ , not $ or [ isObviouslyPlayable pubInQ m | Ann{marks=(Just i, _),possibilities=m} <- myAnnsInQ, c==i ] -- Exclude if there is a playable card with the color. , ann <- take 1 [ ann | ann@Ann{marks=(Just i,_)} <- myAnnsInQ, c==i ]- , let newNumberPos = bit $ rankToBitPos (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.+ , let narrowedPos = currentPos .&. rankToQit (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True. , ixDeck ann == ix , not $ isDefinitelyUnplayable pvInQ ann- , newNumberPos .&. currentNumPos /= 0 ]+ , narrowedPos /= 0 ] pub = publicView pv myAnns = head $ annotations pub in pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : tail pvs instance Monad m => Strategy Stateless m where strategyName ms = return "Stateless"- move pvs@(pv:_) mvs SL = move (sontakuColorHint pvs mvs) mvs S >>= \(mov,S) -> return (mov, SL)+ move pvs@(pv:_) mvs (SL s) = move (sontakuColorHint pvs mvs) mvs s >>= \(mov, s') -> return (mov, SL s') main = do g <- newStdGen- ((eg,_),_) <- start defaultGS [] ([SL],[stdio]) g -- Play it with standard I/O (human player).--- ((eg,_),_) <- start defaultGS [peek] [SL,SL] g -- Play it with itself.+ ((eg,_),_) <- start defaultGS [] ([SL (S False)],[stdio]) g -- Play it with standard I/O (human player).+-- ((eg,_),_) <- start defaultGS [peek] [SL False, SL False] g -- Play it with itself. putStrLn $ prettyEndGame eg
all.hs view
@@ -3,19 +3,15 @@ import Network.HTTP.Types import Network.Wai.Handler.Warp (run) -import Game.Hanabi(mkDS, DynamicStrategy) import Game.Hanabi.Client(clientApp) import Game.Hanabi.Backend(hanabiApp) import Game.Hanabi.Msg(defaultOptions, Options(..)) -import Game.Hanabi.Strategies.SimpleStrategy hiding (main)-import Game.Hanabi.Strategies.StatefulStrategy hiding (main)-import Game.Hanabi.Strategies.Stateless hiding (main)-import Game.Hanabi.Strategies.EndGameSearch hiding (main)+import Game.Hanabi.Strategies(predefinedStrategies) main :: IO () main = do putStrLn "localhost:8080" -- Seemingly other port than 8080 does not work.- let opt = defaultOptions{version="hanabi-dealer quickbuilt server", strategies=strs}+ let opt = defaultOptions{version="hanabi-dealer quickbuilt server", strategies=predefinedStrategies} capp <- clientApp opt bapp <- hanabiApp opt $ \_ resp -> resp $ responseLBS status400 [("Content-Type", "text/plain")] "400 Not a WebSocket request." run 8080 $ route capp bapp@@ -24,12 +20,3 @@ "/ws/" -> bapp request respond _ -> capp request respond -- _ -> respond $ responseLBS status404 [("Content-Type", "text/plain")] "404 Not found"--strs :: [(String, IO (DynamicStrategy IO))]-strs = [- ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S),- ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []),- ("Stateless implementation of the strategy with states", return $ mkDS "Stateless implementation of the strategy with states" SL),- ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG)- -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))- ]
+ batch.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP, FlexibleContexts, RecordWildCards #-}+module Main where+import Game.Hanabi.VersionInfo++import Game.Hanabi.Strategies+import System.Random+#ifdef TFRANDOM+import System.Random.TF+import System.Random.TF.Gen+#else+import System.Random.SplitMix+#endif++import Game.Hanabi.Strategies.AppendDSL+import MagicHaskeller+import Control.Monad.Search.Combinatorial(unMx)++import Control.Concurrent+import Control.Concurrent.MVar++import System.Environment++import System.IO+import Data.Functor.Identity++import Control.Monad.Trans.State+import Control.Monad.Trans.Class(lift)++import Data.List(transpose)++import Game.Hanabi hiding (main) -- (pileNum, egToInt, Card) -- (Replay(..))++newGen = newSMGen++runOnceToInt :: StateT (AdaptiveLMC SMGen (Stateful Sless), SMGen) IO Int+runOnceToInt = do+ (almc, g) <- get++ guessedProgName <- foldr const (return "No program remained!") $ map (strategyName . return) (concat $ unMx $ head $ rolloutStrategiesLMC almc :: [Stateful Sless])+ lift $ putStrLn $+ "------------------------------------------------------\n"+ ++ guessedProgName+ ++ "\n------------------------------------------------------\n"+ let (gen,g') = split g+#ifdef TEST+{-+ (((eg,st:_,_),(_,[almc'])),_) <-startToEnd defaultGS [] ([SF {guessColorToPlay=True,+ guessPositionalDrop=True,+ baseStrategy=simpleSl,+ anns=[]}+ ], [almc]) gen+-}+-- (((eg,st:_,_),(_,[almc'])),_) <-startToEnd defaultGS [] ([testSl], [almc]) gen+-- (((eg,st:_,_),(_,[almc'])),_) <-startToEnd defaultGS [] ([SL $ S False], [almc]) gen+ (((eg,st:_,_),(_,[almc'])),_) <-startToEnd defaultGS [] ([SF{guessColorToPlay=True, guessPositionalDrop=True, baseStrategy=S False, anns=[]}], [almc]) gen+#else+ (((eg,st:_,_),(_,[almc'])),_) <-startToEnd defaultGS [] ([simpleSl], [almc]) gen+#endif+ put (almc', g')+ lift $ print $ egToInt st eg+ return $ egToInt st eg++tryManyExperiments :: ExpSpec -> IO [[Int]]+tryManyExperiments ES{..} = do+ hSetBuffering stdout NoBuffering+ seed <- case mbSeed of+ Nothing -> newGen+ Just s -> return s+{-+-- let seed = read "SMGen 13080994445437667243 17591135057895218335" :: SMGen -- unlucky+ let seed = read "SMGen 7907189382150968454 13455886919517719531" :: SMGen -- lucky+-}+ putStrLn $ "seed = " ++ show seed+ let (g0, g1) = split seed+ putStrLn ("(g0,g1) = " ++ show (g0,g1))++ hPutStr stderr "Preparing MagicHaskeller..."+++-- constrAssoc <- mapM sequenceA [ (name, crs) | (name, Just crs) <- predefinedStrategies]+ -- almc <- snd $ last constrAssoc++ ioalmc <- preload (mkAdaptiveLMC paramsES instinct g0) return False+ hPutStrLn stderr "Done!"++ let gens = take numExperiments $ map snd $ iterate (split.fst) $ split g1+ putStrLn $ "seeds = " ++ show gens+ mvars <- sequence $ replicate numExperiments newEmptyMVar+ mapM_ (forkIO . tryManyGames ioalmc numGames) $ zip gens mvars+ mapM takeMVar mvars++data ExpSpec = ES { mbSeed :: Maybe SMGen+ , numExperiments :: Int+ , numGames :: Int+ , paramsES :: ParamsADSL -- could be an ADT, maybe defined in Strategies.hs+ , outFile :: FilePath+ }+ deriving (Show, Read)+defaultES = ES (read "Just (SMGen 7907189382150968454 13455886919517719531)") 10 40 (PADSL (PALMC 0 AverageScore PartiallyObserved {- FromTheBeginning -} 800 False) 1 (ProgsPerDepth 20000)) "noname.out"++tryManyGames :: IO (AdaptiveLMC SMGen (Stateful Sless)) -> Int -> (SMGen, MVar [Int]) -> IO ()+tryManyGames ioalmc n (gen,mvar) = do+ almc <- ioalmc+{-+#ifdef TEST+ almc <- mkAdaptiveLMC 200000 simpleInstinct g0+#else+ almc <- mkAdaptiveLMC 200000 instinct g0+#endif++-- ready almc `seq` hPutStrLn stderr "Done!"++ almc' <- initialize almc+ hPutStrLn stderr "Done!"+-}++ result <- evalStateT (sequence $ replicate n $ runOnceToInt) (almc, gen)+ putMVar mvar result++-- convert the result of tryManyExperiments into a String that can be supplied to Gnuplot.+experimentsToPlottable :: [[Int]] -> String+experimentsToPlottable es = unlines $ map (\(x, vs) -> unwords $ map show [x, average vs, sd vs]) $ zip [1..] $ transpose es++average :: [Int] -> Double+average xs = fromIntegral (sum xs) / fromIntegral (length xs)++variance :: [Int] -> Double+variance xs = average [ x*x | x<-xs] - ave * ave+ where ave = average xs++sd :: [Int] -> Double+sd xs = sqrt $ variance xs++-- チームメイトがまだparameterizeされていなくて、TESTで頑張ってる+main = do let ver = versionInfo+ hPutStrLn stderr ver+ mbFilename <- lookupEnv "EXPSPEC"+ es <- case mbFilename of Nothing -> do hPutStrLn stderr "EXPSPEC not defined. Using the default."+ return defaultES+ Just fn -> do cs <- readFile fn+ readIO cs+ resultss <- tryManyExperiments es+ let reportLastGames n = let results = concat $ map (drop (numGames es - n)) resultss+ in "Average of averages of last "++shows n " games = " ++ shows (average results) ", S.D. = " ++ shows (sd results) "\n"+ appendFile (outFile es) $ ver ++ "\n" ++ show resultss ++ '\n' : reportLastGames 5 ++ reportLastGames 10++reproduceSplit :: IO ()+reproduceSplit = do+ hSetBuffering stdout NoBuffering+ let g0 = read "SMGen 11480901701853605824 13110886293999377183" :: SMGen+ let g = read "SMGen " :: SMGen+ putStrLn ("(g0,g) = " ++ show (g0,g))+#ifdef TEST+ almc <- mkAdaptiveLMC (PADSL (PALMC 0 AverageScore PartiallyObserved 800 False) 1 (ProgsPerDepth 200000)) simpleInstinct g0+#else+ almc <- mkAdaptiveLMC (PADSL (PALMC 0 AverageScore PartiallyObserved 800 False) 1 (ProgsPerDepth 200000)) instinct g0+#endif+ runStateT runOnceToInt (almc,g)+ return ()
client.hs view
@@ -1,18 +1,5 @@-import Game.Hanabi.VersionInfo-import Game.Hanabi.Client--import Game.Hanabi.Strategies.SimpleStrategy hiding (main)-import Game.Hanabi.Strategies.StatefulStrategy hiding (main)-import Game.Hanabi.Strategies.Stateless hiding (main)-import Game.Hanabi.Strategies.EndGameSearch hiding (main)--main = client defOpt{strategies=strs}---- strs :: [(String, IO (DynamicStrategy IO))]-strs = [- ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S),- ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []),- ("Stateless implementation of the strategy with states", return $ mkDS "Stateless implementation of the strategy with states" SL),- ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG)- -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))- ]+import Game.Hanabi.VersionInfo(defOpt)+--import Game.Hanabi.Msg(Options(..))+import Game.Hanabi.Client(client, Options(..))+import Game.Hanabi.Strategies(predefinedStrategies)+main = client defOpt{strategies=predefinedStrategies}
examples/exampleStrategy.lhs view
@@ -1,8 +1,8 @@ #!/bin/sh-cabal install --flags=jsaddle miso # This is important: unregister beforehand if already built without the jsaddle flag.-cabal install --flags=jsaddle hanabi-dealer-cabal exec runghc -- $0 &-firefox "localhost:8080"+cabal install --flags=jsaddle miso # This is important for cabal v1: unregister beforehand if already built without the jsaddle flag.+cabal install --flags="jsaddle server -mhlmc" hanabi-dealer+runghc $0 -package hanabi-dealer & # cabal exec --flags="jsaddle -mhlmc" -- runghc -- $0 &+chromium-browser "http://localhost:8080" exit @@ -18,7 +18,8 @@ import Data.Bits(bit, (.&.)) import qualified Data.IntMap as IM -import Game.Hanabi.Strategies.EndGameSearch hiding (main)+import Game.Hanabi.Strategies.EndGameLite+import Game.Hanabi.Strategies(mksd, mkStr, Constrs) \end{code} The following is a renamed copy of EndGameSearch.hs.@@ -50,8 +51,8 @@ guessedAnn:_ -> guessedAnn _ -> realAnn | realAnn <- myAnns ]- hintedAnns = [ ann{possibilities = (currentColPos, newNumberPos)}- | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=(currentColPos, currentNumPos)} <- myAnns+ hintedAnns = [ ann{possibilities = narrowedPos}+ | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=currentPos} <- myAnns , (p,pvInQ,c) <- take 1 [ (p,pvq,c) | (p, pvq, Hint q (Left d)) <- zip3 [1..] pvs mvs, c==d && p `mod` numPlayers (gameSpec pub) == q ] , let pubInQ = publicView pvInQ@@ -59,11 +60,11 @@ , not $ or [ isObviouslyPlayable pubInQ m | Ann{marks=(Just i, _),possibilities=m} <- myAnnsInQ, c==i ] -- Exclude if there is a playable card with the color. , ann <- take 1 [ ann | ann@Ann{marks=(Just i,_)} <- myAnnsInQ, c==i ]- , let newNumberPos = bit $ rankToBitPos (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.+ , let narrowedPos = currentPos .&. rankToQit (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True. , ixDeck ann == ix , not $ isDefinitelyUnplayable pvInQ ann- , newNumberPos .&. currentNumPos /= 0 ]+ , narrowedPos /= 0 ] pub = publicView pv myAnns = head $ annotations pub in pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : tail pvs@@ -89,32 +90,39 @@ myAnns = head $ annotations pub myHand = zip [0..] myAnns numHand = length myAnns+ colorHint pl = Hint pl . Left . color+ rankHint pl = Hint pl . Right . rank isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ]) || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just num)}) <- nextPlayer, color c == col ] isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer. markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new.- markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ rank te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ]+ markUnhintedCritical = take 1 [ if isColorMarkable (color te) then colorHint 1 te else rankHint 1 te | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ] keep2 = take 1 [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ] unhintedNon2 = [ t | t@(_, c@(C _ n), ann) <- nextPlayer, n/=K2 || isUseless pub c, not $ isHinted $ marks ann ]- colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked+ colorMarkUnmarkedPlayable = take 1 [ colorHint 1 d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked isNewestOfColor i d, -- but be cautious not to color-mark newer cards. not $ havePlayableCardWithTheSameColor $ color d ] -- refrain marking if I have a playable card with the same color- colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked.+ colorMarkNumberMarkedPlayable = take 1 [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ] removeDuplicate = take 1 [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- myHand ], m `elem` [ m' | (_, Ann{marks=m'}) <- xs ] ]- numberMarkPlayable = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked.+ numberMarkPlayable = take 1 [ rankHint 1 d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ] havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ]- numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ rankToBitPos (rank d)) ]- colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{possibilities=p@(_, pn)}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ colorToBitPos (color d), pn),+ numberMarkIfInformative cond = take 1 [ rankHint 1 d | (_,d,Ann{marks=(Just _,Nothing),possibilities=p}) <- nextPlayer, not $ cond pub p, cond pub (p .&. rankToQit (rank d)) ]+ numberMarkUselessIfInformative = numberMarkIfInformative isObviouslyUseless+ numberMarkUncriticalIfInformative = numberMarkIfInformative isObviouslyUncritical+ colorMarkIfInformative cond = take 1 [ colorHint 1 d | (i,d,Ann{marks=(Nothing,Just _),possibilities=p}) <- reverse nextPlayer, not $ cond pub p, cond pub (p .&. colorToQit (color d)), isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.- numberMarkUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]- numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]- colorMarkColorUnmarked = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p,+ colorMarkUselessIfInformative = colorMarkIfInformative isObviouslyUseless+ colorMarkUncriticalIfInformative = colorMarkIfInformative isObviouslyUncritical++ numberMarkUnmarked = take 1 [ rankHint 1 d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]+ numberMarkNumberUnmarked = take 1 [ rankHint 1 d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]+ colorMarkColorUnmarked = take 1 [ colorHint 1 d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. playPlayable5 = take 1 [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ] dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,ann) <- reverse myHand, isDefinitelyUseless pv ann ]@@ -168,9 +176,10 @@ \begin{code} main = client defOpt{strategies=strs} --- strs :: [(String, IO (DynamicStrategy IO))]-strs = [- ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG),- ("example strategy", return $ mkDS "example strategy" ES)++strs :: [(String, Maybe Constrs)]+strs = map mkStr [+ ("simpler example strategy", mksd S),+ ("example strategy", mksd ES) ] \end{code}
hanabi-dealer.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.11.0.2+version: 0.15.1.1 -- A short (one-line) description of the package. synopsis: Hanabi card game@@ -19,7 +19,7 @@ -- description: -- URL for the project homepage or repository.-homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/Sontakki/+homepage: https://nautilus.cs.miyazaki-u.ac.jp/~skata/Sontakki/ -- The license under which the package is released. license: BSD3@@ -61,12 +61,14 @@ Flag WARP Description: Use Warp instead of runServer. Default: True-FLAG TFRANDOM- Description: Use tf-random instead of random.- Default: True++-- -- Temporarily commented out because this is misleading. Use of random >=1.2.0 is recommended.+-- FLAG TFRANDOM+-- Description: Use tf-random instead of random.+-- Default: True+ FLAG official Description: The client connects to the official server URI instead of localhost.- (NB: Currently the official server is behind our firewall and is being tested internally.) Default: False FLAG TH Description: Use template-haskell just for obtaining the compilation time.@@ -82,13 +84,22 @@ Flag examples Description: Include example strategies in the library. Default: True+Flag mhlmc+ Description: Include strategies using MagicHaskeller. (Patched version of MagicHaskeller is recommended.)+ Default: False+Flag miso1710+ Description: Avoid using miso>=1.8.* when building with GHCJS, because those versions do not work with Konqueror or Falkon.+ Default: True+Flag debug+ Description: debug flag+ Default: False library -- Modules exported by the library.- exposed-modules: Game.Hanabi+ exposed-modules: Game.Hanabi, Game.Hanabi.Strategies.EndGameLite, Game.Hanabi.Strategies.EndGameOld -- Other library packages from which modules are imported.- build-depends: base >=4.8 && <4.14, containers >=0.5, random >=1.1+ build-depends: base >=4.8 && <4.15, containers >=0.5, random >=1.1 -- Modules included in this library but not exported. -- other-modules:@@ -103,9 +114,16 @@ -- Base language which the package is written in. default-language: Haskell2010 - if flag(examples)- exposed-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch-+ if flag(debug)+ cpp-options: -DDEBUG+ build-depends: QuickCheck+ if flag(examples) || flag(mhlmc) || impl(ghcjs)+ exposed-modules: Game.Hanabi.Strategies, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch, Game.Hanabi.Strategies.MCSearch, Game.Hanabi.Strategies.LazyMC+ build-depends: tf-random, array+ if flag(mhlmc)+ cpp-options: -DMHLMC+ exposed-modules: Game.Hanabi.Strategies.AppendDSL, Game.Hanabi.Strategies.AdaptiveLMC+ build-depends: MagicHaskeller >=0.9.7.0, parallel if impl(ghcjs) || flag(server) || flag(jsaddle) exposed-modules: Game.Hanabi.VersionInfo other-modules: Game.Hanabi.Msg@@ -119,9 +137,9 @@ -- Not sure if -O2 is worthy, but this should be OK because the server is not built by default. exposed-modules: Game.Hanabi.Backend build-depends: websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string- if flag(TFRANDOM)- build-depends: tf-random- cpp-options: -DTFRANDOM+-- if flag(TFRANDOM)+-- build-depends: tf-random+-- cpp-options: -DTFRANDOM 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@@ -131,50 +149,65 @@ cpp-options: -DWARP if impl(ghcjs) || flag(jsaddle) exposed-modules: Game.Hanabi.Client+ build-depends: servant >=0.12+ -- miso-1.7.1.0 fails to build without servant if impl(ghcjs)- build-depends: base >=4.12 && <4.14, aeson, miso, time, network-uri >=2.6+ build-depends: base >=4.12 && <4.15, aeson, time, network-uri >=2.6 other-modules: Game.Hanabi.FFI ghcjs-options: -dedupe -O+ if flag(miso1710)+ build-depends: miso <1.8+ else+ build-depends: miso else- build-depends: base <4.14, aeson, miso, time, network-uri >=2.6+ build-depends: base <4.15, aeson, miso, time, network-uri >=2.6 build-depends: wai, warp, websockets, jsaddle, jsaddle-warp if flag(official)- cpp-options: -DWSURI="ws://133.54.228.39:8720"+ cpp-options: -DWSURI="//nautilus.cs.miyazaki-u.ac.jp/wshanabi" -- if flag(jsaddle) -- build-depends: warp, wai, websockets executable hanabiq main-is: all.hs- other-modules: Game.Hanabi, Game.Hanabi.Msg, Game.Hanabi.Backend, Game.Hanabi.Client, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch+ other-modules: Game.Hanabi, Game.Hanabi.Strategies, Game.Hanabi.Strategies.EndGameLite, Game.Hanabi.Strategies.EndGameOld, Game.Hanabi.Msg, Game.Hanabi.Backend, Game.Hanabi.Client, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch, Game.Hanabi.Strategies.MCSearch, Game.Hanabi.Strategies.LazyMC+ build-depends: tf-random, array -- if !flag(all) if !flag(jsaddle) buildable: False else ghc-options: -O0 -rtsopts- cpp-options: -DWSURI="ws://localhost:8080/ws/" -DWARP -DALL- build-depends: base >=4.9 && <4.14, containers >=0.5, random >=1.1, jsaddle, jsaddle-warp >=0.9, aeson, miso >=1.4, servant >=0.12, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types, network-uri >=2.6+ cpp-options: -DWSURI="//localhost:8080/ws/" -DWARP -DALL+ build-depends: base >=4.9 && <4.15, containers >=0.5, random >=1.1, jsaddle, jsaddle-warp >=0.9, aeson, miso >=1.4, servant >=0.12, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types, network-uri >=2.6 -- I am not sure but seemingly miso fails to build without servant.- if flag(TFRANDOM)- build-depends: tf-random- cpp-options: -DTFRANDOM+-- if flag(TFRANDOM)+-- build-depends: tf-random+-- cpp-options: -DTFRANDOM default-language: Haskell2010 executable hanabib main-is: server.hs- other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch+ other-modules: Game.Hanabi.Strategies, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch, Game.Hanabi.Strategies.MCSearch, Game.Hanabi.Strategies.LazyMC+ build-depends: tf-random, array if impl(ghcjs) || !flag(server) buildable: False else ghc-options: -O2 -threaded -Wall -rtsopts -- Not sure if -O2 is worthy, but this should be OK because the server is not built by default. cpp-options: -DCABAL- build-depends: base >=4.8 && <4.14, containers >=0.5, random >=1.1, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, hanabi-dealer+ build-depends: base >=4.8 && <4.15, containers >=0.5, random >=1.1, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, array, hanabi-dealer default-language: Haskell2010+ if flag(mhlmc)+ cpp-options: -DMHLMC+ other-modules: Game.Hanabi.Strategies.AppendDSL, Game.Hanabi.Strategies.AdaptiveLMC+ build-depends: MagicHaskeller >=0.9.7.0, parallel+ if flag(debug)+ cpp-options: -DDEBUG+ build-depends: QuickCheck if flag(TH) build-depends: template-haskell- if flag(TFRANDOM)- build-depends: tf-random- cpp-options: -DTFRANDOM+-- if flag(TFRANDOM)+-- build-depends: tf-random+-- cpp-options: -DTFRANDOM 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@@ -185,20 +218,53 @@ executable hanabif main-is: client.hs- other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch+ other-modules: Game.Hanabi.Strategies, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch, Game.Hanabi.Strategies.MCSearch, Game.Hanabi.Strategies.LazyMC+ build-depends: tf-random, array if !impl(ghcjs) && !flag(jsaddle) buildable: False else ghcjs-options: -dedupe -O cpp-options: -DCABAL+ if flag(debug)+ cpp-options: -DDEBUG+ build-depends: QuickCheck if !impl(ghcjs)- build-depends: base >=4.9 && <4.14, containers >=0.5, random >=1.1, jsaddle, jsaddle-warp >=0.9, aeson, miso >=1.4, servant >=0.12, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types, network-uri >=2.6+ build-depends: base >=4.9 && <4.15, containers >=0.5, random >=1.1, jsaddle, jsaddle-warp >=0.9, aeson, miso >=1.4, servant >=0.12, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types, network-uri >=2.6 else- build-depends: base >=4.12 && <4.14, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time >=1.6, hanabi-dealer, network-uri >=2.6+ build-depends: base >=4.12 && <4.15, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, time >=1.6, hanabi-dealer, network-uri >=2.6+ if flag(miso1710)+ build-depends: miso <1.8+ else+ build-depends: miso default-language: Haskell2010+ if flag(mhlmc)+ cpp-options: -DMHLMC+ other-modules: Game.Hanabi.Strategies.AppendDSL, Game.Hanabi.Strategies.AdaptiveLMC+ build-depends: MagicHaskeller >=0.9.7.0, parallel if flag(official)- cpp-options: -DWSURI="ws://133.54.228.39:8720"+-- cpp-options: -DWSURI="//133.54.228.39:8720"+ cpp-options: -DWSURI="//nautilus.cs.miyazaki-u.ac.jp/wshanabi" if flag(TH) build-depends: template-haskell -- if flag(jsaddle) -- build-depends: warp, wai, websockets++-- hanabibat executes batch experiments and prints the resulting statistics+executable hanabibat+ main-is: batch.hs+ other-modules: Game.Hanabi.Strategies, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch, Game.Hanabi.Strategies.MCSearch, Game.Hanabi.Strategies.LazyMC,+ Game.Hanabi.VersionInfo,+ Game.Hanabi.Strategies.AppendDSL, Game.Hanabi.Strategies.AdaptiveLMC+ build-depends: base >=4.8 && <4.15, containers >=0.5, random >=1.2, splitmix, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6, text >=1.2, utf8-string, array, hanabi-dealer, parallel, transformers, MagicHaskeller >=0.9.7.0+ if !flag(mhlmc)+ buildable: False+ else+ default-language: Haskell2010+ ghc-options: -threaded -Wall -rtsopts+ -- Maybe -O2 is desired?+ cpp-options: -DCABAL -DMHLMC+ if flag(debug)+ cpp-options: -DDEBUG+ build-depends: QuickCheck+ if flag(TH)+ build-depends: template-haskell
server.hs view
@@ -1,18 +1,5 @@ import Game.Hanabi.Backend-import Game.Hanabi.VersionInfo--import Game.Hanabi.Strategies.SimpleStrategy hiding (main)-import Game.Hanabi.Strategies.StatefulStrategy hiding (main)-import Game.Hanabi.Strategies.Stateless hiding (main)-import Game.Hanabi.Strategies.EndGameSearch hiding (main)--main = server defOpt{strategies=strs}+import Game.Hanabi.VersionInfo(defOpt)+import Game.Hanabi.Strategies(predefinedStrategies) -strs :: [(String, IO (DynamicStrategy IO))]-strs = [- ("Stupid example strategy", return $ mkDS "Stupid example strategy" S),- ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []),- ("Stateless implementation of the strategy with states", return $ mkDS "Stateless implementation of the strategy with states" SL),- ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG)- -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))- ]+main = server defOpt{strategies=predefinedStrategies}