riichi-scoring 0.5.0.0 → 0.6.0.0

raw patch · 10 files changed

+312/−21 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +1/−1
• app/Main.hs +3/−1
• riichi-scoring.cabal +3/−1
• src/Riichi/Display.hs +17/−1
• src/Riichi/Efficiency.hs +55/−0
• src/Riichi/Meld.hs +59/−14
• src/Riichi/Shanten.hs +103/−0
• src/Riichi/Tile.hs +54/−0
• src/Riichi/Waits.hs +6/−3

@@ -63,3 +63,14 @@   just all ways of pulling out a complete set of melds (when the hand is   complete to begin with) - Internal code refactors according to hlint++## 0.5.1.0+- Form melds now does divide and conquer across different suits.++## 0.6.0.0+- Shanten calculation+- Optimised formMelds by ensuring we don't consider a number of kans that+  doesn't make sense with the given hand size. This however does require that+  the original size of the hand is known by the function.+- Now have tile efficiency, driven by shanten calculations, which allows for a+  "discard" command that recommends the most efficient discards.

@@ -3,7 +3,7 @@ The CLI tool supplied is the riichi command. Help information is as follows:      Command riichi:-        Possible subcommands: yaku, waits, score (default = yaku)+        Possible subcommands: yaku, waits, score, shanten, discard (default = yaku)      Usage:         riichi <subcommand> "<hand>"

@@ -29,13 +29,15 @@             | arg1 == "yaku" -> displayHandYaku $ mkHand arg2             | arg1 == "waits" -> displayHandWaits $ mkHand arg2             | arg1 == "score" -> displayHandScore $ mkHand arg2+            | arg1 == "shanten" -> displayHandShanten $ mkHand arg2+            | arg1 == "discard" -> displayHandDiscard $ mkHand arg2             | otherwise -> putStrLn "Command not recognised"  helpString :: String helpString =     "Command riichi: version = "         ++ showVersion version-        ++ " \n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage:\+        ++ " \n\tPossible subcommands: yaku, waits, score, shanten, discard (default = yaku)\n\nUsage:\            \\n\triichi <subcommand> \"<hand>\"\            \\n\n\t\"yaku\" and \"score\" subcommands expect a full hand.\            \\n\t\"waits\" subcommand expects a hand that is tenpai.\

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.5.0.0+version: 0.6.0.0 -- A short (one-line) description of the package. synopsis: A CLI tool for interpreting and scoring Riichi Mahjong hands. -- A longer description of the package.@@ -61,8 +61,10 @@     Paths_riichi_scoring     Riichi.Context     Riichi.Display+    Riichi.Efficiency     Riichi.Meld     Riichi.Scoring+    Riichi.Shanten     Riichi.Tile     Riichi.Waits     Riichi.Yaku

@@ -13,8 +13,10 @@ import Data.List (intercalate, intersperse, sort) import Data.Monoid (getSum) import Riichi.Context+import Riichi.Efficiency import Riichi.Meld import Riichi.Scoring+import Riichi.Shanten import Riichi.Tile import Riichi.Waits import Riichi.Yaku@@ -82,7 +84,7 @@ displayHandWaits :: Hand -> IO () displayHandWaits hand = do     let waits = getWaits hand-    putStrLn $ "Waits are: " ++ intercalate ", " (waits & map show)+    putStrLn $ "Waits are: " ++ intercalate ", " (map show waits)  -- | Implements the "score" command for the CLI. displayHandScore :: Hand -> IO ()@@ -136,3 +138,17 @@                             ++ " points for Dealer, "                             ++ toGreen (show (yakumans * 32000))                             ++ " points for Non-Dealer."++displayHandShanten :: Hand -> IO ()+displayHandShanten hand = do+    let shanten = getShanten hand+    case shanten of+        -1 -> putStrLn $ "Hand is: " ++ toMagenta (show shanten ++ " shanten") ++ toBlue " (Complete)"+        0 -> putStrLn $ "Hand is: " ++ toMagenta (show shanten ++ " shanten") ++ toBlue " (Tenpai)"+        1 -> putStrLn $ "Hand is: " ++ toMagenta (show shanten ++ " shanten") ++ toBlue " (Iishanten)"+        _ -> putStrLn $ "Hand is: " ++ toMagenta (show shanten ++ " shanten")++displayHandDiscard :: Hand -> IO ()+displayHandDiscard hand = do+    let discards = optimalDiscards hand+    putStrLn $ "Optimal discards are: " ++ intercalate ", " (map show discards)

