diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,3 +30,15 @@ approach, defined in new Context submodule. This helps simplify function signatures for operations that need many pieces of information besides just the superficial composition of a hand. + +## 0.3.0.1 +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, +a bug introduced by the refactor, since mkYakumanContext intentionally gets less +information than mkYakuContext since generally it needs less. +Now only ask for wind context if we see a wind tile in the hand. Note even a +wind pair could matter - it won't affect most yaku but affects Fu. +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +This package provides a CLI tool with commands for determining the yaku, fu, and score of a hand in Riichi Mahjong. It can also determine the waits of a partial hand. + +The CLI tool supplied is the riichi command. Help information is as follows: + + Command riichi: + Possible subcommands: yaku, waits, score (default = yaku) + + Usage: + riichi "" + + "yaku" and "score" subcommands expect a full hand. + "waits" subcommand expects a hand that is tenpai. + + Example hands include: + "123p 234m 444p rrrr NN" + "344556s 444p 222m EE" + "19p 19s 19m 1p NESWrgw" + + In detail, numeric tiles are denoted (1-9) + (m, p, or s), + Winds are denoted N, E, S, W, and Dragons are r, w, g. + A 0 can be used to denote a red five. + Numeric tiles of the same suit, and honour tiles, can be + grouped as seen in the examples (but needn't be). + + In scoring a hand, dora and seat/round wind must be supplied, + also in this format. + +Internal libraries are also exposed. + +Hackage page: https://hackage.haskell.org/package/riichi-scoring 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.0.0 +version: 0.3.1.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. @@ -28,6 +28,10 @@ This package provides a CLI tool with commands for determining the yaku, fu, and score of a hand in Riichi Mahjong. It can also determine the waits of a partial hand. See README.md for usage, or run: riichi --help +extra-doc-files: + CHANGELOG.md + README.md + -- The license under which the package is released. license: BSD-3-Clause -- The file containing the license text. @@ -100,6 +104,7 @@ main-is: Test.hs build-depends: base >=4.19.2.0 && <5, + containers >=0.6.8 && <0.8, riichi-scoring, tasty >=1.5.4 && <1.6, tasty-hunit >=0.10.2 && <0.11, diff --git a/src/Riichi/Context.hs b/src/Riichi/Context.hs --- a/src/Riichi/Context.hs +++ b/src/Riichi/Context.hs @@ -243,7 +243,16 @@ mkYakumanContext :: Hand -> Maybe InterpretedHand -> Maybe Bool -> IO (Maybe YakumanContext) mkYakumanContext hand (Just ih) maybeClosure = do - let isSuuaa = suuankou ih + -- let isSuuaa = suuankou ih + isSuuaa <- + if suuankou ih + -- Want to check concealment without the whole handContext, add riichi context, add closure context + -- rigmarole. If we've been told the hand is open, then one of the four triplets is open since these + -- are all the melds. If the hand is closed, a meld could still be open so we need to ask. + then case maybeClosure of + Just False -> return False + otherwise -> askYesNo "Are the four triplets all concealed? [y/n]: " + else return False let isSuuka = suukantsu ih let isDaisa = daisangen ih let isShous = shousuushii ih @@ -324,7 +333,7 @@ if chiitoitsu hand then askYesNo "Seven pairs? [y/n]: " else return False - let handContext@HandContext{isThirteenOrphans = orphans} = getMinimalHandContext hand sevenPairs + let orphans = thirteenOrphans hand maybeIh <- if sevenPairs || orphans then @@ -352,12 +361,25 @@ maybeYakumanContext <- mkYakumanContext hand maybeIh Nothing case maybeYakumanContext of Nothing -> do - handContext' <- + putStrLn "Input dora (or leave blank):" + dora <- mkHand <$> getLine + if dora /= [] + then + putStrLn "" + else return () + + let hand' = addDora dora hand + -- I suppose this will calculate thirteenOrphans hand' all over again, slight inneficiency in that sense + -- as we are checking it twice... Except... Laziness probably saves us from that! + let handContext = getMinimalHandContext hand' sevenPairs + handContext' <- do + let hasWind = hand' & (filter isWind) & (/= []) if not sevenPairs - then pure handContext >>= addWindContext >>= addRiichiContext >>= addTsumoContext >>= addWaitContext + then pure handContext >>= (if hasWind then addWindContext else pure) >>= addRiichiContext >>= addTsumoContext >>= addWaitContext else pure handContext >>= addRiichiContext >>= addTsumoContext (maybeIh', handContext'') <- addClosedContext maybeIh handContext' - let yakuContext = mkYakuContext hand maybeIh' handContext'' + let yakuContext = mkYakuContext hand' maybeIh' handContext'' return $ Context maybeIh' handContext'' (Left yakuContext) Just yakumanContext -> do + let handContext@HandContext{isThirteenOrphans = orphans} = getMinimalHandContext hand sevenPairs return $ Context maybeIh handContext (Right yakumanContext) diff --git a/src/Riichi/Display.hs b/src/Riichi/Display.hs --- a/src/Riichi/Display.hs +++ b/src/Riichi/Display.hs @@ -95,15 +95,7 @@ if length hand < 14 then putStrLn "Hand is the wrong size" else do - putStrLn "Input dora (or leave blank):" - dora <- mkHand <$> getLine - if dora /= [] - then - putStrLn "" - else return () - - let hand' = addDora dora hand - context@(Context _ handContext _) <- mkContext hand' + context@(Context _ handContext _) <- mkContext hand let string = formContextString context let tsumo = isTsumo handContext let closure = isClosed handContext @@ -147,170 +139,3 @@ ++ " points for Dealer, " ++ toGreen (show (yakumans * 32000)) ++ " points for Non-Dealer." - --- putStrLn "Input round and seat wind: " --- (Honour (Wind roundWind) _) : (Honour (Wind seatWind) _) : _ <- mkHand <$> getLine --- putStrLn "Riichi? [y/n]: " --- riichi <- (== "y") <$> getLine --- ippatsu <- --- if riichi --- then do --- putStrLn "Ippatsu? [y/n]: " --- (== "y") <$> getLine --- else return False --- putStrLn "Tsumo? [y/n]: " --- input <- getLine --- let tsumo = (input == "y") --- --- sevenPairs <- --- if chiitoitsu hand' --- then do --- putStrLn "Seven pairs? [y/n]: " --- input <- getLine --- if input == "y" --- then --- return True --- else --- return False --- else return False - --- if sevenPairs == True --- then do --- let (value, yaku_string) = getYaku hand' Nothing riichi ippatsu tsumo False seatWind roundWind True --- putStrLn $ case value of --- Left (han, _) -> --- yaku_string --- ++ "\t\t" --- ++ toGreen (show (getSum han)) --- ++ " Han total, closed by definition\n" --- ++ "\n\t" --- ++ toGreen (show (getScore han 25 True tsumo)) --- ++ " points for Dealer, " --- ++ toGreen (show (getScore han 25 False tsumo)) --- ++ " points for Non-Dealer." --- ++ ( if name /= "" --- then --- " (" --- ++ toMagenta name --- ++ ")." --- else "" --- ) --- where --- name = hanToHandName han --- Right yakumans -> --- yaku_string --- ++ "\t\t" --- ++ toGreen (show (getSum yakumans)) --- ++ " Yakuman total\n" --- ++ "\n\t" --- ++ toGreen (show (getSum yakumans * 48000)) --- ++ " points for Dealer, " --- ++ toGreen (show (getSum yakumans * 32000)) --- ++ " points for Non-Dealer." --- else do --- let ihs = interpretHand hand' --- maybeIh <- --- if thirteenOrphans hand' --- then return Nothing --- else do --- (pair, melds) <- --- if length ihs > 1 --- then do --- putStrLn "Select hand interpretation: " --- sequence_ $ [("[" ++ show n ++ "]: " ++ (ih & showInterpretedHand)) & putStrLn | (n :: Integer, ih) <- zip [0 ..] ihs] --- n <- read <$> getLine :: IO Int --- return (ihs !! n) --- else do --- putStrLn "Found one way to interpret this hand: " --- let ih = head ihs --- putStrLn (showInterpretedHand ih) --- return ih --- --- melds' <- case (riichi, tsumo) of --- (True, True) -> return melds --- (True, False) -> getRonMeld melds --- -- putStrLn "Which meld was opened by Ron? (enter an index): " --- -- sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds] --- -- input <- getLine --- -- let index :: Int = input & read --- -- return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld --- (False, _) -> getOpenMelds melds --- -- putStrLn "Which melds are open? (enter a string of indices, or leave blank if all closed): " --- -- sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds] --- -- input <- getLine --- -- let indices :: [Int] = input & map return & (map read) --- -- return $ (zip [0 ..] melds) & map (\(i, meld) -> if i `elem` indices then openMeld meld else meld) --- return $ Just (pair, melds') --- --- putStrLn "Did the hand have an open wait? [y/n]: " --- ryanmanWait <- (== "y") <$> getLine --- shanponWait <- --- if ryanmanWait --- then return False --- else do --- putStrLn "Did the hand have a dual pair wait? [y/n]: " --- (== "y") <$> getLine --- let goodWait = not (ryanmanWait || shanponWait) --- --- closedHand <- case maybeIh of --- Just (_, melds) -> --- case numOpen of --- 0 -> return True --- _ --- | numOpen > 1 -> return False --- | otherwise -> case (riichi, tsumo) of --- (True, _) -> return True --- (False, True) -> return False -- Already know there is an open meld. Now we know it wasn't opened by Ron. --- (False, False) -> --- ( do --- putStrLn "Damaten? [y/n]:" --- (== "y") <$> getLine --- ) --- where --- numOpen = melds & filter isOpen & length --- Nothing -> return $ True --- let (value, yaku_string) = getYaku hand' maybeIh riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand --- let fu = case maybeIh of --- Just ih -> --- if pinfu ih seatWind roundWind ryanmanWait closedHand --- then if tsumo then 20 else 30 --- else getFu ih seatWind roundWind goodWait tsumo closedHand --- -- Seven pairs already taken care of, so Nothing signifies thirteen orphans or an invalid hand. --- -- So yakuman or invalid - 0 Fu, we will say. --- Nothing -> 0 --- putStrLn $ case value of --- Left (hanClosed, hanOpen) -> --- "\tYaku:\n" --- ++ yaku_string --- ++ "\t\t" --- ++ openClosed --- ++ toGreen (show (getSum han)) --- ++ " Han total, with " --- ++ toBlue (show fu) --- ++ " Fu\n" --- ++ "\n\t" --- ++ toGreen (show (getScore han fu True tsumo)) --- ++ " points for Dealer, " --- ++ toGreen (show (getScore han fu False tsumo)) --- ++ " points for Non-Dealer" --- ++ ( if name /= "" --- then --- " (" --- ++ toMagenta name --- ++ ")." --- else "" --- ) --- where --- han = if (closedHand) then hanClosed else hanOpen --- name = hanToHandName han --- openClosed = if closedHand then "Closed hand: " else "Open hand: " --- Right yakumans -> --- yaku_string --- ++ "\t\t" --- ++ toGreen (show (getSum yakumans)) --- ++ " Yakuman total\n" --- ++ "\n\t" --- ++ toGreen (show (getSum yakumans * 48000)) --- ++ " points for Dealer, " --- ++ toGreen (show (getSum yakumans * 32000)) --- ++ " points for Non-Dealer." diff --git a/src/Riichi/Meld.hs b/src/Riichi/Meld.hs --- a/src/Riichi/Meld.hs +++ b/src/Riichi/Meld.hs @@ -34,7 +34,8 @@ getDora (Honour _ d) = d getDora (Numeric _ _ d) = d -newtype Pair = Pair Tile deriving (Show) +-- Note derived equality will ignore dora as tile Eq ignores dora +newtype Pair = Pair Tile deriving (Show, Eq) data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord) type Open = Bool diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,10 @@ import Test.Tasty import Test.Tasty.HUnit +import Data.Set qualified as Set +import Riichi.Context +import Riichi.Meld +import Riichi.Scoring import Riichi.Tile main :: IO () @@ -11,6 +15,8 @@ testGroup "All tests" [ tileTests + , meldsTests + , scoringTest ] tileTests :: TestTree @@ -23,6 +29,82 @@ , testCase "Single tile read test" $ ((read "0m" :: Tile) == (read "5m" :: Tile)) && (read "r" == Honour (Dragon Red) 1) @?= True - , testCase "Multi tile read test" $ + , testCase "Multi tile read test 1" $ (readTileBlock "123p" @?= [Numeric Pin 1 0, Numeric Pin 2 0, Numeric Pin 3 0]) + , testCase "Multi tile read test 2" $ + (readTileBlock "rwN" @?= [Honour (Dragon Red) 0, Honour (Dragon White) 0, Honour (Wind North) 0]) ] + +meldsTests :: TestTree +meldsTests = + testGroup + "Melds test group" + [ testCase "Form melds test 1" $ + let + hand = mkHand "13p 3333s 2p N 65m rrr 7m N" + (pair, melds) = head $ interpretHand hand + expectedPair = Pair (Honour (Wind North) 4) + expextedMelds = + Set.fromList + [ Kan (Numeric Sou 3 0) False + , Chi (Numeric Pin 1 0) (Numeric Pin 2 0) (Numeric Pin 3 1) False + , Chi (Numeric Man 7 0) (Numeric Man 5 2) (Numeric Man 6 0) True + , Pon (Honour (Dragon Red) 1) False + ] + in + (Set.fromList melds == expextedMelds) && (pair == expectedPair) @?= True + , testCase "Form melds test 2" $ + let + hand = mkHand "222m 333m 444m 555m 77p" + ihs = interpretHand hand + in + (length ihs) @?= 3 + ] + +scoringTest :: TestTree +scoringTest = + testGroup + "Scoring test group" + [ testCase "Scoring test 1" $ + testHanHandScore "567m 44s N EgEgEg NN" "6p" False False False False False North East False @?= (5, 50, 8000) + , testCase "Scoring test 2" $ + testHanHandScore "345789m 78999s ggg" "9s" False False True False True West East False @?= (4, 40, 12000) + , testCase "Scoring test 3" $ + testHanHandScore "345789m 78999s ggg" "9s" False False False False True West East False @?= (4, 30, 11600) + , testCase "Scoring test 4" $ + testHanHandScore "567p 33557788993s" "" True False False True False South South False @?= (2, 40, 2600) + , testCase "Scoring test 5" $ + testHanHandScore "22221345663p NNN" "r" False False False False False North South False @?= (3, 40, 5200) + , testCase "Scoring test 6" $ + testHanHandScore "234m 7p 567s 34p 66p 66p 57p" "5s w" False False False False True North South False @?= (2, 40, 3900) + ] + +testHanHandScore handString doraString riichi ippatsu tsumo closed dealer sw rw sevenPairs = + let + hand = mkHand handString + dora = mkHand doraString + hand' = addDora dora hand + handContext = getMinimalHandContext hand' sevenPairs + handContext' = + handContext + { riichi = + RiichiContext + { isRiichi = riichi + , isIppatsu = ippatsu + } + , isTsumo = tsumo + , isClosed = closed + , wind = + WindContext + { seatWind = sw + , roundWind = rw + } + } + ih = head $ interpretHand hand' + yakuContext = mkYakuContext hand' (Just ih) handContext' + context = Context (Just ih) handContext' (Left yakuContext) + (Left han) = getContextHanOrYakumans context + fu = getContextFu context + score = getScore han fu dealer tsumo + in + (han, fu, score)