riichi-scoring 0.3.1.0 → 0.4.0.0

raw patch · 8 files changed

+152/−156 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• riichi-scoring.cabal +1/−1
• src/ColourStrings.hs +5/−0
• src/Riichi/Context.hs +39/−5
• src/Riichi/Meld.hs +41/−2
• src/Riichi/Scoring.hs +46/−147
• src/Riichi/Tile.hs +9/−0
• src/Riichi/Waits.hs +5/−0

@@ -31,7 +31,7 @@ signatures for operations that need many pieces of information besides just the superficial composition of a hand. -## 0.3.0.1+## 0.3.1.0 Now only ask for dora after we know the hand is not a yakuman, as part of the mkContext function (previously handled dora in displayHandScore). Four concealed triplets now asks about concealment. It wasn't doing this before,@@ -42,3 +42,8 @@ Speaking of -      NOTE: Seat+Round wind pair counts as a yakuhai pair and awards     2+2=4 Fu. Some rulesets would only award 2 Fu.++## 0.4.0.0+Extended documentation. Old getFu replaced with new one (previously _getFu).+Removed old getYaku function+

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.3.1.0+version: 0.4.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.

@@ -6,17 +6,22 @@ -} module ColourStrings where +-- | Wrap a string in the escape sequences for red toRed :: String -> String toRed s = "\o33[31m" ++ s ++ "\o33[0m" +-- | Wrap a string in the escape sequences for blue toBlue :: String -> String toBlue s = "\o33[34m" ++ s ++ "\o33[0m" +-- | Wrap a string in the escape sequences for magenta toMagenta :: String -> String toMagenta s = "\o33[35m" ++ s ++ "\o33[0m" +-- | Wrap a string in the escape sequences for cyan toCyan :: String -> String toCyan s = "\o33[36m" ++ s ++ "\o33[0m" +-- | Wrap a string in the escape sequences for green toGreen :: String -> String toGreen s = "\o33[32m" ++ s ++ "\o33[0m"

