listen cal

9 files changed, 138 insertions, 85 deletions

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
--- a/dist/setup-config
+++ b/dist/setup-config
diff --git a/dist/setup-config.ghc-mod.cabal-components b/dist/setup-config.ghc-mod.cabal-components
index 17ef2f7..3a26b8a 100644
--- a/dist/setup-config.ghc-mod.cabal-components
+++ b/dist/setup-config.ghc-mod.cabal-components
diff --git a/dist/setup-config.ghc-mod.package-options b/dist/setup-config.ghc-mod.package-options
index d350fa1..2dbfa69 100644
--- a/dist/setup-config.ghc-mod.package-options
+++ b/dist/setup-config.ghc-mod.package-options
diff --git a/dist/setup-config.ghc-mod.resolved-components b/dist/setup-config.ghc-mod.resolved-components
index daf12e2..615c1d1 100644
--- a/dist/setup-config.ghc-mod.resolved-components
+++ b/dist/setup-config.ghc-mod.resolved-components
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/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/Pai.hs b/src/Mahjong/Tile.hs
index 067196e..05e2f89 100644
--- a/src/Mahjong/Pai.hs
+++ b/src/Mahjong/Tile.hs
@@ -1,4 +1,4 @@
-module Pai where
+module Tile where
 
 import Data.Char (toUpper)
 import Data.List (sort)
@@ -7,7 +7,7 @@ import Control.Monad
 
 data MCol = Man | Pin | Sou | Cha
     deriving (Eq,Ord)
-data MCard = MCard MCol Int
+data MTile = MTile MCol Int
     deriving (Eq,Ord)
 
 charMcol = [(Man,'M'),(Pin,'P'),(Sou,'S'),(Cha,'C')]
@@ -17,26 +17,29 @@ instance Show MCol where
 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 Show MTile where
+    show (MTile a b) = show b ++ show a
 
-instance Read MCard where
-    readsPrec p r = [ (MCard col n,u) | (c1,t)<- lex r, 
+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@(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)
+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)
 
-orderedPai = sort $ [MCard c n | c<-[Man,Pin,Sou], n <-[1..9]] ++ (map (MCard Cha) [1..7])
+orderedTile = sort $ [MTile c n | c<-[Man,Pin,Sou], n <-[1..9]] ++ (map (MTile Cha) [1..7])
 
-nextPai p = if xs /= [] then Just $ head xs
+nextTile p = if xs /= [] then Just $ head xs
             else Nothing
-    where (x:xs) = dropWhile (/= p) orderedPai
+    where (x:xs) = dropWhile (/= p) orderedTile
 
-nextPai' p@(MCard c n) = do
-    nx <- nextPai p
+nextTile' :: Maybe MTile -> Maybe MTile
+nextTile' jp = do
+    p <- jp
+    nx@(MTile c n) <- nextTile p
     guard ((c /= Cha) && (n /= 9))
     return nx
+