summaryrefslogtreecommitdiff
path: root/Game/Hanabi.hs
blob: 89da39f14ebd8ef290237dae88c42211e0164ec2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-}
module Game.Hanabi(
              -- * Functions for Dealing Games
              main, selfplay, start, createGame, run,
              prettyEndGame, isMoveValid, checkEndGame, help,
              -- * Datatypes
              -- ** The Class of Strategies
              Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose,
              -- ** The Game Specification
              GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid,
              -- ** The Game State and Interaction History
              Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..),
              -- ** The Cards
              Card(..), Color(..), Number(..), cardToInt, intToCard, readsColorChar, readsNumberChar,
              -- * Utilities
              -- ** Hints
              isCritical, isUseless, bestPossibleRank, isPlayable, invisibleBag,
              -- ** Minor ones
              what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view) where
-- module Hanabi where
import qualified Data.IntMap as IM
import System.Random
import Control.Monad(when)
import Control.Monad.IO.Class(MonadIO, liftIO)
import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper)
import Data.Maybe(fromJust)
import Data.List(isPrefixOf, group)
import System.IO
import Data.Dynamic

import GHC.Generics hiding (K1)

data Number  = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)
data Color = White | Yellow | Red | Green | Blue | Multicolor
  deriving (Eq, Show, Read, Enum, Generic)
readsColorChar :: ReadS Color
readsColorChar (c:str)
  | isSpace c = readsColorChar str
  | otherwise = case lookup (toUpper c) [(head $ show i, i) | i <- [White, Yellow, Red, Green, Blue]] of
                           Nothing -> []
                           Just i  -> [(i, str)]
readsColorChar [] = []
readsNumberChar :: ReadS Number
readsNumberChar ('0':rest) = [(Empty,rest)]
readsNumberChar str = reads ('K':str)

data Card = C {color :: Color, number :: Number} deriving (Eq, Generic)
instance Show Card where
  showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++)
instance Read Card where
  readsPrec _ str = [(C i k, rest) | (i, xs) <- readsColorChar str, (k, rest) <- readsNumberChar xs]
cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c)
intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Number)) of (c,k) -> C (toEnum c) (toEnum k)
type Index = Int -- starts from 0

data Move = Drop {index::Index}            -- ^ drop the card (0-origin)
          | Play {index::Index}            -- ^ play the card (0-origin)
          | Hint Int (Either Color Number) -- ^ give hint to the ith next player
            deriving (Eq, Generic)
instance Show Move where
    showsPrec _ (Drop i) = ("Drop"++) . shows i
    showsPrec _ (Play i) = ("Play"++) . shows i
    showsPrec _ (Hint i eith) = ("Hint"++) . shows i . (either (\i -> (take 1 (show i) ++)) (\k -> tail . shows k) eith)
instance Read Move where
    readsPrec _ str
      = let (cmd,other) = span (not.isSpace) str'
            str' = dropWhile isSpace str
        in case span (not . (`elem` "dDpP")) cmd of
          (tk, d:dr) | all (not.isAlphaNum) tkdr && null (drop 1 $ group tkdr) -> [((if toLower d == 'd' then Drop else Play) $ length tk, other)] 
                    where tkdr = tk++dr
          _ -> case span isAlpha str' of
                        (kw, xs)  | kwl `isPrefixOf` "hint" -> parseHint xs  -- Since kwl can be "", "11" parses as "Hint11".
                                  | kwl `isPrefixOf` "drop" -> [(Drop i, rest) | (i, rest) <- reads xs]
                                  | kwl `isPrefixOf` "play" -> [(Play i, rest) | (i, rest) <- reads xs]
                                  where kwl = map toLower kw
                        _         -> []
                 where parseHint xs = [(Hint i eith, rest) | let (istr, ys) = splitAt 1 $ dropWhile isSpace xs -- These two lines is similar to @(i, ys) <- reads xs@,
                                                           , (i, _) <- reads istr                              -- but additionally accepts something like "hint12".
                                                           , let ys' = dropWhile isSpace ys
                                                           , (eith, rest) <- [ (Left c, zs) | (c,zs) <- readsColorChar ys' ] ++ [ (Right c, zs) | (c,zs) <- readsNumberChar ys' ] ]

