diff options
Diffstat (limited to 'src/Mahjong')
| -rw-r--r-- | src/Mahjong/Hand.hs | 84 | ||||
| -rw-r--r-- | src/Mahjong/Point.hs | 2 | ||||
| -rw-r--r-- | src/Mahjong/Set.hs | 4 | ||||
| -rw-r--r-- | src/Mahjong/Tile.hs | 21 |
4 files changed, 76 insertions, 35 deletions
diff --git a/src/Mahjong/Hand.hs b/src/Mahjong/Hand.hs index 13055ff..c5446da 100644 --- a/src/Mahjong/Hand.hs +++ b/src/Mahjong/Hand.hs @@ -1,7 +1,7 @@ -module Hand where +module Mahjong.Hand where -import Set -import Tile +import Mahjong.Set +import Mahjong.Tile import Data.List (sort) import Data.Maybe import Control.Monad @@ -15,13 +15,16 @@ pairs :: Int -> [MTile] -> Int pairs c (h:hs) = (if length (filter (==h) hs) >= c then 1 else 0) + (pairs c $ filter (/=h) hs) pairs c [] = 0 -seven h = 7 - (pairs 1 h) -mosou h = 14 - (pairs 0 h') - (if pairs 1 h' > 0 then 1 else 0) +seven' h = 7 - (pairs 1 h) +musou' h = 14 - (pairs 0 h') - (if pairs 1 h' > 0 then 1 else 0) where h' = filter is19 h +seven = seven'.getHand +musou = musou'.getHand + -- For normal xAAA+yBCD+EE is easy -- First calculate the maximum number of x+y then the number of partials -normal h = minimum $ map listen $ normalSet h +normal h = minimum $ map nlisten $ normalSet h normalSet :: Hand -> [([MSet],[MSet],[MSet],MSet)] normalSet h = do @@ -29,28 +32,28 @@ normalSet h = do (part,rr) <- partTest $ sort $ r return (getCall h,set,part,rr) -listen :: ([MSet],[MSet],[MSet],MSet) -> Int -listen (call,set,part,rr) = rem +nlisten :: ([MSet],[MSet],[MSet],MSet) -> Int +nlisten (call,set,part,rr) = rem where pair = min 1 $ length (filter (\(t1:t2:t) -> t1==t2) part) cal = 4 - (length call) - (length set) rem = cal * 2 - (min cal ((length part)-pair)) + 1 - pair setTest :: MSet -> [([MSet],MSet)] -setTest t@(t1:t2:t3:ts) = (aaaTest)++(bcdTest)++other +setTest t@(t1:t2:t3:ts) = (bcdTest)++(aaaTest)++other where aaaTest = do guard (t1==t2 && t1==t3) (res,h) <- setTest ts return ([t1,t2,t3]:res,h) + jt1 = Just t1 + jn1 = nextTile jt1 + jn2 = nextTile jn1 bcdTest = do - n1 <- maybeToList $ nextTile' $ Just t1 - n2 <- maybeToList $ nextTile' $ Just n1 - guard (n1 `elem` t && n2 `elem` t) - let rem = t `rmTile` t1 `rmTile` n1 `rmTile` n2 + (tt,rem) <- tryTiles [jt1,jn1,jn2] t (res,h) <- setTest rem - return ([t1,n1,n2]:res,h) + return (tt:res,h) other = do (res,h) <- setTest $ tail t return (res,t1:h) @@ -63,29 +66,60 @@ partTest t@(t1:t2:ts) = aaTest ++ bcTest ++ bdTest ++ other guard (t1==t2) (res,h) <- partTest ts return ([t1,t2]:res,h) - jn1 = nextTile' (Just t1) - jn2 = nextTile' jn1 + jt1 = Just t1 + jn1 = nextTile jt1 + jn2 = nextTile jn1 bcTest = do - n1 <- maybeToList jn1 - guard (n1 `elem` t) - let rem = t `rmTile` t1 `rmTile` n1 + (tt,rem) <- tryTiles [jn1,jt1] t (res,h) <- partTest rem - return ([t1,n1]:res,h) + return (tt:res,h) bdTest = do - n2 <- maybeToList jn2 - guard (n2 `elem` t) - let rem = t `rmTile` t1 `rmTile` n2 + (tt,rem) <- tryTiles [jn2,jt1] t (res,h) <- partTest rem - return ([t1,n2]:res,h) + return (tt:res,h) other = do (res,h) <- partTest $ tail t return (res,t1:h) partTest t = [([],t)] -rmTile :: MSet -> MTile -> MSet +rmTile :: Eq a => [a] -> a -> [a] rmTile ts t = (takeWhile (/=t) ts) ++ if h == [] then [] else tail h where h = (dropWhile (/=t) ts) +listen :: Hand -> Int +listen h = max 0 $ minimum $ [seven,musou,normal] <*> [h] + +nextTileSet :: Hand -> MSet +nextTileSet h@(Hand hand call) = [ tile | tile <- orderedTile, (>) l $ listen $ Hand (tile:hand) call] + where + l = listen h + +trySet :: [[Maybe MTile]] -> Hand -> [(MSet,Hand)] +trySet tiles h@(Hand hand call) = map (\(tt,rr) -> (tt,Hand rr (tt:call))) $ concat $ tryTiles <$> tiles <*> [hand] + +chi :: Hand -> MTile -> [(MSet,Hand)] +chi h t = trySet [[p2,p1],[p1,n1],[n1,n2]] h + where + p1 = prevTile $ Just t + p2 = prevTile p1 + n1 = nextTile $ Just t + n2 = nextTile n1 + +peng :: Hand -> MTile -> [(MSet,Hand)] +peng h t = trySet [[jt,jt]] h + where jt = Just t +ankang :: Hand -> MTile -> [(MSet,Hand)] +ankang h@(Hand hand call) t = trySet (map ((take 4).repeat.Just) orderedTile) (Hand (t:hand) call) +mingkang :: Hand -> MTile -> [(MSet,Hand)] +mingkang h t = trySet (map ((take 3).repeat.Just) [t]) h +jiakang :: Hand -> MTile -> [(MSet,Hand)] +jiakang h@(Hand hand call) t = [ (tt,Hand hand ((ht:tt):(call `rmTile` tt)))| tt<-call, let ht = head tt, let ts = (t:hand), ht `elem` ts] + +tryTiles :: [Maybe MTile] -> MSet -> [(MSet,MSet)] +tryTiles tl ts = maybeToList $ do + tt <- sequence tl + guard $ all (`elem` ts) tt + return (tt,foldl rmTile ts tt) diff --git a/src/Mahjong/Point.hs b/src/Mahjong/Point.hs index d2ae679..ec25001 100644 --- a/src/Mahjong/Point.hs +++ b/src/Mahjong/Point.hs @@ -1,4 +1,4 @@ -module Point where +module Mahjong.Point where calPoint (han,fu) | han < 6 = if med > 2000 then 2000 else med diff --git a/src/Mahjong/Set.hs b/src/Mahjong/Set.hs index 31798e5..555806e 100644 --- a/src/Mahjong/Set.hs +++ b/src/Mahjong/Set.hs @@ -1,6 +1,6 @@ -module Set where +module Mahjong.Set where -import Tile +import Mahjong.Tile import Data.List (sort) import Data.Char (isDigit) import Data.Either diff --git a/src/Mahjong/Tile.hs b/src/Mahjong/Tile.hs index 05e2f89..b952f48 100644 --- a/src/Mahjong/Tile.hs +++ b/src/Mahjong/Tile.hs @@ -1,4 +1,4 @@ -module Tile where +module Mahjong.Tile where import Data.Char (toUpper) import Data.List (sort) @@ -32,14 +32,21 @@ is19 c@(MTile col n) = (isCha c) || (isLaoTou c) orderedTile = sort $ [MTile c n | c<-[Man,Pin,Sou], n <-[1..9]] ++ (map (MTile Cha) [1..7]) -nextTile p = if xs /= [] then Just $ head xs +nextTile' p tiles = if xs /= [] then Just $ head xs else Nothing - where (x:xs) = dropWhile (/= p) orderedTile + where (x:xs) = dropWhile (/= p) tiles -nextTile' :: Maybe MTile -> Maybe MTile -nextTile' jp = do - p <- jp - nx@(MTile c n) <- nextTile p +nextTile :: Maybe MTile -> Maybe MTile +nextTile jp = do + p@(MTile c n) <- jp guard ((c /= Cha) && (n /= 9)) + nx <- nextTile' p orderedTile return nx +prevTile jp = do + p@(MTile c n) <- jp + guard ((c /= Cha) && (n /= 1)) + nx <- nextTile' p $ reverse orderedTile + return nx + + |