diff options
| -rw-r--r-- | hmj.cabal | 14 | ||||
| -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 | ||||
| -rw-r--r-- | src/Main.hs | 48 |
6 files changed, 131 insertions, 42 deletions
@@ -3,23 +3,25 @@ name: hmj version: 0.1.0.0 --- synopsis: --- description: license: MIT license-file: LICENSE -author: Joe Zhao +author: Tuowen Zhao maintainer: ztuowen@gmail.com --- copyright: category: Game build-type: Simple --- extra-source-files: cabal-version: >=1.10 synopsis: This is a mahjong lib/game written in haskell just for fun. +description: hmj is a Mahjong minigame, currently only have a stub where you can draw and discard tiles with a + library that supports calculating 向听数,进张. Future version is to add score calculation and to + incorporate wx for graphical environment. executable hmj main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <4.9, + random >= 1.1, + array, + monad-loops hs-source-dirs: src default-language: Haskell2010 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 + + diff --git a/src/Main.hs b/src/Main.hs index 6a8ebb3..653b399 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,51 @@ -- This is the default main module Main where +import Mahjong.Set +import Mahjong.Hand +import Mahjong.Tile +import System.Random +import Data.Array.IO +import Control.Monad +import Control.Monad.Loops + +allTiles = concat $ take 4 $ repeat orderedTile +shuffle :: [a] -> IO [a] +shuffle xs = do + ar <- newArray n xs + forM [1..n] $ \i -> do + j <- randomRIO (i,n) + vi <- readArray ar i + vj <- readArray ar j + writeArray ar j vi + return vj + where + n = length xs + newArray :: Int -> [a] -> IO (IOArray Int a) + newArray n xs = newListArray (1,n) xs + main = do - print "Just a test" + t <- shuffle allTiles + let h = take 13 t + let r = drop 13 t + choose (Hand h []) r + +choose :: Hand -> MSet -> IO () +choose h r = do + let (n:rr) = r + let hand = getHand h + let call = getCall h + let nh = hand++[n] + let l = listen $ Hand nh call + putStrLn $ (showMSet hand) ++ ":" ++ (show n) + putStrLn $ (show l) ++ " "++ (show $ map showMSet $ call) + putStrLn $ show $ nextTileSet $ Hand nh call + if l == 0 then putStrLn "End" + else do + c <- iterateWhile (\c -> not $ c `elem` nh) $ do + i <- getLine + let c = head $ readMSet i + return c + let nnh = nh `rmTile` c + choose (Hand nnh call) rr + |