« Scala で麻雀の役判定の基本処理の部分を書いてみた | Main | MariaDB Galera Cluster (RC) のテスト »

Scala で書いた麻雀役判定のプログラムを Haskell で書き直してみた

Scala で書いた麻雀の役判定の基本処理を、これもお勉強で今度は Haskell で書いてみた。
これは本当に初めて書いた Haskell プログラム。
アルゴリズムも基本的な流れは同じだが、Scala版よりも数か月時あとに書いたのもあって、事前に牌種を分ける 処理を省いたりなど多少改良されている。
表示方法などはちょっと手を抜いてるが.....

純粋なテストなので、テスト用のデータも一緒に書いてあります。
しかし、Haskell だとホント、yacc 気分をより感じますね。
文法も手伝って、定義ファイルっぽくてすっきりというか。

mj.hs ファイル
module MJTest
(
)
where

import Data.List
import Data.Maybe

-------- 汎用的なもの
-- 組み合わせ
comb :: [a] -> Int -> [[a]]
comb xs n
  | n <= 0 = []
  | n == 1 = [ [x] | x <- xs ]
  | otherwise = [ xs!!x : y | x <- [0..lenm], y <- comb (drop (x+1) xs) (n-1)]
    where
        lenm = length xs - 1

-- 全網羅組み合わせ生成
allComb :: [a] -> [[a]]
allComb s = foldl' (\r n -> r ++ comb s n) [] [1..length s]

-- リスト中の指定した要素数を数える
count :: Eq a => [a] -> a -> Int
count xs p = foldl' (\ a x -> if x==p then a+1 else a) 0 xs

-- ユニークな要素を抽出 (テストでnubを使わずに)
distinict :: Eq a => [a] -> [a]
distinict xs = foldr (\x a -> if elem x a then a else x : a) [] xs

-------- ほぼ専用なもの

-- 牌の種類
data PaiType = Pinzu | Souzu | Wanzu | Tsu deriving(Show,Eq,Ord)

-- 牌1つ
data Pai = Pai { typ :: PaiType, idx :: Int } deriving(Eq,Ord)
instance Show Pai where         -- Show カスタマイズ
    show (Pai Tsu i)
        | i==1 = "TON"
        | i==2 = "NAN"
        | i==3 = "SHA"
        | i==4 = "PEI"
        | i==5 = "HAKU"
        | i==6 = "HATSU"
        | i==7 = "CHUN"
        | otherwise = "?"
    show (Pai t i) = show t ++ ":" ++ show i

-- 牌数。ある牌が何個あるかを保持する
data PaiN = PaiN { pai :: Pai, pn :: Int } deriving(Show,Eq,Ord)

-- 分類後の牌1セット
data PaiAnalyzed = PaiAnalyzed { toitsu :: [Pai], koutsu :: [Pai], jyuntsu :: [Pai] } deriving(Show,Eq,Ord)

-- 牌の数としてカウントする
countPai :: [Pai] -> Pai -> PaiN
countPai l p = PaiN p (count l p)

-- 各牌が何枚あるか数えて牌数リストにする
pail2PaiN :: [Pai] -> [PaiN]
pail2PaiN s = map (countPai s) (distinict s)

-- 牌数値から順値を取り出す
getpaiidx a = idx (pai a)

-- 牌数値からタイプを取り出す
getpaityp a = typ (pai a)

-- 牌数値から牌数を取り出す
getpaiN a   = pn a

-- 対子、刻子候補を選抜する
koutsuList a = [ pai x | x <- a, getpaiN x >= 3 ]
toitsuList a = [ pai x | x <- a, getpaiN x >= 2 ]

-- 順子チェック (牌種、順序のチェック)
juntsuCheck a b c = t /= Tsu && typEq3 && jcheck
    where
        t = getpaityp a
        typEq3 = t == getpaityp b && t == getpaityp c
        jcheck = getpaiidx a == (getpaiidx b) - 1 && getpaiidx a == (getpaiidx c) - 2

-- 先頭の順子をひとつ検出する。順序関係を見るのでソート済み必須
checkHeadJuntsu (x0:x1:x2:_)
    | juntsuCheck x0 x1 x2 = True
    | otherwise = False
