diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for Mahjong -## 0.1.0.0 -- YYYY-mm-dd +See git repo for more detailed commit information. -* First version. Released on an unsuspecting world. +## 0.1.0.0 +First functional prototype. + +## 0.1.0.1 +Dependency versions reworked. + +## 0.2.0.0 +Help messages improved. Module structure refactored. Documentation begun. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,17 +1,24 @@ +{- | +Module : Main +Description : Contains entrypoint for CLI in main function. +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} module Main (main) where -import Display -import Meld +import Riichi.Display +import Riichi.Meld import System.Environment (getArgs) +-- | Entrypoint for CLI executable riichi. main :: IO () main = do args <- getArgs let list = ['1' .. '9'] ++ "NESWrgw" case args of - [] -> putStrLn "No arguments supplied" + [] -> putStrLn "No arguments supplied. Run riichi --help for more info." (arg : []) - | (arg `elem` ["--help", "-h", "help"]) -> putStrLn "Command riichi:\n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage: mahjong \"\"" + | (arg `elem` ["--help", "-h", "help"]) -> putStrLn helpString | (arg `elem` ["yaku", "waits", "score"]) -> putStrLn "Missing hand" | (head arg) `elem` list -> displayHandYaku $ mkHand arg | otherwise -> putStrLn "Command not recognised" @@ -20,3 +27,21 @@ | arg1 == "waits" -> displayHandWaits $ mkHand arg2 | arg1 == "score" -> displayHandScore $ mkHand arg2 | otherwise -> putStrLn "Command not recognised" + +helpString :: String +helpString = + "Command riichi:\n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage:\ + \\n\triichi \"\"\ + \\n\n\t\"yaku\" and \"score\" subcommands expect a full hand.\ + \\n\t\"waits\" subcommand expects a hand that is tenpai.\ + \\n\n\tExample hands include:\ + \\n\t\t\"123p 234m 444p rrrr NN\"\ + \\n\t\t\"344556s 444p 222m EE\"\ + \\n\t\t\"19p 19s 19m 1p NESWrgw\"\ + \\n\n\tIn detail, numeric tiles are denoted (1-9) + (m, p, or s),\ + \\n\tWinds are denoted N, E, S, W, and Dragons are r, w, g.\ + \\n\tA 0 can be used to denote a red five.\ + \\n\tNumeric tiles of the same suit, and honour tiles, can be \ + \\n\tgrouped as seen in the examples (but needn't be).\ + \\n\n\tIn scoring a hand, dora and seat/round wind must be supplied,\ + \\n\talso in this format." diff --git a/riichi-scoring.cabal b/riichi-scoring.cabal --- a/riichi-scoring.cabal +++ b/riichi-scoring.cabal @@ -20,11 +20,14 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.1 +version: 0.2.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. -description: 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. +description: + 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 + -- The license under which the package is released. license: BSD-3-Clause -- The file containing the license text. @@ -49,21 +52,21 @@ common warnings ghc-options: -Wall -library +library riichi-lib exposed-modules: - Display - Meld - Scoring - Tile - Waits - Yaku + Riichi.Display + Riichi.Meld + Riichi.Scoring + Riichi.Tile + Riichi.Waits + Riichi.Yaku other-modules: ColourStrings hs-source-dirs: src build-depends: - base ^>=4.19.2.0, + base >=4.19.2.0 && <5, containers >=0.7 && <0.8, mtl >=2.3.1 && <2.4, @@ -80,12 +83,24 @@ -- other-extensions: -- Other library packages from which modules are imported. build-depends: - base ^>=4.19.2.0, + base >=4.19.2.0 && <5, containers >=0.7 && <0.8, mtl >=2.3.1 && <2.4, - riichi-scoring, + riichi-lib, -- Directories containing source files. hs-source-dirs: app -- Base language which the package is written in. + default-language: GHC2021 + +test-suite riichi-scoring-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: + base >=4.19.2.0 && <5, + riichi-lib, + tasty, + tasty-hunit, + default-language: GHC2021 diff --git a/src/ColourStrings.hs b/src/ColourStrings.hs --- a/src/ColourStrings.hs +++ b/src/ColourStrings.hs @@ -1,3 +1,9 @@ +{- | +Module : ColourStrings +Description : Helper functions for colouring output +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} module ColourStrings where toRed :: String -> String diff --git a/src/Display.hs b/src/Display.hs deleted file mode 100644 --- a/src/Display.hs +++ /dev/null @@ -1,224 +0,0 @@ -module Display where - -import ColourStrings -import Data.Function -import Data.List (intersperse, sort) -import Data.Monoid (getSum) -import Meld -import Scoring -import Tile -import Waits -import Yaku - -displayHandYaku :: Hand -> IO () -displayHandYaku hand = do - if length hand < 14 - then - putStrLn "Hand is the wrong size" - else do - let ihs = interpretHand hand - putStrLn "🀀 🀁 🀂 🀃 " - putStrLn "Assuming East round and East seat." - let num = length ihs - if num >= 1 - then do - if num == 1 - then putStrLn $ "Found " ++ show num ++ " way to interpret this hand:\n" - else putStrLn $ "Found " ++ show num ++ " ways to interpret this hand:\n" - putStrLn $ concat $ do - ih <- ihs - let hand_string = ih & showInterpretedHand - let (value, yaku_string) = getYaku hand (Just ih) False False False False East East False - return $ case value of - Left (hanClosed, hanOpen) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum hanClosed)) ++ " Han total if closed, " ++ toGreen (show (getSum hanOpen)) ++ " if open\n" - Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n" - else return () - if allPairs hand || thirteenOrphans hand - then do - if num == 0 - then putStrLn "This hand can be interpreted as:\n" - else putStrLn "This hand can also be interpreted as:\n" - let hand_string = hand & sort & map show & intersperse ", " & concat - let (value, yaku_string) = getYaku hand Nothing False False False False East East False - putStrLn $ case value of - Left (han, _) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum han)) ++ " Han total, closed by definition\n" - Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n" - else - if num == 0 - then putStrLn $ toRed "This hand is not valid" - else return () - -displayHandWaits :: Hand -> IO () -displayHandWaits hand = do - let waits = getWaits hand - putStrLn $ "Waits are: " ++ (waits & map show & intersperse ", " & concat) - -displayHandScore :: Hand -> IO () -displayHandScore hand = do - putStrLn "Input dora: (or leave blank)" - dora <- mkHand <$> getLine - let hand' = addDora dora hand - 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 (allPairs hand') && (length hand' == 14) - then do - putStrLn "Seven pairs? [y/n]: " - input <- getLine - if input == "y" - 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." - return True - else - return False - else return False - if sevenPairs == False - then 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) -> do - 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, _) -> do - 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." - else return () diff --git a/src/Meld.hs b/src/Meld.hs deleted file mode 100644 --- a/src/Meld.hs +++ /dev/null @@ -1,217 +0,0 @@ -module Meld where - -import Data.Function -import Data.List -import Data.Set qualified as Set -import Tile - -type Hand = [Tile] - -mkHand :: String -> Hand -mkHand tiles = tiles & words & (map readTileBlock) & concat - -addDora :: Hand -> Hand -> Hand -addDora [] hand = hand -addDora dora@(doraTile : rest) hand = do - let hand' = addDora rest hand - tile <- hand' - if doraTile == tile - then return $ case tile of - (Honour x d) -> (Honour x (d + 1)) - (Numeric s v d) -> (Numeric s v (d + 1)) - else - return tile - -getDora :: Tile -> Dora -getDora (Honour _ d) = d -getDora (Numeric _ _ d) = d - -newtype Pair = Pair Tile deriving (Show) - -data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord) -type Open = Bool - -instance Eq Meld where - (==) (Pon tile1 _) (Pon tile2 _) = tile1 == tile2 - (==) (Kan tile1 _) (Kan tile2 _) = tile1 == tile2 - (==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList ([tile1, tile2, tile3]) == Set.fromList ([tile1', tile2', tile3']) - (==) _ _ = False - -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) - show (Pon (Numeric suit v1 _) True) = "Open pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit) - show (Pon (Numeric suit v1 _) False) = "Closed pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit) - show (Kan (Numeric suit v1 _) True) = "Open kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit) - show (Kan (Numeric suit v1 _) False) = "Closed kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit) - show (Pon (tile) True) = "Open pon: " ++ (tile & show & repeat & (take 3) & concat) - show (Pon (tile) False) = "Closed pon: " ++ (tile & show & repeat & (take 3) & concat) - show (Kan (tile) True) = "Open kan: " ++ (tile & show & repeat & (take 4) & concat) - show (Kan (tile) False) = "Closed kan: " ++ (tile & show & repeat & (take 4) & concat) - -allEqual :: (Eq a) => [a] -> Bool -allEqual [] = True -allEqual [_] = True -allEqual (x : y : ys) = (x == y) && (allEqual (y : ys)) - -allDifferent :: (Eq a) => [a] -> Bool -allDifferent [] = True -allDifferent [_] = True -allDifferent (x : xs) = (not (x `elem` xs)) && (allDifferent xs) - -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])) - where - m = minimum [v1, v2, v3] -isChi _ _ _ = False - -isPon :: Tile -> Tile -> Tile -> Bool -isPon t1 t2 t3 = allEqual [t1, t2, t3] - -isKan :: Tile -> Tile -> Tile -> Tile -> Bool -isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4] - -isOpen :: Meld -> Bool -isOpen (Chi _ _ _ x) = x -isOpen (Pon _ x) = x -isOpen (Kan _ x) = x - -isClosed :: Meld -> Bool -isClosed = not . isOpen - -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 - -meldIsChi :: Meld -> Bool -meldIsChi (Chi _ _ _ _) = True -meldIsChi _ = False - -meldIsPon :: Meld -> Bool -meldIsPon (Pon _ _) = True -meldIsPon _ = False - -meldIsKan :: Meld -> Bool -meldIsKan (Kan _ _) = True -meldIsKan _ = False - -getMeldBase :: Meld -> Either Integer Honour -getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3]) -getMeldBase (Pon (Numeric _ v1 _) _) = Left v1 -getMeldBase (Kan (Numeric _ v1 _) _) = Left v1 -getMeldBase (Pon (Honour honour _) _) = Right honour -getMeldBase (Kan (Honour honour _) _) = Right honour - --- This considers each dragon and wind to be its own suit, effectively. -getMeldSuit :: Meld -> Either Suit Honour -getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit -getMeldSuit (Pon (Numeric suit _ _) _) = Left suit -getMeldSuit (Kan (Numeric suit _ _) _) = Left suit -getMeldSuit (Pon (Honour honour _) _) = Right honour -getMeldSuit (Kan (Honour honour _) _) = Right honour - -getPairSuit :: Pair -> Either Suit Honour -getPairSuit (Pair (Numeric suit _ _)) = Left suit -getPairSuit (Pair (Honour honour _)) = Right honour - -formMelds :: Hand -> [[Meld]] -formMelds [] = [[]] -formMelds [_] = [[]] -formMelds [_, _] = [[]] -formMelds hand@(tile : tiles) = - let - -- Form all possible sets of melds with the first meld including the first tile: - -- triples = tiles & tails & init & (map (\x -> (head x, tail x))) & (map (\(tile2, final_tiles) -> [[tile, tile2, tile3] | tile3 <- final_tiles])) & concat - triples = do - (tile2 : rest) <- tiles & tails & init - tile3 <- rest - return [tile, tile2, tile3] - - possible_melds = - ( map - ( \triple@(tile1 : tile2 : tile3 : _) -> - if (isChi tile1 tile2 tile3) - then map ((Chi tile1 tile2 tile3 False) :) (formMelds (hand \\ triple)) - else - if (isPon tile1 tile2 tile3) - then map ((Pon tile1 False) :) (formMelds (hand \\ triple)) - else [] - ) - triples - & concat - ) - & map sort - & sort - & group - & (map head) - in - if possible_melds == [] - then formMelds (tail hand) - else possible_melds - -meldsLength :: [Meld] -> Int -meldsLength [] = 0 -meldsLength ((Kan _ _) : rest) = 4 + (meldsLength rest) -meldsLength (_ : rest) = 3 + (meldsLength rest) - -concatMelds :: [Meld] -> Hand -concatMelds [] = [] -concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest -concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest -concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest - -findPairs :: Hand -> [(Pair, Hand)] -findPairs hand = - hand - & sort - & group - & (filter (\list -> 2 <= (length list))) - & (map head) - & (map (\tile -> (Pair tile, hand \\ [tile, tile]))) - -findKans :: Hand -> [([Meld], Hand)] -findKans hand = - hand - & sort - & group - & filter (\list -> 4 == (length list)) - & map head - & map (\tile -> (Kan tile False)) - & subsequences - & tail - & map (\kans -> (kans, hand \\ (concat [tile & repeat & take 4 | Kan tile _ <- kans]))) - --- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans). --- An InterpretedHand can then be passed on to other functions to check for yakus. --- Seven pairs, thirteen orphans etc are handeled in other functions, that should be --- checked separately. -type InterpretedHand = (Pair, [Meld]) -interpretHand :: Hand -> [InterpretedHand] -interpretHand hand = - let - possible_pairs = hand & findPairs - pairs_kans_hands = do - (pair, hand') <- possible_pairs - (kans, hand'') <- findKans hand' - melds <- formMelds hand'' - return (pair, kans ++ melds) - -- possible_pairs - -- >>= \(pair, hand') -> - -- [(pair, kan, hand'') | (kan, hand'') <- findKans hand'] - -- >>= \(pair, kan, hand'') -> [(pair, kan : melds) | melds <- formMelds hand''] - pairs_hands = do - (pair, hand') <- possible_pairs - melds <- formMelds hand' - return (pair, melds) - in - -- possible_pairs - -- >>= (\(pair, hand') -> [(pair, melds) | melds <- formMelds hand']) - - (pairs_kans_hands ++ pairs_hands) - -- & (filter (\(_, melds) -> melds /= [])) - & (filter (\(_, melds) -> (length hand) == 2 + (meldsLength melds))) - -showInterpretedHand :: InterpretedHand -> String -showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat diff --git a/src/Riichi/Display.hs b/src/Riichi/Display.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Display.hs @@ -0,0 +1,230 @@ +{- | +Module : Riichi.Display +Description : Functions handling UI. Pending major revision. +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} +module Riichi.Display where + +import ColourStrings +import Data.Function +import Data.List (intersperse, sort) +import Data.Monoid (getSum) +import Riichi.Meld +import Riichi.Scoring +import Riichi.Tile +import Riichi.Waits +import Riichi.Yaku + +displayHandYaku :: Hand -> IO () +displayHandYaku hand = do + if length hand < 14 + then + putStrLn "Hand is the wrong size" + else do + let ihs = interpretHand hand + putStrLn "🀀 🀁 🀂 🀃 " + putStrLn "Assuming East round and East seat." + let num = length ihs + if num >= 1 + then do + if num == 1 + then putStrLn $ "Found " ++ show num ++ " way to interpret this hand:\n" + else putStrLn $ "Found " ++ show num ++ " ways to interpret this hand:\n" + putStrLn $ concat $ do + ih <- ihs + let hand_string = ih & showInterpretedHand + let (value, yaku_string) = getYaku hand (Just ih) False False False False East East False + return $ case value of + Left (hanClosed, hanOpen) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum hanClosed)) ++ " Han total if closed, " ++ toGreen (show (getSum hanOpen)) ++ " if open\n" + Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n" + else return () + if allPairs hand || thirteenOrphans hand + then do + if num == 0 + then putStrLn "This hand can be interpreted as:\n" + else putStrLn "This hand can also be interpreted as:\n" + let hand_string = hand & sort & map show & intersperse ", " & concat + let (value, yaku_string) = getYaku hand Nothing False False False False East East False + putStrLn $ case value of + Left (han, _) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum han)) ++ " Han total, closed by definition\n" + Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n" + else + if num == 0 + then putStrLn $ toRed "This hand is not valid" + else return () + +displayHandWaits :: Hand -> IO () +displayHandWaits hand = do + let waits = getWaits hand + putStrLn $ "Waits are: " ++ (waits & map show & intersperse ", " & concat) + +displayHandScore :: Hand -> IO () +displayHandScore hand = do + putStrLn "Input dora: (or leave blank)" + dora <- mkHand <$> getLine + let hand' = addDora dora hand + 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 (allPairs hand') && (length hand' == 14) + then do + putStrLn "Seven pairs? [y/n]: " + input <- getLine + if input == "y" + 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." + return True + else + return False + else return False + if sevenPairs == False + then 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) -> do + 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, _) -> do + 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." + else return () diff --git a/src/Riichi/Meld.hs b/src/Riichi/Meld.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Meld.hs @@ -0,0 +1,225 @@ +{- | +Module : Riichi.Meld +Description : Datatypes representing melds and associated functions. +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com + +A meld is our catch all term for chis, pons and kans. +-} +module Riichi.Meld where + +import Data.Function +import Data.List +import Data.Set qualified as Set +import Riichi.Tile + +type Hand = [Tile] + +mkHand :: String -> Hand +mkHand tiles = tiles & words & (map readTileBlock) & concat + +addDora :: Hand -> Hand -> Hand +addDora [] hand = hand +addDora dora@(doraTile : rest) hand = do + let hand' = addDora rest hand + tile <- hand' + if doraTile == tile + then return $ case tile of + (Honour x d) -> (Honour x (d + 1)) + (Numeric s v d) -> (Numeric s v (d + 1)) + else + return tile + +getDora :: Tile -> Dora +getDora (Honour _ d) = d +getDora (Numeric _ _ d) = d + +newtype Pair = Pair Tile deriving (Show) + +data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord) +type Open = Bool + +instance Eq Meld where + (==) (Pon tile1 _) (Pon tile2 _) = tile1 == tile2 + (==) (Kan tile1 _) (Kan tile2 _) = tile1 == tile2 + (==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList ([tile1, tile2, tile3]) == Set.fromList ([tile1', tile2', tile3']) + (==) _ _ = False + +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) + show (Pon (Numeric suit v1 _) True) = "Open pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit) + show (Pon (Numeric suit v1 _) False) = "Closed pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit) + show (Kan (Numeric suit v1 _) True) = "Open kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit) + show (Kan (Numeric suit v1 _) False) = "Closed kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit) + show (Pon (tile) True) = "Open pon: " ++ (tile & show & repeat & (take 3) & concat) + show (Pon (tile) False) = "Closed pon: " ++ (tile & show & repeat & (take 3) & concat) + show (Kan (tile) True) = "Open kan: " ++ (tile & show & repeat & (take 4) & concat) + show (Kan (tile) False) = "Closed kan: " ++ (tile & show & repeat & (take 4) & concat) + +allEqual :: (Eq a) => [a] -> Bool +allEqual [] = True +allEqual [_] = True +allEqual (x : y : ys) = (x == y) && (allEqual (y : ys)) + +allDifferent :: (Eq a) => [a] -> Bool +allDifferent [] = True +allDifferent [_] = True +allDifferent (x : xs) = (not (x `elem` xs)) && (allDifferent xs) + +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])) + where + m = minimum [v1, v2, v3] +isChi _ _ _ = False + +isPon :: Tile -> Tile -> Tile -> Bool +isPon t1 t2 t3 = allEqual [t1, t2, t3] + +isKan :: Tile -> Tile -> Tile -> Tile -> Bool +isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4] + +isOpen :: Meld -> Bool +isOpen (Chi _ _ _ x) = x +isOpen (Pon _ x) = x +isOpen (Kan _ x) = x + +isClosed :: Meld -> Bool +isClosed = not . isOpen + +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 + +meldIsChi :: Meld -> Bool +meldIsChi (Chi _ _ _ _) = True +meldIsChi _ = False + +meldIsPon :: Meld -> Bool +meldIsPon (Pon _ _) = True +meldIsPon _ = False + +meldIsKan :: Meld -> Bool +meldIsKan (Kan _ _) = True +meldIsKan _ = False + +getMeldBase :: Meld -> Either Integer Honour +getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3]) +getMeldBase (Pon (Numeric _ v1 _) _) = Left v1 +getMeldBase (Kan (Numeric _ v1 _) _) = Left v1 +getMeldBase (Pon (Honour honour _) _) = Right honour +getMeldBase (Kan (Honour honour _) _) = Right honour + +-- This considers each dragon and wind to be its own suit, effectively. +getMeldSuit :: Meld -> Either Suit Honour +getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit +getMeldSuit (Pon (Numeric suit _ _) _) = Left suit +getMeldSuit (Kan (Numeric suit _ _) _) = Left suit +getMeldSuit (Pon (Honour honour _) _) = Right honour +getMeldSuit (Kan (Honour honour _) _) = Right honour + +getPairSuit :: Pair -> Either Suit Honour +getPairSuit (Pair (Numeric suit _ _)) = Left suit +getPairSuit (Pair (Honour honour _)) = Right honour + +formMelds :: Hand -> [[Meld]] +formMelds [] = [[]] +formMelds [_] = [[]] +formMelds [_, _] = [[]] +formMelds hand@(tile : tiles) = + let + -- Form all possible sets of melds with the first meld including the first tile: + -- triples = tiles & tails & init & (map (\x -> (head x, tail x))) & (map (\(tile2, final_tiles) -> [[tile, tile2, tile3] | tile3 <- final_tiles])) & concat + triples = do + (tile2 : rest) <- tiles & tails & init + tile3 <- rest + return [tile, tile2, tile3] + + possible_melds = + ( map + ( \triple@(tile1 : tile2 : tile3 : _) -> + if (isChi tile1 tile2 tile3) + then map ((Chi tile1 tile2 tile3 False) :) (formMelds (hand \\ triple)) + else + if (isPon tile1 tile2 tile3) + then map ((Pon tile1 False) :) (formMelds (hand \\ triple)) + else [] + ) + triples + & concat + ) + & map sort + & sort + & group + & (map head) + in + if possible_melds == [] + then formMelds (tail hand) + else possible_melds + +meldsLength :: [Meld] -> Int +meldsLength [] = 0 +meldsLength ((Kan _ _) : rest) = 4 + (meldsLength rest) +meldsLength (_ : rest) = 3 + (meldsLength rest) + +concatMelds :: [Meld] -> Hand +concatMelds [] = [] +concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest +concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest +concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest + +findPairs :: Hand -> [(Pair, Hand)] +findPairs hand = + hand + & sort + & group + & (filter (\list -> 2 <= (length list))) + & (map head) + & (map (\tile -> (Pair tile, hand \\ [tile, tile]))) + +findKans :: Hand -> [([Meld], Hand)] +findKans hand = + hand + & sort + & group + & filter (\list -> 4 == (length list)) + & map head + & map (\tile -> (Kan tile False)) + & subsequences + & tail + & map (\kans -> (kans, hand \\ (concat [tile & repeat & take 4 | Kan tile _ <- kans]))) + +-- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans). +-- An InterpretedHand can then be passed on to other functions to check for yakus. +-- Seven pairs, thirteen orphans etc are handeled in other functions, that should be +-- checked separately. +type InterpretedHand = (Pair, [Meld]) +interpretHand :: Hand -> [InterpretedHand] +interpretHand hand = + let + possible_pairs = hand & findPairs + pairs_kans_hands = do + (pair, hand') <- possible_pairs + (kans, hand'') <- findKans hand' + melds <- formMelds hand'' + return (pair, kans ++ melds) + -- possible_pairs + -- >>= \(pair, hand') -> + -- [(pair, kan, hand'') | (kan, hand'') <- findKans hand'] + -- >>= \(pair, kan, hand'') -> [(pair, kan : melds) | melds <- formMelds hand''] + pairs_hands = do + (pair, hand') <- possible_pairs + melds <- formMelds hand' + return (pair, melds) + in + -- possible_pairs + -- >>= (\(pair, hand') -> [(pair, melds) | melds <- formMelds hand']) + + (pairs_kans_hands ++ pairs_hands) + -- & (filter (\(_, melds) -> melds /= [])) + & (filter (\(_, melds) -> (length hand) == 2 + (meldsLength melds))) + +showInterpretedHand :: InterpretedHand -> String +showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat diff --git a/src/Riichi/Scoring.hs b/src/Riichi/Scoring.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Scoring.hs @@ -0,0 +1,424 @@ +{- | +Module : Riichi.Scoring +Description : Functions for score calculation (yaku, han, fu) +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} +module Riichi.Scoring where + +import ColourStrings +import Control.Monad (when) +import Control.Monad.Writer +import Data.Function ((&)) +import Data.Map qualified as M +import Data.Monoid (Sum) +import Riichi.Meld +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) $ 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 isClosed 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, 1, toCyan "\t2 Han: Triple triplets (-1 Han if open)\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 + + sevenPairs = allPairs hand + 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 + + (_, (han, output)) = runWriter hanWriter + in + if yakumans > 0 + then (Right yakumans, yakumanOutput) + else + if sevenPairs + then + (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output) + else + (Left (0, 0), "This hand is not valid\n") + +getMeldFu :: Meld -> Fu +getMeldFu (Chi _ _ _ _) = 0 +getMeldFu (Pon (Numeric _ v _) True) = if v `elem` [1, 9] then 4 else 2 +getMeldFu (Pon (Honour _ _) True) = 4 +getMeldFu (Pon (Numeric _ v _) False) = if v `elem` [1, 9] then 8 else 4 +getMeldFu (Pon (Honour _ _) False) = 8 +getMeldFu (Kan (Numeric _ v _) True) = if v `elem` [1, 9] then 16 else 8 +getMeldFu (Kan (Honour _ _) True) = 16 +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 +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)) + +getScore :: Han -> Fu -> Bool -> Bool -> Integer +getScore han fu dealer tsumo = + if dealer + then case han of + _ + | han >= 13 -> 32000 + | han >= 5 -> case M.lookup han manganToSanbaimanTableDealer of + Just score -> score + Nothing -> 0 + | otherwise -> + if tsumo + then case M.lookup (han, fu) scoreTableTsumoDealer of + Just score -> score + Nothing -> 0 + else case M.lookup (han, fu) scoreTableRonDealer of + Just score -> score + Nothing -> 0 + else case han of + _ + | han >= 13 -> 24000 + | han >= 5 -> case M.lookup han manganToSanbaimanTableNonDealer of + Just score -> score + Nothing -> 0 + | otherwise -> + if tsumo + then case M.lookup (han, fu) scoreTableTsumoNonDealer of + Just score -> score + Nothing -> 0 + else case M.lookup (han, fu) scoreTableRonNonDealer of + Just score -> score + Nothing -> 0 + +scoreTableTsumoDealer :: M.Map (Han, Fu) Integer +scoreTableTsumoDealer = + M.fromList + [ ((1, 20), 1200) + , ((1, 30), 1500) + , ((1, 40), 2100) + , ((1, 50), 2400) + , ((1, 60), 3000) + , ((1, 70), 3600) + , ((1, 80), 3900) + , ((1, 90), 4500) + , ((1, 100), 4800) + , ((1, 110), 5400) + , ((2, 20), 2100) + , ((2, 30), 3000) + , ((2, 40), 3900) + , ((2, 50), 4800) + , ((2, 60), 6000) + , ((2, 70), 6900) + , ((2, 80), 7800) + , ((2, 90), 8700) + , ((2, 100), 9600) + , ((2, 110), 10800) + , ((3, 20), 3900) + , ((3, 25), 4800) + , ((3, 30), 6000) + , ((3, 40), 7800) + , ((3, 50), 9600) + , ((3, 60), 11700) + , ((3, 70), 12000) + , ((3, 80), 12000) + , ((3, 90), 12000) + , ((3, 100), 12000) + , ((3, 110), 12000) + , ((4, 20), 7800) + , ((4, 25), 9600) + , ((4, 30), 11700) + , ((4, 40), 12000) + , ((4, 50), 12000) + , ((4, 60), 12000) + , ((4, 70), 12000) + , ((4, 80), 12000) + , ((4, 90), 12000) + , ((4, 100), 12000) + , ((4, 110), 12000) + ] + +scoreTableRonDealer :: M.Map (Han, Fu) Integer +scoreTableRonDealer = + M.fromList + [ ((1, 30), 1500) + , ((1, 40), 2000) + , ((1, 50), 2400) + , ((1, 60), 2900) + , ((1, 70), 3400) + , ((1, 80), 3900) + , ((1, 90), 4400) + , ((1, 100), 4800) + , ((1, 110), 5300) + , ((2, 25), 2400) + , ((2, 30), 2900) + , ((2, 40), 3900) + , ((2, 50), 4800) + , ((2, 60), 5800) + , ((2, 70), 6800) + , ((2, 80), 7700) + , ((2, 90), 8700) + , ((2, 100), 9600) + , ((2, 110), 10600) + , ((3, 25), 4800) + , ((3, 30), 5800) + , ((3, 40), 7700) + , ((3, 50), 9600) + , ((3, 60), 11600) + , ((3, 70), 12000) + , ((3, 80), 12000) + , ((3, 90), 12000) + , ((3, 100), 12000) + , ((3, 110), 12000) + , ((4, 25), 9600) + , ((4, 30), 11600) + , ((4, 40), 12000) + , ((4, 50), 12000) + , ((4, 60), 12000) + , ((4, 70), 12000) + , ((4, 80), 12000) + , ((4, 90), 12000) + , ((4, 100), 12000) + , ((4, 110), 12000) + ] + +scoreTableTsumoNonDealer :: M.Map (Han, Fu) Integer +scoreTableTsumoNonDealer = + M.fromList + [ ((1, 20), 800) + , ((1, 30), 1100) + , ((1, 40), 1500) + , ((1, 50), 1600) + , ((1, 60), 2000) + , ((1, 70), 2400) + , ((1, 80), 2700) + , ((1, 90), 3100) + , ((1, 100), 3200) + , ((1, 110), 3600) + , ((2, 20), 1500) + , ((2, 30), 2000) + , ((2, 40), 2700) + , ((2, 50), 3200) + , ((2, 60), 4000) + , ((2, 70), 4700) + , ((2, 80), 5200) + , ((2, 90), 5900) + , ((2, 100), 6400) + , ((2, 110), 7200) + , ((3, 20), 2700) + , ((3, 25), 3200) + , ((3, 30), 4000) + , ((3, 40), 5200) + , ((3, 50), 6400) + , ((3, 60), 7900) + , ((3, 70), 8000) + , ((3, 80), 8000) + , ((3, 90), 8000) + , ((3, 100), 8000) + , ((3, 110), 8000) + , ((4, 20), 5200) + , ((4, 25), 6400) + , ((4, 30), 7900) + , ((4, 40), 8000) + , ((4, 50), 8000) + , ((4, 60), 8000) + , ((4, 70), 8000) + , ((4, 80), 8000) + , ((4, 90), 8000) + , ((4, 100), 8000) + , ((4, 110), 8000) + ] + +scoreTableRonNonDealer :: M.Map (Han, Fu) Integer +scoreTableRonNonDealer = + M.fromList + [ ((1, 30), 1000) + , ((1, 40), 1300) + , ((1, 50), 1600) + , ((1, 60), 2000) + , ((1, 70), 2300) + , ((1, 80), 2600) + , ((1, 90), 2900) + , ((1, 100), 3200) + , ((1, 110), 3600) + , ((2, 25), 1600) + , ((2, 30), 2000) + , ((2, 40), 2600) + , ((2, 50), 3200) + , ((2, 60), 3900) + , ((2, 70), 4500) + , ((2, 80), 5200) + , ((2, 90), 5800) + , ((2, 100), 6400) + , ((2, 110), 7100) + , ((3, 25), 3200) + , ((3, 30), 3900) + , ((3, 40), 5200) + , ((3, 50), 6400) + , ((3, 60), 7700) + , ((3, 70), 8000) + , ((3, 80), 8000) + , ((3, 90), 8000) + , ((3, 100), 8000) + , ((3, 110), 8000) + , ((4, 25), 6400) + , ((4, 30), 7700) + , ((4, 40), 8000) + , ((4, 50), 8000) + , ((4, 60), 8000) + , ((4, 70), 8000) + , ((4, 80), 8000) + , ((4, 90), 8000) + , ((4, 100), 8000) + , ((4, 110), 8000) + ] + +manganToSanbaimanTableDealer :: M.Map Han Integer +manganToSanbaimanTableDealer = + M.fromList + [ (5, 12000) + , (6, 18000) + , (7, 18000) + , (8, 24000) + , (9, 24000) + , (10, 24000) + , (11, 36000) + , (12, 36000) + ] + +manganToSanbaimanTableNonDealer :: M.Map Han Integer +manganToSanbaimanTableNonDealer = + M.fromList + [ (5, 8000) + , (6, 12000) + , (7, 12000) + , (8, 16000) + , (9, 16000) + , (10, 16000) + , (11, 24000) + , (12, 24000) + ] + +hanToHandName :: Han -> String +hanToHandName 5 = "Mangan" +hanToHandName 6 = "Haneman" +hanToHandName 7 = "Haneman" +hanToHandName 8 = "Baiman" +hanToHandName 9 = "Baiman" +hanToHandName 10 = "Baiman" +hanToHandName 11 = "Sanbaiman" +hanToHandName 12 = "Sanbaiman" +hanToHandName n = if n >= 13 then "Counted Yakuman" else "" diff --git a/src/Riichi/Tile.hs b/src/Riichi/Tile.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Tile.hs @@ -0,0 +1,131 @@ +{- | +Module : Riichi.Tile +Description : Datatypes representing tiles and associated functions. +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} +module Riichi.Tile where + +import Data.Function +import Data.List (intersperse) + +{- | +Tile data type. Can be an honour tile or a numeric tile. Dora is tracked +here too on a per tile basis (necessary for red fives) +-} +data Tile = Honour Honour Dora | Numeric Suit Value Dora deriving (Ord) + +type Dora = Integer +type Value = Integer + +-- | An honour tile is a dragon or a wind +data Honour = Dragon (Dragon) | Wind (Wind) deriving (Show, Eq, Ord) + +data Dragon = White | Green | Red deriving (Show, Eq, Ord) +data Wind = North | East | South | West deriving (Show, Eq, Ord) + +data Suit = Man | Pin | Sou deriving (Show, Eq, Ord) + +instance Read Tile where + readsPrec :: Int -> ReadS Tile + readsPrec _ (x : []) = [(tile, [])] + where + tile = case x of + 'N' -> (Honour $ Wind $ North) 0 + 'E' -> (Honour $ Wind $ East) 0 + 'S' -> (Honour $ Wind $ South) 0 + 'W' -> (Honour $ Wind $ West) 0 + 'r' -> (Honour $ Dragon $ Red) 0 + 'g' -> (Honour $ Dragon $ Green) 0 + 'w' -> (Honour $ Dragon $ White) 0 + readsPrec _ (x : y : _) = do + let ((value, dora), suit) = + ( case x of + '0' -> (5, 1) + '1' -> (1, 0) + '2' -> (2, 0) + '3' -> (3, 0) + '4' -> (4, 0) + '5' -> (5, 0) + '6' -> (6, 0) + '7' -> (7, 0) + '8' -> (8, 0) + '9' -> (9, 0) + , case y of + 'p' -> Pin + 'm' -> Man + 's' -> Sou + ) + in [(Numeric suit value dora, [])] + +readTileBlock :: String -> [Tile] +readTileBlock string = + let + final = last string + (stripped, separator) = case final of + 'p' -> (init string, "p ") + 'm' -> (init string, "m ") + 's' -> (init string, "s ") + _ -> (string, " ") + in + stripped & map (\c -> [c]) & intersperse separator & concat & (++ separator) & words & map read + +instance Show Tile where + show (Honour (Dragon Red) _) = "r" + show (Honour (Dragon Green) _) = "g" + show (Honour (Dragon White) _) = "w" + show (Honour (Wind North) _) = "N" + show (Honour (Wind East) _) = "E" + show (Honour (Wind South) _) = "S" + show (Honour (Wind West) _) = "W" + show (Numeric Pin 5 d) = if d == 0 then "5p" else "5p*" + show (Numeric Man 5 d) = if d == 0 then "5m" else "5m*" + show (Numeric Sou 5 d) = if d == 0 then "5s" else "5s*" + show (Numeric Pin n _) = (show n) ++ "p" + show (Numeric Man n _) = (show n) ++ "m" + show (Numeric Sou n _) = (show n) ++ "s" + +-- We don't care about dora when equating tiles +instance Eq Tile where + (==) (Honour honour _) (Honour honour' _) = (honour == honour') + (==) (Numeric suit value _) (Numeric suit' value' _) = (suit == suit') && (value == value') + (==) _ _ = False + +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 + +isSimple :: Tile -> Bool +isSimple (Honour _ _) = False +isSimple (Numeric _ 1 _) = False +isSimple (Numeric _ 9 _) = False +isSimple _ = True + +isTerminal :: Tile -> Bool +isTerminal (Numeric _ 1 _) = True +isTerminal (Numeric _ 9 _) = True +isTerminal _ = False + +isHonour :: Tile -> Bool +isHonour (Honour _ _) = True +isHonour _ = False + +isNumeric :: Tile -> Bool +isNumeric = not . isHonour + +isDragon :: Tile -> Bool +isDragon (Honour (Dragon _) _) = True +isDragon _ = False + +isWind :: Tile -> Bool +isWind (Honour (Wind _) _) = True +isWind _ = False + +honourIsDragon :: Honour -> Bool +honourIsDragon (Dragon _) = True +honourIsDragon _ = False + +honourIsWind :: Honour -> Bool +honourIsWind = not . honourIsDragon diff --git a/src/Riichi/Waits.hs b/src/Riichi/Waits.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Waits.hs @@ -0,0 +1,72 @@ +{- | +Module : Riichi.Waits +Description : Methods for determining the waits of a hand +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} +module Riichi.Waits where + +import Data.Function +import Data.List +import Riichi.Meld +import Riichi.Tile + +getWaits :: Hand -> [Tile] +getWaits hand = + if length hand < 13 + then [] + else + -- Check seven pairs + let pairs = findPairs hand + sevenPairsWait = + ( if length pairs == 6 + then case (hand & sort & group & filter (\gp -> 1 == length gp)) of + [[tile]] -> [tile] + _ -> [] + else [] + ) + -- Check thirteen orphans + orphansWaits = + if length hand == 13 + then do + let orphans = (mkHand "1p 9p 1s 9s 1m 9m N E S W r g w") + let difference = hand \\ orphans + case difference of + [] -> orphans + [tile] | tile `elem` orphans -> orphans \\ hand + _ -> [] + else [] + -- Check waits from standard interpretations + -- If we have four melds already, a single remaning tile can wait for a pair + possibleMelds = formMelds hand + fourMelds = possibleMelds & filter (\melds -> length melds == 4) + fourMeldsWaits = fourMelds & map (concatMelds) & map (hand \\) & filter (\diff -> length diff == 1) & concat + -- Finally, we might be waiting with three melds and a pair + threeMeldWaits = concat $ do + (pair, hand') <- findPairs hand + melds <- formMelds hand' + if length melds /= 3 + then return [] + else + let diff = hand' \\ (concatMelds melds) + in if length diff /= 2 + then return [] + else let [a, b] = diff in return (meldWait a b) + in (sevenPairsWait ++ orphansWaits ++ fourMeldsWaits ++ threeMeldWaits) & sort & group & map head + +meldWait :: Tile -> Tile -> [Tile] +meldWait a b + | a == b = [a] +meldWait t1@(Numeric s1 v1 _) t2@(Numeric s2 v2 _) + | v1 > v2 = meldWait t2 t1 + | s1 /= s2 = [] + -- \| v1 == v2 = [Numeric s1 v1 0] + | v1 + 1 == v2 = + if v1 == 1 + then [Numeric s1 (v2 + 1) 0] + else + if v2 == 9 + then [Numeric s1 (v1 - 1) 0] + else [Numeric s1 (v1 - 1) 0, Numeric s1 (v2 + 1) 0] + | v1 + 2 == v2 = [Numeric s1 (v1 + 1) 0] +meldWait _ _ = [] diff --git a/src/Riichi/Yaku.hs b/src/Riichi/Yaku.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Yaku.hs @@ -0,0 +1,275 @@ +{- | +Module : Riichi.Yaku +Description : Methods for detecting the various yaku conditions +License : BSD-3-Clause +Maintainer : surplussinewaves@gmail.com +-} +module Riichi.Yaku where + +import Data.Either (lefts, rights) +import Data.Function +import Data.List +import Data.Set qualified as Set +import Riichi.Meld +import Riichi.Tile + +-- Note that Yaku functions that operate on Hands needn't check that the +-- hand is actually valid to begin with. This should be done by the caller, +-- by seeing if interpretHand returns an nonempty list of interpretations. +-- Some of these could probably be rephrased to be point free but I think +-- that would just make them more confusing. + +tanyao :: Hand -> Bool +tanyao hand = hand & (map isSimple) & and + +allPairs :: Hand -> Bool +allPairs hand = (hand & findPairs & length) * 2 == length hand + +-- Yakuman +thirteenOrphans :: Hand -> Bool +thirteenOrphans hand = + ( Set.fromList hand + == Set.fromList + [ (Honour $ Dragon $ Red) 0 + , (Honour $ Dragon $ White) 0 + , (Honour $ Dragon $ Green) 0 + , (Honour $ Wind $ North) 0 + , (Honour $ Wind $ South) 0 + , (Honour $ Wind $ East) 0 + , (Honour $ Wind $ West) 0 + , (Numeric Pin 1) 0 + , (Numeric Pin 9) 0 + , (Numeric Man 1) 0 + , (Numeric Man 9) 0 + , (Numeric Sou 1) 0 + , (Numeric Sou 9) 0 + ] + ) + && (length hand == 14) + +-- Counts the number of yakuhai pairs. One han each. +yakuhai :: InterpretedHand -> Int +yakuhai (_, melds) = + melds + & ( filter + ( \meld -> + meld + `elem` [ Pon ((Honour $ Dragon $ Red) 0) False + , Pon ((Honour $ Dragon $ Green) 0) False + , Pon ((Honour $ Dragon $ White) 0) False + ] + ) + ) + & length + +checkPon :: Tile -> InterpretedHand -> Bool +checkPon tile (_, melds) = Pon tile False `elem` melds + +haku :: InterpretedHand -> Bool +haku = checkPon ((Honour $ Dragon $ White) 0) + +hatsu :: InterpretedHand -> Bool +hatsu = checkPon ((Honour $ Dragon $ Green) 0) + +chun :: InterpretedHand -> Bool +chun = checkPon ((Honour $ Dragon $ Red) 0) + +checkNorth :: InterpretedHand -> Bool +checkNorth = checkPon ((Honour $ Wind $ North) 0) + +checkEast :: InterpretedHand -> Bool +checkEast = checkPon ((Honour $ Wind $ East) 0) + +checkSouth :: InterpretedHand -> Bool +checkSouth = checkPon ((Honour $ Wind $ South) 0) + +checkWest :: InterpretedHand -> Bool +checkWest = checkPon ((Honour $ Wind $ West) 0) + +checkWind :: Wind -> InterpretedHand -> Bool +checkWind East = checkEast +checkWind North = checkNorth +checkWind West = checkWest +checkWind South = checkSouth + +-- Same sequence in all three suits +sanshokuDoujun :: InterpretedHand -> Bool +sanshokuDoujun (_, melds) = + let + chis = melds & (filter meldIsChi) + suits = chis & (map getMeldSuit) + bases = chis & (map getMeldBase) + suits_bases = zip suits bases + in + or + [ ((Left Man, Left base) `elem` suits_bases) + && ((Left Pin, Left base) `elem` suits_bases) + && ((Left Sou, Left base) `elem` suits_bases) + | base <- [1 .. 7] + ] + +-- Same triplet (or Kan!) in all three suits +sanshokuDoukou :: InterpretedHand -> Bool +sanshokuDoukou (_, melds) = + let + pons = melds & (filter (\meld -> meldIsPon meld || meldIsKan meld)) + suits = pons & (map getMeldSuit) + bases = pons & (map getMeldBase) + suits_bases = zip suits bases + in + or + [ ((Left Man, Left base) `elem` suits_bases) + && ((Left Pin, Left base) `elem` suits_bases) + && ((Left Sou, Left base) `elem` suits_bases) + | base <- [1 .. 9] + ] + +-- Full flush +-- chinitsu :: InterpretedHand -> Bool +-- chinitsu (pair, melds) = allEqual ((getPairSuit pair) : (melds & (map getMeldSuit))) +chinitsu :: Hand -> Bool +chinitsu hand = hand & map getTileSuit & allEqual + +-- Half flush +-- Only check equality on the lefts of Either Suit Honour, i.e the suited melds. +-- honitsu :: InterpretedHand -> Bool +-- honitsu (pair, melds) = +-- ((getPairSuit pair) : (melds & (map getMeldSuit))) +-- & lefts +-- & allEqual +honitsu :: Hand -> Bool +honitsu hand = hand & map getTileSuit & lefts & allEqual + +toitoi :: InterpretedHand -> Bool +toitoi (_, melds) = melds & (map (\meld -> meldIsPon meld || meldIsKan meld)) & and + +ittsuu :: InterpretedHand -> Bool +ittsuu (_, melds) = + let + chis = melds & (filter meldIsChi) + suits = chis & (map getMeldSuit) + bases = chis & (map getMeldBase) + suits_bases = zip suits bases + in + or + [ ((Left suit, Left 1) `elem` suits_bases) + && ((Left suit, Left 4) `elem` suits_bases) + && ((Left suit, Left 7) `elem` suits_bases) + | suit <- [Man, Pin, Sou] + ] + +-- Three quads (open or closed) +sankantsu :: InterpretedHand -> Bool +sankantsu (_, melds) = melds & (filter meldIsKan) & length & (3 ==) + +-- Four quads (open or closed). Yakuman +suukantsu :: InterpretedHand -> Bool +suukantsu (_, melds) = melds & (filter meldIsKan) & length & (4 ==) + +-- Little three dragons. Worth noting that we permit ourselves to assume that hands +-- don't contain more than 4 of a given tile! So no need to worry about multiple melds +-- of the same dragon. +shousangen :: InterpretedHand -> Bool +shousangen (Pair tile, melds) = + (isDragon tile) + && ( melds + & (map getMeldSuit) + & rights + & (filter honourIsDragon) + & length + & (2 ==) + ) + +-- Big three dragons. Yakuman +daisangen :: InterpretedHand -> Bool +daisangen (_, melds) = + ( melds + & (map getMeldSuit) + & rights + & (filter honourIsDragon) + & length + & (3 ==) + ) + +-- Little winds. Yakuman +shousuushii :: InterpretedHand -> Bool +shousuushii (Pair tile, melds) = + (isWind tile) + && ( melds + & (map getMeldSuit) + & rights + & (filter honourIsWind) + & length + & (3 ==) + ) + +-- Big winds. Double Yakuman +daisuushii :: InterpretedHand -> Bool +daisuushii (_, melds) = + ( melds + & (map getMeldSuit) + & rights + & (filter honourIsWind) + & length + & (4 ==) + ) + +-- Pure double sequence. Closed only! +iipeikou :: InterpretedHand -> Bool +iipeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (== 1) + +-- Twice pure double sequence. Note we require the two pairs of sequences to be distinct. +ryanpeikou :: InterpretedHand -> Bool +ryanpeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (>= 2) + +-- Half outside hand +chanta :: InterpretedHand -> Bool +chanta (Pair tile, melds) = (melds & map getMeldBase & lefts & filter (\x -> x /= 1 && x /= 7)) == [] && (not $ isSimple tile) + +-- Fully outside hand (chanta + no honours) +junchan :: InterpretedHand -> Bool +junchan ih@(Pair tile, melds) = (isNumeric tile) && (melds & map getMeldBase & rights) == [] && (chanta ih) + +-- All terminals and honours +honroutou :: Hand -> Bool +honroutou hand = hand & map (\tile -> isHonour tile || isTerminal tile) & and + +-- All honours. Yakuman +tsuuiisou :: Hand -> Bool +tsuuiisou hand = hand & map isHonour & and + +-- All terminals. Yakuman +chinroutou :: Hand -> Bool +chinroutou hand = hand & map isTerminal & and + +-- All green. Yakuman +ryuuiisou :: Hand -> Bool +ryuuiisou hand = hand & map isGreen & and + where + isGreen (Numeric Sou v _) = (v `elem` [2, 3, 4, 6, 8]) + isGreen (Honour (Dragon Green) _) = True + isGreen _ = False + +-- Nine Gates. Yakuman +-- Length == 9 precludes the possibility of a all honours chinitsu. +chuurenPoutou :: Hand -> Bool +chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3) + where + list = (hand & sort & group & map length) + +-- Three concealed triplets +sanankou :: InterpretedHand -> Bool +sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 3 + +-- Four concealed triplets +suuankou :: InterpretedHand -> Bool +suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 4 + +pinfu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool +pinfu (Pair tile, melds) seatWind roundWind ryanmanWait closedHand = + (melds & filter (not . meldIsChi)) == [] + && closedHand + && (not $ isDragon tile) + && (tile /= (Honour (Wind seatWind) 0)) + && (tile /= (Honour (Wind roundWind) 0)) + && ryanmanWait diff --git a/src/Scoring.hs b/src/Scoring.hs deleted file mode 100644 --- a/src/Scoring.hs +++ /dev/null @@ -1,418 +0,0 @@ -module Scoring where - -import ColourStrings -import Control.Monad (when) -import Control.Monad.Writer -import Data.Function ((&)) -import Data.Map qualified as M -import Data.Monoid (Sum) -import Meld -import Tile -import 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) $ 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 isClosed 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, 1, toCyan "\t2 Han: Triple triplets (-1 Han if open)\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 - - sevenPairs = allPairs hand - 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 - - (_, (han, output)) = runWriter hanWriter - in - if yakumans > 0 - then (Right yakumans, yakumanOutput) - else - if sevenPairs - then - (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output) - else - (Left (0, 0), "This hand is not valid\n") - -getMeldFu :: Meld -> Fu -getMeldFu (Chi _ _ _ _) = 0 -getMeldFu (Pon (Numeric _ v _) True) = if v `elem` [1, 9] then 4 else 2 -getMeldFu (Pon (Honour _ _) True) = 4 -getMeldFu (Pon (Numeric _ v _) False) = if v `elem` [1, 9] then 8 else 4 -getMeldFu (Pon (Honour _ _) False) = 8 -getMeldFu (Kan (Numeric _ v _) True) = if v `elem` [1, 9] then 16 else 8 -getMeldFu (Kan (Honour _ _) True) = 16 -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 -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)) - -getScore :: Han -> Fu -> Bool -> Bool -> Integer -getScore han fu dealer tsumo = - if dealer - then case han of - _ - | han >= 13 -> 32000 - | han >= 5 -> case M.lookup han manganToSanbaimanTableDealer of - Just score -> score - Nothing -> 0 - | otherwise -> - if tsumo - then case M.lookup (han, fu) scoreTableTsumoDealer of - Just score -> score - Nothing -> 0 - else case M.lookup (han, fu) scoreTableRonDealer of - Just score -> score - Nothing -> 0 - else case han of - _ - | han >= 13 -> 24000 - | han >= 5 -> case M.lookup han manganToSanbaimanTableNonDealer of - Just score -> score - Nothing -> 0 - | otherwise -> - if tsumo - then case M.lookup (han, fu) scoreTableTsumoNonDealer of - Just score -> score - Nothing -> 0 - else case M.lookup (han, fu) scoreTableRonNonDealer of - Just score -> score - Nothing -> 0 - -scoreTableTsumoDealer :: M.Map (Han, Fu) Integer -scoreTableTsumoDealer = - M.fromList - [ ((1, 20), 1200) - , ((1, 30), 1500) - , ((1, 40), 2100) - , ((1, 50), 2400) - , ((1, 60), 3000) - , ((1, 70), 3600) - , ((1, 80), 3900) - , ((1, 90), 4500) - , ((1, 100), 4800) - , ((1, 110), 5400) - , ((2, 20), 2100) - , ((2, 30), 3000) - , ((2, 40), 3900) - , ((2, 50), 4800) - , ((2, 60), 6000) - , ((2, 70), 6900) - , ((2, 80), 7800) - , ((2, 90), 8700) - , ((2, 100), 9600) - , ((2, 110), 10800) - , ((3, 20), 3900) - , ((3, 25), 4800) - , ((3, 30), 6000) - , ((3, 40), 7800) - , ((3, 50), 9600) - , ((3, 60), 11700) - , ((3, 70), 12000) - , ((3, 80), 12000) - , ((3, 90), 12000) - , ((3, 100), 12000) - , ((3, 110), 12000) - , ((4, 20), 7800) - , ((4, 25), 9600) - , ((4, 30), 11700) - , ((4, 40), 12000) - , ((4, 50), 12000) - , ((4, 60), 12000) - , ((4, 70), 12000) - , ((4, 80), 12000) - , ((4, 90), 12000) - , ((4, 100), 12000) - , ((4, 110), 12000) - ] - -scoreTableRonDealer :: M.Map (Han, Fu) Integer -scoreTableRonDealer = - M.fromList - [ ((1, 30), 1500) - , ((1, 40), 2000) - , ((1, 50), 2400) - , ((1, 60), 2900) - , ((1, 70), 3400) - , ((1, 80), 3900) - , ((1, 90), 4400) - , ((1, 100), 4800) - , ((1, 110), 5300) - , ((2, 25), 2400) - , ((2, 30), 2900) - , ((2, 40), 3900) - , ((2, 50), 4800) - , ((2, 60), 5800) - , ((2, 70), 6800) - , ((2, 80), 7700) - , ((2, 90), 8700) - , ((2, 100), 9600) - , ((2, 110), 10600) - , ((3, 25), 4800) - , ((3, 30), 5800) - , ((3, 40), 7700) - , ((3, 50), 9600) - , ((3, 60), 11600) - , ((3, 70), 12000) - , ((3, 80), 12000) - , ((3, 90), 12000) - , ((3, 100), 12000) - , ((3, 110), 12000) - , ((4, 25), 9600) - , ((4, 30), 11600) - , ((4, 40), 12000) - , ((4, 50), 12000) - , ((4, 60), 12000) - , ((4, 70), 12000) - , ((4, 80), 12000) - , ((4, 90), 12000) - , ((4, 100), 12000) - , ((4, 110), 12000) - ] - -scoreTableTsumoNonDealer :: M.Map (Han, Fu) Integer -scoreTableTsumoNonDealer = - M.fromList - [ ((1, 20), 800) - , ((1, 30), 1100) - , ((1, 40), 1500) - , ((1, 50), 1600) - , ((1, 60), 2000) - , ((1, 70), 2400) - , ((1, 80), 2700) - , ((1, 90), 3100) - , ((1, 100), 3200) - , ((1, 110), 3600) - , ((2, 20), 1500) - , ((2, 30), 2000) - , ((2, 40), 2700) - , ((2, 50), 3200) - , ((2, 60), 4000) - , ((2, 70), 4700) - , ((2, 80), 5200) - , ((2, 90), 5900) - , ((2, 100), 6400) - , ((2, 110), 7200) - , ((3, 20), 2700) - , ((3, 25), 3200) - , ((3, 30), 4000) - , ((3, 40), 5200) - , ((3, 50), 6400) - , ((3, 60), 7900) - , ((3, 70), 8000) - , ((3, 80), 8000) - , ((3, 90), 8000) - , ((3, 100), 8000) - , ((3, 110), 8000) - , ((4, 20), 5200) - , ((4, 25), 6400) - , ((4, 30), 7900) - , ((4, 40), 8000) - , ((4, 50), 8000) - , ((4, 60), 8000) - , ((4, 70), 8000) - , ((4, 80), 8000) - , ((4, 90), 8000) - , ((4, 100), 8000) - , ((4, 110), 8000) - ] - -scoreTableRonNonDealer :: M.Map (Han, Fu) Integer -scoreTableRonNonDealer = - M.fromList - [ ((1, 30), 1000) - , ((1, 40), 1300) - , ((1, 50), 1600) - , ((1, 60), 2000) - , ((1, 70), 2300) - , ((1, 80), 2600) - , ((1, 90), 2900) - , ((1, 100), 3200) - , ((1, 110), 3600) - , ((2, 25), 1600) - , ((2, 30), 2000) - , ((2, 40), 2600) - , ((2, 50), 3200) - , ((2, 60), 3900) - , ((2, 70), 4500) - , ((2, 80), 5200) - , ((2, 90), 5800) - , ((2, 100), 6400) - , ((2, 110), 7100) - , ((3, 25), 3200) - , ((3, 30), 3900) - , ((3, 40), 5200) - , ((3, 50), 6400) - , ((3, 60), 7700) - , ((3, 70), 8000) - , ((3, 80), 8000) - , ((3, 90), 8000) - , ((3, 100), 8000) - , ((3, 110), 8000) - , ((4, 25), 6400) - , ((4, 30), 7700) - , ((4, 40), 8000) - , ((4, 50), 8000) - , ((4, 60), 8000) - , ((4, 70), 8000) - , ((4, 80), 8000) - , ((4, 90), 8000) - , ((4, 100), 8000) - , ((4, 110), 8000) - ] - -manganToSanbaimanTableDealer :: M.Map Han Integer -manganToSanbaimanTableDealer = - M.fromList - [ (5, 12000) - , (6, 18000) - , (7, 18000) - , (8, 24000) - , (9, 24000) - , (10, 24000) - , (11, 36000) - , (12, 36000) - ] - -manganToSanbaimanTableNonDealer :: M.Map Han Integer -manganToSanbaimanTableNonDealer = - M.fromList - [ (5, 8000) - , (6, 12000) - , (7, 12000) - , (8, 16000) - , (9, 16000) - , (10, 16000) - , (11, 24000) - , (12, 24000) - ] - -hanToHandName :: Han -> String -hanToHandName 5 = "Mangan" -hanToHandName 6 = "Haneman" -hanToHandName 7 = "Haneman" -hanToHandName 8 = "Baiman" -hanToHandName 9 = "Baiman" -hanToHandName 10 = "Baiman" -hanToHandName 11 = "Sanbaiman" -hanToHandName 12 = "Sanbaiman" -hanToHandName n = if n >= 13 then "Counted Yakuman" else "" diff --git a/src/Tile.hs b/src/Tile.hs deleted file mode 100644 --- a/src/Tile.hs +++ /dev/null @@ -1,124 +0,0 @@ -module Tile where - -import Data.Function -import Data.List (intersperse) - -data Tile = Honour Honour Dora | Numeric Suit Value Dora deriving (Ord) -type Dora = Integer -type Value = Integer - -data Honour = Dragon (Dragon) | Wind (Wind) deriving (Show, Eq, Ord) -data Dragon = White | Green | Red deriving (Show, Eq, Ord) -data Wind = North | East | South | West deriving (Show, Eq, Ord) - -data Suit = Man | Pin | Sou deriving (Show, Eq, Ord) - --- instance Show Value where --- show (Value int) = show int --- --- instance Ord Value where --- compare (Value a) (Value b) = compare a b - -instance Read Tile where - readsPrec :: Int -> ReadS Tile - readsPrec _ (x : []) = [(tile, [])] - where - tile = case x of - 'N' -> (Honour $ Wind $ North) 0 - 'E' -> (Honour $ Wind $ East) 0 - 'S' -> (Honour $ Wind $ South) 0 - 'W' -> (Honour $ Wind $ West) 0 - 'r' -> (Honour $ Dragon $ Red) 0 - 'g' -> (Honour $ Dragon $ Green) 0 - 'w' -> (Honour $ Dragon $ White) 0 - readsPrec _ (x : y : _) = do - let ((value, dora), suit) = - ( case x of - '0' -> (5, 1) - '1' -> (1, 0) - '2' -> (2, 0) - '3' -> (3, 0) - '4' -> (4, 0) - '5' -> (5, 0) - '6' -> (6, 0) - '7' -> (7, 0) - '8' -> (8, 0) - '9' -> (9, 0) - , case y of - 'p' -> Pin - 'm' -> Man - 's' -> Sou - ) - in [(Numeric suit value dora, [])] - -readTileBlock :: String -> [Tile] -readTileBlock string = - let - final = last string - (stripped, separator) = case final of - 'p' -> (init string, "p ") - 'm' -> (init string, "m ") - 's' -> (init string, "s ") - _ -> (string, " ") - in - stripped & map (\c -> [c]) & intersperse separator & concat & (++ separator) & words & map read - -instance Show Tile where - show (Honour (Dragon Red) _) = "r" - show (Honour (Dragon Green) _) = "g" - show (Honour (Dragon White) _) = "w" - show (Honour (Wind North) _) = "N" - show (Honour (Wind East) _) = "E" - show (Honour (Wind South) _) = "S" - show (Honour (Wind West) _) = "W" - show (Numeric Pin 5 d) = if d == 0 then "5p" else "5p*" - show (Numeric Man 5 d) = if d == 0 then "5m" else "5m*" - show (Numeric Sou 5 d) = if d == 0 then "5s" else "5s*" - show (Numeric Pin n _) = (show n) ++ "p" - show (Numeric Man n _) = (show n) ++ "m" - show (Numeric Sou n _) = (show n) ++ "s" - --- We don't care about dora when equating tiles -instance Eq Tile where - (==) (Honour honour _) (Honour honour' _) = (honour == honour') - (==) (Numeric suit value _) (Numeric suit' value' _) = (suit == suit') && (value == value') - (==) _ _ = False - -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 - -isSimple :: Tile -> Bool -isSimple (Honour _ _) = False -isSimple (Numeric _ 1 _) = False -isSimple (Numeric _ 9 _) = False -isSimple _ = True - -isTerminal :: Tile -> Bool -isTerminal (Numeric _ 1 _) = True -isTerminal (Numeric _ 9 _) = True -isTerminal _ = False - -isHonour :: Tile -> Bool -isHonour (Honour _ _) = True -isHonour _ = False - -isNumeric :: Tile -> Bool -isNumeric = not . isHonour - -isDragon :: Tile -> Bool -isDragon (Honour (Dragon _) _) = True -isDragon _ = False - -isWind :: Tile -> Bool -isWind (Honour (Wind _) _) = True -isWind _ = False - -honourIsDragon :: Honour -> Bool -honourIsDragon (Dragon _) = True -honourIsDragon _ = False - -honourIsWind :: Honour -> Bool -honourIsWind = not . honourIsDragon diff --git a/src/Waits.hs b/src/Waits.hs deleted file mode 100644 --- a/src/Waits.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Waits where - -import Data.Function -import Data.List -import Meld -import Tile - -getWaits :: Hand -> [Tile] -getWaits hand = - if length hand < 13 - then [] - else - -- Check seven pairs - let pairs = findPairs hand - sevenPairsWait = - ( if length pairs == 6 - then case (hand & sort & group & filter (\gp -> 1 == length gp)) of - [[tile]] -> [tile] - _ -> [] - else [] - ) - -- Check thirteen orphans - orphansWaits = - if length hand == 13 - then do - let orphans = (mkHand "1p 9p 1s 9s 1m 9m N E S W r g w") - let difference = hand \\ orphans - case difference of - [] -> orphans - [tile] | tile `elem` orphans -> orphans \\ hand - _ -> [] - else [] - -- Check waits from standard interpretations - -- If we have four melds already, a single remaning tile can wait for a pair - possibleMelds = formMelds hand - fourMelds = possibleMelds & filter (\melds -> length melds == 4) - fourMeldsWaits = fourMelds & map (concatMelds) & map (hand \\) & filter (\diff -> length diff == 1) & concat - -- Finally, we might be waiting with three melds and a pair - threeMeldWaits = concat $ do - (pair, hand') <- findPairs hand - melds <- formMelds hand' - if length melds /= 3 - then return [] - else - let diff = hand' \\ (concatMelds melds) - in if length diff /= 2 - then return [] - else let [a, b] = diff in return (meldWait a b) - in (sevenPairsWait ++ orphansWaits ++ fourMeldsWaits ++ threeMeldWaits) & sort & group & map head - -meldWait :: Tile -> Tile -> [Tile] -meldWait a b - | a == b = [a] -meldWait t1@(Numeric s1 v1 _) t2@(Numeric s2 v2 _) - | v1 > v2 = meldWait t2 t1 - | s1 /= s2 = [] - -- \| v1 == v2 = [Numeric s1 v1 0] - | v1 + 1 == v2 = - if v1 == 1 - then [Numeric s1 (v2 + 1) 0] - else - if v2 == 9 - then [Numeric s1 (v1 - 1) 0] - else [Numeric s1 (v1 - 1) 0, Numeric s1 (v2 + 1) 0] - | v1 + 2 == v2 = [Numeric s1 (v1 + 1) 0] -meldWait _ _ = [] diff --git a/src/Yaku.hs b/src/Yaku.hs deleted file mode 100644 --- a/src/Yaku.hs +++ /dev/null @@ -1,269 +0,0 @@ -module Yaku where - -import Data.Either (lefts, rights) -import Data.Function -import Data.List -import Data.Set qualified as Set -import Meld -import Tile - --- Note that Yaku functions that operate on Hands needn't check that the --- hand is actually valid to begin with. This should be done by the caller, --- by seeing if interpretHand returns an nonempty list of interpretations. --- Some of these could probably be rephrased to be point free but I think --- that would just make them more confusing. - -tanyao :: Hand -> Bool -tanyao hand = hand & (map isSimple) & and - -allPairs :: Hand -> Bool -allPairs hand = (hand & findPairs & length) * 2 == length hand - --- Yakuman -thirteenOrphans :: Hand -> Bool -thirteenOrphans hand = - ( Set.fromList hand - == Set.fromList - [ (Honour $ Dragon $ Red) 0 - , (Honour $ Dragon $ White) 0 - , (Honour $ Dragon $ Green) 0 - , (Honour $ Wind $ North) 0 - , (Honour $ Wind $ South) 0 - , (Honour $ Wind $ East) 0 - , (Honour $ Wind $ West) 0 - , (Numeric Pin 1) 0 - , (Numeric Pin 9) 0 - , (Numeric Man 1) 0 - , (Numeric Man 9) 0 - , (Numeric Sou 1) 0 - , (Numeric Sou 9) 0 - ] - ) - && (length hand == 14) - --- Counts the number of yakuhai pairs. One han each. -yakuhai :: InterpretedHand -> Int -yakuhai (_, melds) = - melds - & ( filter - ( \meld -> - meld - `elem` [ Pon ((Honour $ Dragon $ Red) 0) False - , Pon ((Honour $ Dragon $ Green) 0) False - , Pon ((Honour $ Dragon $ White) 0) False - ] - ) - ) - & length - -checkPon :: Tile -> InterpretedHand -> Bool -checkPon tile (_, melds) = Pon tile False `elem` melds - -haku :: InterpretedHand -> Bool -haku = checkPon ((Honour $ Dragon $ White) 0) - -hatsu :: InterpretedHand -> Bool -hatsu = checkPon ((Honour $ Dragon $ Green) 0) - -chun :: InterpretedHand -> Bool -chun = checkPon ((Honour $ Dragon $ Red) 0) - -checkNorth :: InterpretedHand -> Bool -checkNorth = checkPon ((Honour $ Wind $ North) 0) - -checkEast :: InterpretedHand -> Bool -checkEast = checkPon ((Honour $ Wind $ East) 0) - -checkSouth :: InterpretedHand -> Bool -checkSouth = checkPon ((Honour $ Wind $ South) 0) - -checkWest :: InterpretedHand -> Bool -checkWest = checkPon ((Honour $ Wind $ West) 0) - -checkWind :: Wind -> InterpretedHand -> Bool -checkWind East = checkEast -checkWind North = checkNorth -checkWind West = checkWest -checkWind South = checkSouth - --- Same sequence in all three suits -sanshokuDoujun :: InterpretedHand -> Bool -sanshokuDoujun (_, melds) = - let - chis = melds & (filter meldIsChi) - suits = chis & (map getMeldSuit) - bases = chis & (map getMeldBase) - suits_bases = zip suits bases - in - or - [ ((Left Man, Left base) `elem` suits_bases) - && ((Left Pin, Left base) `elem` suits_bases) - && ((Left Sou, Left base) `elem` suits_bases) - | base <- [1 .. 7] - ] - --- Same triplet (or Kan!) in all three suits -sanshokuDoukou :: InterpretedHand -> Bool -sanshokuDoukou (_, melds) = - let - pons = melds & (filter (\meld -> meldIsPon meld || meldIsKan meld)) - suits = pons & (map getMeldSuit) - bases = pons & (map getMeldBase) - suits_bases = zip suits bases - in - or - [ ((Left Man, Left base) `elem` suits_bases) - && ((Left Pin, Left base) `elem` suits_bases) - && ((Left Sou, Left base) `elem` suits_bases) - | base <- [1 .. 9] - ] - --- Full flush --- chinitsu :: InterpretedHand -> Bool --- chinitsu (pair, melds) = allEqual ((getPairSuit pair) : (melds & (map getMeldSuit))) -chinitsu :: Hand -> Bool -chinitsu hand = hand & map getTileSuit & allEqual - --- Half flush --- Only check equality on the lefts of Either Suit Honour, i.e the suited melds. --- honitsu :: InterpretedHand -> Bool --- honitsu (pair, melds) = --- ((getPairSuit pair) : (melds & (map getMeldSuit))) --- & lefts --- & allEqual -honitsu :: Hand -> Bool -honitsu hand = hand & map getTileSuit & lefts & allEqual - -toitoi :: InterpretedHand -> Bool -toitoi (_, melds) = melds & (map (\meld -> meldIsPon meld || meldIsKan meld)) & and - -ittsuu :: InterpretedHand -> Bool -ittsuu (_, melds) = - let - chis = melds & (filter meldIsChi) - suits = chis & (map getMeldSuit) - bases = chis & (map getMeldBase) - suits_bases = zip suits bases - in - or - [ ((Left suit, Left 1) `elem` suits_bases) - && ((Left suit, Left 4) `elem` suits_bases) - && ((Left suit, Left 7) `elem` suits_bases) - | suit <- [Man, Pin, Sou] - ] - --- Three quads (open or closed) -sankantsu :: InterpretedHand -> Bool -sankantsu (_, melds) = melds & (filter meldIsKan) & length & (3 ==) - --- Four quads (open or closed). Yakuman -suukantsu :: InterpretedHand -> Bool -suukantsu (_, melds) = melds & (filter meldIsKan) & length & (4 ==) - --- Little three dragons. Worth noting that we permit ourselves to assume that hands --- don't contain more than 4 of a given tile! So no need to worry about multiple melds --- of the same dragon. -shousangen :: InterpretedHand -> Bool -shousangen (Pair tile, melds) = - (isDragon tile) - && ( melds - & (map getMeldSuit) - & rights - & (filter honourIsDragon) - & length - & (2 ==) - ) - --- Big three dragons. Yakuman -daisangen :: InterpretedHand -> Bool -daisangen (_, melds) = - ( melds - & (map getMeldSuit) - & rights - & (filter honourIsDragon) - & length - & (3 ==) - ) - --- Little winds. Yakuman -shousuushii :: InterpretedHand -> Bool -shousuushii (Pair tile, melds) = - (isWind tile) - && ( melds - & (map getMeldSuit) - & rights - & (filter honourIsWind) - & length - & (3 ==) - ) - --- Big winds. Double Yakuman -daisuushii :: InterpretedHand -> Bool -daisuushii (_, melds) = - ( melds - & (map getMeldSuit) - & rights - & (filter honourIsWind) - & length - & (4 ==) - ) - --- Pure double sequence. Closed only! -iipeikou :: InterpretedHand -> Bool -iipeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (== 1) - --- Twice pure double sequence. Note we require the two pairs of sequences to be distinct. -ryanpeikou :: InterpretedHand -> Bool -ryanpeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (>= 2) - --- Half outside hand -chanta :: InterpretedHand -> Bool -chanta (Pair tile, melds) = (melds & map getMeldBase & lefts & filter (\x -> x /= 1 && x /= 7)) == [] && (not $ isSimple tile) - --- Fully outside hand (chanta + no honours) -junchan :: InterpretedHand -> Bool -junchan ih@(Pair tile, melds) = (isNumeric tile) && (melds & map getMeldBase & rights) == [] && (chanta ih) - --- All terminals and honours -honroutou :: Hand -> Bool -honroutou hand = hand & map (\tile -> isHonour tile || isTerminal tile) & and - --- All honours. Yakuman -tsuuiisou :: Hand -> Bool -tsuuiisou hand = hand & map isHonour & and - --- All terminals. Yakuman -chinroutou :: Hand -> Bool -chinroutou hand = hand & map isTerminal & and - --- All green. Yakuman -ryuuiisou :: Hand -> Bool -ryuuiisou hand = hand & map isGreen & and - where - isGreen (Numeric Sou v _) = (v `elem` [2, 3, 4, 6, 8]) - isGreen (Honour (Dragon Green) _) = True - isGreen _ = False - --- Nine Gates. Yakuman --- Length == 9 precludes the possibility of a all honours chinitsu. -chuurenPoutou :: Hand -> Bool -chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3) - where - list = (hand & sort & group & map length) - --- Three concealed triplets -sanankou :: InterpretedHand -> Bool -sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 3 - --- Four concealed triplets -suuankou :: InterpretedHand -> Bool -suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 4 - -pinfu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool -pinfu (Pair tile, melds) seatWind roundWind ryanmanWait closedHand = - (melds & filter (not . meldIsChi)) == [] - && closedHand - && (not $ isDragon tile) - && (tile /= (Honour (Wind seatWind) 0)) - && (tile /= (Honour (Wind roundWind) 0)) - && ryanmanWait diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,28 @@ +import Test.Tasty +import Test.Tasty.HUnit + +import Riichi.Tile + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "All tests" + [ tileTests + ] + +tileTests :: TestTree +tileTests = + testGroup + "Tile test group" + [ testCase "Tile equality ignores dora" $ + (Numeric Pin 7 0 == Numeric Pin 7 1) + && (Honour (Wind North) 1 == Honour (Wind North) 0) @?= True + , testCase "Single tile read test" $ + ((read "0m" :: Tile) == (read "5m" :: Tile)) + && (read "r" == Honour (Dragon Red) 1) @?= True + , testCase "Multi tile read test" $ + (readTileBlock "123p" @?= [Numeric Pin 1 0, Numeric Pin 2 0, Numeric Pin 3 0]) + ]