diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 + diff --git a/riichi-scoring.cabal b/riichi-scoring.cabal --- a/riichi-scoring.cabal +++ b/riichi-scoring.cabal @@ -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. diff --git a/src/ColourStrings.hs b/src/ColourStrings.hs --- a/src/ColourStrings.hs +++ b/src/ColourStrings.hs @@ -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" diff --git a/src/Riichi/Context.hs b/src/Riichi/Context.hs --- a/src/Riichi/Context.hs +++ b/src/Riichi/Context.hs @@ -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 <- diff --git a/src/Riichi/Meld.hs b/src/Riichi/Meld.hs --- a/src/Riichi/Meld.hs +++ b/src/Riichi/Meld.hs @@ -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): " diff --git a/src/Riichi/Scoring.hs b/src/Riichi/Scoring.hs --- a/src/Riichi/Scoring.hs +++ b/src/Riichi/Scoring.hs @@ -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" diff --git a/src/Riichi/Tile.hs b/src/Riichi/Tile.hs --- a/src/Riichi/Tile.hs +++ b/src/Riichi/Tile.hs @@ -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 diff --git a/src/Riichi/Waits.hs b/src/Riichi/Waits.hs --- a/src/Riichi/Waits.hs +++ b/src/Riichi/Waits.hs @@ -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]