1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
module Mahjong.Hand where
import Mahjong.Set
import Mahjong.Tile
import Data.List (sort)
import Data.Maybe
import Control.Monad
data Hand = Hand {getHand::MSet, getCall::[MSet]}
deriving (Show)
max2Win = 7
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)
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 nlisten $ 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)
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) = (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
(tt,rem) <- tryTiles [jt1,jn1,jn2] t
(res,h) <- setTest rem
return (tt: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)
jt1 = Just t1
jn1 = nextTile jt1
jn2 = nextTile jn1
bcTest =
do
(tt,rem) <- tryTiles [jn1,jt1] t
(res,h) <- partTest rem
return (tt:res,h)
bdTest =
do
(tt,rem) <- tryTiles [jn2,jt1] t
(res,h) <- partTest rem
return (tt:res,h)
other =
do
(res,h) <- partTest $ tail t
return (res,t1:h)
partTest t = [([],t)]
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)
|