-- | The help text.
help :: String
help = "`Play0',  `play0',   `P0', `p0', etc.        ... play the 0th card from the left (0-origin).\n"
     ++"`Drop1',  `drop1',   `D1', `d1', etc.        ... drop the 1st card from the left (0-origin).\n"
     ++"`Hint2W', `hint2w', `h2w', `H2W', `2w', etc. ... tell the White card(s) of the 2nd next player.\n"
     ++"`Hint14',           `h14', `H14', `14', etc. ... tell the Rank-4 card(s) of the next player.\n"
     ++"`---P-',  `@@@p@', `___P', `...p', etc.      ... play the 3rd card from the left (0-origin). Letters other than p or P must not be alphanumeric. Also note that just `p' or `P' means playing the 0th card.\n"
     ++"`D////',  `d~~~~', `D',    `d',    etc.      ... drop the 0th card from the left (0-origin). Letters other than d or D must not be alphanumeric.\n"

-- | 'Rule' is the datatype representing the game variants.
--
--   [Minor remark] When adopting Variant 4, that is, the rule of continuing even after a round after the pile is exhausted, there can be a situation where a player cannot choose any valid move, because she has no card and there is no hint token.
--   This can happen, after one player (who has no critical card) repeats discarding, and other players repeat hinting each other, consuming hint tokens.
--   Seemingly, the rule book does not state what happens in such a case, but I (Susumu) believe the game should end as failure, then, because
--
--   * This situation can easily be made, and easily be avoided;
--
--   * If deadline is set up, this should cause time out;
--
--   * When Variant 4 is adopted, the game must end with either the perfect game or failure.
--
--   See also the definition of 'checkEndGame'.
data Rule = R { numBlackTokens :: Int    -- ^ E.g., if this is 3, the third failure ends the game with failure.
              , funPlayerHand  :: [Int]  -- ^ memoized function taking the number of players; the default is [5,5,4,4,4,4,4,4,4,4,4,4,4,4]
              , numColors      :: Int    -- ^ number of colors. 5 for the normal rule, and 6 for Variant 1-3 of the rule book.
              , prolong        :: Bool   -- ^ continue even after a round after the pile is exhausted. @True@ for Variant 4 of the rule book.
              , numMulticolors :: [Int]  -- ^ number of each of multicolor cards. @[3,2,2,2,1]@ for Variant 1 (and Variant 3?), and @[1,1,1,1,1]@ for Variant 2.

--          x , multicolor     :: Bool   -- ^ multicolor play, or Variant 3
              } deriving (Show, Read, Eq, Generic)
isRuleValid rule@R{..} = numBlackTokens > 0 && all (>0) funPlayerHand && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors)
-- | @defaultRule@ is the normal rule from the rule book of the original card game Hanabi.
defaultRule = R { numBlackTokens = 3
                , funPlayerHand  = [5,5]++take 12 (repeat 4)
                , numColors      = 5
                , prolong        = False
                , numMulticolors = replicate 5 0
--          x , multicolor     = False
              }
defaultGS = GS{numPlayers=2, rule=defaultRule}
initialPileNum gs = sum (take (numColors $ rule gs) $  [10,10,10,10,10]++[sum (numMulticolors $ rule gs)])
                    - numPlayerHand gs * numPlayers gs
numPlayerHand gs = (funPlayerHand (rule gs) ++ repeat 4) !! (numPlayers gs - 2)
data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic)

