From 7c467a66bf44626c181c7a0b22224ce73af45d31 Mon Sep 17 00:00:00 2001 From: Tuowen Zhao Date: Sun, 22 May 2016 21:50:48 -0500 Subject: listen cal --- dist/build/autogen/Paths_hmj.hs | 4 +- dist/build/autogen/cabal_macros.h | 74 +++++++++---------- dist/setup-config | Bin 53555 -> 53073 bytes dist/setup-config.ghc-mod.cabal-components | Bin 1264 -> 1256 bytes dist/setup-config.ghc-mod.package-options | Bin 295 -> 287 bytes dist/setup-config.ghc-mod.resolved-components | Bin 2533 -> 2558 bytes src/Mahjong/Hand.hs | 101 +++++++++++++++++++------- src/Mahjong/Pai.hs | 42 ----------- src/Mahjong/Set.hs | 13 ++-- src/Mahjong/Tile.hs | 45 ++++++++++++ 10 files changed, 166 insertions(+), 113 deletions(-) delete mode 100644 src/Mahjong/Pai.hs create mode 100644 src/Mahjong/Tile.hs diff --git a/dist/build/autogen/Paths_hmj.hs b/dist/build/autogen/Paths_hmj.hs index 0ca6d46..76f64cd 100644 --- a/dist/build/autogen/Paths_hmj.hs +++ b/dist/build/autogen/Paths_hmj.hs @@ -17,8 +17,8 @@ version = Version [0,1,0,0] [] bindir, libdir, datadir, libexecdir, sysconfdir :: FilePath bindir = "/home/joe/.cabal/bin" -libdir = "/home/joe/.cabal/lib/x86_64-linux-ghc-7.10.1/hmj_EJVUBKD2OSK8NwQkzGMiCB" -datadir = "/home/joe/.cabal/share/x86_64-linux-ghc-7.10.1/hmj-0.1.0.0" +libdir = "/home/joe/.cabal/lib/x86_64-linux-ghc-7.10.3/hmj-0.1.0.0-2JClTFhqsNQ7p2xTwE8Zcb" +datadir = "/home/joe/.cabal/share/x86_64-linux-ghc-7.10.3/hmj-0.1.0.0" libexecdir = "/home/joe/.cabal/libexec" sysconfdir = "/home/joe/.cabal/etc" diff --git a/dist/build/autogen/cabal_macros.h b/dist/build/autogen/cabal_macros.h index 02c1076..493bf23 100644 --- a/dist/build/autogen/cabal_macros.h +++ b/dist/build/autogen/cabal_macros.h @@ -1,53 +1,53 @@ /* DO NOT EDIT: This file is automatically generated by Cabal */ -/* package base-4.8.0.0 */ -#define VERSION_base "4.8.0.0" +/* package base-4.8.2.0 */ +#define VERSION_base "4.8.2.0" #define MIN_VERSION_base(major1,major2,minor) (\ (major1) < 4 || \ (major1) == 4 && (major2) < 8 || \ - (major1) == 4 && (major2) == 8 && (minor) <= 0) + (major1) == 4 && (major2) == 8 && (minor) <= 2) -/* tool alex-3.1.4 */ -#define TOOL_VERSION_alex "3.1.4" +/* tool alex-3.1.7 */ +#define TOOL_VERSION_alex "3.1.7" #define MIN_TOOL_VERSION_alex(major1,major2,minor) (\ (major1) < 3 || \ (major1) == 3 && (major2) < 1 || \ - (major1) == 3 && (major2) == 1 && (minor) <= 4) + (major1) == 3 && (major2) == 1 && (minor) <= 7) -/* tool cpphs-1.19.2 */ -#define TOOL_VERSION_cpphs "1.19.2" +/* tool cpphs-1.20.1 */ +#define TOOL_VERSION_cpphs "1.20.1" #define MIN_TOOL_VERSION_cpphs(major1,major2,minor) (\ (major1) < 1 || \ - (major1) == 1 && (major2) < 19 || \ - (major1) == 1 && (major2) == 19 && (minor) <= 2) + (major1) == 1 && (major2) < 20 || \ + (major1) == 1 && (major2) == 20 && (minor) <= 1) -/* tool gcc-5.2.0 */ -#define TOOL_VERSION_gcc "5.2.0" +/* tool gcc-6.1.1 */ +#define TOOL_VERSION_gcc "6.1.1" #define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ - (major1) < 5 || \ - (major1) == 5 && (major2) < 2 || \ - (major1) == 5 && (major2) == 2 && (minor) <= 0) + (major1) < 6 || \ + (major1) == 6 && (major2) < 1 || \ + (major1) == 6 && (major2) == 1 && (minor) <= 1) -/* tool ghc-7.10.1 */ -#define TOOL_VERSION_ghc "7.10.1" +/* tool ghc-7.10.3 */ +#define TOOL_VERSION_ghc "7.10.3" #define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ (major1) < 7 || \ (major1) == 7 && (major2) < 10 || \ - (major1) == 7 && (major2) == 10 && (minor) <= 1) + (major1) == 7 && (major2) == 10 && (minor) <= 3) -/* tool ghc-pkg-7.10.1 */ -#define TOOL_VERSION_ghc_pkg "7.10.1" +/* tool ghc-pkg-7.10.3 */ +#define TOOL_VERSION_ghc_pkg "7.10.3" #define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ (major1) < 7 || \ (major1) == 7 && (major2) < 10 || \ - (major1) == 7 && (major2) == 10 && (minor) <= 1) + (major1) == 7 && (major2) == 10 && (minor) <= 3) -/* tool haddock-2.16.0 */ -#define TOOL_VERSION_haddock "2.16.0" +/* tool haddock-2.16.1 */ +#define TOOL_VERSION_haddock "2.16.1" #define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ (major1) < 2 || \ (major1) == 2 && (major2) < 16 || \ - (major1) == 2 && (major2) == 16 && (minor) <= 0) + (major1) == 2 && (major2) == 16 && (minor) <= 1) /* tool happy-1.19.5 */ #define TOOL_VERSION_happy "1.19.5" @@ -70,26 +70,26 @@ (major1) == 0 && (major2) < 67 || \ (major1) == 0 && (major2) == 67 && (minor) <= 0) -/* tool hscolour-1.22 */ -#define TOOL_VERSION_hscolour "1.22" +/* tool hscolour-1.24 */ +#define TOOL_VERSION_hscolour "1.24" #define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ (major1) < 1 || \ - (major1) == 1 && (major2) < 22 || \ - (major1) == 1 && (major2) == 22 && (minor) <= 0) + (major1) == 1 && (major2) < 24 || \ + (major1) == 1 && (major2) == 24 && (minor) <= 0) -/* tool pkg-config-0.28 */ -#define TOOL_VERSION_pkg_config "0.28" +/* tool pkg-config-0.29.1 */ +#define TOOL_VERSION_pkg_config "0.29.1" #define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\ (major1) < 0 || \ - (major1) == 0 && (major2) < 28 || \ - (major1) == 0 && (major2) == 28 && (minor) <= 0) + (major1) == 0 && (major2) < 29 || \ + (major1) == 0 && (major2) == 29 && (minor) <= 1) -/* tool strip-2.25 */ -#define TOOL_VERSION_strip "2.25" +/* tool strip-2.26 */ +#define TOOL_VERSION_strip "2.26" #define MIN_TOOL_VERSION_strip(major1,major2,minor) (\ (major1) < 2 || \ - (major1) == 2 && (major2) < 25 || \ - (major1) == 2 && (major2) == 25 && (minor) <= 0) + (major1) == 2 && (major2) < 26 || \ + (major1) == 2 && (major2) == 26 && (minor) <= 0) -#define CURRENT_PACKAGE_KEY "hmj_EJVUBKD2OSK8NwQkzGMiCB" +#define CURRENT_PACKAGE_KEY "hmj_2JClTFhqsNQ7p2xTwE8Zcb" diff --git a/dist/setup-config b/dist/setup-config index 2217067..07fa2cb 100644 Binary files a/dist/setup-config and b/dist/setup-config differ diff --git a/dist/setup-config.ghc-mod.cabal-components b/dist/setup-config.ghc-mod.cabal-components index 17ef2f7..3a26b8a 100644 Binary files a/dist/setup-config.ghc-mod.cabal-components and b/dist/setup-config.ghc-mod.cabal-components differ diff --git a/dist/setup-config.ghc-mod.package-options b/dist/setup-config.ghc-mod.package-options index d350fa1..2dbfa69 100644 Binary files a/dist/setup-config.ghc-mod.package-options and b/dist/setup-config.ghc-mod.package-options differ diff --git a/dist/setup-config.ghc-mod.resolved-components b/dist/setup-config.ghc-mod.resolved-components index daf12e2..615c1d1 100644 Binary files a/dist/setup-config.ghc-mod.resolved-components and b/dist/setup-config.ghc-mod.resolved-components differ diff --git a/src/Mahjong/Hand.hs b/src/Mahjong/Hand.hs index f58b602..13055ff 100644 --- a/src/Mahjong/Hand.hs +++ b/src/Mahjong/Hand.hs @@ -1,40 +1,91 @@ module Hand where import Set -import Pai +import Tile import Data.List (sort) import Data.Maybe +import Control.Monad data Hand = Hand {getHand::MSet, getCall::[MSet]} + deriving (Show) max2Win = 7 -pairs c (h:hs) = (if length (filter (==h) hs) >= c then 1 else 0) + (pairs $ filter (/=h) hs) +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) where h' = filter is19 h -normal h = maxmum $ map getSteps $ normal' (0,0,0) (0,0,0) (head orderedPai) $ sort $ h - where getSteps (p,w,m) = --pairs, waits, mianzi - (if p == 0 then 1 else 0) + - (min w' 4)+2*(max 0 (4-w'-m)) - where w' = (+) w $ max 0 (p-1) - -normal' (a,b,c) (p,w,m) cur (h:hs) - | cur == h = normal' (a,b,c+1) (p,w,m) cur hs - | a + b + c < 2 = -- TODO return - | a < 1 = if nextPai' cur == Nothing - then normal' (b,c,0) cur hs - -costM a b = (sum $ zipWith (snd.sMmin) a b,zipWith (fst.sMmin) a b) -sMmin a b = if (a>b) then (a-b,0) else (0,b-a) - -parseCol xx@(a:b:c:xs) (t,m,p) = - concat [] -parseCol _ r = return r - -normal h = cm = - where cm = pairs 2 $ filter isCha h - cp = (pairs 1 $ filter isCha h) - cm - + +-- 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 + +normalSet :: Hand -> [([MSet],[MSet],[MSet],MSet)] +normalSet h = do + (set,r) <- setTest $ sort $ getHand h + (part,rr) <- partTest $ sort $ r + return (getCall h,set,part,rr) + +listen :: ([MSet],[MSet],[MSet],MSet) -> Int +listen (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 + where aaaTest = + do + guard (t1==t2 && t1==t3) + (res,h) <- setTest ts + return ([t1,t2,t3]:res,h) + 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 + (res,h) <- setTest rem + return ([t1,n1,n2]:res,h) + other = do + (res,h) <- setTest $ tail t + return (res,t1:h) +setTest t = [([],t)] + +partTest :: MSet -> [([MSet],MSet)] +partTest t@(t1:t2:ts) = aaTest ++ bcTest ++ bdTest ++ other + where aaTest = + do + guard (t1==t2) + (res,h) <- partTest ts + return ([t1,t2]:res,h) + jn1 = nextTile' (Just t1) + jn2 = nextTile' jn1 + bcTest = + do + n1 <- maybeToList jn1 + guard (n1 `elem` t) + let rem = t `rmTile` t1 `rmTile` n1 + (res,h) <- partTest rem + return ([t1,n1]:res,h) + bdTest = + do + n2 <- maybeToList jn2 + guard (n2 `elem` t) + let rem = t `rmTile` t1 `rmTile` n2 + (res,h) <- partTest rem + return ([t1,n2]:res,h) + other = + do + (res,h) <- partTest $ tail t + return (res,t1:h) +partTest t = [([],t)] + +rmTile :: MSet -> MTile -> MSet +rmTile ts t = (takeWhile (/=t) ts) ++ if h == [] then [] else tail h + where h = (dropWhile (/=t) ts) + diff --git a/src/Mahjong/Pai.hs b/src/Mahjong/Pai.hs deleted file mode 100644 index 067196e..0000000 --- a/src/Mahjong/Pai.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Pai where - -import Data.Char (toUpper) -import Data.List (sort) -import Data.Maybe -import Control.Monad - -data MCol = Man | Pin | Sou | Cha - deriving (Eq,Ord) -data MCard = MCard MCol Int - deriving (Eq,Ord) - -charMcol = [(Man,'M'),(Pin,'P'),(Sou,'S'),(Cha,'C')] -instance Show MCol where - show x = [snd a | a <-charMcol, fst a == x] - -instance Read MCol where - readsPrec p r = [(fst a,t)|(c,t) <- lex r, a <- charMcol, map toUpper c == [snd a]] - -instance Show MCard where - show (MCard a b) = show b ++ show a - -instance Read MCard where - readsPrec p r = [ (MCard col n,u) | (c1,t)<- lex r, - let n = (read c1)::Int, - (c2,u) <-lex t, - let col=(read c2)::MCol] - -isCha c@(MCard col n) = (col == Cha) -isLaoTou c@(MCard col n) = ((n == 1) || (n == 9)) && (not $ isCha c) -is19 c@(MCard col n) = (isCha c) || (isLaoTou c) - -orderedPai = sort $ [MCard c n | c<-[Man,Pin,Sou], n <-[1..9]] ++ (map (MCard Cha) [1..7]) - -nextPai p = if xs /= [] then Just $ head xs - else Nothing - where (x:xs) = dropWhile (/= p) orderedPai - -nextPai' p@(MCard c n) = do - nx <- nextPai p - guard ((c /= Cha) && (n /= 9)) - return nx diff --git a/src/Mahjong/Set.hs b/src/Mahjong/Set.hs index 4c3e799..31798e5 100644 --- a/src/Mahjong/Set.hs +++ b/src/Mahjong/Set.hs @@ -1,20 +1,19 @@ module Set where -import Pai +import Tile import Data.List (sort) import Data.Char (isDigit) import Data.Either -data MSet = MSet {getMSet:: [MCard]} +type MSet = [MTile] -instance Show MSet where - show xs = fst $ foldr f ("",Nothing) $ sort $ getMSet xs - where f (MCard col n) (o,p) = let o' = show n ++ (if Just col == p then "" - else show col) ++ o in (o', Just col) +showMSet xs = fst $ foldr f ("",Nothing) $ sort xs + where f (MTile col n) (o,p) = let o' = show n ++ (if Just col == p then "" + else show col) ++ o in (o', Just col) readMSet r = fst $ foldr f ([],Man) $ map g r where g x | isDigit x = Left ((read [x])::Int) | otherwise = Right ((read [x])::MCol) - f (Left a) (xs,col) = ((MCard col a):xs,col) + f (Left a) (xs,col) = ((MTile col a):xs,col) f (Right a) (xs,col) = (xs,a) diff --git a/src/Mahjong/Tile.hs b/src/Mahjong/Tile.hs new file mode 100644 index 0000000..05e2f89 --- /dev/null +++ b/src/Mahjong/Tile.hs @@ -0,0 +1,45 @@ +module Tile where + +import Data.Char (toUpper) +import Data.List (sort) +import Data.Maybe +import Control.Monad + +data MCol = Man | Pin | Sou | Cha + deriving (Eq,Ord) +data MTile = MTile MCol Int + deriving (Eq,Ord) + +charMcol = [(Man,'M'),(Pin,'P'),(Sou,'S'),(Cha,'C')] +instance Show MCol where + show x = [snd a | a <-charMcol, fst a == x] + +instance Read MCol where + readsPrec p r = [(fst a,t)|(c,t) <- lex r, a <- charMcol, map toUpper c == [snd a]] + +instance Show MTile where + show (MTile a b) = show b ++ show a + +instance Read MTile where + readsPrec p r = [ (MTile col n,u) | (c1,t)<- lex r, + let n = (read c1)::Int, + (c2,u) <-lex t, + let col=(read c2)::MCol] + +isCha c@(MTile col n) = (col == Cha) +isLaoTou c@(MTile col n) = ((n == 1) || (n == 9)) && (not $ isCha c) +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 + else Nothing + where (x:xs) = dropWhile (/= p) orderedTile + +nextTile' :: Maybe MTile -> Maybe MTile +nextTile' jp = do + p <- jp + nx@(MTile c n) <- nextTile p + guard ((c /= Cha) && (n /= 9)) + return nx + -- cgit v1.2.3-70-g09d2