haskellで清一問題を書く

ソースコードをじかに貼り付けてみる。
ところどころ、他人のHPから勝手に引用したところがありますが申し訳ありません。
申し出がございましたら削除したいと思います。
また、勝手に引用した箇所があるにもかかわらず、このコードの内容の著作権はKing_IAAに帰属するとかいってみたりして。わーお、ちょいわるおやじだ。

このコードを拡張すると、他の牌を組み合わせたあがり型も記述できるかなあ。聴牌(なぜか一発変換できる）を検出するのはまた別の関数をかかないといけないのかなあと思ってみたり、コード張るのであれば、日記用とは別のブログを用意すべきかなあとかいろいろ考えるわけです。

髪を乾かす時間も惜しんでコード書いてるから髪ボサボサなのが困ったことだなあ。

※追記：このコードは、本当に動くだけのものでまだまだ改善の余地があると思いますので。まあ、念のため。

import System

import List

import Data.IORef
data Syurui   = Syuntu | Ankou | Atama
instance Show Syurui where

  show Syuntu = "Syuntu"

  show Ankou  = "Ankou"

  show Atama  = "Atama"
type Hai = (Int, String)

type Youso   = (Syurui ,[Hai])

type Katachi = [Youso]
 --haipai = [(1,"1"),(2,"1"),(3,"1"),(5,"2"),(12,"3")]

 haipai = [(1,"1"),(2,"1"),(3,"1"),(5,"2"),(6,"3")]

 --haipai = [(1,"1"),(2,"1"),(3,"1"),(5,"2"),(8,"2"),(12,"3"),(16,"4"),(20,"5"),(24,"6"),(28,"7"),(32,"8"),(33,"9"),(34,"9"),(35,"9")]
main = do x <- newIORef [ [ ] ]

          mentsu x (choice 3 haipai) []

          readIORef x >>= print
mentsu :: IORef [ [Youso] ] -> [([Hai], [Hai])] -> [Youso] -> IO()

mentsu x [] [] = return ()

mentsu x [] q  = return ()

mentsu x p q

  | selected          == []   = do {print "error"}

  | isSyuntu selected == True = do {mentsu x unselected ([(Syuntu ,selected)] ++ q) ; mentsu x next q}

  | isAnkou  selected == True = do {mentsu x unselected ([( Ankou ,selected)] ++ q) ; mentsu x next q}

  | otherwise                 = do {atama x p q;mentsu x next q}

  where selected   = fst $ head p

        unselected = case length $ snd $ head p of

                       0     -> []

                       1     -> []

                       2     -> choice 2 (snd $ head p)

                       other -> choice 3 (snd $ head p)

        next       = tail p
atama :: IORef [ [Youso] ] -> [([Hai], [Hai])] -> [Youso] -> IO()

atama x [] [] = return ()

atama x [] q  = return ()

atama x p q

  | selected          == []   = do {print "error"}

  | isAtama  selected == True = do {modifyIORef x (++ [([(Atama  ,selected)] ++ q)])}

  | otherwise                 = return ()

  where selected   = fst $ head p
isAtama :: [Hai] -> Bool

isAtama a = if length a == 2 then

              case b of

                "11" -> True

                "22" -> True

                "33" -> True

                "44" -> True

                "55" -> True

                "66" -> True

                "77" -> True

                "88" -> True

                "99" -> True

                other -> False

            else False

                  where b = (snd $ head a) ++ (snd $ head $ tail a)
isSyuntu :: [Hai] -> Bool

isSyuntu a = if length a == 3 then 

               case b of

                 "123" -> True

                 "234" -> True

                 "345" -> True

                 "456" -> True

                 "567" -> True

                 "678" -> True

                 "789" -> True

                 other -> False

              else False

             where b = (snd $ head a) ++ (snd $ head $ tail a) ++ (snd $ head $ tail $ tail a)
isAnkou :: [Hai] -> Bool

isAnkou a = if length a == 3 then 

              case b of

                "111" -> True

                "222" -> True

                "333" -> True

                "444" -> True

                "555" -> True

                "666" -> True

                "777" -> True

                "888" -> True

                "999" -> True

                other -> False

              else False

            where b = (snd $ head a) ++ (snd $ head $ tail a) ++ (snd $ head $ tail $ tail a)
choice  :: Int -> [a] -> [([a], [a])]

choice 0 xs = [([], xs)]

choice n [] = []

choice n (x:xs) = [(x:ys, zs) | (ys, zs) <- choice (n-1) xs] ++

                  [(ys, x:zs) | (ys, zs) <- choice n xs]