diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for Mahjong + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2026, ZBW + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,22 @@ +module Main (main) where + +import Display +import Meld +import System.Environment (getArgs) + +main :: IO () +main = do + args <- getArgs + let list = ['1' .. '9'] ++ "NESWrgw" + case args of + [] -> putStrLn "No arguments supplied" + (arg : []) + | (arg `elem` ["--help", "-h", "help"]) -> putStrLn "Command riichi:\n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage: mahjong \"\"" + | (arg `elem` ["yaku", "waits", "score"]) -> putStrLn "Missing hand" + | (head arg) `elem` list -> displayHandYaku $ mkHand arg + | otherwise -> putStrLn "Command not recognised" + (arg1 : arg2 : _) + | arg1 == "yaku" -> displayHandYaku $ mkHand arg2 + | arg1 == "waits" -> displayHandWaits $ mkHand arg2 + | arg1 == "score" -> displayHandScore $ mkHand arg2 + | otherwise -> putStrLn "Command not recognised" diff --git a/riichi-scoring.cabal b/riichi-scoring.cabal new file mode 100644 --- /dev/null +++ b/riichi-scoring.cabal @@ -0,0 +1,91 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. +-- Initial package description 'Mahjong' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: riichi-scoring +homepage: https://github.com/SurplusSineWaves/riichi-scoring +bug-reports: https://github.com/SurplusSineWaves/riichi-scoring/issues +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.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. +-- The license under which the package is released. +license: BSD-3-Clause +-- The file containing the license text. +license-file: LICENSE +-- The package author(s). +author: ZBW +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: surplussinewaves@gmail.com +-- A copyright notice. +-- copyright: +category: Utility, CLI, Data, Library +build-type: Simple +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/SurplusSineWaves/riichi-scoring.git + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: +common warnings + ghc-options: -Wall + +library + exposed-modules: + Display + Meld + Scoring + Tile + Waits + Yaku + + other-modules: + ColourStrings + + hs-source-dirs: src + build-depends: + base ^>=4.20.2.0, + containers >=0.7 && <0.8, + mtl >=2.3.1 && <2.4, + + default-language: GHC2024 + +executable riichi + -- Import common warning flags. + import: warnings + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + -- Modules included in this executable, other than Main. + other-modules: + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + -- Other library packages from which modules are imported. + build-depends: + base ^>=4.20.2.0, + containers >=0.7 && <0.8, + mtl >=2.3.1 && <2.4, + riichi-scoring, + + -- Directories containing source files. + hs-source-dirs: app + -- Base language which the package is written in. + default-language: GHC2024 diff --git a/src/ColourStrings.hs b/src/ColourStrings.hs new file mode 100644 --- /dev/null +++ b/src/ColourStrings.hs @@ -0,0 +1,16 @@ +module ColourStrings where + +toRed :: String -> String +toRed s = "\o33[31m" ++ s ++ "\o33[0m" + +toBlue :: String -> String +toBlue s = "\o33[34m" ++ s ++ "\o33[0m" + +toMagenta :: String -> String +toMagenta s = "\o33[35m" ++ s ++ "\o33[0m" + +toCyan :: String -> String +toCyan s = "\o33[36m" ++ s ++ "\o33[0m" + +toGreen :: String -> String +toGreen s = "\o33[32m" ++ s ++ "\o33[0m" diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -0,0 +1,224 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Meld.hs @@ -0,0 +1,217 @@ +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/Scoring.hs b/src/Scoring.hs new file mode 100644 --- /dev/null +++ b/src/Scoring.hs @@ -0,0 +1,418 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Tile.hs @@ -0,0 +1,124 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Waits.hs @@ -0,0 +1,66 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Yaku.hs @@ -0,0 +1,269 @@ +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