Haskellで大富豪を作ろう (1)トランプを用意しカードを配ろう
まえがき
Haskellでなんか動くものを作ろうと思った.
規模と知名度等を考えて大富豪あたりが妥当なところかと思ったので, 今回はCUIの大富豪を作ろうということにした*1.
コード自体は完成しているので, 何回かに記事を分けて説明をつけて投稿していくつもり.
なおとにかく動くものを作りたいってことしか考えてなかったので完成したコードはあんまり綺麗じゃない模様.
第一回 トランプを用意しカードを配ろう
まずはトランプを用意しよう. 今回は4種類A~Kまでの通常のカードとジョーカー2枚を使用する.
これをまずはdata Cardとして定義する.
ついでに, 大富豪ではカードの強さ比較をすることが多いのでOrdのインスタンスにする.
このとき大富豪式に数字の強さを(3が弱く2が強くJokerが最強になるように)定義しておくと便利かもしれないということでそうした.
data Suit = Spade | Club | Diamond | Heart deriving (Eq, Enum, Show) 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, Show) instance Ord Card where Joker j <= Joker j' = j <= j' Card _ _ <= Joker _ = True Joker _ <= Card _ _ = False Card _ k <= Card _ k' = k <= k'
カードが用意できたら人数分配ろう.
今回は, n人参加する場合, 一人あたり54/n枚配り, 余ったカードはゲームに使用しないことにした.
deal :: Int -> IO [[Card]] deal n = fmap (take n . chunksOf (length allCards `div` n)) $ shuffleM allCards
実行例
Let's play 大富豪! [[Card Spade 3,Card Club K,Card Diamond A,Card Club J,Card Club 4,Card Heart 4,Card Heart A,Card Club Q,Card Spade A,Card Spade Q,Card Heart J,Card Spade 6,Card Heart K],[Card Club 9,Card Club 7,Card Club 2,Card Diamond 3,Card Club 10,Card Heart 9,Card Club 3,Card Spade 9,Card Club 5,Card Diamond 7,Card Diamond 8,Card Spade 4,Card Spade 8],[Card Heart 10,Card Diamond J,Joker J2,Card Heart 3,Joker J1,Card Club 6,Card Spade 7,Card Heart Q,Card Spade 10,Card Heart 5,Card Spade 5,Card Diamond 9,Card Diamond Q],[Card Club 8,Card Heart 8,Card Spade K,Card Heart 2,Card Diamond 10,Card Diamond 5,Card Heart 6,Card Diamond 4,Card Club A,Card Spade 2,Card Diamond 2,Card Heart 7,Card Spade J]]
使用したパッケージ
以下をインストールするとページ末尾のコードが動く.
なお関係ないけどインストールにはcabalじゃなくてstackとかを使うと便利.
- split: Combinator library for splitting lists. | Hackage
- random-shuffle: Random shuffle implementation. | Hackage
ソースコード
module Main where import Data.List import Data.List.Split (chunksOf) import System.Random.Shuffle (shuffleM) -- (1) トランプを用意しカードを配ろう data Suit = Spade | Club | Diamond | Heart deriving (Eq, Enum, Show) 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, Show) allCards :: [Card] allCards = [Card s n | s <- [Spade .. Heart], n <- [N3 .. N2]] ++ [Joker j | j <- [J1,J2]] instance Show Number where show N1 = "A" show N11 = "J" show N12 = "Q" show N13 = "K" show k | k <= N13 = show $ fromEnum k + 3 | otherwise = show $ fromEnum k - 10 -- 大富豪式順序 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 (take n . chunksOf (length allCards `div` n)) $ shuffleM allCards main = do putStrLn "Let's play 大富豪!" print =<< deal 4
*1:完成してから思ったのはこれは少し失敗だった. 入力値のエラーチェック等が激しく面倒なので多少無理してもブラウザで動くものにすればよかった
Haskellで大富豪を作ろう (3)カードの組を判定しよう
前回までの記事
- Haskellで大富豪を作ろう (1)トランプを用意しカードを配ろう - Just $ A sandbox
- Haskellで大富豪を作ろう (2)ターンを進めよう - Just $ A sandbox
第三回 カードの組を判定しよう
前回はカードを捨てられるようになったので, 次は同じ数字は組として一緒に出せるようにしよう.
ところで, 例えば同じカードが3枚あればそのうち好きな1枚または2枚を出すこともできるので, 何を組にして出すかはユーザーに選択させるようにしよう.
また, 左から何枚目のカードを捨てるというのは分かりにくいので, どの数字を捨てるかを入力させることにしよう.
結果として, 自分のターンには,
- 何の数字のカードを出すか選択
- 同じ数字のカードが1枚しかない場合はそれを出す. 2枚以上ある場合はカードを表示して, どのカードを出すかを選択させる
の操作を行うことにした.
player :: StateT Game IO [Card] player = do ds <- use (decks . ix 0) lift $ print $ groupBy sameNum ds lift $ putStrLn "出すカードを選択してください. (ジョーカーはJ)" str <- lift getLine case pickWith str ds of Just ps -> process ds ps Nothing -> do lift $ putStrLn "正しいカードNoを選択してください." 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) return ps False -> whichToDiscard ds ps
次回は大富豪として遊べるようになるために, カードの出し方やパスといった基本的なルールを組み込もう.
実行例
Let's play 大富豪! あなたの番です. [[♣3,♥3],[♠5],[♥7,♣7],[♥8],[♦K,♣K],[♦2,♥2,♠2],[Joker 0],[Joker 1]] 出すカードを選択してください. (ジョーカーはJ) > 3 0:♣3 1:♥3 どのカードを出しますか? (複数の場合はスペースで区切る) > 0 1 場札:[♣3,♥3] CPU1さんの番です. 場札:♠3 CPU2さんの番です. 場札:♦3 CPU3さんの番です. 場札:♠4 あなたの番です. [[♠5],[♥7,♣7],[♥8],[♦K,♣K],[♦2,♥2,♠2],[Joker 0],[Joker 1]] 出すカードを選択してください. (ジョーカーはJ) > J 0:Joker 0 1:Joker 1 どのカードを出しますか? (複数の場合はスペースで区切る) > 0 場札:[Joker 0] CPU1さんの番です. 場札:♣4 CPU2さんの番です. 場札:♣5 CPU3さんの番です. 場札:♦4 あなたの番です. [[♠5],[♥7,♣7],[♥8],[♦K,♣K],[♦2,♥2,♠2],[Joker 1]] 出すカードを選択してください. (ジョーカーはJ)
使用したパッケージ
- split: Combinator library for splitting lists. | Hackage
- random-shuffle: Random shuffle implementation. | Hackage
ソースコード
{-# LANGUAGE TemplateHaskell #-} module Main where import Control.Lens import Control.Monad.State import Data.Char import Data.List import qualified Data.IntMap as IM import Data.List.Split (chunksOf) import System.Random.Shuffle (shuffleM) -- (3) カードの組を判定しよう 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 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 } makeLenses ''Game game :: StateT Game IO () game = do t <- use turn case t == 0 of True -> do lift $ putStrLn $ "あなたの番です." k <- player lift $ putStrLn $ "場札:" ++ show k False -> do lift $ putStrLn $ "CPU" ++ show t ++ "さんの番です." k <- auto lift $ putStrLn $ "場札:" ++ show k p <- use players turn %= nextTurn p game where player :: StateT Game IO [Card] player = do ds <- use (decks . ix 0) lift $ print $ groupBy sameNum ds lift $ putStrLn "出すカードを選択してください. (ジョーカーはJ)" str <- lift getLine case pickWith str ds of Just ps -> process ds ps Nothing -> do lift $ putStrLn "正しいカードNoを選択してください." 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) return ps 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 <- words <$> lift getLine case pickThese str ps of Just cs -> do decks %= IM.insert 0 (ds \\ cs) return cs Nothing -> whichToDiscard ds ps auto :: StateT Game IO Card auto = do t <- use turn ds <- use (decks . ix t) decks %= IM.insert t (delete (ds !! 0) ds) return $ ds !! 0 nextTurn p t | t == p-1 = 0 | otherwise = t+1 pickWith :: String -> [Card] -> Maybe [Card] pickWith "J" ds = Just $ filter isJoker ds pickWith str ds = filter (isSameNumber (read str)) <$> check where check = if all isDigit str && 1 <= read str && read str <= 13 then Just ds else Nothing pickThese :: [String] -> [Card] -> Maybe [Card] pickThese ss ps = fmap snd . filter (\(i,_) -> i `elem` fmap read ss) . zip [0..] <$> check where check = if all (all isDigit) ss && all (\s -> 0 <= read s && read s <= length ps - 1) ss 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 sameNum :: Card -> Card -> Bool sameNum (Card _ k) (Card _ l) = k == l sameNum (Joker k) (Joker l) = k == l sameNum _ _ = False main = do putStrLn "Let's play 大富豪!" let pl = 4 d <- deal pl runStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl
Lens from Scratch
久しぶりのLensの記事です.
5億回は繰り返されてきたであろうLens再実装を通して, Lens, Getter, Setter, Iso, Equality, Traversal, Prism, Foldの仕組みを理解するのが目的です.
亜Lens family
Getter
Getterは基本的にはConstをかぶせる操作とそれを剥がす操作で実現可能です.
つまりgetConst (Const k) = kですが, このConst kがデータであり, getConstは値を取り出すgetterになります.
アクセサの型がGetting r s aであるとき, sからaを取り出せる(=s -> aなるgetterである)という意味です.
(^.)はGetterとデータから具体的に値を取り出し, toは函数をGetterに変換するための函数です.
type Getting r s a = (a -> Const r a) -> s -> Const r s (^.) :: s -> Getting a s a -> a s ^. l = getConst (l Const s) to :: (s -> a) -> Getting r s a to f = \k -> Const . getConst . k . f
Tuple
タプルに対するGettingアクセサが定義できます. 2変数の場合は
-- case: 2-tuple _1 :: Getting r (a,b) a _1 = to fst
とすることで, (a,b) ^. _1 == aが実現できます.
あるいは, 任意個のTupleに対してこの_1や_2を使いたい場合は, 本家のパッケージのように型クラスで定義します.
class TupleIndex t a | t -> a where _1 :: Getting r t a instance TupleIndex (a,b) a where _1 = to (\(a,_) -> a) instance TupleIndex (a,b,c) a where _1 = to (\(a,_,_) -> a)
List
リストに対してもアクセサを提供できます.
ix :: Int -> Getting r [a] a ix n = to (!! n)
例としては[1..10] ^. ix 7 == 8のようになります.
Setter
Setter(ここではSetting型)にはIdentityが使われます.
Identity xをIdentity yに書き換える操作がsetterで実現できます.
(.~)はSetting s t a b型のアクセサに対し, データsをbによって書き換えtを得る操作に対応します.
(%~)は函数を適用し, setsは函数をSetterに変換します.
type Setting s t a b = (a -> Identity b) -> s -> Identity t infixr 4 .~ (.~) :: Setting s t a b -> b -> s -> t (.~) l = (runIdentity .) . (l . const . Identity) (%~) :: Setting s t a b -> (a -> b) -> s -> t (%~) l f = runIdentity . l (Identity . f) sets :: ((a -> b) -> s -> t) -> Setting s t a b sets h = \k -> Identity . h (runIdentity . k)
Lens
さて, GetterとSetterの定義はよく似ています.
少々天下り的に導入したこれらの定義はいずれもLensの具体例になっています. (LensはGetterとSetterを一般化した概念)
定義より, GetterやSetterに対する函数はLensに対しても使えます.
lensはgetterとsetterをLensに変換する函数です.
accessor = lens getter setterのようにして使います.
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens g h = \f s -> fmap (h s) (f (g s))
Tuple
さて先ほど定義した_1はGetterではなくLensになるように拡張します.
これによって_1がGetterとしてもSetterとしても働くようになります.
class TupleIndex s t a b | s -> a, t -> b, s b -> t, t a -> s where _1 :: Lens s t a b instance TupleIndex (a,b) (a',b) a a' where _1 = lens (\(a,_) -> a) (\(_,y) b -> (b,y)) instance TupleIndex (a,b,c) (a',b,c) a a' where _1 = lens (\(a,_,_) -> a) (\(_,y,z) b -> (b,y,z))
List
Listに対するアクセサixも同様にLensに拡張します.
ix :: Int -> Lens [a] [a] a a ix n = lens (!! n) (\ts x -> take n ts ++ [x] ++ drop (n+1) ts)
Traversal
次はTraversalです. これはLensより少し制約の強いもので, 大体traverseができるようなデータです.
bothは2-tupleの両方の値に一度に処理をするようなTraversalです.
both %~ f $ (a,b) == (f a, f b)みたいに使います.
type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t traverseOf :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t traverseOf = id both :: Traversal (a,a) (b,b) a b both = \k (x,y) -> (,) <$> k x <*> k y
Each
Traversalに対する処理をさせるために, Traversalなアクセサを定義します.
例えば本家のパッケージではEachという, リストや配列の全ての要素に対する操作を行うアクセサが提供されています.
class Each s t a b | s -> a, t -> b, s b -> t, t a -> s where each :: Traversal s t a b instance Each [a] [b] a b where each = traverse
例えばtraverseOf each print [1,2,3]はリストの各値を表示して, [(),(),()]を返します.
Fold
FoldはTraversalよりさらに制約が強い型です. ただしここではTraversalもFoldも一般化していないので同じものになっています.
foldingは函数をFoldに変換します. (^..)は結果をリストにして返すのでFoldとともによく使われます.
type Fold s a = forall f. (Applicative f) => (a -> f a) -> s -> f s infixl 8 ^.. (^..) :: s -> Getting (Endo [a]) s a -> [a] s ^.. l = (appEndo $ getConst $ l (Const . Endo . (:)) s) [] folding :: Foldable f => (s -> f a) -> Fold s a folding h = \k s -> traverse_ k (h s) *> pure s
例として[[1,2],[3]] ^.. traverse . traverse == [1,2,3]や[1,2,3] ^.. folding tail == [2,3]です.
Iso
IsoはLensの(->)をProfunctorに一般化したものです.
(亜)Lensは本来ここにあるよりもっと一般化された型ですが, 今の場合は必要以上に一般化しない方針で実装をしているのでここで初めてProfunctorが登場します.
Profunctorはp a bが合った時, aとbの両方に(反変的に)函数が作用するようなデータです.
Isoは大体Iso s s a aの形で使い, s -> aとa -> sの2つの変換を保持するLensのようなものです.
class Profunctor p where dimap :: (a -> b) -> (c -> d) -> p b c -> p a d dimap f g = lmap f . rmap g lmap :: (a -> b) -> p b c -> p a c lmap f = dimap f id rmap :: (b -> c) -> p a b -> p a c rmap = dimap id instance Profunctor (->) where dimap f g k = g . k . f type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) enum :: Enum a => Iso Int Int a a enum = iso toEnum fromEnum curried :: Iso ((a, b) -> c) ((d, e) -> f) (a -> b -> c) (d -> e -> f) curried = iso curry uncurry reversed :: Iso String String String String reversed = iso reverse reverse
Equality
本家のパッケージにはIsoより更に制約の弱いEqualityという型もあります.
Isoから更にProfunctorとFunctorの制約を外したものですが, 制約がないせいでほとんど何も出来ないためあまり役に立つことはないでしょう.
type Equality s t a b = forall p f. p a (f b) -> p s (f t) simple :: Equality a a a a simple = id
Prism
PrismはLensに制約を加えたものです. ここではPrismも一般化されていないのでFoldと同じものになっています.
Prismは大体LensですがEitherを主に扱うためのものです.
prismは函数をPrismに変換し, _LeftはEitherのLeftへのアクセサです.
type Prism s t a b = forall f. Applicative f => (a -> f b) -> s -> (f t) prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt sta = \k s -> case sta s of Left t -> pure t Right a -> fmap bt $ k a _Left :: Prism (Either a c) (Either b c) a b _Left = \k s -> case s of Left a -> fmap Left $ k a Right c -> pure $ Right c
さてこのままではPrismを何かのデータ型に作用させることができませんが, 次のReviewによってそれが可能になります.
Review
ReviewはPrismの(->)の部分を一般化します.
ReviewはPrismの最初と最後の(->)の部分をProfunctorに一般化します. これによって, ReviewはProfunctorの間の変換になります.
ここで, Tagged s bはbのみをデータとしてもち, sは幽霊型になっているデータです.
instance Profunctor Tagged where dimap _ g = Tagged . g . unTagged type Review s a = forall p f. (Applicative f) => p a (f a) -> p s (f s) type AReview s a = Tagged a (Identity a) -> Tagged s (Identity s) re :: AReview s a -> Getting r a s re r = to (runIdentity . unTagged . r . Tagged . Identity) review :: AReview s a -> a -> s review r a = a ^. re r
さて, ここでAReviewは(->)ではなくTaggedというProfunctorを使っています.
このため今の定義ではAReviewはPrismにはなりません. よってPrismの定義もProfunctorを使ったものに変えて, reviewがPrismに対しても使えるようにしましょう.
Prism再び
ところで, Prismの定義をProfunctorに書き換えると, prismと_Leftの定義は描き直す必要があります.
しかし実はprismを定義するためには(prismがEitherを扱うこととの兼ね合いで)Profunctorでは不十分で, もっと制約の強い(ここではChoice)型クラスが必要になります.
class (Profunctor p) => Choice p where left' :: p a b -> p (Either a c) (Either b c) left' = dimap (either Right Left) (either Right Left) . right' right' :: p a b -> p (Either c a) (Either c b) right' = dimap (either Right Left) (either Right Left) . left' instance Choice (->) where left' k (Left a) = Left $ k a left' _ (Right c) = Right c instance Choice Tagged where left' = Tagged . Left . unTagged type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt sta = dimap sta (either pure (fmap bt)) . right' _Left :: Prism (Either a c) (Either b c) a b _Left = prism Left (either Right (Left . Right))
これでAReviewはPrismとなり, review _Left "hoge" == Left "hoge"のようにreviewが使えるようになります.
Cons
今定義されたPrismを使ってConsを定義します.
ConsはリストやVectorなどの, 先頭が定義できるようなデータを表します.
(<|)はConsの先頭に要素を追加するような函数です.
また, _headはConsの先頭の要素へのアクセサです.
class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where _Cons :: Prism s t (a,s) (b,t) instance Cons [a] [b] a b where _Cons = prism (uncurry (:)) $ \ass -> case ass of (a:as) -> Right (a,as) [] -> Left [] infixr 5 <| (<|) :: Cons s s a a => a -> s -> s a <| s = review _Cons (a,s) _head :: Cons s s a a => Traversal s s a a _head = \k s -> _Cons (\(a,s') -> (,) <$> k a <*> pure s') s
0 <| [1,2,3] == [0,1,2,3]のように使います.
参考
- Haskellのlensの使い方 (詳しめ) - うさぎ小屋
- lens: Lenses, Folds and Traversals | Hackage
- lens-family-core: Haskell 98 Lens Families | Hackage
終わりに
これで, Control.Lensにある亜Lensファミリーの重要と思われる型の大部分はカバーできたと思います.
あとの細々したところは実際の実装を追うのがよいでしょう.
Lensは巨大で複雑ですがこのように一つ一つ1から実装していけばそこまで難しくはないと思います. 個々のレベルではIdentityとかConstとかTaggedとかを使って型合わせゲームしているだけでちゃんと動きます.
というわけで以上です.
最後にコード全体を載せておきます.