checkHeadJuntsu _ = False   -- 3個取り出せない場合は問答無用に失敗
-- 先頭の順子分を1つ取り出す。チェック済みなこと前提
dropHeadJuntsu p = [ PaiN (pai x) (-1 + getpaiN x) | x <- take 3 p, (getpaiN x) > 1 ] ++ drop 3 p

-- すべてを順子に分解する。牌数リストはソート済み必須。余りがでた場合(全分解不可)は Nothing
divideJuntsu :: [PaiN] -> Maybe [Pai]
divideJuntsu p = f p []
    where
        f [] r = Just r                         -- 残り牌がないので成功終了
        f pl r 
            | checkHeadJuntsu pl    = f (dropHeadJuntsu pl) ( (pai (head pl)) : r)
            | otherwise             = Nothing   -- 牌があるのに順子が取り出せないので失敗

-- 牌数リストから指定リストの刻子/対子を取り出す(1つ目の引数で減算数を指定)
dropKoutsu :: Int -> [PaiN] -> [Pai] -> [PaiN]
dropKoutsu m xs kls = filter ff (map mf xs)
    where
        ff x = getpaiN x > 0                    -- 残なし牌消去フィルタ関数
        mf x = if pchk then (PaiN p nn) else x  -- 刻子削除(減数)処理関数
            where
                p = pai x
                nn = getpaiN x - m
                pchk = p `elem` kls             -- 刻子リストに入っているかチェック

-- 刻子候補リストを与えて評価(結果生成のために対子も渡す)
paiEvaluteGiveKoutsu :: [PaiN] -> Pai -> [[Pai]] -> [PaiAnalyzed]
paiEvaluteGiveKoutsu pl ts kl = [ PaiAnalyzed [ts] k (fromJust mdj) | k <- kl, let mdj = divideJuntsu (dk k), isJust mdj]
    where
        dk = dropKoutsu 3 pl

-- 対子を与えて残りを全パターン評価
paiEvaluteGiveToitsu :: [PaiN] -> Pai -> [PaiAnalyzed]
paiEvaluteGiveToitsu pl t = paiEvaluteGiveKoutsu npl t al
    where
        tl = [t]
        npl = dropKoutsu 2 pl [t]               -- 対子を除いた牌数リスト
        al = [] : allComb (koutsuList npl)      -- 刻子全パターン+刻子なしの刻子候補リストを生成

-- 評価 (全対子候補ごとに評価を行う)
paiEvalute :: [Pai] -> [PaiAnalyzed]
paiEvalute src = foldl' (\r x-> (evf x) ++ r) chktoi tlist
    where
        pain = sort (pail2PaiN src)             -- 牌数リスト化してソートしたもの
        tlist = toitsuList pain                 -- 全対子候補
        chktoi = if (length tlist) == 7 then [ PaiAnalyzed tlist [] [] ] else []    -- 七対子判定 & 生成
        evf = paiEvaluteGiveToitsu pain


-- テスト用データ
plist0 = [ Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 3 ]       -- 失敗
plist1 = [ Pai Tsu 1, Pai Tsu 2, Pai Tsu 3, Pai Tsu 5, Pai Tsu 5 ]                              -- 失敗
plist2 = [ Pai Tsu 1, Pai Tsu 1, Pai Tsu 1, Pai Tsu 2, Pai Tsu 2, Pai Tsu 2, Pai Tsu 3, Pai Tsu 3, Pai Tsu 3, Pai Tsu 4, Pai Tsu 4, Pai Tsu 4, Pai Tsu 5, Pai Tsu 5 ]
plist3 = [ Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 4, Pai Pinzu 4 ]
plist4 = [ Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 1, Pai Pinzu 3, Pai Pinzu 4, Pai Pinzu 4]
plist5 = [ Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Wanzu 5, Pai Wanzu 5, Pai Wanzu 5, Pai Tsu 1, Pai Tsu 1]
plist6 = [ Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 4, Pai Pinzu 4, Pai Pinzu 5, Pai Pinzu 5, Pai Pinzu 6, Pai Pinzu 6, Pai Pinzu 7, Pai Pinzu 7 ]
plist7 = [ Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 4, Pai Pinzu 4, Pai Pinzu 4, Pai Souzu 5, Pai Souzu 5 ]
plist8 = [ Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 1, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 2, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 3, Pai Pinzu 4, Pai Pinzu 4, Pai Pinzu 4, Pai Pinzu 5, Pai Pinzu 5 ]