@@ -1,19 +1,25 @@+{- |+Module      : Riichi.Context+Description : Functions and datatypes for tracking the context surrounding a hand, such as closure, riichi, seat wind, yakus ...+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-} module Riichi.Context where +import Control.Exception (handle) import Data.Function ((&)) import Riichi.Meld import Riichi.Tile import Riichi.Yaku +-- | Ask a yes/no question askYesNo :: String -> IO Bool askYesNo string = do     putStrLn string     input <- getLine     if input == "y" then return True else return False -{- | Record to track the additional context for a hand. Fields with a Maybe type are information that-we may not need in order to fully understand the hand.--}+-- | Record to track the additional context for a hand. data HandContext = HandContext     { isClosed :: Bool     , isTsumo :: Bool@@ -25,6 +31,11 @@     , dora :: Integer     } +{- | Get a basic hand context with the minimal amount of information. Defaults to a closed hand+| with no riichi, tsumo, ippatsu, special waits and East round and seat wind. Calculates the dora+| and figures out if the hand is thirteen orphans. The boolean input specifies whether the hand+| is seven pairs+-} getMinimalHandContext :: Hand -> Bool -> HandContext getMinimalHandContext hand sevenPairs =     let@@ -41,33 +52,42 @@             , dora = hand & map getDora & sum             } +-- | Make a hand context open openHandContext :: HandContext -> HandContext openHandContext handContext = handContext{isClosed = False} +-- | Make a hand context closed closeHandContext :: HandContext -> HandContext closeHandContext handContext = handContext{isClosed = True} +-- | Ask for information to add riichi context to the hand context. addRiichiContext :: HandContext -> IO HandContext addRiichiContext handContext = do     riichiContext <- askRiichiContext     return handContext{riichi = riichiContext} +-- | Ask about the waits of the hand, and add this context addWaitContext :: HandContext -> IO HandContext addWaitContext handContext = do     waitContext <- askWaitContext     return handContext{wait = waitContext} +-- | Ask about the round and seat winds, and add this context addWindContext :: HandContext -> IO HandContext addWindContext handContext = do     windContext <- askWindContext     return handContext{wind = windContext} +-- | Ask if the hand was tsumo, and add this context addTsumoContext :: HandContext -> IO HandContext addTsumoContext handContext = do     tsumo <- askYesNo "Tsumo? [y/n]:"     return handContext{isTsumo = tsumo} --- The context must already know riichi and tsumo values for this to work+{- | Figure out which melds are open / closed, if the hand has the standard shape. Return the+| updated melds along with the updated hand context. The context must already know riichi and+| tsumo values for this to work+-} addClosedContext :: Maybe InterpretedHand -> HandContext -> IO (Maybe InterpretedHand, HandContext) addClosedContext (Just (tile, melds)) handContext = do     let HandContext{isTsumo = t, riichi = RiichiContext{isRiichi = r}} = handContext@@ -87,11 +107,13 @@     return (Just (tile, melds'), handContext{isClosed = closedHand}) addClosedContext Nothing handContext = return (Nothing, handContext{isClosed = True}) +-- | The context for the waits of a hand data WaitContext = WaitContext     { isRyanmanWait :: Bool     , isShanponWait :: Bool     } +-- | Ask about the waits, and return a wait context. askWaitContext :: IO (WaitContext) askWaitContext = do     ryanmanWait <- askYesNo "Did the hand have an open wait? [y/n]: "@@ -101,18 +123,22 @@             else askYesNo "Did the hand have a dual pair wait? [y/n]: "     return WaitContext{isRyanmanWait = ryanmanWait, isShanponWait = shanponWait} +-- | The context for the seat and round winds for a hand data WindContext = WindContext     {seatWind :: Wind, roundWind :: Wind} +-- | Ask about round and seat winds, and return a wind context. askWindContext :: IO (WindContext) askWindContext = do     putStrLn "Input round and seat wind: "     (Honour (Wind r) _) : (Honour (Wind s) _) : _ <- mkHand <$> getLine     return WindContext{seatWind = s, roundWind = r} +-- | Context tracking if a hand is riichi / ippatsu data RiichiContext = RiichiContext     {isRiichi :: Bool, isIppatsu :: Bool} +-- | Ask about the hand being riichi, return a riichi context. askRiichiContext :: IO (RiichiContext) askRiichiContext = do     riichi <- askYesNo "Riichi? [y/n]: "@@ -122,6 +148,7 @@             else return False     return RiichiContext{isRiichi = riichi, isIppatsu = ippatsu} +-- | A context that tracks the yaku that a hand has data YakuContext = YakuContext     -- , isTsumo :: Bool     { isPinfu :: Bool@@ -151,6 +178,7 @@       isChiitoitsu :: Bool     } +-- | Given a hand, possibly an interpretation, and the surrounding context, build a yaku context. mkYakuContext :: Hand -> Maybe InterpretedHand -> HandContext -> YakuContext mkYakuContext hand (Just ih) handContext =     let@@ -225,6 +253,7 @@             , isChiitoitsu = chiitoitsu hand             } +-- | A context that tracks the yakuman that a hand has data YakumanContext = YakumanContext     { isSuuankou :: Bool     , isSuukantsu :: Bool@@ -238,8 +267,10 @@     , isKokushiMusou :: Bool     } --- maybeClosure var allows us to shortcicuit the IO check. If we already know whether the hand is closed or not,+-- maybeClosure var allows us to shortcircuit the IO check. If we already know whether the hand is closed or not, -- we don't ask. This way, the yaku command doesn't ask, and the score command does.++-- | Construct a yakuman context, asking questions when necessary mkYakumanContext :: Hand -> Maybe InterpretedHand -> Maybe Bool -> IO (Maybe YakumanContext) mkYakumanContext hand (Just ih) maybeClosure =     do@@ -325,8 +356,11 @@                                     , isKokushiMusou = True                                     }                     else return Nothing++-- | Overarching context type data Context = Context (Maybe InterpretedHand) HandContext (Either YakuContext YakumanContext) +-- | Top level interface for building a context about a hand. Determines the interpretation, yaku, yakuman etc mkContext :: Hand -> IO Context mkContext hand = do     sevenPairs <-

@@ -13,11 +13,17 @@ import Data.Set qualified as Set import Riichi.Tile +-- | A type alias. A hand is a list of tiles type Hand = [Tile] +{- | Build a hand from an input string.+| The string should be in the format as described in the help message+| eg: 123p parses to 1 Pin, 2 Pin, 3 Pin; rgNE parses to Red, Green, North, East+-} mkHand :: String -> Hand mkHand tiles = tiles & words & (map readTileBlock) & concat +-- | Add dora (in the first argument) a the hand (in the second argument) addDora :: Hand -> Hand -> Hand addDora [] hand = hand addDora dora@(doraTile : rest) hand = do@@ -30,14 +36,18 @@         else             return tile +-- | Get the dora of a given tile getDora :: Tile -> Dora getDora (Honour _ d) = d getDora (Numeric _ _ d) = d --- Note derived equality will ignore dora as tile Eq ignores dora+-- | The data for a pair is just a tile newtype Pair = Pair Tile deriving (Show, Eq) +-- | A meld is a chi, pon, or kan data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord)++-- | Type alias for tracking open / closed melds type Open = Bool  -- | Almost identical to what deriving Eq would generate, except we consider open and closed melds that are otherwise equal to be the same.@@ -47,6 +57,7 @@     (==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList ([tile1, tile2, tile3]) == Set.fromList ([tile1', tile2', tile3'])     (==) _ _ = False +-- | Using the show instance for tile, show melds as "Open/Closed chi/pon/kan: tile tile tile (tile)" instance Show Meld where     show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) True) = "Open chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)     show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) False) = "Closed chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)@@ -59,16 +70,19 @@     show (Kan (tile) True) = "Open kan: " ++ (tile & show & repeat & (take 4) & concat)     show (Kan (tile) False) = "Closed kan: " ++ (tile & show & repeat & (take 4) & concat) +-- | Check if all elements of a list of equatable elements are equal allEqual :: (Eq a) => [a] -> Bool allEqual [] = True allEqual [_] = True allEqual (x : y : ys) = (x == y) && (allEqual (y : ys)) +-- | Check if all elements of a list of equatable elements are different allDifferent :: (Eq a) => [a] -> Bool allDifferent [] = True allDifferent [_] = True allDifferent (x : xs) = (not (x `elem` xs)) && (allDifferent xs) +-- | Check if three tiles form a chi (a sequence) isChi :: Tile -> Tile -> Tile -> Bool isChi (Numeric s1 v1 _) (Numeric s2 v2 _) (Numeric s3 v3 _) =     (allEqual [s1, s2, s3]) && (Set.fromList (map (subtract m) [v1, v2, v3]) == Set.fromList ([0, 1, 2]))@@ -76,37 +90,48 @@     m = minimum [v1, v2, v3] isChi _ _ _ = False +-- | Check if three tiles form a pon (a triple) isPon :: Tile -> Tile -> Tile -> Bool isPon t1 t2 t3 = allEqual [t1, t2, t3] +-- | Check if four tiles form a kan (a quad) isKan :: Tile -> Tile -> Tile -> Tile -> Bool isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4] +-- | Check if a meld is open isOpen :: Meld -> Bool isOpen (Chi _ _ _ x) = x isOpen (Pon _ x) = x isOpen (Kan _ x) = x +-- | Check if a meld is closed meldIsClosed :: Meld -> Bool meldIsClosed = not . isOpen +-- | Open a meld openMeld :: Meld -> Meld openMeld (Chi a b c _) = Chi a b c True openMeld (Pon a _) = Pon a True openMeld (Kan a _) = Kan a True +-- | Check if a meld is a chi meldIsChi :: Meld -> Bool meldIsChi (Chi _ _ _ _) = True meldIsChi _ = False +-- | Check if a meld is a pon meldIsPon :: Meld -> Bool meldIsPon (Pon _ _) = True meldIsPon _ = False +-- | Check if a meld is a kan meldIsKan :: Meld -> Bool meldIsKan (Kan _ _) = True meldIsKan _ = False +{- | Get the "base" of a Meld. For a chi this is the lowest value. Otherwise it is the common value or+| honour instance of the tiles.+-} getMeldBase :: Meld -> Either Integer Honour getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3]) getMeldBase (Pon (Numeric _ v1 _) _) = Left v1@@ -114,7 +139,7 @@ getMeldBase (Pon (Honour honour _) _) = Right honour getMeldBase (Kan (Honour honour _) _) = Right honour --- This considers each dragon and wind to be its own suit, effectively.+-- | Get a meld's suit. This considers each dragon and wind to be its own suit. getMeldSuit :: Meld -> Either Suit Honour getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit getMeldSuit (Pon (Numeric suit _ _) _) = Left suit@@ -122,10 +147,12 @@ getMeldSuit (Pon (Honour honour _) _) = Right honour getMeldSuit (Kan (Honour honour _) _) = Right honour +-- | Get a pair's suit. Treats each dargon and wind as its own suit. getPairSuit :: Pair -> Either Suit Honour getPairSuit (Pair (Numeric suit _ _)) = Left suit getPairSuit (Pair (Honour honour _)) = Right honour +-- | Given a hand, return all the possible ways of interpreting it as a sequence of melds formMelds :: Hand -> [[Meld]] formMelds [] = [[]] formMelds [_] = [[]]@@ -161,11 +188,13 @@             then formMelds (tail hand)             else possible_melds +-- | Count the tiles in a list of melds meldsLength :: [Meld] -> Int meldsLength [] = 0 meldsLength ((Kan _ _) : rest) = 4 + (meldsLength rest) meldsLength (_ : rest) = 3 + (meldsLength rest) +-- | Reverse form melds. Concatenate a list of melds back into a hand. concatMelds :: [Meld] -> Hand concatMelds [] = [] concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest@@ -182,6 +211,7 @@         & (map head)         & (map (\tile -> (Pair tile, hand \\ [tile, tile]))) +-- | 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@@ -198,7 +228,11 @@ -- 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 -- checked separately.++-- | A pair and four melds, constituting a complete hand type InterpretedHand = (Pair, [Meld])++-- | Find all the ways of interpreting a hand as a pair and four melds. interpretHand :: Hand -> [InterpretedHand] interpretHand hand =     let@@ -224,9 +258,11 @@             -- & (filter (\(_, melds) -> melds /= []))             & (filter (\(_, melds) -> (length hand) == 2 + (meldsLength melds))) +-- | Show a full interpreted hand showInterpretedHand :: InterpretedHand -> String showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat +-- | Ask which meld was opened by ron. Return modified melds with that meld opened. getRonMeld :: [Meld] -> IO [Meld] getRonMeld melds = do     putStrLn "Which meld was opened by Ron? (leave blank if it was the pair): "@@ -238,6 +274,9 @@             let index :: Int = input & read              in return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld) +{- | Ask which melds are open in a set of melds. Return modified melds with this data added. Opens the specified melds,+| but if a meld is already open it stays that way. (This may change in the future)+-} getOpenMelds :: [Meld] -> IO [Meld] getOpenMelds melds = do     putStrLn "Which melds are open? (enter a string of indices, or leave blank if all closed): "

@@ -17,132 +17,13 @@ import Riichi.Tile import Riichi.Yaku -type YakumanCount = Sum Int-type Han = Sum Int--getYaku :: Hand -> Maybe InterpretedHand -> Bool -> Bool -> Bool -> Bool -> Wind -> Wind -> Bool -> (Either (Han, Han) YakumanCount, String)-getYaku hand (Just ih@(Pair _, melds)) riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand =-    -- The caller should ensure ih is not empty, as some of these yaku funcitons only look-    -- at the hand, and don't re-check if it has a valid interpretation.-    let-        -- Check Yakuman first.-        yakumanWriter :: Writer (YakumanCount, String) () = do-            when (suuankou ih) $ tell (1, toMagenta "\tYakuman: Four Concealed Triplets\n")-            when (suukantsu ih) $ tell (1, toMagenta "\tYakuman: Four Kans\n")-            when (daisangen ih) $ tell (1, toMagenta "\tYakuman: Big Four Dragons\n")-            when (shousuushii ih) $ tell (1, toMagenta "\tYakuman: Little Winds\n")-            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours\n")-            when (chinroutou hand) $ tell (1, toMagenta "\tYakuman: All Terminals\n")-            when (ryuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Green\n")-            when (chuurenPoutou hand && closedHand) $ tell (1, toMagenta "\tYakuman: Nine Gates\n")-            when (daisuushii ih) $ tell (2, toMagenta "\tDouble Yakuman: Big Winds\n")-        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter--        hanWriter :: Writer (Han, Han, String) () = do-            when (riichi) $ tell (1, 0, toCyan "\t1 Han: Riichi\n")-            when (ippatsu) $ tell (1, 0, toCyan "\t1 Han: Ippatsu\n")-            when (tsumo && and (map meldIsClosed melds)) $ tell (1, 0, toCyan "\t1 Han: Fully concealed hand\n")-            when (pinfu ih seatWind roundWind ryanmanWait closedHand) $ tell (1, 0, toCyan "\t1 Han: Pinfu\n")-            when (tanyao hand) $ tell (1, 1, toCyan "\t1 Han: All simples\n")-            when (haku ih) $ tell (1, 1, toCyan "\t1 Han: Haku (White Dragon)\n")-            when (hatsu ih) $ tell (1, 1, toCyan "\t1 Han: Hatsu (Green Dragon)\n")-            when (chun ih) $ tell (1, 1, toCyan "\t1 Han: Chun (Red Dragon)\n")-            when (checkWind seatWind ih) $ tell (1, 1, toCyan "\t1 Han: Seat wind\n")-            when (checkWind roundWind ih) $ tell (1, 1, toCyan "\t1 Han: Round wind\n")-            when (sanshokuDoujun ih) $ tell (2, 1, toCyan "\t2 Han: Mixed triple sequence (-1 Han if open)\n")-            when (sanshokuDoukou ih) $ tell (2, 2, toCyan "\t2 Han: Triple triplets\n")-            when (sanankou ih) $ tell (2, 2, toCyan "\t2 Han: Three concealed triplets\n")-            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)-            if fullFlush-                then-                    tell (6, 5, toCyan "\t6 Han: Full flush (-1 Han if open)\n")-                else-                    if halfFlush-                        then-                            tell (3, 2, toCyan "\t3 Han: Half flush (-1 Han if open)\n")-                        else-                            return ()-            when (toitoi ih) $ tell (2, 2, toCyan "\t2 Han: All triplets\n")-            when (ittsuu ih) $ tell (2, 1, toCyan "\t2 Han: Pure straight (-1 Han if open)\n")-            when (sankantsu ih) $ tell (2, 2, toCyan "\t2 Han: Three kans\n")-            when (shousangen ih) $ tell (2, 2, toCyan "\t2 Han: Little three dragons\n")-            let (twicePure, singlePure) = (ryanpeikou ih, iipeikou ih)-            if twicePure-                then-                    tell (3, 0, toCyan "\t3 Han: Twice pure double sequence (Closed only)\n")-                else-                    if singlePure-                        then-                            tell (1, 0, toCyan "\t1 Han: Pure double sequence (Closed only)\n")-                        else-                            return ()-            let (fullyOutside, halfOutside, terminalsHonours) = (junchan ih, chanta ih, honroutou hand)-            if fullyOutside-                then-                    tell (3, 2, toCyan "\t3 Han: Fully outside hand (-1 Han if open)\n")-                else-                    if terminalsHonours-                        then-                            tell (2, 2, toCyan "\t2 Han: All terminals and honours\n")-                        else-                            if halfOutside-                                then-                                    tell (2, 1, toCyan "\t2 Han: Half outside hand (-1 Han if open)\n")-                                else-                                    return ()-            when (dora > 0) $ tell (fromInteger dora, fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))-          where-            dora = hand & map getDora & sum--        (_, (hanClosed, hanOpen, output)) = runWriter hanWriter-     in-        if yakumans > 0-            then (Right yakumans, yakumanOutput)-            else-                if output == ""-                    then-                        (Left (0, 0), "\tNo explicit yaku found, riichi or menzen tsumo is required\n")-                    else-                        (Left (hanClosed, hanOpen), output)-getYaku hand Nothing riichi ippatsu tsumo _ _ _ _ =-    let-        -- Check Yakuman first.-        yakumanWriter :: Writer (YakumanCount, String) () = do-            when (thirteenOrphans hand) $ tell (1, toMagenta "\tYakuman: Thirteen Orphans (Double Yakuman if wait is 13 sided)\n")-            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours (+ seven pairs)\n")-        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter--        hanWriter :: Writer (Han, String) () = do-            when (riichi) $ tell (1, toCyan "\t1 Han: Riichi\n")-            when (ippatsu) $ tell (1, toCyan "\t1 Han: Ippatsu\n")-            when (tsumo) $ tell (1, toCyan "\t1 Han: Fully concealed hand\n")-            when (tanyao hand) $ tell (1, toCyan "\t1 Han: All simples\n")-            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)-            if fullFlush-                then-                    tell (6, toCyan "\t6 Han: Full flush\n")-                else-                    if halfFlush-                        then-                            tell (3, toCyan "\t3 Han: Half flush\n")-                        else-                            return ()-            when (honroutou hand) $ tell (2, toCyan "\t2 Han: All terminals and honours\n")-            when (dora > 0) $ tell (fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))-          where-            dora = hand & map getDora & sum+-- | Type alias+type YakumanCount = Int -        (_, (han, output)) = runWriter hanWriter-     in-        if yakumans > 0-            then (Right yakumans, yakumanOutput)-            else-                if chiitoitsu hand-                    then-                        (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output)-                    else-                        (Left (0, 0), "This hand is not valid\n")+-- | Type alias+type Han = Sum Int +-- | Get the fu contributed by a meld (only pons and kans give fu) getMeldFu :: Meld -> Fu getMeldFu (Chi _ _ _ _) = 0 getMeldFu (Pon (Numeric _ v _) True) = if v `elem` [1, 9] then 4 else 2@@ -154,24 +35,26 @@ getMeldFu (Kan (Numeric _ v _) False) = if v `elem` [1, 9] then 32 else 16 getMeldFu (Kan (Honour _ _) False) = 32 --- Get fu for a standard hand. Seven pairs and thirteen orphans, as ever, are handled separately+-- | Get fu for a standard hand. Seven pairs and thirteen orphans, as ever, are handled separately type Fu = Int-getFu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool -> Fu-getFu (Pair tile, melds) seatWind roundWind goodWait tsumo closedHand =-    -- Perhaps a writer monad over the sum int monoid would be more elegant here but I think this more-    -- descriptive method is fine too.-    let meldsFu = melds & map getMeldFu & sum-        waitFu = if goodWait then 2 else 0-        yakuhaiFu =-            (if (tile & isDragon) then 2 else 0)-                + (if (tile == (Honour (Wind roundWind) 0)) then 2 else 0)-                + (if (tile == (Honour (Wind seatWind) 0)) then 2 else 0)-        ronClosedFu = if (not tsumo) && closedHand then 10 else 0-        tsumoFu = if tsumo then 2 else 0-     in roundUp (20 + meldsFu + waitFu + yakuhaiFu + ronClosedFu + tsumoFu)-  where-    roundUp n = last ([120, 110 .. 10] & filter (>= n)) +-- getFu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool -> Fu+-- getFu (Pair tile, melds) seatWind roundWind goodWait tsumo closedHand =+--     -- Perhaps a writer monad over the sum int monoid would be more elegant here but I think this more+--     -- descriptive method is fine too.+--     let meldsFu = melds & map getMeldFu & sum+--         waitFu = if goodWait then 2 else 0+--         yakuhaiFu =+--             (if (tile & isDragon) then 2 else 0)+--                 + (if (tile == (Honour (Wind roundWind) 0)) then 2 else 0)+--                 + (if (tile == (Honour (Wind seatWind) 0)) then 2 else 0)+--         ronClosedFu = if (not tsumo) && closedHand then 10 else 0+--         tsumoFu = if tsumo then 2 else 0+--      in roundUp (20 + meldsFu + waitFu + yakuhaiFu + ronClosedFu + tsumoFu)+--   where+--     roundUp n = last ([120, 110 .. 10] & filter (>= n))++-- | Given the han and fu, together with dealer and tsumo info, return the score of a hand getScore :: Han -> Fu -> Bool -> Bool -> Integer getScore han fu dealer tsumo =     if dealer@@ -204,6 +87,7 @@                             Just score -> score                             Nothing -> 0 +-- | Form the string describing the yaku, given a yaku context formYakuString :: YakuContext -> String formYakuString yakuContext@YakuContext{yakuHandContext = handContext@HandContext{riichi = riichiContext, dora}} =     let hanWriter :: Writer String () = do@@ -236,6 +120,7 @@         (_, string) = runWriter hanWriter      in string +-- | Get the han specified by a yaku context getYakuHan :: YakuContext -> Han getYakuHan yakuContext@YakuContext{yakuHandContext = handContext@HandContext{riichi = riichiContext, dora}} =     let@@ -271,6 +156,7 @@      in         han +-- | Form the string describing the yakumans of a yakuman context formYakumanString :: YakumanContext -> String formYakumanString yakumanContext =     let@@ -288,7 +174,9 @@         (_, string) = runWriter yakumanWriter      in         string-getYakumanCount :: YakumanContext -> Int++-- | Count the yakumans in a yakuman context+getYakumanCount :: YakumanContext -> YakumanCount getYakumanCount yakumanContext =     let         yakumanWriter :: Writer (Sum Int) () = do@@ -306,15 +194,18 @@      in         getSum yakumans +-- | For the string for a general context. Works fo yaku and yakuman. formContextString :: Context -> String formContextString (Context _ _ (Left yakuContext)) = formYakuString yakuContext formContextString (Context _ _ (Right yakumanContext)) = formYakumanString yakumanContext -getContextHanOrYakumans :: Context -> Either Han Int+-- | Get the han or yakumans of a context+getContextHanOrYakumans :: Context -> Either Han YakumanCount getContextHanOrYakumans (Context _ _ (Left yakuContext)) = Left $ getYakuHan yakuContext getContextHanOrYakumans (Context _ _ (Right yakumanContext)) = Right $ getYakumanCount yakumanContext -getContextHansOrYakumans :: Context -> Either (Han, Han) Int+-- | Get the open and closed han, or yakumans, of a context+getContextHansOrYakumans :: Context -> Either (Han, Han) YakumanCount getContextHansOrYakumans (Context _ _ (Left yakuContext@YakuContext{yakuHandContext = handContext})) =     Left $         ( getYakuHan yakuContext{yakuHandContext = closeHandContext handContext}@@ -322,8 +213,9 @@         ) getContextHansOrYakumans (Context _ _ (Right yakumanContext)) = Right $ getYakumanCount yakumanContext -_getFu :: InterpretedHand -> HandContext -> Fu-_getFu (Pair tile, melds) c =+-- | Get the fu of an interpreted hand, given some context about the hand+getFu :: InterpretedHand -> HandContext -> Fu+getFu (Pair tile, melds) c =     let         sw = seatWind $ wind c         rw = roundWind $ wind c@@ -343,11 +235,12 @@   where     roundUp n = last ([120, 110 .. 10] & filter (>= n)) --- Partial function!+-- | Get the fu for a context. getContextFu :: Context -> Fu-getContextFu (Context (Just ih) handContext _) = _getFu ih handContext+getContextFu (Context (Just ih) handContext _) = getFu ih handContext getContextFu (Context Nothing handContext _) = 25 +-- | Score table hashmap for tsumo + dealer. 4 han and below. scoreTableTsumoDealer :: M.Map (Han, Fu) Integer scoreTableTsumoDealer =     M.fromList@@ -395,6 +288,7 @@         , ((4, 110), 12000)         ] +-- | Score table hashmap for ron + dealer. 4 han and below. scoreTableRonDealer :: M.Map (Han, Fu) Integer scoreTableRonDealer =     M.fromList@@ -439,6 +333,7 @@         , ((4, 110), 12000)         ] +-- | Score table hashmap for tsumo + non-dealer. 4 han and below. scoreTableTsumoNonDealer :: M.Map (Han, Fu) Integer scoreTableTsumoNonDealer =     M.fromList@@ -486,6 +381,7 @@         , ((4, 110), 8000)         ] +-- | Score table hashmap for ron + non-dealer. 4 han and below. scoreTableRonNonDealer :: M.Map (Han, Fu) Integer scoreTableRonNonDealer =     M.fromList@@ -530,6 +426,7 @@         , ((4, 110), 8000)         ] +-- | Score table for 5 han and up. Dealer manganToSanbaimanTableDealer :: M.Map Han Integer manganToSanbaimanTableDealer =     M.fromList@@ -543,6 +440,7 @@         , (12, 36000)         ] +-- | Score table for 5 han and up. Non-dealer manganToSanbaimanTableNonDealer :: M.Map Han Integer manganToSanbaimanTableNonDealer =     M.fromList@@ -556,6 +454,7 @@         , (12, 24000)         ] +-- | Get the name for a 5+ han hand hanToHandName :: Han -> String hanToHandName 5 = "Mangan" hanToHandName 6 = "Haneman"

@@ -106,41 +106,50 @@     (==) (Numeric suit value _) (Numeric suit' value' _) = (suit == suit') && (value == value')     (==) _ _ = False +-- | Get the suit of a tile, as an Either getTileSuit :: Tile -> Either Suit Honour getTileSuit (Numeric Pin _ _) = Left Pin getTileSuit (Numeric Man _ _) = Left Man getTileSuit (Numeric Sou _ _) = Left Sou getTileSuit (Honour honour _) = Right honour +-- | Check if a tile is a simple (2-8 Numeric) isSimple :: Tile -> Bool isSimple (Honour _ _) = False isSimple (Numeric _ 1 _) = False isSimple (Numeric _ 9 _) = False isSimple _ = True +-- | Check if a tile is a terminal (1 or 9 Numeric) isTerminal :: Tile -> Bool isTerminal (Numeric _ 1 _) = True isTerminal (Numeric _ 9 _) = True isTerminal _ = False +-- | Check if a tile is an honour (dragon or wind) isHonour :: Tile -> Bool isHonour (Honour _ _) = True isHonour _ = False +-- | Check if a tile is numeric isNumeric :: Tile -> Bool isNumeric = not . isHonour +-- | Check if a tile is a dragon isDragon :: Tile -> Bool isDragon (Honour (Dragon _) _) = True isDragon _ = False +-- | Check if a tile is a wind isWind :: Tile -> Bool isWind (Honour (Wind _) _) = True isWind _ = False +-- | Check if an honour is a dragon honourIsDragon :: Honour -> Bool honourIsDragon (Dragon _) = True honourIsDragon _ = False +-- | Check if an honour is a wind honourIsWind :: Honour -> Bool honourIsWind = not . honourIsDragon

@@ -11,6 +11,7 @@ import Riichi.Meld import Riichi.Tile +-- | Get the waits of a hand, represented as a list of tiles. getWaits :: Hand -> [Tile] getWaits hand =     if length hand < 13@@ -54,6 +55,10 @@                                     else let [a, b] = diff in return (meldWait a b)              in (sevenPairsWait ++ orphansWaits ++ fourMeldsWaits ++ threeMeldWaits) & sort & group & map head +{- | Find the waits of a partial meld, specified as two tiles. Note we'll never be waiting on a Kan, since+forming a Kan with a single tile means you already had a meld, thus already had a complete hand. But a+player can't be holding a complete hand.+-} meldWait :: Tile -> Tile -> [Tile] meldWait a b     | a == b = [a]