読者です 読者をやめる 読者になる 読者になる

Just $ A sandbox

プログラミングとかPCとかの技術的なメモ

MonadPlusとNearSemiringで反例探し

d.hatena.ne.jp

上の記事を読んでちょっと考えたこととかをまとめる.

NearSemiringとは和についてモノイド, 積について半群で, 0が左吸収元である左分配的集合.(wikipedia流儀; 関係ないけど以下に出てくる例はHaskellMonadで, Monad則からreturnが積の単位元になるのでNearSemiringより少し強い)
まず元の記事にあるように, MonadPlus mに対し演算mplus及び>>=によってNearSemiringの構造が入るらしい.

当然最初の疑問として, そもそもbind>>=は左右で要求する型が違うので, そもそもどこ上の演算と見てるんだよという話である.
これはmplus>>=a -> m a上などに拡張してやると定義自体は普通にできる.

class NearSemiring m where
  (<+>) :: m a -> m a -> m a
  zero :: m a
  (<*>) :: m a -> m a -> m a
  one :: m a

newtype S m a = S { unS :: a -> m a }

instance MonadPlus m => NearSemiring (S m) where
  (S ma) <+> (S mb) = S $ \x -> ma x `mplus` mb x
  zero = S $ const mzero
  (S m) <*> (S k) = S $ \x -> m x >>= k
  one = S return

上の定義によって, MonadPlus mのもとでS m *上に演算<+><*>が定まる.
これが実際にNearSemiringの構造を与えることは適当に式を変形すればできると思う.
例えば右分配則だけやると以下(ただし以下ではS xxを自然に同一視する).

(m1 <+> m2) <*> k = \x -> (m1 x `mplus` m2 x) >>= k  (<+><*>の定義)
  = \x -> (m1 x >>= k) `mplus` (m2 x >>= k)  (MonadPlusの右分配則)
  = (\x -> m1 x >>= k) <+> (\x -> m2 x >>= k)  (<+>の定義)
  = (m1 <*> k) <+> (m2 <*> k)  (<*>の定義)

さてこれでまともな演算が定義できた.
あとはQuickCheck辺りを使えば, 具体的なmに対して左分配則が成り立たないような反例を見つけてくれる.

実際に動かして発見できた反例は以下.

[0,0] <*> ([0] <+> [1]) ≠ ([0,0] <*> [0]) <+> ([0,0] <*> [1])

---> [0,1,0,1] /= [0,0,1,1]

ところで, 記事で紹介されている論文には上のようなことはざっと見た限り載っていなさそうだった.(ちゃんと読んでないので書いてあったらすいません)

論文で扱っているNearSermiringはもう少し違う感じのやつで, 例えば以下のようにして定めたDCはMonadPlusになり, よってNearSemiringの構造が入る. (コードは論文より引用)

newtype Ran f g x = Ran { unRan :: forall y. (x -> f y) -> g y }
newtype Exp f g x = Exp { unExp :: forall y. (x -> y) -> (f y -> g y) }
newtype DC f x = DC { unDC :: Ran (Exp f f) (Exp f f) x }

instance Monad (DC f) where
  return x = DC $ Ran $ \f -> f x
  DC (Ran m) >>= f = DC $ Ran $ \g -> m (\a -> unRan (unDC $ f a) g)

instance MonadPlus (DC f) where
  mzero = DC $ Ran $ \k -> Exp $ \c x -> x
  mplus (DC (Ran a)) (DC (Ran b)) = DC $ Ran $ \sk -> Exp $ \f fk -> unExp (a sk) f $ unExp (b sk) f fk

rep :: Monad m => m a -> DC m a
rep x = DC $ Ran $ \g -> Exp $ \h m -> x >>= \a -> unExp (g a) h m

abs :: MonadPlus m => DC m a -> m a
abs (DC (Ran f)) = unExp (f $ \x -> Exp $ \h m -> return (h x) `mplus` m) id mzero

さてせっかくなのでこうして定義されたDCに対しても, 前述の仕方でNearSemiring型クラスのインスタンスにし, 右分配則が成り立たない反例を探してみよう.
QuickCheckで探した所以下の例が見つかった. (ただし以下の例ではabsとrepを用いてm aDC m aを同一視している)

