chi peng kangHEADmaster

6 files changed, 131 insertions, 42 deletions

diff --git a/hmj.cabal b/hmj.cabal
index b8524b0..a9e5e70 100644
--- a/hmj.cabal
+++ b/hmj.cabal
@@ -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
+