riichi-scoring (empty) → 0.1.0.0
raw patch · 11 files changed
+1481/−0 lines, 11 filesdep +basedep +containersdep +mtl
Dependencies added: base, containers, mtl, riichi-scoring
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- app/Main.hs +22/−0
- riichi-scoring.cabal +91/−0
- src/ColourStrings.hs +16/−0
- src/Display.hs +224/−0
- src/Meld.hs +217/−0
- src/Scoring.hs +418/−0
- src/Tile.hs +124/−0
- src/Waits.hs +66/−0
- src/Yaku.hs +269/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for Mahjong++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ app/Main.hs view
@@ -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 <subcommand> \"<hand>\""+ | (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"
+ riichi-scoring.cabal view
@@ -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
+ src/ColourStrings.hs view
@@ -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"
+ src/Display.hs view
@@ -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 ()
+ src/Meld.hs view
@@ -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
+ src/Scoring.hs view
@@ -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 ""
+ src/Tile.hs view
@@ -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
+ src/Waits.hs view
@@ -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 _ _ = []
+ src/Yaku.hs view
@@ -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