[0,0] <*> ([0] <+> [0]) ≠ ([0,0] <*> [0]) <+> ([0,0] <*> [0])

--> [0,0,0,0] /= [0,0,0,0,0,0]

というわけでQuickCheck様様という話でした. おしまい.

参考文献

コード

Haskellで大富豪を作ろう (5)勝敗の判定をしよう

前回までの記事

第五回 勝敗の判定をしよう

今回で1通りゲームとして遊べるようになる.
最後に, ゲームの勝敗の判定をしよう. 手札がなくなった人から抜けていき, 4位まで決定したら(3人が上がったら)ゲームを終了して結果を表示する.

game :: StateT Game IO ()
game = do
  ... (略)

  ds <- use (decks . ix t)
  ws <- use winner
  when (length ds == 0 && t `notElem` ws) $ do
    winner %= (t :)
    case t == 0 of
      True -> lift $ putStrLn $ "あなたの勝ち抜けです."
      False -> lift $ putStrLn $ "CPU" ++ show t ++ "さんが勝ち抜けました."
 
  ... (略)
 
  ws <- use winner
  when (length ws < p) $ game

main = do
  putStrLn "Let's play 大富豪!"
 
  let pl = 4
  d <- deal pl
  g <- execStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0 []
 
  let ws = zip [1..] (g^.winner)
  putStrLn $ "\n=========="
  putStrLn $ "勝敗"
  forM_ (reverse ws) $ \(i,k) -> do
    putStrLn $ show i ++ "位: " ++ (if k == 0 then "あなた" else ("CPU" ++ show k))

実行例

6人でやってみた実行例.

