riichi-scoring 0.3.0.0 → 0.3.1.0

raw patch · 7 files changed

+161/−184 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +30/−0
• riichi-scoring.cabal +6/−1
• src/Riichi/Context.hs +27/−5
• src/Riichi/Display.hs +1/−176
• src/Riichi/Meld.hs +2/−1
• test/Test.hs +83/−1

@@ -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.

@@ -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 <subcommand> "<hand>"++        "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

@@ -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,

@@ -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)

@@ -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."

@@ -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

@@ -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)