-- | State consists of all the information of the current game state, including public info, private info, and the hidden deck.
data State = St { publicState :: PublicInfo
                , pile :: [Card]    -- ^ invisible card pile or deck.
                , hands :: [[Card]] -- ^ partly invisible list of each player's hand.
                                    --   In the current implementation (arguably), this represents [current player's hand, next player's hand, second next player's hand, ...]
                                    --   and this is rotated every turn.
                } deriving (Read, Show, Eq, Generic)

-- | PublicInfo is the info that is available to all players.
data PublicInfo = PI { gameSpec  :: GameSpec
                     , pileNum   :: Int               -- ^ The number of cards at the pile.
                     , played    :: IM.IntMap Number  -- ^ @'Color' -> 'Number'@. The maximum number of successfully played cards of etch number.

                                                      -- Just a list with length 5 or 6 could do the job.
                     , discarded :: IM.IntMap Int     -- ^ @'Card' -> Int@. The multiset of discarded cards.

                     , nonPublic :: IM.IntMap Int     -- ^ @'Card' -> Int@. The multiset of Cards that have not been revealed to the public.
                                                      --   This does not include cards whose Color and Number are both revealed.
                                                      --
                                                      --   This is redundant information that can be computed from 'played' and 'discarded'.
                     , turn      :: Int               -- ^ How many turns have been completed since the game started. This can be computed from 'pileNum', 'deadline', and @map length 'givenHints'@.
                     , lives      :: Int              -- ^ The number of black tokens. decreases at each failure
                     , hintTokens :: Int              -- ^ The number of remaining hint tokens.

--                 , numHandCards :: [Int]  -- the number of cards each player has. This was used by isMoveValid, but now abolished because @numHandCards == map length . givenHints@.
                     , deadline   :: Maybe Int        -- ^ The number of turns until the endgame, after the pile exhausted. @Nothing@ when @pileNum > 0@.
                     , givenHints :: [[(Maybe Color, Maybe Number)]]
                                                      -- ^ The Number and Color hints given to each card in each player's hand.

                                                      -- Negative hints should also be implemented, but they should be kept separate from givenHints,
                                                      -- in order to guess the behavior of algorithms that do not use such information.
                     , result :: Result               -- ^ The result of the last move. This info may be separated from 'PublicInfo' in future.
                     } deriving (Read, Show, Eq, Generic)




-- | the best achievable rank for each color.
bestPossibleRank :: PublicInfo -> Color -> Number
bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numCards (gameSpec pub) iro)
                                                                                (map ((discarded pub IM.!) . cardToInt . C iro) [K1 .. K5])
numCards :: GameSpec -> Color -> [Int]
numCards gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1]
-- | isUseless pi card means either the card is already played or it is above the bestPossibleRank.
isUseless :: PublicInfo -> Card -> Bool
isUseless pub card =  number card <= (played pub IM.! fromEnum (color card)) -- the card is already played
                   || number 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 = not (isUseless pub card)
                      && succ (discarded pub IM.! cardToInt card) == (numCards (gameSpec pub) (color card) !! (pred $ fromEnum $ number card))

isPlayable :: PublicInfo -> Card -> Bool
isPlayable pub card = pred (number card) == played pub IM.! fromEnum (color card)


-- | 'Result' is the result of the last move.
data Result = None -- ^ Hinted or at the beginning of the game
            | Discard Card | Success Card | Fail Card deriving (Read, Show, Eq, Generic)