Let's play 大富豪!
あなたの番です.
手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥Q,♦Q,♣Q],[♥2]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 12
0:[♥Q] 1:[♦Q] 2:[♥Q,♦Q] 3:[♣Q] 4:[♥Q,♣Q] 5:[♦Q,♣Q] 6:[♥Q,♦Q,♣Q]
どのカードを出しますか?
> 6
場札:[♥Q,♦Q,♣Q]
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU4さんの番です.
パス
CPU5さんの番です.
パス
あなたの番です.
手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥2]]
候補: []
パス
場が流れました.
あなたの番です.
手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥2]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 7
0:[♦7] 1:[♥7] 2:[♦7,♥7]
どのカードを出しますか?
> 2
場札:[♦7,♥7]
CPU1さんの番です.
場札:[♥K,♣K]
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU4さんの番です.
場札:[♣A,♦A]
CPU5さんの番です.
パス
あなたの番です.
手札: [[♥9,♣9],[♥J],[♥2]]
候補: []
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU4さんの番です.
パス
場が流れました.
CPU4さんの番です.
場札:[♠3]
CPU5さんの番です.
場札:[♠4]
あなたの番です.
手札: [[♥9,♣9],[♥J],[♥2]]
候補: [[♥9],[♣9],[♥J],[♥2]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 11
場札:[♥J]
CPU1さんの番です.
場札:[♠Q]
CPU2さんの番です.
場札:[♦K]
CPU3さんの番です.
場札:[♠A]
CPU4さんの番です.
場札:[Joker 0]
CPU5さんの番です.
パス
あなたの番です.
手札: [[♥9,♣9],[♥2]]
候補: []
パス
CPU1さんの番です.
パス
CPU2さんの番です.
場札:[Joker 1]
CPU3さんの番です.
パス
CPU4さんの番です.
パス
CPU5さんの番です.
パス
あなたの番です.
手札: [[♥9,♣9],[♥2]]
候補: []
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
場が流れました.
CPU2さんの番です.
場札:[♦3]
CPU3さんの番です.
場札:[♣4]
CPU4さんの番です.
場札:[♥6]
CPU5さんの番です.
場札:[♠7]
あなたの番です.
手札: [[♥9,♣9],[♥2]]
候補: [[♥9],[♣9],[♥2]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 2
場札:[♥2]
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU4さんの番です.
パス
CPU5さんの番です.
パス
あなたの番です.
手札: [[♥9,♣9]]
候補: []
パス
場が流れました.
あなたの番です.
手札: [[♥9,♣9]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 9
0:[♥9] 1:[♣9] 2:[♥9,♣9]
どのカードを出しますか?
> 2 
場札:[♥9,♣9]
あなたの勝ち抜けです.
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
場札:[♠10,♥10]
CPU4さんの番です.
場札:[♠J,♦J]
CPU5さんの番です.
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU4さんの番です.
パス
場が流れました.
CPU4さんの番です.
場札:[♣7]
CPU5さんの番です.
場札:[♣8]
CPU1さんの番です.
場札:[♠9]
CPU2さんの番です.
場札:[♣J]
CPU3さんの番です.
場札:[♣2]
CPU4さんの番です.
パス
CPU5さんの番です.
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
CPU3さんの番です.
パス
場が流れました.
CPU3さんの番です.
場札:[♥3]
CPU4さんの番です.
場札:[♠K]
CPU4さんが勝ち抜けました.
CPU5さんの番です.
場札:[♥A]
CPU1さんの番です.
場札:[♠2]
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU5さんの番です.
パス
CPU1さんの番です.
パス
場が流れました.
CPU1さんの番です.
場札:[♣3]
CPU2さんの番です.
場札:[♣5]
CPU3さんの番です.
場札:[♦8]
CPU5さんの番です.
場札:[♦10]
CPU1さんの番です.
パス
CPU2さんの番です.
場札:[♦2]
CPU3さんの番です.
パス
CPU5さんの番です.
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
場が流れました.
CPU2さんの番です.
場札:[♦6]
CPU3さんの番です.
場札:[♠8]
CPU5さんの番です.
パス
CPU1さんの番です.
場札:[♣10]
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU5さんの番です.
パス
CPU1さんの番です.
パス
場が流れました.
CPU1さんの番です.
場札:[♥4,♦4]
CPU1さんが勝ち抜けました.
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU5さんの番です.
場札:[♥5,♠5]
CPU2さんの番です.
パス
CPU3さんの番です.
パス
CPU5さんの番です.
場札:[♠6,♣6]
CPU5さんが勝ち抜けました.
CPU2さんの番です.
パス
CPU3さんの番です.
パス
場が流れました.
CPU3さんの番です.
場札:[♦5]
CPU3さんが勝ち抜けました.
CPU2さんの番です.
場札:[♥8]
CPU2さんの番です.
場札:[♦9]
CPU2さんが勝ち抜けました.

==========
勝敗
1位: あなた
2位: CPU4
3位: CPU1
4位: CPU5
5位: CPU3
6位: CPU2

ソースコード

{-# LANGUAGE TemplateHaskell #-}
module Main where
 
import Control.Lens
import Control.Monad.State
import Control.Monad.Except
import Data.Char
import Data.List
import qualified Data.IntMap as IM
import Data.List.Split (chunksOf)
import System.Random.Shuffle (shuffleM)
 
-- (5'') 勝敗の判定をしよう
 
data Suit = Spade | Club | Diamond | Heart deriving (Eq, Enum)
data Number = N3 | N4 | N5 | N6 | N7 | N8 | N9 | N10 | N11 | N12 | N13 | N1 | N2 deriving (Eq, Ord, Enum)
data JokerNumber = J1 | J2 deriving (Eq, Ord, Enum, Show)
data Card = Card Suit Number | Joker JokerNumber deriving Eq
 
allCards :: [Card]
allCards = [Card s n | s <- [Spade .. Heart], n <- [N3 .. N2]] ++ [Joker j | j <- [J1,J2]]
 
isNormalCard :: Card -> Bool
isNormalCard (Card _ _) = True
isNormalCard _ = False
 
isJoker :: Card -> Bool
isJoker (Card _ _) = False
isJoker _ = True
 
sameNumber :: Card -> Card -> Bool
sameNumber (Card _ k) (Card _ l) = k == l
sameNumber (Joker k) (Joker l) = k == l
sameNumber _ _ = False
 
toNumber :: Int -> Number
toNumber n
  | 3 <= n && n <= 13 = toEnum $ n - 3
  | n == 1 || n == 2 = toEnum $ n + 10
  | otherwise = toNumber (n `mod` 13)
 
fromNumber :: Number -> Int
fromNumber n
  | n <= N13 = fromEnum n + 3
  | otherwise = fromEnum n - 10
 
instance Show Suit where
  show Spade = "♠"
  show Club = "♣"
  show Diamond = "♦"
  show Heart = "♥"
 
instance Show Number where
  show N1 = "A"
  show N11 = "J"
  show N12 = "Q"
  show N13 = "K"
  show k = show $ fromNumber k
 
instance Show Card where
  show (Card s n) = show s ++ show n
  show (Joker k) = "Joker " ++ show (fromEnum k)
 
instance Ord Card where
  Joker _ <= Joker _ = False
  Card _ _ <= Joker _ = True
  Joker _ <= Card _ _ = False
  Card _ k <= Card _ k' = k <= k'
 
deal :: Int -> IO [[Card]]
deal n = fmap (fmap sort . take n . chunksOf (length allCards `div` n)) $ shuffleM allCards
 
data Game = Game {
  _decks :: IM.IntMap [Card],
  _turn :: Int,
  _players :: Int,
  _layout :: Maybe [Card],
  _passtimes :: Int,
  _winner :: [Int]
  }
 
makeLenses ''Game
 
strongPairs :: [Card] -> [Card] -> [[Card]]
strongPairs lay hands = concat $ fmap combi $ filter (\h -> h !! 0 > lay !! 0) $ filter (\h -> length h >= length lay) hands' where
  hands' = groupBy sameNumber hands
  combi us = filter (\h -> length h == length lay) $ subsequences us
 
game :: StateT Game IO ()
game = do
  t <- use turn
  ws <- use winner
 
  when (t `notElem` ws) $ do
    k <- case t == 0 of
      True -> (lift $ putStrLn $ "あなたの番です.") >> runExceptT player
      False -> (lift $ putStrLn $ "CPU" ++ show t ++ "さんの番です.") >> runExceptT auto
 
    case k of
      Left () -> do
        lift $ putStrLn $ "パス"
        passtimes += 1
      Right l -> do
        lift $ putStrLn $ "場札:" ++ show l
        layout .= Just l
        passtimes .= 0
 
  p <- use players
  ws <- use winner
  pt <- use passtimes
  when (pt >= p - length ws) $ do
    lift $ putStrLn $ "場が流れました."
    layout .= Nothing
    turn -= 1
 
  ds <- use (decks . ix t)
  ws <- use winner
  when (length ds == 0 && t `notElem` ws) $ do
    winner %= (t :)
    case t == 0 of
      True -> lift $ putStrLn $ "あなたの勝ち抜けです."
      False -> lift $ putStrLn $ "CPU" ++ show t ++ "さんが勝ち抜けました."
 
  p <- use players
  turn %= nextTurn p
 
  ws <- use winner
  when (length ws < p) $ game
 
  where
    nextTurn p t | t == p-1 = 0
                 | otherwise = t+1
 
player :: ExceptT () (StateT Game IO) [Card]
player = do
  ds <- use (decks . ix 0)
  ls <- use layout
 
  lift $ lift $ putStrLn $ "手札: " ++ show (groupBy sameNumber ds)
  ps <- case (\l -> strongPairs l ds) <$> ls of
    Just ps -> (lift $ lift $ putStrLn $ "候補: " ++ show ps) >> return ps
    Nothing -> return $ concat $ fmap subsequences $ groupBy sameNumber ds
 
  when (length ps == 0) $ throwError ()
 
  lift $ lift $ putStrLn "出すカードの数字を入力してください. (J: ジョーカー, P: パス)"
  str <- lift $ lift getLine
  when (str == "P") $ throwError ()
 
  case contains str ps of
    Just ps' -> lift $ process ds ps'
    Nothing -> do
      lift $ lift $ putStrLn "正しい数字を入力してください."
      player
 
  where
    process :: [Card] -> [[Card]] -> StateT Game IO [Card]
    process ds ps = do
      case length ps == 1 of
        True -> do
          decks %= IM.insert 0 (ds \\ ps !! 0)
          return $ ps !! 0
        False -> whichToDiscard ds ps
 
    whichToDiscard :: [Card] -> [[Card]] -> StateT Game IO [Card]
    whichToDiscard ds ps = do
      let psi = zip [0..] ps
      lift $ putStrLn $ unwords $ fmap (\(i,c) -> show i ++ ":" ++ show c) psi
      lift $ putStrLn "どのカードを出しますか?"
      str <- lift getLine
      case pick str ps of
        Just cs -> do
          decks %= IM.insert 0 (ds \\ cs)
          return cs
        Nothing -> whichToDiscard ds ps
 
    contains :: String -> [[Card]] -> Maybe [[Card]]
    contains "J" ds = Just $ filter (any isJoker) ds
    contains str ds = isEmpty $ filter (any (isSameNumber (read str))) <$> check where
      check = if all isDigit str && 1 <= read str && read str <= 13
              then Just ds else Nothing
      isEmpty p = if p == Just [] then Nothing else p
 
    pick :: String -> [[Card]] -> Maybe [Card]
    pick ss ps = (!! read ss) <$> check where
      check = if (all isDigit) ss &&
                 (0 <= read ss && read ss <= length ps - 1)
              then Just ps else Nothing
 
    isSameNumber :: Int -> Card -> Bool
    isSameNumber n x = isNormalCard x && cardNumber x == n where
      cardNumber (Card _ n) = fromNumber n
      cardNumber _ = -1
 
auto :: ExceptT () (StateT Game IO) [Card]
auto = do
  t <- use turn
  ls <- use layout
  ds <- use (decks . ix t)
 
  case (\l -> strongPairs l ds) <$> ls of
    Just [] -> throwError ()
    Just ps -> do
      let ps' = ps !! 0
      decks %= IM.insert t (ds \\ ps')
      return ps'
    Nothing -> do
      let ps' = (groupBy sameNumber ds) !! 0
      decks %= IM.insert t (ds \\ ps')
      return ps'
 
main = do
  putStrLn "Let's play 大富豪!"
 
  let pl = 6
  d <- deal pl
  g <- execStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0 []
 
  let ws = zip [1..] (reverse $ g^.winner)
  putStrLn $ "\n=========="
  putStrLn $ "勝敗"
  forM_ ws $ \(i,k) -> do
    putStrLn $ show i ++ "位: " ++ (if k == 0 then "あなた" else ("CPU" ++ show k))

Haskellで大富豪を作ろう (4)基本のルールと場の流れを作ろう

前回までの記事

第四回 基本のルールと場の流れを作ろう

前回は同じ数字で組を作れるようになったので, いよいよちゃんとしたルールを作ろう.

まずは出せるカードは場にあるカードより強い数字で, 場にあるカード以上の枚数のものに限ることにしよう. (ついでに, 自分のターンには出せるカードの候補を表示しておくことにしよう)
自分のターンには, 入力された数に対して, それが正しい数字であって, 出せるカードである時にそれを出すという操作をする.

さらに, パスもできることにする.
出せるカードがない場合かパスを入力した場合はパスとして扱うことにする. このため, player, auto :: StateT Game IO [Card]の2つの函数は, パスかどうかを判断できる型に変更する.

パスかどうかを判断するにはもちろん今までのようにMaybeを使っても良いが, パスが宣言されるタイミングが2ヶ所あるので, パスを宣言するとそこで処理が終了することにすると書きやすい.
要はパスは例外処理として扱うと便利なので, 今回はパスをmtlにあるExceptモナドを使って実装しよう. (単に個人的に使ってみたかっただけともいう)

player :: ExceptT () (StateT Game IO) [Card]に対して, runExceptT player :: StateT Game IO (Either () [Card]) となるので, これを実行した結果がLeftの場合はパス, Rightの場合は[Card]がこのターンに出すカードということになる.
ちなみにplayer, autoの中ではExceptとStateの2つのモナドが重なっているので, Stateに対する処理はliftを使って持ち上げる必要がある.

player :: ExceptT () (StateT Game IO) [Card]
player = do
  ds <- use (decks . ix 0)
  ls <- use layout
 
  lift $ lift $ putStrLn $ "手札: " ++ show (groupBy sameNumber ds)
  ps <- case (\l -> strongPairs l ds) <$> ls of
    Just ps -> (lift $ lift $ putStrLn $ "候補: " ++ show ps) >> return ps
    Nothing -> return $ concat $ fmap subsequences $ groupBy sameNumber ds
 
  when (length ps == 0) $ throwError ()
 
  lift $ lift $ putStrLn "出すカードの数字を入力してください. (J: ジョーカー, P: パス)"
  str <- lift $ lift getLine
  when (str == "P") $ throwError ()
 
  case contains str ps of
    Just ps' -> lift $ process ds ps'
    Nothing -> do
      lift $ lift $ putStrLn "正しい数字を入力してください."
      player

ここで, throwErrorが例外を出す所. throwErrorが実行されるとそこで処理が終わる.

ついでにパスが繰り返されると場が流れ, 最後にカードを出した人からスタートすることにした.

さらについでに, カードを組で出す場合, 出せる組を表示してそこから選ばせるようにした.
例えば"♠2, ♥2"をもっているとき, 2の出し方は"[♠2], [♥2], [♠2, ♥2]"の3通りの出し方があるのでユーザーはこの中から出し方を選択することにした. (こっちの方が入力が簡単なので)

実行例

Let's play 大富豪!
あなたの番です.
手札: [[♦3,♠3],[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 3
0:[♦3] 1:[♠3] 2:[♦3,♠3]
どのカードを出しますか?
> 2
場札:[♦3,♠3]
CPU1さんの番です.
場札:[♠5,♣5]
CPU2さんの番です.
場札:[♦7,♣7]
CPU3さんの番です.
場札:[♦Q,♥Q]
あなたの番です.
手札: [[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
候補: [[♦K,♥K]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> P
パス
CPU1さんの番です.
パス
CPU2さんの番です.
場札:[♣2,♠2]
CPU3さんの番です.
パス
あなたの番です.
手札: [[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
候補: []
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
場が流れました.
CPU2さんの番です.
場札:[♥3]
CPU3さんの番です.
場札:[♣4]
あなたの番です.

ソースコード

{-# LANGUAGE TemplateHaskell #-}
module Main where
 
import Control.Lens
import Control.Monad.State
import Control.Monad.Except
import Data.Char
import Data.List
import qualified Data.IntMap as IM
import Data.List.Split (chunksOf)
import System.Random.Shuffle (shuffleM)
 
-- (4) 基本のルールと場の流れを作ろう
 
data Suit = Spade | Club | Diamond | Heart deriving (Eq, Enum)
data Number = N3 | N4 | N5 | N6 | N7 | N8 | N9 | N10 | N11 | N12 | N13 | N1 | N2 deriving (Eq, Ord, Enum)
data JokerNumber = J1 | J2 deriving (Eq, Ord, Enum, Show)
data Card = Card Suit Number | Joker JokerNumber deriving Eq
 
allCards :: [Card]
allCards = [Card s n | s <- [Spade .. Heart], n <- [N3 .. N2]] ++ [Joker j | j <- [J1,J2]]
 
isNormalCard :: Card -> Bool
isNormalCard (Card _ _) = True
isNormalCard _ = False
 
isJoker :: Card -> Bool
isJoker (Card _ _) = False
isJoker _ = True
 
sameNumber :: Card -> Card -> Bool
sameNumber (Card _ k) (Card _ l) = k == l
sameNumber (Joker k) (Joker l) = k == l
sameNumber _ _ = False
 
toNumber :: Int -> Number
toNumber n
  | 3 <= n && n <= 13 = toEnum $ n - 3
  | n == 1 || n == 2 = toEnum $ n + 10
  | otherwise = toNumber (n `mod` 13)
 
fromNumber :: Number -> Int
fromNumber n
  | n <= N13 = fromEnum n + 3
  | otherwise = fromEnum n - 10
 
instance Show Suit where
  show Spade = "♠"
  show Club = "♣"
  show Diamond = "♦"
  show Heart = "♥"
 
instance Show Number where
  show N1 = "A"
  show N11 = "J"
  show N12 = "Q"
  show N13 = "K"
  show k = show $ fromNumber k
 
instance Show Card where
  show (Card s n) = show s ++ show n
  show (Joker k) = "Joker " ++ show (fromEnum k)
 
instance Ord Card where
  Joker j <= Joker j' = j <= j'
  Card _ _ <= Joker _ = True
  Joker _ <= Card _ _ = False
  Card _ k <= Card _ k' = k <= k'
 
deal :: Int -> IO [[Card]]
deal n = fmap (fmap sort . take n . chunksOf (length allCards `div` n)) $ shuffleM allCards
 
data Game = Game {
  _decks :: IM.IntMap [Card],
  _turn :: Int,
  _players :: Int,
  _layout :: Maybe [Card],
  _passtimes :: Int
  }
 
makeLenses ''Game
 
strongPairs :: [Card] -> [Card] -> [[Card]]
strongPairs lay hands = concat $ fmap combi $ filter (\h -> h !! 0 >= lay !! 0) $ filter (\h -> length h >= length lay) hands' where
  hands' = groupBy sameNumber hands
  combi us = filter (\h -> length h == length lay) $ subsequences us
 
game :: StateT Game IO ()
game = do
  t <- use turn
 
  k <- case t == 0 of
    True -> (lift $ putStrLn $ "あなたの番です.") >> runExceptT player
    False -> (lift $ putStrLn $ "CPU" ++ show t ++ "さんの番です.") >> runExceptT auto
 
  case k of
    Left () -> do
      lift $ putStrLn $ "パス"
      passtimes += 1
    Right l -> do
      lift $ putStrLn $ "場札:" ++ show l
      layout .= Just l
      passtimes .= 0
 
  pt <- use passtimes
  when (pt >= 4) $ do
    lift $ putStrLn $ "場が流れました."
    layout .= Nothing
    turn -= 1
 
  p <- use players
  turn %= nextTurn p
 
  game
 
  where
    nextTurn p t | t == p-1 = 0
                 | otherwise = t+1
 
player :: ExceptT () (StateT Game IO) [Card]
player = do
  ds <- use (decks . ix 0)
  ls <- use layout
 
  lift $ lift $ putStrLn $ "手札: " ++ show (groupBy sameNumber ds)
  ps <- case (\l -> strongPairs l ds) <$> ls of
    Just ps -> (lift $ lift $ putStrLn $ "候補: " ++ show ps) >> return ps
    Nothing -> return $ concat $ fmap subsequences $ groupBy sameNumber ds
 
  when (length ps == 0) $ throwError ()
 
  lift $ lift $ putStrLn "出すカードの数字を入力してください. (J: ジョーカー, P: パス)"
  str <- lift $ lift getLine
  when (str == "P") $ throwError ()
 
  case contains str ps of
    Just ps' -> lift $ process ds ps'
    Nothing -> do
      lift $ lift $ putStrLn "正しい数字を入力してください."
      player
 
  where
    process :: [Card] -> [[Card]] -> StateT Game IO [Card]
    process ds ps = do
      case length ps == 1 of
        True -> do
          decks %= IM.insert 0 (ds \\ ps !! 0)
          return $ ps !! 0
        False -> whichToDiscard ds ps
 
    whichToDiscard :: [Card] -> [[Card]] -> StateT Game IO [Card]
    whichToDiscard ds ps = do
      let psi = zip [0..] ps
      lift $ putStrLn $ unwords $ fmap (\(i,c) -> show i ++ ":" ++ show c) psi
      lift $ putStrLn "どのカードを出しますか?"
      str <- lift getLine
      case pick str ps of
        Just cs -> do
          decks %= IM.insert 0 (ds \\ cs)
          return cs
        Nothing -> whichToDiscard ds ps
 
    contains :: String -> [[Card]] -> Maybe [[Card]]
    contains "J" ds = Just $ filter (any isJoker) ds
    contains str ds = isEmpty $ filter (any (isSameNumber (read str))) <$> check where
      check = if all isDigit str && 1 <= read str && read str <= 13
              then Just ds else Nothing
      isEmpty p = if p == Just [] then Nothing else p
 
    pick :: String -> [[Card]] -> Maybe [Card]
    pick ss ps = (!! read ss) <$> check where
      check = if (all isDigit) ss &&
                 (0 <= read ss && read ss <= length ps - 1)
              then Just ps else Nothing
 
    isSameNumber :: Int -> Card -> Bool
    isSameNumber n x = isNormalCard x && cardNumber x == n where
      cardNumber (Card _ n) = fromNumber n
      cardNumber _ = -1
 
auto :: ExceptT () (StateT Game IO) [Card]
auto = do
  t <- use turn
  ls <- use layout
  ds <- use (decks . ix t)
 
  case (\l -> strongPairs l ds) <$> ls of
    Just [] -> throwError ()
    Just ps -> do
      let ps' = ps !! 0
      decks %= IM.insert t (ds \\ ps')
      return ps'
    Nothing -> return $ (groupBy sameNumber ds) !! 0
 
main = do
  putStrLn "Let's play 大富豪!"
 
  let pl = 4
  d <- deal pl
  runStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0