-- 表示付きテスト関数

paiListDisp msg list = if list == [] then 
        return () 
    else do
        putStr $ " " ++ msg ++ "=" ++ show list

paiAnalyzedDisp a i = do
    putStr $ show i
    paiListDisp "Toitsu" t
    paiListDisp "Koutsu" k
    paiListDisp "Juntsu" j
    putStrLn ""
    where
        t = toitsu a
        k = koutsu a
        j = jyuntsu a

anaDisp list = f (paiEvalute list) 1
    where
        f (x:xs) i = do
            paiAnalyzedDisp x i
            f xs $ i+1
        f _ _ = return ()


GHCi での実行例
C:\haskell>ghci
GHCi, version 7.4.2: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Prelude> :load mj
[1 of 1] Compiling MJTest           ( mj.hs, interpreted )
Ok, modules loaded: MJTest.
*MJTest> anaDisp plist0
*MJTest> anaDisp plist1
*MJTest> anaDisp plist2
1 Toitsu=[HAKU] Koutsu=[TON,NAN,SHA,PEI]
*MJTest> anaDisp plist3
1 Toitsu=[Pinzu:4] Juntsu=[Pinzu:1,Pinzu:1]
2 Toitsu=[Pinzu:1] Juntsu=[Pinzu:2,Pinzu:2]
*MJTest> anaDisp plist4
1 Toitsu=[Pinzu:4] Juntsu=[Pinzu:1,Pinzu:1,Pinzu:1]
2 Toitsu=[Pinzu:4] Koutsu=[Pinzu:1,Pinzu:2,Pinzu:3]
3 Toitsu=[Pinzu:1] Juntsu=[Pinzu:2,Pinzu:2,Pinzu:1]
*MJTest> anaDisp plist5
1 Toitsu=[TON] Koutsu=[Wanzu:5] Juntsu=[Pinzu:1,Pinzu:1]
*MJTest> anaDisp plist6
1 Toitsu=[Pinzu:7] Juntsu=[Pinzu:4,Pinzu:4,Pinzu:1,Pinzu:1]
2 Toitsu=[Pinzu:4] Juntsu=[Pinzu:5,Pinzu:5,Pinzu:1,Pinzu:1]
3 Toitsu=[Pinzu:1] Juntsu=[Pinzu:5,Pinzu:5,Pinzu:2,Pinzu:2]
4 Toitsu=[Pinzu:1,Pinzu:2,Pinzu:3,Pinzu:4,Pinzu:5,Pinzu:6,Pinzu:7]
*MJTest> anaDisp plist7
1 Toitsu=[Souzu:5] Koutsu=[Pinzu:1] Juntsu=[Pinzu:2,Pinzu:2,Pinzu:2]
2 Toitsu=[Souzu:5] Koutsu=[Pinzu:4] Juntsu=[Pinzu:1,Pinzu:1,Pinzu:1]
3 Toitsu=[Souzu:5] Koutsu=[Pinzu:1,Pinzu:2,Pinzu:3,Pinzu:4]
*MJTest> anaDisp plist8
1 Toitsu=[Pinzu:5] Koutsu=[Pinzu:1] Juntsu=[Pinzu:2,Pinzu:2,Pinzu:2]
2 Toitsu=[Pinzu:5] Koutsu=[Pinzu:4] Juntsu=[Pinzu:1,Pinzu:1,Pinzu:1]
3 Toitsu=[Pinzu:5] Koutsu=[Pinzu:1,Pinzu:2,Pinzu:3,Pinzu:4]
4 Toitsu=[Pinzu:2] Koutsu=[Pinzu:1] Juntsu=[Pinzu:3,Pinzu:3,Pinzu:2]
*MJTest>

|

« Scala で麻雀の役判定の基本処理の部分を書いてみた | Main | MariaDB Galera Cluster (RC) のテスト »

プログラム」カテゴリの記事

Comments

The comments to this entry are closed.

TrackBack


Listed below are links to weblogs that reference Scala で書いた麻雀役判定のプログラムを Haskell で書き直してみた:

« Scala で麻雀の役判定の基本処理の部分を書いてみた | Main | MariaDB Galera Cluster (RC) のテスト »