-- The view history [PrivateView] records the memory of what has been visible `as is'. That is, the info of the cards in the history is not updated by revealing them.
-- I guess, sometimes, ignorance of other players might also be an important knowledge.
-- Algorithms that want updated info could implement the functionality for themselves.


-- | PrivateView is the info that is available to the player that has @head 'hands'@.
data PrivateView = PV { publicView :: PublicInfo
                      , handsPV :: [[Card]]           -- ^ Other players' hands. [next player's hand, second next player's hand, ...]
                                                      --   This is based on the viewer's viewpoint (unlike 'hands' which is based on the current player's viewpoint),
                                                      --   and the view history @[PrivateView]@ must be from the same player's viewpoint (as the matter of course).
                      } deriving (Read, Show, Eq, Generic)
-- | 'invisibleBag' returns the bag of unknown cards (which are either in the pile or in the player's hand).
invisibleBag :: PrivateView
                -> IM.IntMap Int -- ^ @'Card' -> Int@
invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ handsPV pv 

prettyPV :: Verbosity -> PrivateView -> String
prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n"
                                              ++ concat (replicate (length myHand) " __") ++ "\n"
                                              ++ concat (replicate (length myHand) "|**") ++ "|\n"
                                              ++ (if markHints v then showHintLine myHand else "")
                                     -- x         ++ concat (replicate (length myHand) " ~~") ++ "\n"
                                              ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]
                                              ++ concat (zipWith3 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) $ tail $ givenHints pub)
  where myHand = head (givenHints pub)
prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) $ givenHints pub)
verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markHints=True}
prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [(Maybe Color, Maybe Number)] -> String
prettyHand v pub ithPnumP i cards hl = "\n\n" ++ ithPnumP i ++ " hand:\n"
--                          ++ concat (replicate (length cards) " __") ++ " \n"
                          ++ concat [ if markUseless v && isUseless pub card then " .."
                                      else case (warnCritical v && tup==(Nothing,Nothing) && isCritical pub card, markPlayable v && isPlayable pub card) of
                                             (True, True)  -> " !^"
                                             (True, False) -> " !!"
                                             (False,True)  -> " _^"
                                             (False,False) -> " __"
                                    | (card, tup) <- zip cards hl ] ++"\n"
                          ++ concat [ '|':show card | card <- cards ] ++"|\n"
                          ++ (if markHints v then showHintLine hl else "")
                          ++ concat (replicate (length cards) "+--")

showHintLine :: [(Maybe Color, Maybe Number)] -> String
showHintLine hl = '|' : concat [ maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n"

-- | '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 ".."
                   , markPlayable :: Bool -- ^ mark playable cards with "_^". ("!^" if it is unhinted critical and warnCritical==True.)
                   , markHints    :: Bool -- ^ mark hints
                   } deriving (Read, Show, Eq, Generic)


prettyPI pub
{- This was too verbose
  = let
      showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), "
      showDeck 1 = "1 card at the deck, "
      showDeck n = shows n " cards at the deck, "
    in  "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n"
-}
  = let
      showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "
      showDeck 1 = "Deck: 1,  "
      showDeck n = "Deck: " ++ shows n ",  "
    in  "Turn: "++ shows (turn pub) ",  " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ",  Hints: " ++ shows (hintTokens pub) ";\n\n"
            ++ "played:" ++ concat [ "  " ++ concat [ show $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ]
            ++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n"

view :: State -> PrivateView
view st = PV {publicView = publicState st,
              handsPV    = tail $ hands st}

main = selfplay defaultGS

-- | 'selfplay' starts selfplay with yourself:)
--
--   Also,
--
-- > selfplay defaultGS{numPlayers=n}
--
--  (where 1<n<10) starts selfplay with youselves:D
selfplay gs
     = do g <- newStdGen
          ((finalSituation,_),_) <- start gs [stdio] g
          putStrLn $ prettyEndGame finalSituation

-- | 'prettyEndGame' can be used to pretty print the final situation.
prettyEndGame :: (EndGame, [State], [Move]) -> String
prettyEndGame (eg,sts@(st:_),mvs)
   = unlines $ recentEvents ithPlayerFromTheLast (map view sts) mvs :
               replicate 80 '!' :
               surround (replicate 40 '!') (show eg) :
               replicate 80 '!' :
               map (surround $ replicate 38 ' ' ++"!!") (lines $ prettySt ithPlayerFromTheLast st) ++
             [ replicate 80 '!' ]
surround ys xs = let len  = length xs
                     len2 =len `div` 2
                 in reverse (drop len2 ys) ++ xs ++ drop (len - len2) ys

-- | 'start' creates and runs a game. This is just the composition of 'createGame' and 'run'.
start :: (RandomGen g, Monad m, Strategies ps m) =>
       GameSpec -> ps -> g -> m (((EndGame, [State], [Move]), ps), g)
start gs players gen = let
                         (st, g) = createGame gs gen
                       in fmap (\e -> (e,g)) $ run [st] [] players
run :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps)
run states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players
                              case mbeg of Nothing -> run sts mvs ps
                                           Just eg -> return ((eg, sts, mvs), ps)

-- | The 'Strategy' class is exactly the interface that
--   AI researchers defining their algorithms have to care about.
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

      -- | '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.
                   -> [Move]     -- ^ The history of 'Move's, new to old.
                   -> p          -- ^ The strategy's current state. This can be isomorphic to @()@ if the strategy does not have any parameter.
                   -> m (Move, p) -- ^ 'move' returns the pair of the Move and the next state, wrapped with monad m that is usually either IO or Identity.
                                  --   The next state can be the same as the current one unless the algorithm is learning on-line during the game.

      -- | 'observe' is called during other players' turns. It allows (mainly) human players to think while waiting.
      --
      --   It is arguable whether algorithms running on the same machine may think during other players' turn, especially when the game is timed.
      observe :: [PrivateView] -- ^ The history of 'PrivateView's, new to old.
                 -> [Move]     -- ^ The history of 'Move's, new to old.
                 -> p          -- ^ The strategy's current state. This can be isomorphic to @()@ if the strategy does not have any parameter.
                 -> m ()
      observe _pvs _moves st = return () -- The default does nothing.
{-
                 -> m ((), p)  -- ^ 'observe' returns the next state, wrapped with monad m that is usually either IO or Identity.
                               --   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.
-}


-- 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}
type HanabiT s m a =  [PrivateView] -> [Move] -> s -> m (a, s)
type Mover    s m = HanabiT s m Move
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}
instance Monad m => Strategy (StrategyDict m s) m where
  strategyName mp = do p <- mp
                       return $ sdName p
  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


-- Should DynamicStrategy be limited to IO?
type DynamicStrategy m = StrategyDict m Dynamic
mkDS :: (Monad m, Typeable s, Strategy s m) => String -> s -> DynamicStrategy m
mkDS name s = mkDS' $ mkSD name s
mkDS' :: (Monad m, Typeable s) => StrategyDict m s -> DynamicStrategy m
mkDS' gs = SD{sdName    = sdName gs,
              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")),
              sdState   = toDyn $ sdState gs}


-- | The 'Strategies' class defines the list of 'Strategy's. If all the strategies have the same type, one can use the list instance.
--   I (Susumu) guess that in most cases one can use 'Dynamic' in order to force the same type, but just in case, the tuple instance is also provided. (Also, the tuple instance should be more handy.)
--
--   The strategies are used in order, cyclically.
--   The number of strategies need not be the same as 'numPlayers', though the latter should be a divisor of the former.
--   For normal play, they should be the same. 
--   If only one strategy is provided, that means selfplay, though this is not desired because all the hidden info can be memorized. (In order to avoid such cheating, the same strategy should be repeated.)
--   If there are twice as many strategies as 'numPlayers', the game will be "Pair Hanabi", like "Pair Go" or "Pair Golf" or whatever. (Maybe this is also interesting.)
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)
{- 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
-}
instance (Strategies p1 m, Strategies p2 m, Monad m) => Strategies (p1,p2) m where
   runARound hook states moves (p,ps) = runARound hook states moves p >>= \(tup@(mbeg,sts,mvs), p') -> case mbeg of
                                                               Nothing -> do (tups,ps') <- runARound hook sts mvs ps
                                                                             return (tups, (p',ps'))
                                                               _       -> return (tup, (p',ps))
   broadcast states moves (p1,p2) offset = do (sts, ofs) <- broadcast states moves p1 offset
                                              broadcast sts moves p2 ofs
instance (Strategy p m, Monad m) => Strategies [p] m where
--   runARound hook states moves []     = return ((Nothing, states, moves), [])
   runARound hook states moves []     = error "It takes at least one algorithm to play Hanabi!"
   runARound hook states moves [p]    = hook states moves >> runATurn states moves p >>= \(tup, p') -> return (tup, [p'])
   runARound hook states moves (p:ps) = hook states moves >> runATurn states moves p >>= \(tup@(mbeg,sts,mvs), p') -> case mbeg of 
                                                               Nothing -> do (tups,ps') <- runARound hook sts mvs ps
                                                                             return (tups, (p':ps'))
                                                               _       -> return (tup, (p':ps))
   broadcast _      _     []     _   = error "It takes at least one algorithm to play Hanabi!"
   broadcast states moves [p]    ofs = when (ofs/=0) (observe (map view states) moves p) >> return (map (rotate 1) states, pred ofs)
   broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (map view states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs)

runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p)
runATurn states moves p = let alg = move (map view $ zipWith rotate [0..] states) moves p in
                                     do (mov, p') <- alg
                                        case proceed (head states) mov of
                                          Nothing -> do name <- strategyName (fmap snd alg)
                                                        error $ show mov ++ " by " ++ name ++ ": invalid move!"  -- 'strategyName' exists in order to blame stupid algorithms:) 
                                                                                                                 -- (but seriously, this could end with failure. There is a safety net for human players.)
                                          Just st -> let nxt = rotate 1 st
                                                     in return ((checkEndGame $ publicState nxt, nxt:states, mov:moves), p')

-- | Verbose makes a player verbose. It is useful to monitor the viewpoint of a specific player.
data Verbose p = Verbose {unV :: p, verbV :: Verbosity} deriving (Read, Show)
instance (Strategy p m, MonadIO m) => Strategy (Verbose p) m where
    strategyName mp = do name <- strategyName $ fmap unV mp
                         return $ if name == "Blind" then "STDIO" else "Verbose " ++ name
    move views@(v:_) moves (Verbose p verb) = let alg = move views moves p in
                                              do name <- strategyName (fmap (\a -> Verbose (snd a) verb) alg)
                                                 liftIO $ putStrLn $ what'sUp verb name views moves
                                                 (mv,p') <- alg
                                                 -- liftIO $ putStrLn $ "Move is " ++ show mv -- This is redundant because of echo back.
                                                 return (mv, Verbose p' verb)
    observe _     []    _ = return ()
    observe (v:_) (m:_) (Verbose _ verb) = liftIO $ putStrLn $ what'sUp1 verb v m

what'sUp verb name views@(v:_) moves = replicate 20 '-' ++ '\n' :
                                  recentEvents ithPlayer views moves ++ '\n' :
                                  replicate 20 '-' ++ '\n' :
                                  "Algorithm: " ++ name ++ '\n' :
                                  prettyPV verb v ++ "\nYour turn.\n"
what'sUp1 verb v m = replicate 20 '-' ++ '\n' :
                showTrial (const "") undefined v m ++ '\n' :
                replicate 20 '-' ++ '\n' :
                prettyPV verb v

recentEvents ithP vs@(v:_) ms = unlines $ reverse $ zipWith3 (showTrial $ ithP nump) [pred nump, nump-2..0] vs ms
   where nump = numPlayers $ gameSpec $ publicView v

showTrial ithP i v m = ithP i ++ " move: " ++ replicate (length (ithP 2) - length (ithP i)) ' ' ++ show m ++
                                                        case result $ publicView v of Discard c -> ", which revealed "++shows c "."
                                                                                      Success c -> ", which succeeded revealing "++shows c "."
                                                                                      Fail    c -> ", which failed revealing " ++ shows c "."
                                                                                      _         -> "."

ithPlayer _ 0 = "My"
ithPlayer _ i = "The " ++ ith i ++"next player's"
ith 1 = ""
ith 2 = "2nd "
ith 3 = "3rd "
ith i = shows i "th "
ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's"

type STDIO = Verbose Blind
stdio = Verbose Blind verbose
data Blind = Blind
instance (MonadIO m) => Strategy Blind m where
    strategyName p = return "Blind"
    move (v:_) _ _ = do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v
                        return (mov, Blind)
data ViaHandles = VH {hin :: Handle, hout :: Handle, verbVH :: Verbosity}
instance (MonadIO m) => Strategy ViaHandles m where
    strategyName p = return "via handles"
    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)

repeatReadingAMoveUntilSuccess :: Handle -> Handle -> PrivateView -> IO Move
repeatReadingAMoveUntilSuccess hin hout v = do
    str <- hGetLine hin
    case reads str of [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else hPutStrLn hout "Invalid Move" >> repeatReadingAMoveUntilSuccess hin hout v
                      _            -> hPutStr hout ("Parse error.\n"++help) >> repeatReadingAMoveUntilSuccess hin hout v


createGame :: RandomGen g => GameSpec -> g -> (State, g) -- Also returns the new RNG state, in order not to require safe 'split' for collecting statistics. RNG is only used for initial shuffling.
createGame gs gen = splitCons (numPlayers gs) [] shuffled
           where splitCons 0 hnds stack
                   = (St {publicState = PI {gameSpec   = gs,
                                            pileNum    = initialPileNum gs,
                                            played     = IM.fromAscList [ (i,            Empty) | i <- [0 .. pred $ numColors $ rule gs] ],
                                            discarded  = IM.fromList    [ (cardToInt $ C i k, 0) | i <- take (numColors $ rule gs) [White .. Multicolor],
                                                                                                   k <- [K1 ..K5] ],
                                            nonPublic  = cardMap $ rule gs,
                                            turn       = 0,
                                            lives      = numBlackTokens $ rule gs,
                                            hintTokens = 8,
                                            deadline   = Nothing,
                                            givenHints = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (Nothing, Nothing),
                                            result     = None
                                           },
                           pile  = stack,
                           hands = hnds
                          }, g)
                 splitCons n hnds stack = case splitAt (numPlayerHand gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr
                 (shuffled, g) = shuffle (cardBag $ rule gs) gen
numAssoc = zip [K1 ..K5] [3,2,2,2,1]
cardAssoc :: Rule -> [(Card,Int)]
cardAssoc rule = take (5 * numColors rule) $
               [ (C i k, n) | i <- [White .. pred Multicolor], (k,n) <- numAssoc ] ++ [ (C Multicolor k, n) | (k, n) <- zip [K1 ..K5] (numMulticolors rule) ]
cardBag rule = concat         [ replicate n c | (c,n) <- cardAssoc rule ]
cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ]

shuffle :: RandomGen g => [Card] -> g -> ([Card], g)
shuffle xs = shuf [] xs $ length xs
shuf result _  0 gen  = (result, gen)
shuf result xs n gen  = let (i,  g)    = randomR (0, pred n) gen
                            (nth,rest) = pickNth i xs
                        in shuf (nth:result) rest (pred n) g

-- | 'isMoveValid' can be used to check if the candidate Move is compliant to the rule under the current situation. Each player can decide it based on the current 'PrivateView' (without knowing the full state).
isMoveValid :: PrivateView -> Move -> Bool
isMoveValid PV{publicView=pub} (Drop ix) = hintTokens pub < 8 && length (head $ givenHints pub) > ix && ix >= 0
isMoveValid PV{publicView=pub} (Play ix) = length (head $ givenHints pub) > ix && ix >= 0
isMoveValid PV{publicView=pub,handsPV=tlHands} (Hint hintedpl eck)
                                         = hintTokens pub > 0 &&
                                           hintedpl > 0 && hintedpl < numPlayers (gameSpec pub) &&    -- existing player other than the current
                                           not (null $ filter willBeHinted (tlHands !! pred hintedpl))
    where willBeHinted :: Card -> Bool
          willBeHinted = either (\c -> (==c).color) (\k -> (==k).number) eck
pickNth    n   xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++dr)
replaceNth n x xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++x:dr)    -- = updateNth n (const x) xs
updateNth  n f xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++f nth:dr)

-- | 'proceed' updates the state based on the current player's Move, without rotating.
proceed :: State -> Move -> Maybe State
proceed st@(St{publicState=pub@PI{gameSpec=gS}}) mv = if (isMoveValid (view st) mv) then return (prc mv) else Nothing where

  -- only used by Drop and Play
  (nth, droppedHand) = pickNth (index mv) playersHand where playersHand = head $ hands st
  (_  , droppedHint) = pickNth (index mv) playersHint where playersHint = head $ givenHints pub
  (nextHand,nextHint,nextPile, nextPileNum) = case pile st of []   -> (droppedHand,   droppedHint,                   [], 0)
                                                              d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, ps, pred $ pileNum pub)
  nextHands = nextHand : tail (hands st)
  nextHints = nextHint : tail (givenHints pub)
  prc (Drop _) = st{pile = nextPile,
                    hands = nextHands,
                    publicState = pub{pileNum = nextPileNum,
                                      discarded = IM.update (Just . succ) (cardToInt nth) $ discarded pub,
                                      nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,
                                      turn       = succ $ turn pub,
                                      hintTokens = succ $ hintTokens pub,
                                      givenHints = nextHints,
                                      deadline   = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS
                                                                                | otherwise      -> Nothing
                                                                        Just i  -> Just $ pred i,
                                      result     = Discard nth}}
  prc (Play i) | failure   = let newst@St{publicState=newpub} = prc (Drop i) in newst{publicState=newpub{hintTokens = hintTokens pub, lives = pred $ lives pub, result = Fail nth}}
               | otherwise = st{pile = nextPile,
                                hands = nextHands,
                                publicState = pub{pileNum = nextPileNum,
                                                  played = IM.update (Just . succ) (fromEnum $ color nth) (played pub),
                                                  nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,
                                                  turn       = succ $ turn pub,
                                                  hintTokens = if hintTokens pub < 8 && number nth == K5 then succ $ hintTokens pub else hintTokens pub,
                                                  givenHints = nextHints,
                                                  deadline   = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS
                                                                                            | otherwise      -> Nothing
                                                                                    Just i  -> Just $ pred i,
                                                  result = Success nth}}
    where failure = played pub IM.! fromEnum (color nth) /= pred (number nth)
  prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub,
                                                 turn       = succ $ turn pub,
                                                 givenHints = snd $ updateNth hintedpl newHints (givenHints pub),
                                                 deadline   = case deadline pub of Nothing | pileNum pub==0 -> Just $ numPlayers gS
                                                                                           | otherwise      -> Nothing
                                                                                   Just i  -> Just $ pred i,
                                                 result     = None}}
    where newHints hs = zipWith zipper (hands st !! hintedpl) hs
          zipper (C ir ka) (mi,mk) = case eik of Left  i | i==ir -> (Just i, mk)
                                                 Right k | k==ka -> (mi, Just k)
                                                 _               -> (mi,     mk)

-- | @'rotate' num@ rotates the first person by @num@ (modulo the number of players).
rotate :: Int -> State -> State
rotate num st@(St{publicState=pub@PI{gameSpec=gS}}) = st{hands       = rotateList $ hands st,
                                                         publicState = pub{givenHints = rotateList $ givenHints pub}}
    where rotateList xs = case splitAt (num `mod` numPlayers gS) xs of (tk,dr) -> dr++tk

-- | 'EndGame' represents the game score, along with the info of how the game ended.
--   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'.
data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic)

checkEndGame :: PublicInfo -> Maybe EndGame
checkEndGame pub | lives pub == 0                                        = Just Failure
                 | all (==Just K5) $ map (\k -> IM.lookup (fromEnum k) (played pub)) $ take (numColors $ rule $ gameSpec pub) [White .. Multicolor] = Just Perfect
                 | deadline pub == Just 0                              = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub
                 | hintTokens pub == 0 && null (head $ givenHints pub) = Just Failure -- No valid play is possible for the next player. This can happen when prolong==True.
                 | otherwise                                           = Nothing