#!/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"
exit


This is an example strategy module, which is actually the same as EndGameSearch, but is self-contained and thus can freely be edited in every detail.

\begin{code}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
import Game.Hanabi.VersionInfo
import Game.Hanabi.Client
import Game.Hanabi hiding (main)
import Data.Maybe(isNothing)
import Data.List(sortOn, tails)
import Data.Bits(bit, (.&.))
import qualified Data.IntMap as IM

import Game.Hanabi.Strategies.EndGameSearch hiding (main)
\end{code}

The following is a renamed copy of EndGameSearch.hs.

\begin{code}
-- An example strategy, which is actually a simplified version of EndGameSearch
data Example = ES

instance (Monad m) => Strategy Example m where
  strategyName ms = return "Example"
  move pvs@(pv:_) mvs ES = do (m, _) <- move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite $ assumeOthersAreSLLite SL
                              return (m, ES)
                              where searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) SL fallback (numPlayers $ gameSpec $ publicView pv)
                                    assumeOthersAreSLLite fallback = egl (\pub -> pileNum pub <= 1) SL fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL
\end{code}

The following is a copy of Stateless.hs.

\begin{code}
-- A stateless implementation of Stateful
data Stateless = SL

lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a]
lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]

sontakuColorHint :: [PrivateView] -> [Move] -> [PrivateView]
sontakuColorHint pvs@(pv:_) mvs = let
                           consistentGuess = [ case lookupOn ixDeck realAnn hintedAnns of
                                                 guessedAnn:_ -> guessedAnn
                                                 _            -> realAnn
                                             | realAnn <- myAnns ]
                           hintedAnns = [ ann{possibilities = (currentColPos, newNumberPos)}
                                        | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=(currentColPos, currentNumPos)} <- 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
                                              myAnnsInQ = head $ annotations pubInQ
                                        , 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.
                                        , ixDeck ann == ix

                                        , not $ isDefinitelyUnplayable pvInQ ann
                                        , newNumberPos .&. currentNumPos /= 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)
\end{code}

The following is a copy of SimpleStrategy.hs.

\begin{code}
-- An example of a simple and stupid strategy.
data Simple = S

instance Monad m => Strategy Simple m where
  strategyName ms = return "Stupid example strategy"
  move (pv:pvs) mvs s = 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
                           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 ]
                           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
                                                                                          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.
                                                                                              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.
                                                                                     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),
                                                                                              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,
                                                                                           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.
                                                                    | 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.)
                                                _                   -> []
                           sontakuPositionalDrop = 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
                                                     _ -> []
                           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 ]
                           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
--                                        ++ 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 ]
                       in return (mov, s)
\end{code}

The main function.

\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)
  ]
\end{code}