@@ -0,0 +1,55 @@+{- |+Module      : Riichi.Efficiency+Description : Functions for calculating discard tile efficiency+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Efficiency where++import Data.Bifunctor (second)+import Data.Function ((&))+import Data.List+import Riichi.Meld+import Riichi.Shanten+import Riichi.Tile+import Riichi.Waits++optimalDiscards :: Hand -> [Tile]+optimalDiscards hand =+    counts+        & filter (\(_, count) -> count == maxCount)+        & map fst+        & sort+        & group+        & map head+  where+    currentShanten = getShanten hand+    removeOne xs = zipWith (++) (inits xs) (map tail (init (tails xs)))+    counts =+        removeOne hand+            & zip hand+            & filter (\(_, hand') -> getShanten hand' <= currentShanten)+            & map (\(tile, hand') -> (tile, countImprovements [tile] hand'))+    maxCount =+        counts+            & maximumBy (\(_, x) (_, y) -> compare x y)+            & snd++improvements :: Hand -> [Tile]+improvements hand = case currentShanten of+    -1 -> []+    0 -> getWaits hand+    _ -> filter (\tile -> currentShanten > getShanten (tile : hand)) allTiles+  where+    currentShanten = getShanten hand++countImprovements :: Hand -> Hand -> Int+countImprovements alreadyDiscarded hand =+    let+        imps = improvements hand+        nums = [4 - countElem imp notAvailable | imp <- imps]+     in+        sum nums+  where+    countElem x list = length $ filter (== x) list+    notAvailable = hand ++ alreadyDiscarded

@@ -42,7 +42,7 @@ getDora (Numeric _ _ d) = d  -- | The data for a pair is just a tile-newtype Pair = Pair Tile deriving (Show, Eq)+newtype Pair = Pair Tile deriving (Show, Eq, Ord)  -- | A meld is a chi, pon, or kan data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord)@@ -152,6 +152,23 @@ getPairSuit (Pair (Numeric suit _ _)) = Left suit getPairSuit (Pair (Honour honour _)) = Right honour +{- | Some functions can be evaluated on each suit separately. In particular, when forming melds, different+| suits don't interact so we can speed up recursive algorithms by first splitting the hand by suits.+-}+splitAcrossSuits :: (Hand -> [[a]]) -> (Hand -> [[a]])+splitAcrossSuits f hand = do+    let hs = f (filter isHonour hand)+    let ss = f (filter isSou hand)+    let ps = f (filter isPin hand)+    let ms = f (filter isMan hand)+    h <- hs+    s <- ss+    p <- ps+    m <- ms+    return (m ++ p ++ s ++ h)++-- f (filter isHonour hand) ++ f (filter isSou hand) ++ f (filter isPin hand) ++ f (filter isMan hand)+ -- | Given a hand, return all the possible ways of pulling out chis and pons, in increasing order of length form3Melds :: Hand -> [[Meld]] form3Melds [] = [[]]@@ -189,13 +206,26 @@                 & groupBy (\x y -> length x == length y)             ) --- | Given a hand, return all the possible ways of interpreting it as a sequence of melds-formMelds :: Hand -> [[Meld]]-formMelds hand = do-    (kans, hand') <- findKans hand-    melds <- form3Melds hand'-    return $ kans ++ melds+{- | Given a hand, return all the possible ways of interpreting it as a sequence of melds, including those that do not use all tiles+| (but still ensuring there are never more than 4 melds). We need to know the size of the original hand to limit how many kans are possible+| (eg can't have a kan in a 13 tile hand). Sometimes a pair has already been trimmed off a hand before being fed to this function, hence the+| need to pass the size value manually.+-}+formMelds :: Int -> Hand -> [[Meld]]+formMelds size hand = do+    (kans, hand') <-+        findKans hand+            & filter (\(kans, _) -> let num = length kans in size - 14 <= num && num <= size - 13)+    melds <- splitAcrossSuits form3Melds hand'+    let kans_melds = kans ++ melds+    if length kans_melds <= 4+        then return kans_melds+        else [] +-- | Use this when the size of the size of the original hand is just the length of the hand being passed in.+formMelds' :: Hand -> [[Meld]]+formMelds' hand = formMelds (length hand) hand+ -- | Given a hand, return all the possible ways of spliting the entire hand into chis, pons and kans formComplete3Melds :: Hand -> [[Meld]] formComplete3Melds [] = [[]]@@ -230,16 +260,27 @@             & group             & map head --- | Given a hand, return all the possible ways of interpreting it as a sequence of melds-formCompleteMelds :: Hand -> [[Meld]]-formCompleteMelds hand = do-    (kans, hand') <- findKans hand-    melds <- formComplete3Melds hand'+{- | Given a hand, return all the possible ways of interpreting it as a sequence of melds which includes all tiles.+| In other words, formCompleteMelds always returns a strict subset of what formMelds returns. We need to know the+| size of the original hand to limit how many kans are possible (eg can't have a kan in a 13 tile hand). Sometimes+| a pair has already been trimmed off a hand before being fed to this function, hence the need to pass the size value+| manually.+-}+formCompleteMelds :: Int -> Hand -> [[Meld]]+formCompleteMelds size hand = do+    (kans, hand') <-+        findKans hand+            & filter (\(kans, _) -> let num = length kans in size - 14 <= num && num <= size - 13)+    melds <- splitAcrossSuits formComplete3Melds hand'     let kans_melds = kans ++ melds     if length kans_melds == 4         then return kans_melds         else [] +-- | Use this when the size of the size of the original hand is just the length of the hand being passed in.+formCompleteMelds' :: Hand -> [[Meld]]+formCompleteMelds' hand = formCompleteMelds (length hand) hand+ -- | Count the tiles in a list of melds meldsLength :: [Meld] -> Int meldsLength [] = 0@@ -262,7 +303,7 @@         & filter (\list -> 2 <= length list)         & map ((\tile -> (Pair tile, hand \\ [tile, tile])) . head) --- | Find all the ways of pulling kans out of a hand. In each case pair the set of kans with what remains of the hand+-- | Find all the ways of pulling kans out of a hand. In each case pair the set of kans with what remains of the hand. findKans :: Hand -> [([Meld], Hand)] findKans hand =     hand@@ -274,6 +315,10 @@         -- & tail         & map (\kans -> (kans, hand \\ concat [replicate 4 tile | Kan tile _ <- kans])) +-- | Count the kans in a list of melds+countKans :: [Meld] -> Int+countKans melds = length (filter meldIsKan melds)+ -- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans). -- An InterpretedHand can then be passed on to other functions to check for yakus. -- Seven pairs, thirteen orphans etc are handeled in other functions, that should be@@ -289,7 +334,7 @@         possible_pairs = hand & findPairs         pairs_melds = do             (pair, hand') <- possible_pairs-            melds <- formCompleteMelds hand'+            melds <- formCompleteMelds (length hand) hand'             return (pair, melds)      in         pairs_melds

@@ -0,0 +1,103 @@+{- |+Module      : Riichi.Shanten+Description : Datatypes and functions for calculating Shanten+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Shanten where++import Data.Either (lefts)+import Data.Function ((&))+import Data.List+import Data.Maybe+import Riichi.Meld+import Riichi.Tile+import Text.ParserCombinators.ReadP (count)++data Taatsu = Taatsu Tile Tile deriving (Show, Eq, Ord)++type Partial = Either Taatsu Pair++getShanten :: Hand -> Int+getShanten hand+    | length hand `elem` [13, 14] = if 0 `elem` list then 0 else minimum list+    | otherwise = basicShanten hand+  where+    -- Postpone basic shanten calculation until after we know the other two (which are faster) are not 0+    p = pairsShanten hand+    o = orphansShanten hand+    b = basicShanten hand+    list = [p, o, b]++basicShanten :: Hand -> Int+basicShanten hand = minimum $ do+    -- The combinatorics can blow up here, especially on a hand like 1111p 2222p 3333p 4444p rr+    -- Need to try to prune out as many cases as we can, and we must dispose of cases that find so+    -- many taatsu or melds that shanten is negative!+    let meldss = formMelds' hand+    melds <- meldss+    let m = length melds+    -- Don't bother if the number of partials pushes us past 5 blocks+    let partialss = splitAcrossSuits (formPartials (5 - m)) (hand \\ concatMelds melds)+    partials <- partialss+    let (t, p) = countTatsuPairs partials+    return $ 8 - (2 * m) - min (t + p) (4 - m) - (if p >= 1 && (m + t + p >= 5) then 1 else 0)++pairsShanten :: Hand -> Int+pairsShanten hand = 6 - numPairs + max 0 (7 - uniqueTiles)+  where+    numPairs = length $ findPairs hand+    uniqueTiles = length $ map head $ group $ sort hand++orphansShanten :: Hand -> Int+orphansShanten hand = 13 - uniqueOrphans - pairs+  where+    orphans = filter (not . isSimple) hand+    groupedOrphans = group $ sort orphans+    uniqueOrphans = length $ map head groupedOrphans+    pairs = if any ((>= 2) . length) groupedOrphans then 1 else 0++countTatsuPairs :: [Partial] -> (Int, Int)+countTatsuPairs partials = (numTatsu, numPairs)+  where+    num = length partials+    numTatsu = length $ lefts partials+    numPairs = num - numTatsu++formPartials :: Int -> Hand -> [[Partial]]+formPartials 0 _ = [[]]+formPartials _ [] = [[]]+formPartials _ [_] = [[]]+formPartials n hand@(tile1 : hand') =+    let+        -- Get all sets of 2 tiles, including the first tile+        doubles = do+            tile2 <- hand'+            return [tile1, tile2]+        partials =+            formPartials n (tail hand) ++ do+                [tile1, tile2] <- doubles+                partial <- maybeToList $ mkPartial tile1 tile2+                map (partial :) $ formPartials (n - 1) (hand' \\ [tile2])+     in+        partials+            -- & sortBy (\x y -> compare (length x) (length y))+            & map sort+            & sort+            & group+            & map head++mkPartial :: Tile -> Tile -> Maybe Partial+mkPartial tile1@(Numeric suit1 val1 _) tile2@(Numeric suit2 val2 _)+    | suit1 /= suit2 = Nothing+    | val1 == val2 = Just $ Right $ Pair tile1+    | abs (val1 - val2) <= 2 =+        if val1 <= val2+            then Just $ Left $ Taatsu tile1 tile2+            else Just $ Left $ Taatsu tile2 tile1+    | otherwise = Nothing+mkPartial tile1@(Honour _ _) tile2@(Honour _ _) =+    if tile1 == tile2+        then Just $ Right $ Pair tile1+        else Nothing+mkPartial _ _ = Nothing

@@ -131,6 +131,21 @@ isHonour (Honour _ _) = True isHonour _ = False +-- | Check if a tile is in the Souzu suit+isSou :: Tile -> Bool+isSou (Numeric Sou _ _) = True+isSou _ = False++-- | Check if a tile is in the Pinzu suit+isPin :: Tile -> Bool+isPin (Numeric Pin _ _) = True+isPin _ = False++-- | Check if a tile is in the Manzu suit+isMan :: Tile -> Bool+isMan (Numeric Man _ _) = True+isMan _ = False+ -- | Check if a tile is numeric isNumeric :: Tile -> Bool isNumeric = not . isHonour@@ -153,3 +168,42 @@ -- | Check if an honour is a wind honourIsWind :: Honour -> Bool honourIsWind = not . honourIsDragon++-- | Utility. Contains one of each tile (all with 0 dora)+allTiles :: [Tile]+allTiles =+    [ Honour (Dragon Red) 0+    , Honour (Dragon Green) 0+    , Honour (Dragon White) 0+    , Honour (Wind North) 0+    , Honour (Wind East) 0+    , Honour (Wind South) 0+    , Honour (Wind West) 0+    , Numeric Man 1 0+    , Numeric Man 2 0+    , Numeric Man 3 0+    , Numeric Man 4 0+    , Numeric Man 5 0+    , Numeric Man 6 0+    , Numeric Man 7 0+    , Numeric Man 8 0+    , Numeric Man 9 0+    , Numeric Pin 1 0+    , Numeric Pin 2 0+    , Numeric Pin 3 0+    , Numeric Pin 4 0+    , Numeric Pin 5 0+    , Numeric Pin 6 0+    , Numeric Pin 7 0+    , Numeric Pin 8 0+    , Numeric Pin 9 0+    , Numeric Sou 1 0+    , Numeric Sou 2 0+    , Numeric Sou 3 0+    , Numeric Sou 4 0+    , Numeric Sou 5 0+    , Numeric Sou 6 0+    , Numeric Sou 7 0+    , Numeric Sou 8 0+    , Numeric Sou 9 0+    ]

@@ -12,7 +12,10 @@ import Riichi.Meld import Riichi.Tile --- | Get the waits of a hand, represented as a list of tiles.+{- | Get the waits of a hand, represented as a list of tiles. This can also be accomplished via the improvements function,+| efficiency module, but getWaits is faster as it uses the fact that the hand is in tenpai.+| In fact, improvements now deferes to getWaits when the given hand is in tenpai.+-} getWaits :: Hand -> [Tile] getWaits hand =     if length hand < 13@@ -40,13 +43,13 @@                         else []                 -- Check waits from standard interpretations                 -- If we have four melds already, a single remaning tile can wait for a pair-                possibleMelds = formMelds hand+                possibleMelds = formMelds' hand                 fourMelds = possibleMelds & filter (\melds -> length melds == 4)                 fourMeldsWaits = map ((hand \\) . concatMelds) fourMelds & filter (\diff -> length diff == 1) & concat                 -- Finally, we might be waiting with three melds and a pair                 threeMeldWaits = concat $ do                     (pair, hand') <- findPairs hand-                    melds <- formMelds hand'+                    melds <- formMelds (length hand) hand'                     if length melds /= 3                         then return []                         else