riichi-scoring 0.1.0.1 → 0.2.0.0

raw patch · 17 files changed

+1456/−1336 lines, 17 filesdep +tastydep +tasty-hunitdep ~basedep ~containersdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty, tasty-hunit

Dependency ranges changed: base, containers, mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−2
• app/Main.hs +29/−4
• riichi-scoring.cabal +27/−12
• src/ColourStrings.hs +6/−0
• src/Display.hs +0/−224
• src/Meld.hs +0/−217
• src/Riichi/Display.hs +230/−0
• src/Riichi/Meld.hs +225/−0
• src/Riichi/Scoring.hs +424/−0
• src/Riichi/Tile.hs +131/−0
• src/Riichi/Waits.hs +72/−0
• src/Riichi/Yaku.hs +275/−0
• src/Scoring.hs +0/−418
• src/Tile.hs +0/−124
• src/Waits.hs +0/−66
• src/Yaku.hs +0/−269
• test/Test.hs +28/−0

@@ -1,5 +1,12 @@ # Revision history for Mahjong -## 0.1.0.0 -- YYYY-mm-dd+See git repo for more detailed commit information. -* First version. Released on an unsuspecting world.+## 0.1.0.0+First functional prototype.++## 0.1.0.1+Dependency versions reworked.++## 0.2.0.0+Help messages improved. Module structure refactored. Documentation begun.

@@ -1,17 +1,24 @@+{- |+Module      : Main+Description : Contains entrypoint for CLI in main function.+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-} module Main (main) where -import Display-import Meld+import Riichi.Display+import Riichi.Meld import System.Environment (getArgs) +-- | Entrypoint for CLI executable riichi. main :: IO () main = do     args <- getArgs     let list = ['1' .. '9'] ++ "NESWrgw"     case args of-        [] -> putStrLn "No arguments supplied"+        [] -> putStrLn "No arguments supplied. Run riichi --help for more info."         (arg : [])-            | (arg `elem` ["--help", "-h", "help"]) -> putStrLn "Command riichi:\n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage: mahjong <subcommand> \"<hand>\""+            | (arg `elem` ["--help", "-h", "help"]) -> putStrLn helpString             | (arg `elem` ["yaku", "waits", "score"]) -> putStrLn "Missing hand"             | (head arg) `elem` list -> displayHandYaku $ mkHand arg             | otherwise -> putStrLn "Command not recognised"@@ -20,3 +27,21 @@             | arg1 == "waits" -> displayHandWaits $ mkHand arg2             | arg1 == "score" -> displayHandScore $ mkHand arg2             | otherwise -> putStrLn "Command not recognised"++helpString :: String+helpString =+    "Command riichi:\n\tPossible subcommands: yaku, waits, score (default = yaku)\n\nUsage:\+    \\n\triichi <subcommand> \"<hand>\"\+    \\n\n\t\"yaku\" and \"score\" subcommands expect a full hand.\+    \\n\t\"waits\" subcommand expects a hand that is tenpai.\+    \\n\n\tExample hands include:\+    \\n\t\t\"123p 234m 444p rrrr NN\"\+    \\n\t\t\"344556s 444p 222m EE\"\+    \\n\t\t\"19p 19s 19m 1p NESWrgw\"\+    \\n\n\tIn detail, numeric tiles are denoted (1-9) + (m, p, or s),\+    \\n\tWinds are denoted N, E, S, W, and Dragons are r, w, g.\+    \\n\tA 0 can be used to denote a red five.\+    \\n\tNumeric tiles of the same suit, and honour tiles, can be \+    \\n\tgrouped as seen in the examples (but needn't be).\+    \\n\n\tIn scoring a hand, dora and seat/round wind must be supplied,\+    \\n\talso in this format."

@@ -20,11 +20,14 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.1+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: A CLI tool for interpreting and scoring Riichi Mahjong hands. -- A longer description of the package.-description: This package provides a CLI tool with commands for determining the yaku, fu, and score of a hand in Riichi Mahjong. It can also determine the waits of a partial hand.+description:+  This package provides a CLI tool with commands for determining the yaku, fu, and score of a hand in Riichi Mahjong. It can also determine the waits of a partial hand.+  See README.md for usage, or run: riichi --help+ -- The license under which the package is released. license: BSD-3-Clause -- The file containing the license text.@@ -49,21 +52,21 @@ common warnings   ghc-options: -Wall -library+library riichi-lib   exposed-modules:-    Display-    Meld-    Scoring-    Tile-    Waits-    Yaku+    Riichi.Display+    Riichi.Meld+    Riichi.Scoring+    Riichi.Tile+    Riichi.Waits+    Riichi.Yaku    other-modules:     ColourStrings    hs-source-dirs: src   build-depends:-    base ^>=4.19.2.0,+    base >=4.19.2.0 && <5,     containers >=0.7 && <0.8,     mtl >=2.3.1 && <2.4, @@ -80,12 +83,24 @@   -- other-extensions:   -- Other library packages from which modules are imported.   build-depends:-    base ^>=4.19.2.0,+    base >=4.19.2.0 && <5,     containers >=0.7 && <0.8,     mtl >=2.3.1 && <2.4,-    riichi-scoring,+    riichi-lib,    -- Directories containing source files.   hs-source-dirs: app   -- Base language which the package is written in.+  default-language: GHC2021++test-suite riichi-scoring-test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Test.hs+  build-depends:+    base >=4.19.2.0 && <5,+    riichi-lib,+    tasty,+    tasty-hunit,+   default-language: GHC2021

@@ -1,3 +1,9 @@+{- |+Module      : ColourStrings+Description : Helper functions for colouring output+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-} module ColourStrings where  toRed :: String -> String

@@ -1,224 +0,0 @@-module Display where--import ColourStrings-import Data.Function-import Data.List (intersperse, sort)-import Data.Monoid (getSum)-import Meld-import Scoring-import Tile-import Waits-import Yaku--displayHandYaku :: Hand -> IO ()-displayHandYaku hand = do-    if length hand < 14-        then-            putStrLn "Hand is the wrong size"-        else do-            let ihs = interpretHand hand-            putStrLn "🀀 🀁 🀂 🀃 "-            putStrLn "Assuming East round and East seat."-            let num = length ihs-            if num >= 1-                then do-                    if num == 1-                        then putStrLn $ "Found " ++ show num ++ " way to interpret this hand:\n"-                        else putStrLn $ "Found " ++ show num ++ " ways to interpret this hand:\n"-                    putStrLn $ concat $ do-                        ih <- ihs-                        let hand_string = ih & showInterpretedHand-                        let (value, yaku_string) = getYaku hand (Just ih) False False False False East East False-                        return $ case value of-                            Left (hanClosed, hanOpen) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum hanClosed)) ++ " Han total if closed, " ++ toGreen (show (getSum hanOpen)) ++ " if open\n"-                            Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n"-                else return ()-            if allPairs hand || thirteenOrphans hand-                then do-                    if num == 0-                        then putStrLn "This hand can be interpreted as:\n"-                        else putStrLn "This hand can also be interpreted as:\n"-                    let hand_string = hand & sort & map show & intersperse ", " & concat-                    let (value, yaku_string) = getYaku hand Nothing False False False False East East False-                    putStrLn $ case value of-                        Left (han, _) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum han)) ++ " Han total, closed by definition\n"-                        Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n"-                else-                    if num == 0-                        then putStrLn $ toRed "This hand is not valid"-                        else return ()--displayHandWaits :: Hand -> IO ()-displayHandWaits hand = do-    let waits = getWaits hand-    putStrLn $ "Waits are: " ++ (waits & map show & intersperse ", " & concat)--displayHandScore :: Hand -> IO ()-displayHandScore hand = do-    putStrLn "Input dora: (or leave blank)"-    dora <- mkHand <$> getLine-    let hand' = addDora dora hand-    putStrLn "Input round and seat wind: "-    (Honour (Wind roundWind) _) : (Honour (Wind seatWind) _) : _ <- mkHand <$> getLine-    putStrLn "Riichi? [y/n]: "-    riichi <- (== "y") <$> getLine-    ippatsu <--        if riichi-            then do-                putStrLn "Ippatsu? [y/n]: "-                (== "y") <$> getLine-            else return False-    putStrLn "Tsumo? [y/n]: "-    input <- getLine-    let tsumo = (input == "y")-    sevenPairs <--        if (allPairs hand') && (length hand' == 14)-            then do-                putStrLn "Seven pairs? [y/n]: "-                input <- getLine-                if input == "y"-                    then do-                        let (value, yaku_string) = getYaku hand' Nothing riichi ippatsu tsumo False seatWind roundWind True-                        putStrLn $ case value of-                            Left (han, _) ->-                                yaku_string-                                    ++ "\t\t"-                                    ++ toGreen (show (getSum han))-                                    ++ " Han total, closed by definition\n"-                                    ++ "\n\t"-                                    ++ toGreen (show (getScore han 25 True tsumo))-                                    ++ " points for Dealer, "-                                    ++ toGreen (show (getScore han 25 False tsumo))-                                    ++ " points for Non-Dealer."-                                    ++ ( if name /= ""-                                            then-                                                " ("-                                                    ++ toMagenta name-                                                    ++ ")."-                                            else ""-                                       )-                              where-                                name = hanToHandName han-                            Right yakumans ->-                                yaku_string-                                    ++ "\t\t"-                                    ++ toGreen (show (getSum yakumans))-                                    ++ " Yakuman total\n"-                                    ++ "\n\t"-                                    ++ toGreen (show (getSum yakumans * 48000))-                                    ++ " points for Dealer, "-                                    ++ toGreen (show (getSum yakumans * 32000))-                                    ++ " points for Non-Dealer."-                        return True-                    else-                        return False-            else return False-    if sevenPairs == False-        then do-            let ihs = interpretHand hand'-            maybeIh <--                if thirteenOrphans hand'-                    then return Nothing-                    else do-                        (pair, melds) <--                            if length ihs > 1-                                then do-                                    putStrLn "Select hand interpretation: "-                                    sequence_ $ [("[" ++ show n ++ "]: " ++ (ih & showInterpretedHand)) & putStrLn | (n :: Integer, ih) <- zip [0 ..] ihs]-                                    n <- read <$> getLine :: IO Int-                                    return (ihs !! n)-                                else do-                                    putStrLn "Found one way to interpret this hand: "-                                    let ih = head ihs-                                    putStrLn (showInterpretedHand ih)-                                    return ih--                        melds' <- case (riichi, tsumo) of-                            (True, True) -> return melds-                            (True, False) -> do-                                putStrLn "Which meld was opened by Ron? (enter an index): "-                                sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]-                                input <- getLine-                                let index :: Int = input & read-                                return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld)-                            (False, _) -> do-                                putStrLn "Which melds are open? (enter a string of indices, or leave blank if all closed): "-                                sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]-                                input <- getLine-                                let indices :: [Int] = input & map return & (map read)-                                return $ (zip [0 ..] melds) & map (\(i, meld) -> if i `elem` indices then openMeld meld else meld)-                        return $ Just (pair, melds')--            putStrLn "Did the hand have an open wait? [y/n]: "-            ryanmanWait <- (== "y") <$> getLine-            shanponWait <--                if ryanmanWait-                    then return False-                    else do-                        putStrLn "Did the hand have a dual pair wait? [y/n]: "-                        (== "y") <$> getLine-            let goodWait = not (ryanmanWait || shanponWait)--            closedHand <- case maybeIh of-                Just (_, melds) ->-                    case numOpen of-                        0 -> return True-                        _-                            | numOpen > 1 -> return False-                            | otherwise -> case (riichi, tsumo) of-                                (True, _) -> return True-                                (False, True) -> return False -- Already know there is an open meld. Now we know it wasn't opened by Ron.-                                (False, False) ->-                                    ( do-                                        putStrLn "Damaten? [y/n]:"-                                        (== "y") <$> getLine-                                    )-                  where-                    numOpen = melds & filter isOpen & length-                Nothing -> return $ True-            let (value, yaku_string) = getYaku hand' maybeIh riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand-            let fu = case maybeIh of-                    Just ih ->-                        if pinfu ih seatWind roundWind ryanmanWait closedHand-                            then if tsumo then 20 else 30-                            else getFu ih seatWind roundWind goodWait tsumo closedHand-                    -- Seven pairs already taken care of, so Nothing signifies thirteen orphans or an invalid hand.-                    -- So yakuman or invalid - 0 Fu, we will say.-                    Nothing -> 0-            putStrLn $ case value of-                Left (hanClosed, hanOpen) ->-                    "\tYaku:\n"-                        ++ yaku_string-                        ++ "\t\t"-                        ++ openClosed-                        ++ toGreen (show (getSum han))-                        ++ " Han total, with "-                        ++ toBlue (show fu)-                        ++ " Fu\n"-                        ++ "\n\t"-                        ++ toGreen (show (getScore han fu True tsumo))-                        ++ " points for Dealer, "-                        ++ toGreen (show (getScore han fu False tsumo))-                        ++ " points for Non-Dealer"-                        ++ ( if name /= ""-                                then-                                    " ("-                                        ++ toMagenta name-                                        ++ ")."-                                else ""-                           )-                  where-                    han = if (closedHand) then hanClosed else hanOpen-                    name = hanToHandName han-                    openClosed = if closedHand then "Closed hand: " else "Open hand: "-                Right yakumans ->-                    yaku_string-                        ++ "\t\t"-                        ++ toGreen (show (getSum yakumans))-                        ++ " Yakuman total\n"-                        ++ "\n\t"-                        ++ toGreen (show (getSum yakumans * 48000))-                        ++ " points for Dealer, "-                        ++ toGreen (show (getSum yakumans * 32000))-                        ++ " points for Non-Dealer."-        else return ()

@@ -1,217 +0,0 @@-module Meld where--import Data.Function-import Data.List-import Data.Set qualified as Set-import Tile--type Hand = [Tile]--mkHand :: String -> Hand-mkHand tiles = tiles & words & (map readTileBlock) & concat--addDora :: Hand -> Hand -> Hand-addDora [] hand = hand-addDora dora@(doraTile : rest) hand = do-    let hand' = addDora rest hand-    tile <- hand'-    if doraTile == tile-        then return $ case tile of-            (Honour x d) -> (Honour x (d + 1))-            (Numeric s v d) -> (Numeric s v (d + 1))-        else-            return tile--getDora :: Tile -> Dora-getDora (Honour _ d) = d-getDora (Numeric _ _ d) = d--newtype Pair = Pair Tile deriving (Show)--data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord)-type Open = Bool--instance Eq Meld where-    (==) (Pon tile1 _) (Pon tile2 _) = tile1 == tile2-    (==) (Kan tile1 _) (Kan tile2 _) = tile1 == tile2-    (==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList ([tile1, tile2, tile3]) == Set.fromList ([tile1', tile2', tile3'])-    (==) _ _ = False--instance Show Meld where-    show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) True) = "Open chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)-    show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) False) = "Closed chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)-    show (Pon (Numeric suit v1 _) True) = "Open pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit)-    show (Pon (Numeric suit v1 _) False) = "Closed pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit)-    show (Kan (Numeric suit v1 _) True) = "Open kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit)-    show (Kan (Numeric suit v1 _) False) = "Closed kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit)-    show (Pon (tile) True) = "Open pon: " ++ (tile & show & repeat & (take 3) & concat)-    show (Pon (tile) False) = "Closed pon: " ++ (tile & show & repeat & (take 3) & concat)-    show (Kan (tile) True) = "Open kan: " ++ (tile & show & repeat & (take 4) & concat)-    show (Kan (tile) False) = "Closed kan: " ++ (tile & show & repeat & (take 4) & concat)--allEqual :: (Eq a) => [a] -> Bool-allEqual [] = True-allEqual [_] = True-allEqual (x : y : ys) = (x == y) && (allEqual (y : ys))--allDifferent :: (Eq a) => [a] -> Bool-allDifferent [] = True-allDifferent [_] = True-allDifferent (x : xs) = (not (x `elem` xs)) && (allDifferent xs)--isChi :: Tile -> Tile -> Tile -> Bool-isChi (Numeric s1 v1 _) (Numeric s2 v2 _) (Numeric s3 v3 _) =-    (allEqual [s1, s2, s3]) && (Set.fromList (map (subtract m) [v1, v2, v3]) == Set.fromList ([0, 1, 2]))-  where-    m = minimum [v1, v2, v3]-isChi _ _ _ = False--isPon :: Tile -> Tile -> Tile -> Bool-isPon t1 t2 t3 = allEqual [t1, t2, t3]--isKan :: Tile -> Tile -> Tile -> Tile -> Bool-isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4]--isOpen :: Meld -> Bool-isOpen (Chi _ _ _ x) = x-isOpen (Pon _ x) = x-isOpen (Kan _ x) = x--isClosed :: Meld -> Bool-isClosed = not . isOpen--openMeld :: Meld -> Meld-openMeld (Chi a b c _) = Chi a b c True-openMeld (Pon a _) = Pon a True-openMeld (Kan a _) = Kan a True--meldIsChi :: Meld -> Bool-meldIsChi (Chi _ _ _ _) = True-meldIsChi _ = False--meldIsPon :: Meld -> Bool-meldIsPon (Pon _ _) = True-meldIsPon _ = False--meldIsKan :: Meld -> Bool-meldIsKan (Kan _ _) = True-meldIsKan _ = False--getMeldBase :: Meld -> Either Integer Honour-getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3])-getMeldBase (Pon (Numeric _ v1 _) _) = Left v1-getMeldBase (Kan (Numeric _ v1 _) _) = Left v1-getMeldBase (Pon (Honour honour _) _) = Right honour-getMeldBase (Kan (Honour honour _) _) = Right honour---- This considers each dragon and wind to be its own suit, effectively.-getMeldSuit :: Meld -> Either Suit Honour-getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit-getMeldSuit (Pon (Numeric suit _ _) _) = Left suit-getMeldSuit (Kan (Numeric suit _ _) _) = Left suit-getMeldSuit (Pon (Honour honour _) _) = Right honour-getMeldSuit (Kan (Honour honour _) _) = Right honour--getPairSuit :: Pair -> Either Suit Honour-getPairSuit (Pair (Numeric suit _ _)) = Left suit-getPairSuit (Pair (Honour honour _)) = Right honour--formMelds :: Hand -> [[Meld]]-formMelds [] = [[]]-formMelds [_] = [[]]-formMelds [_, _] = [[]]-formMelds hand@(tile : tiles) =-    let-        -- Form all possible sets of melds with the first meld including the first tile:-        -- triples = tiles & tails & init & (map (\x -> (head x, tail x))) & (map (\(tile2, final_tiles) -> [[tile, tile2, tile3] | tile3 <- final_tiles])) & concat-        triples = do-            (tile2 : rest) <- tiles & tails & init-            tile3 <- rest-            return [tile, tile2, tile3]--        possible_melds =-            ( map-                ( \triple@(tile1 : tile2 : tile3 : _) ->-                    if (isChi tile1 tile2 tile3)-                        then map ((Chi tile1 tile2 tile3 False) :) (formMelds (hand \\ triple))-                        else-                            if (isPon tile1 tile2 tile3)-                                then map ((Pon tile1 False) :) (formMelds (hand \\ triple))-                                else []-                )-                triples-                & concat-            )-                & map sort-                & sort-                & group-                & (map head)-     in-        if possible_melds == []-            then formMelds (tail hand)-            else possible_melds--meldsLength :: [Meld] -> Int-meldsLength [] = 0-meldsLength ((Kan _ _) : rest) = 4 + (meldsLength rest)-meldsLength (_ : rest) = 3 + (meldsLength rest)--concatMelds :: [Meld] -> Hand-concatMelds [] = []-concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest-concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest-concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest--findPairs :: Hand -> [(Pair, Hand)]-findPairs hand =-    hand-        & sort-        & group-        & (filter (\list -> 2 <= (length list)))-        & (map head)-        & (map (\tile -> (Pair tile, hand \\ [tile, tile])))--findKans :: Hand -> [([Meld], Hand)]-findKans hand =-    hand-        & sort-        & group-        & filter (\list -> 4 == (length list))-        & map head-        & map (\tile -> (Kan tile False))-        & subsequences-        & tail-        & map (\kans -> (kans, hand \\ (concat [tile & repeat & take 4 | Kan tile _ <- kans])))---- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans).--- An InterpretedHand can then be passed on to other functions to check for yakus.--- Seven pairs, thirteen orphans etc are handeled in other functions, that should be--- checked separately.-type InterpretedHand = (Pair, [Meld])-interpretHand :: Hand -> [InterpretedHand]-interpretHand hand =-    let-        possible_pairs = hand & findPairs-        pairs_kans_hands = do-            (pair, hand') <- possible_pairs-            (kans, hand'') <- findKans hand'-            melds <- formMelds hand''-            return (pair, kans ++ melds)-        -- possible_pairs-        --     >>= \(pair, hand') ->-        --         [(pair, kan, hand'') | (kan, hand'') <- findKans hand']-        --             >>= \(pair, kan, hand'') -> [(pair, kan : melds) | melds <- formMelds hand'']-        pairs_hands = do-            (pair, hand') <- possible_pairs-            melds <- formMelds hand'-            return (pair, melds)-     in-        -- possible_pairs-        --     >>= (\(pair, hand') -> [(pair, melds) | melds <- formMelds hand'])--        (pairs_kans_hands ++ pairs_hands)-            -- & (filter (\(_, melds) -> melds /= []))-            & (filter (\(_, melds) -> (length hand) == 2 + (meldsLength melds)))--showInterpretedHand :: InterpretedHand -> String-showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat

@@ -0,0 +1,230 @@+{- |+Module      : Riichi.Display+Description : Functions handling UI. Pending major revision.+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Display where++import ColourStrings+import Data.Function+import Data.List (intersperse, sort)+import Data.Monoid (getSum)+import Riichi.Meld+import Riichi.Scoring+import Riichi.Tile+import Riichi.Waits+import Riichi.Yaku++displayHandYaku :: Hand -> IO ()+displayHandYaku hand = do+    if length hand < 14+        then+            putStrLn "Hand is the wrong size"+        else do+            let ihs = interpretHand hand+            putStrLn "🀀 🀁 🀂 🀃 "+            putStrLn "Assuming East round and East seat."+            let num = length ihs+            if num >= 1+                then do+                    if num == 1+                        then putStrLn $ "Found " ++ show num ++ " way to interpret this hand:\n"+                        else putStrLn $ "Found " ++ show num ++ " ways to interpret this hand:\n"+                    putStrLn $ concat $ do+                        ih <- ihs+                        let hand_string = ih & showInterpretedHand+                        let (value, yaku_string) = getYaku hand (Just ih) False False False False East East False+                        return $ case value of+                            Left (hanClosed, hanOpen) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum hanClosed)) ++ " Han total if closed, " ++ toGreen (show (getSum hanOpen)) ++ " if open\n"+                            Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n"+                else return ()+            if allPairs hand || thirteenOrphans hand+                then do+                    if num == 0+                        then putStrLn "This hand can be interpreted as:\n"+                        else putStrLn "This hand can also be interpreted as:\n"+                    let hand_string = hand & sort & map show & intersperse ", " & concat+                    let (value, yaku_string) = getYaku hand Nothing False False False False East East False+                    putStrLn $ case value of+                        Left (han, _) -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum han)) ++ " Han total, closed by definition\n"+                        Right yakumans -> hand_string ++ "\n" ++ yaku_string ++ "\t\t" ++ toGreen (show (getSum yakumans)) ++ " Yakuman total\n"+                else+                    if num == 0+                        then putStrLn $ toRed "This hand is not valid"+                        else return ()++displayHandWaits :: Hand -> IO ()+displayHandWaits hand = do+    let waits = getWaits hand+    putStrLn $ "Waits are: " ++ (waits & map show & intersperse ", " & concat)++displayHandScore :: Hand -> IO ()+displayHandScore hand = do+    putStrLn "Input dora: (or leave blank)"+    dora <- mkHand <$> getLine+    let hand' = addDora dora hand+    putStrLn "Input round and seat wind: "+    (Honour (Wind roundWind) _) : (Honour (Wind seatWind) _) : _ <- mkHand <$> getLine+    putStrLn "Riichi? [y/n]: "+    riichi <- (== "y") <$> getLine+    ippatsu <-+        if riichi+            then do+                putStrLn "Ippatsu? [y/n]: "+                (== "y") <$> getLine+            else return False+    putStrLn "Tsumo? [y/n]: "+    input <- getLine+    let tsumo = (input == "y")+    sevenPairs <-+        if (allPairs hand') && (length hand' == 14)+            then do+                putStrLn "Seven pairs? [y/n]: "+                input <- getLine+                if input == "y"+                    then do+                        let (value, yaku_string) = getYaku hand' Nothing riichi ippatsu tsumo False seatWind roundWind True+                        putStrLn $ case value of+                            Left (han, _) ->+                                yaku_string+                                    ++ "\t\t"+                                    ++ toGreen (show (getSum han))+                                    ++ " Han total, closed by definition\n"+                                    ++ "\n\t"+                                    ++ toGreen (show (getScore han 25 True tsumo))+                                    ++ " points for Dealer, "+                                    ++ toGreen (show (getScore han 25 False tsumo))+                                    ++ " points for Non-Dealer."+                                    ++ ( if name /= ""+                                            then+                                                " ("+                                                    ++ toMagenta name+                                                    ++ ")."+                                            else ""+                                       )+                              where+                                name = hanToHandName han+                            Right yakumans ->+                                yaku_string+                                    ++ "\t\t"+                                    ++ toGreen (show (getSum yakumans))+                                    ++ " Yakuman total\n"+                                    ++ "\n\t"+                                    ++ toGreen (show (getSum yakumans * 48000))+                                    ++ " points for Dealer, "+                                    ++ toGreen (show (getSum yakumans * 32000))+                                    ++ " points for Non-Dealer."+                        return True+                    else+                        return False+            else return False+    if sevenPairs == False+        then do+            let ihs = interpretHand hand'+            maybeIh <-+                if thirteenOrphans hand'+                    then return Nothing+                    else do+                        (pair, melds) <-+                            if length ihs > 1+                                then do+                                    putStrLn "Select hand interpretation: "+                                    sequence_ $ [("[" ++ show n ++ "]: " ++ (ih & showInterpretedHand)) & putStrLn | (n :: Integer, ih) <- zip [0 ..] ihs]+                                    n <- read <$> getLine :: IO Int+                                    return (ihs !! n)+                                else do+                                    putStrLn "Found one way to interpret this hand: "+                                    let ih = head ihs+                                    putStrLn (showInterpretedHand ih)+                                    return ih++                        melds' <- case (riichi, tsumo) of+                            (True, True) -> return melds+                            (True, False) -> do+                                putStrLn "Which meld was opened by Ron? (enter an index): "+                                sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]+                                input <- getLine+                                let index :: Int = input & read+                                return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld)+                            (False, _) -> do+                                putStrLn "Which melds are open? (enter a string of indices, or leave blank if all closed): "+                                sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]+                                input <- getLine+                                let indices :: [Int] = input & map return & (map read)+                                return $ (zip [0 ..] melds) & map (\(i, meld) -> if i `elem` indices then openMeld meld else meld)+                        return $ Just (pair, melds')++            putStrLn "Did the hand have an open wait? [y/n]: "+            ryanmanWait <- (== "y") <$> getLine+            shanponWait <-+                if ryanmanWait+                    then return False+                    else do+                        putStrLn "Did the hand have a dual pair wait? [y/n]: "+                        (== "y") <$> getLine+            let goodWait = not (ryanmanWait || shanponWait)++            closedHand <- case maybeIh of+                Just (_, melds) ->+                    case numOpen of+                        0 -> return True+                        _+                            | numOpen > 1 -> return False+                            | otherwise -> case (riichi, tsumo) of+                                (True, _) -> return True+                                (False, True) -> return False -- Already know there is an open meld. Now we know it wasn't opened by Ron.+                                (False, False) ->+                                    ( do+                                        putStrLn "Damaten? [y/n]:"+                                        (== "y") <$> getLine+                                    )+                  where+                    numOpen = melds & filter isOpen & length+                Nothing -> return $ True+            let (value, yaku_string) = getYaku hand' maybeIh riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand+            let fu = case maybeIh of+                    Just ih ->+                        if pinfu ih seatWind roundWind ryanmanWait closedHand+                            then if tsumo then 20 else 30+                            else getFu ih seatWind roundWind goodWait tsumo closedHand+                    -- Seven pairs already taken care of, so Nothing signifies thirteen orphans or an invalid hand.+                    -- So yakuman or invalid - 0 Fu, we will say.+                    Nothing -> 0+            putStrLn $ case value of+                Left (hanClosed, hanOpen) ->+                    "\tYaku:\n"+                        ++ yaku_string+                        ++ "\t\t"+                        ++ openClosed+                        ++ toGreen (show (getSum han))+                        ++ " Han total, with "+                        ++ toBlue (show fu)+                        ++ " Fu\n"+                        ++ "\n\t"+                        ++ toGreen (show (getScore han fu True tsumo))+                        ++ " points for Dealer, "+                        ++ toGreen (show (getScore han fu False tsumo))+                        ++ " points for Non-Dealer"+                        ++ ( if name /= ""+                                then+                                    " ("+                                        ++ toMagenta name+                                        ++ ")."+                                else ""+                           )+                  where+                    han = if (closedHand) then hanClosed else hanOpen+                    name = hanToHandName han+                    openClosed = if closedHand then "Closed hand: " else "Open hand: "+                Right yakumans ->+                    yaku_string+                        ++ "\t\t"+                        ++ toGreen (show (getSum yakumans))+                        ++ " Yakuman total\n"+                        ++ "\n\t"+                        ++ toGreen (show (getSum yakumans * 48000))+                        ++ " points for Dealer, "+                        ++ toGreen (show (getSum yakumans * 32000))+                        ++ " points for Non-Dealer."+        else return ()

@@ -0,0 +1,225 @@+{- |+Module      : Riichi.Meld+Description : Datatypes representing melds and associated functions.+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com++A meld is our catch all term for chis, pons and kans.+-}+module Riichi.Meld where++import Data.Function+import Data.List+import Data.Set qualified as Set+import Riichi.Tile++type Hand = [Tile]++mkHand :: String -> Hand+mkHand tiles = tiles & words & (map readTileBlock) & concat++addDora :: Hand -> Hand -> Hand+addDora [] hand = hand+addDora dora@(doraTile : rest) hand = do+    let hand' = addDora rest hand+    tile <- hand'+    if doraTile == tile+        then return $ case tile of+            (Honour x d) -> (Honour x (d + 1))+            (Numeric s v d) -> (Numeric s v (d + 1))+        else+            return tile++getDora :: Tile -> Dora+getDora (Honour _ d) = d+getDora (Numeric _ _ d) = d++newtype Pair = Pair Tile deriving (Show)++data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord)+type Open = Bool++instance Eq Meld where+    (==) (Pon tile1 _) (Pon tile2 _) = tile1 == tile2+    (==) (Kan tile1 _) (Kan tile2 _) = tile1 == tile2+    (==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList ([tile1, tile2, tile3]) == Set.fromList ([tile1', tile2', tile3'])+    (==) _ _ = False++instance Show Meld where+    show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) True) = "Open chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)+    show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) False) = "Closed chi: " ++ ((map show $ sort [v1, v2, v3]) & concat) ++ " " ++ (show suit)+    show (Pon (Numeric suit v1 _) True) = "Open pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit)+    show (Pon (Numeric suit v1 _) False) = "Closed pon: " ++ (v1 & show & repeat & (take 3) & concat) ++ " " ++ (show suit)+    show (Kan (Numeric suit v1 _) True) = "Open kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit)+    show (Kan (Numeric suit v1 _) False) = "Closed kan: " ++ (v1 & show & repeat & (take 4) & concat) ++ " " ++ (show suit)+    show (Pon (tile) True) = "Open pon: " ++ (tile & show & repeat & (take 3) & concat)+    show (Pon (tile) False) = "Closed pon: " ++ (tile & show & repeat & (take 3) & concat)+    show (Kan (tile) True) = "Open kan: " ++ (tile & show & repeat & (take 4) & concat)+    show (Kan (tile) False) = "Closed kan: " ++ (tile & show & repeat & (take 4) & concat)++allEqual :: (Eq a) => [a] -> Bool+allEqual [] = True+allEqual [_] = True+allEqual (x : y : ys) = (x == y) && (allEqual (y : ys))++allDifferent :: (Eq a) => [a] -> Bool+allDifferent [] = True+allDifferent [_] = True+allDifferent (x : xs) = (not (x `elem` xs)) && (allDifferent xs)++isChi :: Tile -> Tile -> Tile -> Bool+isChi (Numeric s1 v1 _) (Numeric s2 v2 _) (Numeric s3 v3 _) =+    (allEqual [s1, s2, s3]) && (Set.fromList (map (subtract m) [v1, v2, v3]) == Set.fromList ([0, 1, 2]))+  where+    m = minimum [v1, v2, v3]+isChi _ _ _ = False++isPon :: Tile -> Tile -> Tile -> Bool+isPon t1 t2 t3 = allEqual [t1, t2, t3]++isKan :: Tile -> Tile -> Tile -> Tile -> Bool+isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4]++isOpen :: Meld -> Bool+isOpen (Chi _ _ _ x) = x+isOpen (Pon _ x) = x+isOpen (Kan _ x) = x++isClosed :: Meld -> Bool+isClosed = not . isOpen++openMeld :: Meld -> Meld+openMeld (Chi a b c _) = Chi a b c True+openMeld (Pon a _) = Pon a True+openMeld (Kan a _) = Kan a True++meldIsChi :: Meld -> Bool+meldIsChi (Chi _ _ _ _) = True+meldIsChi _ = False++meldIsPon :: Meld -> Bool+meldIsPon (Pon _ _) = True+meldIsPon _ = False++meldIsKan :: Meld -> Bool+meldIsKan (Kan _ _) = True+meldIsKan _ = False++getMeldBase :: Meld -> Either Integer Honour+getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3])+getMeldBase (Pon (Numeric _ v1 _) _) = Left v1+getMeldBase (Kan (Numeric _ v1 _) _) = Left v1+getMeldBase (Pon (Honour honour _) _) = Right honour+getMeldBase (Kan (Honour honour _) _) = Right honour++-- This considers each dragon and wind to be its own suit, effectively.+getMeldSuit :: Meld -> Either Suit Honour+getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit+getMeldSuit (Pon (Numeric suit _ _) _) = Left suit+getMeldSuit (Kan (Numeric suit _ _) _) = Left suit+getMeldSuit (Pon (Honour honour _) _) = Right honour+getMeldSuit (Kan (Honour honour _) _) = Right honour++getPairSuit :: Pair -> Either Suit Honour+getPairSuit (Pair (Numeric suit _ _)) = Left suit+getPairSuit (Pair (Honour honour _)) = Right honour++formMelds :: Hand -> [[Meld]]+formMelds [] = [[]]+formMelds [_] = [[]]+formMelds [_, _] = [[]]+formMelds hand@(tile : tiles) =+    let+        -- Form all possible sets of melds with the first meld including the first tile:+        -- triples = tiles & tails & init & (map (\x -> (head x, tail x))) & (map (\(tile2, final_tiles) -> [[tile, tile2, tile3] | tile3 <- final_tiles])) & concat+        triples = do+            (tile2 : rest) <- tiles & tails & init+            tile3 <- rest+            return [tile, tile2, tile3]++        possible_melds =+            ( map+                ( \triple@(tile1 : tile2 : tile3 : _) ->+                    if (isChi tile1 tile2 tile3)+                        then map ((Chi tile1 tile2 tile3 False) :) (formMelds (hand \\ triple))+                        else+                            if (isPon tile1 tile2 tile3)+                                then map ((Pon tile1 False) :) (formMelds (hand \\ triple))+                                else []+                )+                triples+                & concat+            )+                & map sort+                & sort+                & group+                & (map head)+     in+        if possible_melds == []+            then formMelds (tail hand)+            else possible_melds++meldsLength :: [Meld] -> Int+meldsLength [] = 0+meldsLength ((Kan _ _) : rest) = 4 + (meldsLength rest)+meldsLength (_ : rest) = 3 + (meldsLength rest)++concatMelds :: [Meld] -> Hand+concatMelds [] = []+concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest+concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest+concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest++findPairs :: Hand -> [(Pair, Hand)]+findPairs hand =+    hand+        & sort+        & group+        & (filter (\list -> 2 <= (length list)))+        & (map head)+        & (map (\tile -> (Pair tile, hand \\ [tile, tile])))++findKans :: Hand -> [([Meld], Hand)]+findKans hand =+    hand+        & sort+        & group+        & filter (\list -> 4 == (length list))+        & map head+        & map (\tile -> (Kan tile False))+        & subsequences+        & tail+        & map (\kans -> (kans, hand \\ (concat [tile & repeat & take 4 | Kan tile _ <- kans])))++-- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans).+-- An InterpretedHand can then be passed on to other functions to check for yakus.+-- Seven pairs, thirteen orphans etc are handeled in other functions, that should be+-- checked separately.+type InterpretedHand = (Pair, [Meld])+interpretHand :: Hand -> [InterpretedHand]+interpretHand hand =+    let+        possible_pairs = hand & findPairs+        pairs_kans_hands = do+            (pair, hand') <- possible_pairs+            (kans, hand'') <- findKans hand'+            melds <- formMelds hand''+            return (pair, kans ++ melds)+        -- possible_pairs+        --     >>= \(pair, hand') ->+        --         [(pair, kan, hand'') | (kan, hand'') <- findKans hand']+        --             >>= \(pair, kan, hand'') -> [(pair, kan : melds) | melds <- formMelds hand'']+        pairs_hands = do+            (pair, hand') <- possible_pairs+            melds <- formMelds hand'+            return (pair, melds)+     in+        -- possible_pairs+        --     >>= (\(pair, hand') -> [(pair, melds) | melds <- formMelds hand'])++        (pairs_kans_hands ++ pairs_hands)+            -- & (filter (\(_, melds) -> melds /= []))+            & (filter (\(_, melds) -> (length hand) == 2 + (meldsLength melds)))++showInterpretedHand :: InterpretedHand -> String+showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat

@@ -0,0 +1,424 @@+{- |+Module      : Riichi.Scoring+Description : Functions for score calculation (yaku, han, fu)+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Scoring where++import ColourStrings+import Control.Monad (when)+import Control.Monad.Writer+import Data.Function ((&))+import Data.Map qualified as M+import Data.Monoid (Sum)+import Riichi.Meld+import Riichi.Tile+import Riichi.Yaku++type YakumanCount = Sum Int+type Han = Sum Int++getYaku :: Hand -> Maybe InterpretedHand -> Bool -> Bool -> Bool -> Bool -> Wind -> Wind -> Bool -> (Either (Han, Han) YakumanCount, String)+getYaku hand (Just ih@(Pair _, melds)) riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand =+    -- The caller should ensure ih is not empty, as some of these yaku funcitons only look+    -- at the hand, and don't re-check if it has a valid interpretation.+    let+        -- Check Yakuman first.+        yakumanWriter :: Writer (YakumanCount, String) () = do+            when (suuankou ih) $ tell (1, toMagenta "\tYakuman: Four Concealed Triplets\n")+            when (suukantsu ih) $ tell (1, toMagenta "\tYakuman: Four Kans\n")+            when (daisangen ih) $ tell (1, toMagenta "\tYakuman: Big Four Dragons\n")+            when (shousuushii ih) $ tell (1, toMagenta "\tYakuman: Little Winds\n")+            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours\n")+            when (chinroutou hand) $ tell (1, toMagenta "\tYakuman: All Terminals\n")+            when (ryuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Green\n")+            when (chuurenPoutou hand) $ tell (1, toMagenta "\tYakuman: Nine Gates\n")+            when (daisuushii ih) $ tell (2, toMagenta "\tDouble Yakuman: Big Winds\n")+        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter++        hanWriter :: Writer (Han, Han, String) () = do+            when (riichi) $ tell (1, 0, toCyan "\t1 Han: Riichi\n")+            when (ippatsu) $ tell (1, 0, toCyan "\t1 Han: Ippatsu\n")+            when (tsumo && and (map isClosed melds)) $ tell (1, 0, toCyan "\t1 Han: Fully concealed hand\n")+            when (pinfu ih seatWind roundWind ryanmanWait closedHand) $ tell (1, 0, toCyan "\t1 Han: Pinfu\n")+            when (tanyao hand) $ tell (1, 1, toCyan "\t1 Han: All simples\n")+            when (haku ih) $ tell (1, 1, toCyan "\t1 Han: Haku (White Dragon)\n")+            when (hatsu ih) $ tell (1, 1, toCyan "\t1 Han: Hatsu (Green Dragon)\n")+            when (chun ih) $ tell (1, 1, toCyan "\t1 Han: Chun (Red Dragon)\n")+            when (checkWind seatWind ih) $ tell (1, 1, toCyan "\t1 Han: Seat wind\n")+            when (checkWind roundWind ih) $ tell (1, 1, toCyan "\t1 Han: Round wind\n")+            when (sanshokuDoujun ih) $ tell (2, 1, toCyan "\t2 Han: Mixed triple sequence (-1 Han if open)\n")+            when (sanshokuDoukou ih) $ tell (2, 1, toCyan "\t2 Han: Triple triplets (-1 Han if open)\n")+            when (sanankou ih) $ tell (2, 2, toCyan "\t2 Han: Three concealed triplets\n")+            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)+            if fullFlush+                then+                    tell (6, 5, toCyan "\t6 Han: Full flush (-1 Han if open)\n")+                else+                    if halfFlush+                        then+                            tell (3, 2, toCyan "\t3 Han: Half flush (-1 Han if open)\n")+                        else+                            return ()+            when (toitoi ih) $ tell (2, 2, toCyan "\t2 Han: All triplets\n")+            when (ittsuu ih) $ tell (2, 1, toCyan "\t2 Han: Pure straight (-1 Han if open)\n")+            when (sankantsu ih) $ tell (2, 2, toCyan "\t2 Han: Three kans\n")+            when (shousangen ih) $ tell (2, 2, toCyan "\t2 Han: Little three dragons\n")+            let (twicePure, singlePure) = (ryanpeikou ih, iipeikou ih)+            if twicePure+                then+                    tell (3, 0, toCyan "\t3 Han: Twice pure double sequence (Closed only)\n")+                else+                    if singlePure+                        then+                            tell (1, 0, toCyan "\t1 Han: Pure double sequence (Closed only)\n")+                        else+                            return ()+            let (fullyOutside, halfOutside, terminalsHonours) = (junchan ih, chanta ih, honroutou hand)+            if fullyOutside+                then+                    tell (3, 2, toCyan "\t3 Han: Fully outside hand (-1 Han if open)\n")+                else+                    if terminalsHonours+                        then+                            tell (2, 2, toCyan "\t2 Han: All terminals and honours\n")+                        else+                            if halfOutside+                                then+                                    tell (2, 1, toCyan "\t2 Han: Half outside hand (-1 Han if open)\n")+                                else+                                    return ()+            when (dora > 0) $ tell (fromInteger dora, fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))+          where+            dora = hand & map getDora & sum++        (_, (hanClosed, hanOpen, output)) = runWriter hanWriter+     in+        if yakumans > 0+            then (Right yakumans, yakumanOutput)+            else+                if output == ""+                    then+                        (Left (0, 0), "\tNo explicit yaku found, riichi or menzen tsumo is required\n")+                    else+                        (Left (hanClosed, hanOpen), output)+getYaku hand Nothing riichi ippatsu tsumo _ _ _ _ =+    let+        -- Check Yakuman first.+        yakumanWriter :: Writer (YakumanCount, String) () = do+            when (thirteenOrphans hand) $ tell (1, toMagenta "\tYakuman: Thirteen Orphans (Double Yakuman if wait is 13 sided)\n")+            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours (+ seven pairs)\n")+        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter++        sevenPairs = allPairs hand+        hanWriter :: Writer (Han, String) () = do+            when (riichi) $ tell (1, toCyan "\t1 Han: Riichi\n")+            when (ippatsu) $ tell (1, toCyan "\t1 Han: Ippatsu\n")+            when (tsumo) $ tell (1, toCyan "\t1 Han: Fully concealed hand\n")+            when (tanyao hand) $ tell (1, toCyan "\t1 Han: All simples\n")+            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)+            if fullFlush+                then+                    tell (6, toCyan "\t6 Han: Full flush\n")+                else+                    if halfFlush+                        then+                            tell (3, toCyan "\t3 Han: Half flush\n")+                        else+                            return ()+            when (honroutou hand) $ tell (2, toCyan "\t2 Han: All terminals and honours\n")+            when (dora > 0) $ tell (fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))+          where+            dora = hand & map getDora & sum++        (_, (han, output)) = runWriter hanWriter+     in+        if yakumans > 0+            then (Right yakumans, yakumanOutput)+            else+                if sevenPairs+                    then+                        (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output)+                    else+                        (Left (0, 0), "This hand is not valid\n")++getMeldFu :: Meld -> Fu+getMeldFu (Chi _ _ _ _) = 0+getMeldFu (Pon (Numeric _ v _) True) = if v `elem` [1, 9] then 4 else 2+getMeldFu (Pon (Honour _ _) True) = 4+getMeldFu (Pon (Numeric _ v _) False) = if v `elem` [1, 9] then 8 else 4+getMeldFu (Pon (Honour _ _) False) = 8+getMeldFu (Kan (Numeric _ v _) True) = if v `elem` [1, 9] then 16 else 8+getMeldFu (Kan (Honour _ _) True) = 16+getMeldFu (Kan (Numeric _ v _) False) = if v `elem` [1, 9] then 32 else 16+getMeldFu (Kan (Honour _ _) False) = 32++-- Get fu for a standard hand. Seven pairs and thirteen orphans, as ever, are handled separately+type Fu = Int+getFu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool -> Fu+getFu (Pair tile, melds) seatWind roundWind goodWait tsumo closedHand =+    -- Perhaps a writer monad over the sum int monoid would be more elegant here but I think this more+    -- descriptive method is fine too.+    let meldsFu = melds & map getMeldFu & sum+        waitFu = if goodWait then 2 else 0+        yakuhaiFu =+            (if (tile & isDragon) then 2 else 0)+                + (if (tile == (Honour (Wind roundWind) 0)) then 2 else 0)+                + (if (tile == (Honour (Wind seatWind) 0)) then 2 else 0)+        ronClosedFu = if (not tsumo) && closedHand then 10 else 0+        tsumoFu = if tsumo then 2 else 0+     in roundUp (20 + meldsFu + waitFu + yakuhaiFu + ronClosedFu + tsumoFu)+  where+    roundUp n = last ([120, 110 .. 10] & filter (>= n))++getScore :: Han -> Fu -> Bool -> Bool -> Integer+getScore han fu dealer tsumo =+    if dealer+        then case han of+            _+                | han >= 13 -> 32000+                | han >= 5 -> case M.lookup han manganToSanbaimanTableDealer of+                    Just score -> score+                    Nothing -> 0+                | otherwise ->+                    if tsumo+                        then case M.lookup (han, fu) scoreTableTsumoDealer of+                            Just score -> score+                            Nothing -> 0+                        else case M.lookup (han, fu) scoreTableRonDealer of+                            Just score -> score+                            Nothing -> 0+        else case han of+            _+                | han >= 13 -> 24000+                | han >= 5 -> case M.lookup han manganToSanbaimanTableNonDealer of+                    Just score -> score+                    Nothing -> 0+                | otherwise ->+                    if tsumo+                        then case M.lookup (han, fu) scoreTableTsumoNonDealer of+                            Just score -> score+                            Nothing -> 0+                        else case M.lookup (han, fu) scoreTableRonNonDealer of+                            Just score -> score+                            Nothing -> 0++scoreTableTsumoDealer :: M.Map (Han, Fu) Integer+scoreTableTsumoDealer =+    M.fromList+        [ ((1, 20), 1200)+        , ((1, 30), 1500)+        , ((1, 40), 2100)+        , ((1, 50), 2400)+        , ((1, 60), 3000)+        , ((1, 70), 3600)+        , ((1, 80), 3900)+        , ((1, 90), 4500)+        , ((1, 100), 4800)+        , ((1, 110), 5400)+        , ((2, 20), 2100)+        , ((2, 30), 3000)+        , ((2, 40), 3900)+        , ((2, 50), 4800)+        , ((2, 60), 6000)+        , ((2, 70), 6900)+        , ((2, 80), 7800)+        , ((2, 90), 8700)+        , ((2, 100), 9600)+        , ((2, 110), 10800)+        , ((3, 20), 3900)+        , ((3, 25), 4800)+        , ((3, 30), 6000)+        , ((3, 40), 7800)+        , ((3, 50), 9600)+        , ((3, 60), 11700)+        , ((3, 70), 12000)+        , ((3, 80), 12000)+        , ((3, 90), 12000)+        , ((3, 100), 12000)+        , ((3, 110), 12000)+        , ((4, 20), 7800)+        , ((4, 25), 9600)+        , ((4, 30), 11700)+        , ((4, 40), 12000)+        , ((4, 50), 12000)+        , ((4, 60), 12000)+        , ((4, 70), 12000)+        , ((4, 80), 12000)+        , ((4, 90), 12000)+        , ((4, 100), 12000)+        , ((4, 110), 12000)+        ]++scoreTableRonDealer :: M.Map (Han, Fu) Integer+scoreTableRonDealer =+    M.fromList+        [ ((1, 30), 1500)+        , ((1, 40), 2000)+        , ((1, 50), 2400)+        , ((1, 60), 2900)+        , ((1, 70), 3400)+        , ((1, 80), 3900)+        , ((1, 90), 4400)+        , ((1, 100), 4800)+        , ((1, 110), 5300)+        , ((2, 25), 2400)+        , ((2, 30), 2900)+        , ((2, 40), 3900)+        , ((2, 50), 4800)+        , ((2, 60), 5800)+        , ((2, 70), 6800)+        , ((2, 80), 7700)+        , ((2, 90), 8700)+        , ((2, 100), 9600)+        , ((2, 110), 10600)+        , ((3, 25), 4800)+        , ((3, 30), 5800)+        , ((3, 40), 7700)+        , ((3, 50), 9600)+        , ((3, 60), 11600)+        , ((3, 70), 12000)+        , ((3, 80), 12000)+        , ((3, 90), 12000)+        , ((3, 100), 12000)+        , ((3, 110), 12000)+        , ((4, 25), 9600)+        , ((4, 30), 11600)+        , ((4, 40), 12000)+        , ((4, 50), 12000)+        , ((4, 60), 12000)+        , ((4, 70), 12000)+        , ((4, 80), 12000)+        , ((4, 90), 12000)+        , ((4, 100), 12000)+        , ((4, 110), 12000)+        ]++scoreTableTsumoNonDealer :: M.Map (Han, Fu) Integer+scoreTableTsumoNonDealer =+    M.fromList+        [ ((1, 20), 800)+        , ((1, 30), 1100)+        , ((1, 40), 1500)+        , ((1, 50), 1600)+        , ((1, 60), 2000)+        , ((1, 70), 2400)+        , ((1, 80), 2700)+        , ((1, 90), 3100)+        , ((1, 100), 3200)+        , ((1, 110), 3600)+        , ((2, 20), 1500)+        , ((2, 30), 2000)+        , ((2, 40), 2700)+        , ((2, 50), 3200)+        , ((2, 60), 4000)+        , ((2, 70), 4700)+        , ((2, 80), 5200)+        , ((2, 90), 5900)+        , ((2, 100), 6400)+        , ((2, 110), 7200)+        , ((3, 20), 2700)+        , ((3, 25), 3200)+        , ((3, 30), 4000)+        , ((3, 40), 5200)+        , ((3, 50), 6400)+        , ((3, 60), 7900)+        , ((3, 70), 8000)+        , ((3, 80), 8000)+        , ((3, 90), 8000)+        , ((3, 100), 8000)+        , ((3, 110), 8000)+        , ((4, 20), 5200)+        , ((4, 25), 6400)+        , ((4, 30), 7900)+        , ((4, 40), 8000)+        , ((4, 50), 8000)+        , ((4, 60), 8000)+        , ((4, 70), 8000)+        , ((4, 80), 8000)+        , ((4, 90), 8000)+        , ((4, 100), 8000)+        , ((4, 110), 8000)+        ]++scoreTableRonNonDealer :: M.Map (Han, Fu) Integer+scoreTableRonNonDealer =+    M.fromList+        [ ((1, 30), 1000)+        , ((1, 40), 1300)+        , ((1, 50), 1600)+        , ((1, 60), 2000)+        , ((1, 70), 2300)+        , ((1, 80), 2600)+        , ((1, 90), 2900)+        , ((1, 100), 3200)+        , ((1, 110), 3600)+        , ((2, 25), 1600)+        , ((2, 30), 2000)+        , ((2, 40), 2600)+        , ((2, 50), 3200)+        , ((2, 60), 3900)+        , ((2, 70), 4500)+        , ((2, 80), 5200)+        , ((2, 90), 5800)+        , ((2, 100), 6400)+        , ((2, 110), 7100)+        , ((3, 25), 3200)+        , ((3, 30), 3900)+        , ((3, 40), 5200)+        , ((3, 50), 6400)+        , ((3, 60), 7700)+        , ((3, 70), 8000)+        , ((3, 80), 8000)+        , ((3, 90), 8000)+        , ((3, 100), 8000)+        , ((3, 110), 8000)+        , ((4, 25), 6400)+        , ((4, 30), 7700)+        , ((4, 40), 8000)+        , ((4, 50), 8000)+        , ((4, 60), 8000)+        , ((4, 70), 8000)+        , ((4, 80), 8000)+        , ((4, 90), 8000)+        , ((4, 100), 8000)+        , ((4, 110), 8000)+        ]++manganToSanbaimanTableDealer :: M.Map Han Integer+manganToSanbaimanTableDealer =+    M.fromList+        [ (5, 12000)+        , (6, 18000)+        , (7, 18000)+        , (8, 24000)+        , (9, 24000)+        , (10, 24000)+        , (11, 36000)+        , (12, 36000)+        ]++manganToSanbaimanTableNonDealer :: M.Map Han Integer+manganToSanbaimanTableNonDealer =+    M.fromList+        [ (5, 8000)+        , (6, 12000)+        , (7, 12000)+        , (8, 16000)+        , (9, 16000)+        , (10, 16000)+        , (11, 24000)+        , (12, 24000)+        ]++hanToHandName :: Han -> String+hanToHandName 5 = "Mangan"+hanToHandName 6 = "Haneman"+hanToHandName 7 = "Haneman"+hanToHandName 8 = "Baiman"+hanToHandName 9 = "Baiman"+hanToHandName 10 = "Baiman"+hanToHandName 11 = "Sanbaiman"+hanToHandName 12 = "Sanbaiman"+hanToHandName n = if n >= 13 then "Counted Yakuman" else ""

@@ -0,0 +1,131 @@+{- |+Module      : Riichi.Tile+Description : Datatypes representing tiles and associated functions.+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Tile where++import Data.Function+import Data.List (intersperse)++{- |+Tile data type. Can be an honour tile or a numeric tile. Dora is tracked+here too on a per tile basis (necessary for red fives)+-}+data Tile = Honour Honour Dora | Numeric Suit Value Dora deriving (Ord)++type Dora = Integer+type Value = Integer++-- | An honour tile is a dragon or a wind+data Honour = Dragon (Dragon) | Wind (Wind) deriving (Show, Eq, Ord)++data Dragon = White | Green | Red deriving (Show, Eq, Ord)+data Wind = North | East | South | West deriving (Show, Eq, Ord)++data Suit = Man | Pin | Sou deriving (Show, Eq, Ord)++instance Read Tile where+    readsPrec :: Int -> ReadS Tile+    readsPrec _ (x : []) = [(tile, [])]+      where+        tile = case x of+            'N' -> (Honour $ Wind $ North) 0+            'E' -> (Honour $ Wind $ East) 0+            'S' -> (Honour $ Wind $ South) 0+            'W' -> (Honour $ Wind $ West) 0+            'r' -> (Honour $ Dragon $ Red) 0+            'g' -> (Honour $ Dragon $ Green) 0+            'w' -> (Honour $ Dragon $ White) 0+    readsPrec _ (x : y : _) = do+        let ((value, dora), suit) =+                ( case x of+                    '0' -> (5, 1)+                    '1' -> (1, 0)+                    '2' -> (2, 0)+                    '3' -> (3, 0)+                    '4' -> (4, 0)+                    '5' -> (5, 0)+                    '6' -> (6, 0)+                    '7' -> (7, 0)+                    '8' -> (8, 0)+                    '9' -> (9, 0)+                , case y of+                    'p' -> Pin+                    'm' -> Man+                    's' -> Sou+                )+         in [(Numeric suit value dora, [])]++readTileBlock :: String -> [Tile]+readTileBlock string =+    let+        final = last string+        (stripped, separator) = case final of+            'p' -> (init string, "p ")+            'm' -> (init string, "m ")+            's' -> (init string, "s ")+            _ -> (string, " ")+     in+        stripped & map (\c -> [c]) & intersperse separator & concat & (++ separator) & words & map read++instance Show Tile where+    show (Honour (Dragon Red) _) = "r"+    show (Honour (Dragon Green) _) = "g"+    show (Honour (Dragon White) _) = "w"+    show (Honour (Wind North) _) = "N"+    show (Honour (Wind East) _) = "E"+    show (Honour (Wind South) _) = "S"+    show (Honour (Wind West) _) = "W"+    show (Numeric Pin 5 d) = if d == 0 then "5p" else "5p*"+    show (Numeric Man 5 d) = if d == 0 then "5m" else "5m*"+    show (Numeric Sou 5 d) = if d == 0 then "5s" else "5s*"+    show (Numeric Pin n _) = (show n) ++ "p"+    show (Numeric Man n _) = (show n) ++ "m"+    show (Numeric Sou n _) = (show n) ++ "s"++-- We don't care about dora when equating tiles+instance Eq Tile where+    (==) (Honour honour _) (Honour honour' _) = (honour == honour')+    (==) (Numeric suit value _) (Numeric suit' value' _) = (suit == suit') && (value == value')+    (==) _ _ = False++getTileSuit :: Tile -> Either Suit Honour+getTileSuit (Numeric Pin _ _) = Left Pin+getTileSuit (Numeric Man _ _) = Left Man+getTileSuit (Numeric Sou _ _) = Left Sou+getTileSuit (Honour honour _) = Right honour++isSimple :: Tile -> Bool+isSimple (Honour _ _) = False+isSimple (Numeric _ 1 _) = False+isSimple (Numeric _ 9 _) = False+isSimple _ = True++isTerminal :: Tile -> Bool+isTerminal (Numeric _ 1 _) = True+isTerminal (Numeric _ 9 _) = True+isTerminal _ = False++isHonour :: Tile -> Bool+isHonour (Honour _ _) = True+isHonour _ = False++isNumeric :: Tile -> Bool+isNumeric = not . isHonour++isDragon :: Tile -> Bool+isDragon (Honour (Dragon _) _) = True+isDragon _ = False++isWind :: Tile -> Bool+isWind (Honour (Wind _) _) = True+isWind _ = False++honourIsDragon :: Honour -> Bool+honourIsDragon (Dragon _) = True+honourIsDragon _ = False++honourIsWind :: Honour -> Bool+honourIsWind = not . honourIsDragon

@@ -0,0 +1,72 @@+{- |+Module      : Riichi.Waits+Description : Methods for determining the waits of a hand+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Waits where++import Data.Function+import Data.List+import Riichi.Meld+import Riichi.Tile++getWaits :: Hand -> [Tile]+getWaits hand =+    if length hand < 13+        then []+        else+            -- Check seven pairs+            let pairs = findPairs hand+                sevenPairsWait =+                    ( if length pairs == 6+                        then case (hand & sort & group & filter (\gp -> 1 == length gp)) of+                            [[tile]] -> [tile]+                            _ -> []+                        else []+                    )+                -- Check thirteen orphans+                orphansWaits =+                    if length hand == 13+                        then do+                            let orphans = (mkHand "1p 9p 1s 9s 1m 9m N E S W r g w")+                            let difference = hand \\ orphans+                            case difference of+                                [] -> orphans+                                [tile] | tile `elem` orphans -> orphans \\ hand+                                _ -> []+                        else []+                -- Check waits from standard interpretations+                -- If we have four melds already, a single remaning tile can wait for a pair+                possibleMelds = formMelds hand+                fourMelds = possibleMelds & filter (\melds -> length melds == 4)+                fourMeldsWaits = fourMelds & map (concatMelds) & map (hand \\) & filter (\diff -> length diff == 1) & concat+                -- Finally, we might be waiting with three melds and a pair+                threeMeldWaits = concat $ do+                    (pair, hand') <- findPairs hand+                    melds <- formMelds hand'+                    if length melds /= 3+                        then return []+                        else+                            let diff = hand' \\ (concatMelds melds)+                             in if length diff /= 2+                                    then return []+                                    else let [a, b] = diff in return (meldWait a b)+             in (sevenPairsWait ++ orphansWaits ++ fourMeldsWaits ++ threeMeldWaits) & sort & group & map head++meldWait :: Tile -> Tile -> [Tile]+meldWait a b+    | a == b = [a]+meldWait t1@(Numeric s1 v1 _) t2@(Numeric s2 v2 _)+    | v1 > v2 = meldWait t2 t1+    | s1 /= s2 = []+    -- \| v1 == v2 = [Numeric s1 v1 0]+    | v1 + 1 == v2 =+        if v1 == 1+            then [Numeric s1 (v2 + 1) 0]+            else+                if v2 == 9+                    then [Numeric s1 (v1 - 1) 0]+                    else [Numeric s1 (v1 - 1) 0, Numeric s1 (v2 + 1) 0]+    | v1 + 2 == v2 = [Numeric s1 (v1 + 1) 0]+meldWait _ _ = []

@@ -0,0 +1,275 @@+{- |+Module      : Riichi.Yaku+Description : Methods for detecting the various yaku conditions+License     : BSD-3-Clause+Maintainer  : surplussinewaves@gmail.com+-}+module Riichi.Yaku where++import Data.Either (lefts, rights)+import Data.Function+import Data.List+import Data.Set qualified as Set+import Riichi.Meld+import Riichi.Tile++-- Note that Yaku functions that operate on Hands needn't check that the+-- hand is actually valid to begin with. This should be done by the caller,+-- by seeing if interpretHand returns an nonempty list of interpretations.+-- Some of these could probably be rephrased to be point free but I think+-- that would just make them more confusing.++tanyao :: Hand -> Bool+tanyao hand = hand & (map isSimple) & and++allPairs :: Hand -> Bool+allPairs hand = (hand & findPairs & length) * 2 == length hand++-- Yakuman+thirteenOrphans :: Hand -> Bool+thirteenOrphans hand =+    ( Set.fromList hand+        == Set.fromList+            [ (Honour $ Dragon $ Red) 0+            , (Honour $ Dragon $ White) 0+            , (Honour $ Dragon $ Green) 0+            , (Honour $ Wind $ North) 0+            , (Honour $ Wind $ South) 0+            , (Honour $ Wind $ East) 0+            , (Honour $ Wind $ West) 0+            , (Numeric Pin 1) 0+            , (Numeric Pin 9) 0+            , (Numeric Man 1) 0+            , (Numeric Man 9) 0+            , (Numeric Sou 1) 0+            , (Numeric Sou 9) 0+            ]+    )+        && (length hand == 14)++-- Counts the number of yakuhai pairs. One han each.+yakuhai :: InterpretedHand -> Int+yakuhai (_, melds) =+    melds+        & ( filter+                ( \meld ->+                    meld+                        `elem` [ Pon ((Honour $ Dragon $ Red) 0) False+                               , Pon ((Honour $ Dragon $ Green) 0) False+                               , Pon ((Honour $ Dragon $ White) 0) False+                               ]+                )+          )+        & length++checkPon :: Tile -> InterpretedHand -> Bool+checkPon tile (_, melds) = Pon tile False `elem` melds++haku :: InterpretedHand -> Bool+haku = checkPon ((Honour $ Dragon $ White) 0)++hatsu :: InterpretedHand -> Bool+hatsu = checkPon ((Honour $ Dragon $ Green) 0)++chun :: InterpretedHand -> Bool+chun = checkPon ((Honour $ Dragon $ Red) 0)++checkNorth :: InterpretedHand -> Bool+checkNorth = checkPon ((Honour $ Wind $ North) 0)++checkEast :: InterpretedHand -> Bool+checkEast = checkPon ((Honour $ Wind $ East) 0)++checkSouth :: InterpretedHand -> Bool+checkSouth = checkPon ((Honour $ Wind $ South) 0)++checkWest :: InterpretedHand -> Bool+checkWest = checkPon ((Honour $ Wind $ West) 0)++checkWind :: Wind -> InterpretedHand -> Bool+checkWind East = checkEast+checkWind North = checkNorth+checkWind West = checkWest+checkWind South = checkSouth++-- Same sequence in all three suits+sanshokuDoujun :: InterpretedHand -> Bool+sanshokuDoujun (_, melds) =+    let+        chis = melds & (filter meldIsChi)+        suits = chis & (map getMeldSuit)+        bases = chis & (map getMeldBase)+        suits_bases = zip suits bases+     in+        or+            [ ((Left Man, Left base) `elem` suits_bases)+                && ((Left Pin, Left base) `elem` suits_bases)+                && ((Left Sou, Left base) `elem` suits_bases)+            | base <- [1 .. 7]+            ]++-- Same triplet (or Kan!) in all three suits+sanshokuDoukou :: InterpretedHand -> Bool+sanshokuDoukou (_, melds) =+    let+        pons = melds & (filter (\meld -> meldIsPon meld || meldIsKan meld))+        suits = pons & (map getMeldSuit)+        bases = pons & (map getMeldBase)+        suits_bases = zip suits bases+     in+        or+            [ ((Left Man, Left base) `elem` suits_bases)+                && ((Left Pin, Left base) `elem` suits_bases)+                && ((Left Sou, Left base) `elem` suits_bases)+            | base <- [1 .. 9]+            ]++-- Full flush+-- chinitsu :: InterpretedHand -> Bool+-- chinitsu (pair, melds) = allEqual ((getPairSuit pair) : (melds & (map getMeldSuit)))+chinitsu :: Hand -> Bool+chinitsu hand = hand & map getTileSuit & allEqual++-- Half flush+-- Only check equality on the lefts of Either Suit Honour, i.e the suited melds.+-- honitsu :: InterpretedHand -> Bool+-- honitsu (pair, melds) =+--     ((getPairSuit pair) : (melds & (map getMeldSuit)))+--         & lefts+--         & allEqual+honitsu :: Hand -> Bool+honitsu hand = hand & map getTileSuit & lefts & allEqual++toitoi :: InterpretedHand -> Bool+toitoi (_, melds) = melds & (map (\meld -> meldIsPon meld || meldIsKan meld)) & and++ittsuu :: InterpretedHand -> Bool+ittsuu (_, melds) =+    let+        chis = melds & (filter meldIsChi)+        suits = chis & (map getMeldSuit)+        bases = chis & (map getMeldBase)+        suits_bases = zip suits bases+     in+        or+            [ ((Left suit, Left 1) `elem` suits_bases)+                && ((Left suit, Left 4) `elem` suits_bases)+                && ((Left suit, Left 7) `elem` suits_bases)+            | suit <- [Man, Pin, Sou]+            ]++-- Three quads (open or closed)+sankantsu :: InterpretedHand -> Bool+sankantsu (_, melds) = melds & (filter meldIsKan) & length & (3 ==)++-- Four quads (open or closed). Yakuman+suukantsu :: InterpretedHand -> Bool+suukantsu (_, melds) = melds & (filter meldIsKan) & length & (4 ==)++-- Little three dragons. Worth noting that we permit ourselves to assume that hands+-- don't contain more than 4 of a given tile! So no need to worry about multiple melds+-- of the same dragon.+shousangen :: InterpretedHand -> Bool+shousangen (Pair tile, melds) =+    (isDragon tile)+        && ( melds+                & (map getMeldSuit)+                & rights+                & (filter honourIsDragon)+                & length+                & (2 ==)+           )++-- Big three dragons. Yakuman+daisangen :: InterpretedHand -> Bool+daisangen (_, melds) =+    ( melds+        & (map getMeldSuit)+        & rights+        & (filter honourIsDragon)+        & length+        & (3 ==)+    )++-- Little winds. Yakuman+shousuushii :: InterpretedHand -> Bool+shousuushii (Pair tile, melds) =+    (isWind tile)+        && ( melds+                & (map getMeldSuit)+                & rights+                & (filter honourIsWind)+                & length+                & (3 ==)+           )++-- Big winds. Double Yakuman+daisuushii :: InterpretedHand -> Bool+daisuushii (_, melds) =+    ( melds+        & (map getMeldSuit)+        & rights+        & (filter honourIsWind)+        & length+        & (4 ==)+    )++-- Pure double sequence. Closed only!+iipeikou :: InterpretedHand -> Bool+iipeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (== 1)++-- Twice pure double sequence. Note we require the two pairs of sequences to be distinct.+ryanpeikou :: InterpretedHand -> Bool+ryanpeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (>= 2)++-- Half outside hand+chanta :: InterpretedHand -> Bool+chanta (Pair tile, melds) = (melds & map getMeldBase & lefts & filter (\x -> x /= 1 && x /= 7)) == [] && (not $ isSimple tile)++-- Fully outside hand (chanta + no honours)+junchan :: InterpretedHand -> Bool+junchan ih@(Pair tile, melds) = (isNumeric tile) && (melds & map getMeldBase & rights) == [] && (chanta ih)++-- All terminals and honours+honroutou :: Hand -> Bool+honroutou hand = hand & map (\tile -> isHonour tile || isTerminal tile) & and++-- All honours. Yakuman+tsuuiisou :: Hand -> Bool+tsuuiisou hand = hand & map isHonour & and++-- All terminals. Yakuman+chinroutou :: Hand -> Bool+chinroutou hand = hand & map isTerminal & and++-- All green. Yakuman+ryuuiisou :: Hand -> Bool+ryuuiisou hand = hand & map isGreen & and+  where+    isGreen (Numeric Sou v _) = (v `elem` [2, 3, 4, 6, 8])+    isGreen (Honour (Dragon Green) _) = True+    isGreen _ = False++-- Nine Gates. Yakuman+-- Length == 9 precludes the possibility of a all honours chinitsu.+chuurenPoutou :: Hand -> Bool+chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3)+  where+    list = (hand & sort & group & map length)++-- Three concealed triplets+sanankou :: InterpretedHand -> Bool+sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 3++-- Four concealed triplets+suuankou :: InterpretedHand -> Bool+suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 4++pinfu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool+pinfu (Pair tile, melds) seatWind roundWind ryanmanWait closedHand =+    (melds & filter (not . meldIsChi)) == []+        && closedHand+        && (not $ isDragon tile)+        && (tile /= (Honour (Wind seatWind) 0))+        && (tile /= (Honour (Wind roundWind) 0))+        && ryanmanWait

@@ -1,418 +0,0 @@-module Scoring where--import ColourStrings-import Control.Monad (when)-import Control.Monad.Writer-import Data.Function ((&))-import Data.Map qualified as M-import Data.Monoid (Sum)-import Meld-import Tile-import Yaku--type YakumanCount = Sum Int-type Han = Sum Int--getYaku :: Hand -> Maybe InterpretedHand -> Bool -> Bool -> Bool -> Bool -> Wind -> Wind -> Bool -> (Either (Han, Han) YakumanCount, String)-getYaku hand (Just ih@(Pair _, melds)) riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand =-    -- The caller should ensure ih is not empty, as some of these yaku funcitons only look-    -- at the hand, and don't re-check if it has a valid interpretation.-    let-        -- Check Yakuman first.-        yakumanWriter :: Writer (YakumanCount, String) () = do-            when (suuankou ih) $ tell (1, toMagenta "\tYakuman: Four Concealed Triplets\n")-            when (suukantsu ih) $ tell (1, toMagenta "\tYakuman: Four Kans\n")-            when (daisangen ih) $ tell (1, toMagenta "\tYakuman: Big Four Dragons\n")-            when (shousuushii ih) $ tell (1, toMagenta "\tYakuman: Little Winds\n")-            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours\n")-            when (chinroutou hand) $ tell (1, toMagenta "\tYakuman: All Terminals\n")-            when (ryuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Green\n")-            when (chuurenPoutou hand) $ tell (1, toMagenta "\tYakuman: Nine Gates\n")-            when (daisuushii ih) $ tell (2, toMagenta "\tDouble Yakuman: Big Winds\n")-        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter--        hanWriter :: Writer (Han, Han, String) () = do-            when (riichi) $ tell (1, 0, toCyan "\t1 Han: Riichi\n")-            when (ippatsu) $ tell (1, 0, toCyan "\t1 Han: Ippatsu\n")-            when (tsumo && and (map isClosed melds)) $ tell (1, 0, toCyan "\t1 Han: Fully concealed hand\n")-            when (pinfu ih seatWind roundWind ryanmanWait closedHand) $ tell (1, 0, toCyan "\t1 Han: Pinfu\n")-            when (tanyao hand) $ tell (1, 1, toCyan "\t1 Han: All simples\n")-            when (haku ih) $ tell (1, 1, toCyan "\t1 Han: Haku (White Dragon)\n")-            when (hatsu ih) $ tell (1, 1, toCyan "\t1 Han: Hatsu (Green Dragon)\n")-            when (chun ih) $ tell (1, 1, toCyan "\t1 Han: Chun (Red Dragon)\n")-            when (checkWind seatWind ih) $ tell (1, 1, toCyan "\t1 Han: Seat wind\n")-            when (checkWind roundWind ih) $ tell (1, 1, toCyan "\t1 Han: Round wind\n")-            when (sanshokuDoujun ih) $ tell (2, 1, toCyan "\t2 Han: Mixed triple sequence (-1 Han if open)\n")-            when (sanshokuDoukou ih) $ tell (2, 1, toCyan "\t2 Han: Triple triplets (-1 Han if open)\n")-            when (sanankou ih) $ tell (2, 2, toCyan "\t2 Han: Three concealed triplets\n")-            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)-            if fullFlush-                then-                    tell (6, 5, toCyan "\t6 Han: Full flush (-1 Han if open)\n")-                else-                    if halfFlush-                        then-                            tell (3, 2, toCyan "\t3 Han: Half flush (-1 Han if open)\n")-                        else-                            return ()-            when (toitoi ih) $ tell (2, 2, toCyan "\t2 Han: All triplets\n")-            when (ittsuu ih) $ tell (2, 1, toCyan "\t2 Han: Pure straight (-1 Han if open)\n")-            when (sankantsu ih) $ tell (2, 2, toCyan "\t2 Han: Three kans\n")-            when (shousangen ih) $ tell (2, 2, toCyan "\t2 Han: Little three dragons\n")-            let (twicePure, singlePure) = (ryanpeikou ih, iipeikou ih)-            if twicePure-                then-                    tell (3, 0, toCyan "\t3 Han: Twice pure double sequence (Closed only)\n")-                else-                    if singlePure-                        then-                            tell (1, 0, toCyan "\t1 Han: Pure double sequence (Closed only)\n")-                        else-                            return ()-            let (fullyOutside, halfOutside, terminalsHonours) = (junchan ih, chanta ih, honroutou hand)-            if fullyOutside-                then-                    tell (3, 2, toCyan "\t3 Han: Fully outside hand (-1 Han if open)\n")-                else-                    if terminalsHonours-                        then-                            tell (2, 2, toCyan "\t2 Han: All terminals and honours\n")-                        else-                            if halfOutside-                                then-                                    tell (2, 1, toCyan "\t2 Han: Half outside hand (-1 Han if open)\n")-                                else-                                    return ()-            when (dora > 0) $ tell (fromInteger dora, fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))-          where-            dora = hand & map getDora & sum--        (_, (hanClosed, hanOpen, output)) = runWriter hanWriter-     in-        if yakumans > 0-            then (Right yakumans, yakumanOutput)-            else-                if output == ""-                    then-                        (Left (0, 0), "\tNo explicit yaku found, riichi or menzen tsumo is required\n")-                    else-                        (Left (hanClosed, hanOpen), output)-getYaku hand Nothing riichi ippatsu tsumo _ _ _ _ =-    let-        -- Check Yakuman first.-        yakumanWriter :: Writer (YakumanCount, String) () = do-            when (thirteenOrphans hand) $ tell (1, toMagenta "\tYakuman: Thirteen Orphans (Double Yakuman if wait is 13 sided)\n")-            when (tsuuiisou hand) $ tell (1, toMagenta "\tYakuman: All Honours (+ seven pairs)\n")-        (_, (yakumans, yakumanOutput)) = runWriter yakumanWriter--        sevenPairs = allPairs hand-        hanWriter :: Writer (Han, String) () = do-            when (riichi) $ tell (1, toCyan "\t1 Han: Riichi\n")-            when (ippatsu) $ tell (1, toCyan "\t1 Han: Ippatsu\n")-            when (tsumo) $ tell (1, toCyan "\t1 Han: Fully concealed hand\n")-            when (tanyao hand) $ tell (1, toCyan "\t1 Han: All simples\n")-            let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)-            if fullFlush-                then-                    tell (6, toCyan "\t6 Han: Full flush\n")-                else-                    if halfFlush-                        then-                            tell (3, toCyan "\t3 Han: Half flush\n")-                        else-                            return ()-            when (honroutou hand) $ tell (2, toCyan "\t2 Han: All terminals and honours\n")-            when (dora > 0) $ tell (fromInteger dora, toCyan ("\t" ++ show dora ++ " Han: Dora\n"))-          where-            dora = hand & map getDora & sum--        (_, (han, output)) = runWriter hanWriter-     in-        if yakumans > 0-            then (Right yakumans, yakumanOutput)-            else-                if sevenPairs-                    then-                        (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output)-                    else-                        (Left (0, 0), "This hand is not valid\n")--getMeldFu :: Meld -> Fu-getMeldFu (Chi _ _ _ _) = 0-getMeldFu (Pon (Numeric _ v _) True) = if v `elem` [1, 9] then 4 else 2-getMeldFu (Pon (Honour _ _) True) = 4-getMeldFu (Pon (Numeric _ v _) False) = if v `elem` [1, 9] then 8 else 4-getMeldFu (Pon (Honour _ _) False) = 8-getMeldFu (Kan (Numeric _ v _) True) = if v `elem` [1, 9] then 16 else 8-getMeldFu (Kan (Honour _ _) True) = 16-getMeldFu (Kan (Numeric _ v _) False) = if v `elem` [1, 9] then 32 else 16-getMeldFu (Kan (Honour _ _) False) = 32---- Get fu for a standard hand. Seven pairs and thirteen orphans, as ever, are handled separately-type Fu = Int-getFu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool -> Fu-getFu (Pair tile, melds) seatWind roundWind goodWait tsumo closedHand =-    -- Perhaps a writer monad over the sum int monoid would be more elegant here but I think this more-    -- descriptive method is fine too.-    let meldsFu = melds & map getMeldFu & sum-        waitFu = if goodWait then 2 else 0-        yakuhaiFu =-            (if (tile & isDragon) then 2 else 0)-                + (if (tile == (Honour (Wind roundWind) 0)) then 2 else 0)-                + (if (tile == (Honour (Wind seatWind) 0)) then 2 else 0)-        ronClosedFu = if (not tsumo) && closedHand then 10 else 0-        tsumoFu = if tsumo then 2 else 0-     in roundUp (20 + meldsFu + waitFu + yakuhaiFu + ronClosedFu + tsumoFu)-  where-    roundUp n = last ([120, 110 .. 10] & filter (>= n))--getScore :: Han -> Fu -> Bool -> Bool -> Integer-getScore han fu dealer tsumo =-    if dealer-        then case han of-            _-                | han >= 13 -> 32000-                | han >= 5 -> case M.lookup han manganToSanbaimanTableDealer of-                    Just score -> score-                    Nothing -> 0-                | otherwise ->-                    if tsumo-                        then case M.lookup (han, fu) scoreTableTsumoDealer of-                            Just score -> score-                            Nothing -> 0-                        else case M.lookup (han, fu) scoreTableRonDealer of-                            Just score -> score-                            Nothing -> 0-        else case han of-            _-                | han >= 13 -> 24000-                | han >= 5 -> case M.lookup han manganToSanbaimanTableNonDealer of-                    Just score -> score-                    Nothing -> 0-                | otherwise ->-                    if tsumo-                        then case M.lookup (han, fu) scoreTableTsumoNonDealer of-                            Just score -> score-                            Nothing -> 0-                        else case M.lookup (han, fu) scoreTableRonNonDealer of-                            Just score -> score-                            Nothing -> 0--scoreTableTsumoDealer :: M.Map (Han, Fu) Integer-scoreTableTsumoDealer =-    M.fromList-        [ ((1, 20), 1200)-        , ((1, 30), 1500)-        , ((1, 40), 2100)-        , ((1, 50), 2400)-        , ((1, 60), 3000)-        , ((1, 70), 3600)-        , ((1, 80), 3900)-        , ((1, 90), 4500)-        , ((1, 100), 4800)-        , ((1, 110), 5400)-        , ((2, 20), 2100)-        , ((2, 30), 3000)-        , ((2, 40), 3900)-        , ((2, 50), 4800)-        , ((2, 60), 6000)-        , ((2, 70), 6900)-        , ((2, 80), 7800)-        , ((2, 90), 8700)-        , ((2, 100), 9600)-        , ((2, 110), 10800)-        , ((3, 20), 3900)-        , ((3, 25), 4800)-        , ((3, 30), 6000)-        , ((3, 40), 7800)-        , ((3, 50), 9600)-        , ((3, 60), 11700)-        , ((3, 70), 12000)-        , ((3, 80), 12000)-        , ((3, 90), 12000)-        , ((3, 100), 12000)-        , ((3, 110), 12000)-        , ((4, 20), 7800)-        , ((4, 25), 9600)-        , ((4, 30), 11700)-        , ((4, 40), 12000)-        , ((4, 50), 12000)-        , ((4, 60), 12000)-        , ((4, 70), 12000)-        , ((4, 80), 12000)-        , ((4, 90), 12000)-        , ((4, 100), 12000)-        , ((4, 110), 12000)-        ]--scoreTableRonDealer :: M.Map (Han, Fu) Integer-scoreTableRonDealer =-    M.fromList-        [ ((1, 30), 1500)-        , ((1, 40), 2000)-        , ((1, 50), 2400)-        , ((1, 60), 2900)-        , ((1, 70), 3400)-        , ((1, 80), 3900)-        , ((1, 90), 4400)-        , ((1, 100), 4800)-        , ((1, 110), 5300)-        , ((2, 25), 2400)-        , ((2, 30), 2900)-        , ((2, 40), 3900)-        , ((2, 50), 4800)-        , ((2, 60), 5800)-        , ((2, 70), 6800)-        , ((2, 80), 7700)-        , ((2, 90), 8700)-        , ((2, 100), 9600)-        , ((2, 110), 10600)-        , ((3, 25), 4800)-        , ((3, 30), 5800)-        , ((3, 40), 7700)-        , ((3, 50), 9600)-        , ((3, 60), 11600)-        , ((3, 70), 12000)-        , ((3, 80), 12000)-        , ((3, 90), 12000)-        , ((3, 100), 12000)-        , ((3, 110), 12000)-        , ((4, 25), 9600)-        , ((4, 30), 11600)-        , ((4, 40), 12000)-        , ((4, 50), 12000)-        , ((4, 60), 12000)-        , ((4, 70), 12000)-        , ((4, 80), 12000)-        , ((4, 90), 12000)-        , ((4, 100), 12000)-        , ((4, 110), 12000)-        ]--scoreTableTsumoNonDealer :: M.Map (Han, Fu) Integer-scoreTableTsumoNonDealer =-    M.fromList-        [ ((1, 20), 800)-        , ((1, 30), 1100)-        , ((1, 40), 1500)-        , ((1, 50), 1600)-        , ((1, 60), 2000)-        , ((1, 70), 2400)-        , ((1, 80), 2700)-        , ((1, 90), 3100)-        , ((1, 100), 3200)-        , ((1, 110), 3600)-        , ((2, 20), 1500)-        , ((2, 30), 2000)-        , ((2, 40), 2700)-        , ((2, 50), 3200)-        , ((2, 60), 4000)-        , ((2, 70), 4700)-        , ((2, 80), 5200)-        , ((2, 90), 5900)-        , ((2, 100), 6400)-        , ((2, 110), 7200)-        , ((3, 20), 2700)-        , ((3, 25), 3200)-        , ((3, 30), 4000)-        , ((3, 40), 5200)-        , ((3, 50), 6400)-        , ((3, 60), 7900)-        , ((3, 70), 8000)-        , ((3, 80), 8000)-        , ((3, 90), 8000)-        , ((3, 100), 8000)-        , ((3, 110), 8000)-        , ((4, 20), 5200)-        , ((4, 25), 6400)-        , ((4, 30), 7900)-        , ((4, 40), 8000)-        , ((4, 50), 8000)-        , ((4, 60), 8000)-        , ((4, 70), 8000)-        , ((4, 80), 8000)-        , ((4, 90), 8000)-        , ((4, 100), 8000)-        , ((4, 110), 8000)-        ]--scoreTableRonNonDealer :: M.Map (Han, Fu) Integer-scoreTableRonNonDealer =-    M.fromList-        [ ((1, 30), 1000)-        , ((1, 40), 1300)-        , ((1, 50), 1600)-        , ((1, 60), 2000)-        , ((1, 70), 2300)-        , ((1, 80), 2600)-        , ((1, 90), 2900)-        , ((1, 100), 3200)-        , ((1, 110), 3600)-        , ((2, 25), 1600)-        , ((2, 30), 2000)-        , ((2, 40), 2600)-        , ((2, 50), 3200)-        , ((2, 60), 3900)-        , ((2, 70), 4500)-        , ((2, 80), 5200)-        , ((2, 90), 5800)-        , ((2, 100), 6400)-        , ((2, 110), 7100)-        , ((3, 25), 3200)-        , ((3, 30), 3900)-        , ((3, 40), 5200)-        , ((3, 50), 6400)-        , ((3, 60), 7700)-        , ((3, 70), 8000)-        , ((3, 80), 8000)-        , ((3, 90), 8000)-        , ((3, 100), 8000)-        , ((3, 110), 8000)-        , ((4, 25), 6400)-        , ((4, 30), 7700)-        , ((4, 40), 8000)-        , ((4, 50), 8000)-        , ((4, 60), 8000)-        , ((4, 70), 8000)-        , ((4, 80), 8000)-        , ((4, 90), 8000)-        , ((4, 100), 8000)-        , ((4, 110), 8000)-        ]--manganToSanbaimanTableDealer :: M.Map Han Integer-manganToSanbaimanTableDealer =-    M.fromList-        [ (5, 12000)-        , (6, 18000)-        , (7, 18000)-        , (8, 24000)-        , (9, 24000)-        , (10, 24000)-        , (11, 36000)-        , (12, 36000)-        ]--manganToSanbaimanTableNonDealer :: M.Map Han Integer-manganToSanbaimanTableNonDealer =-    M.fromList-        [ (5, 8000)-        , (6, 12000)-        , (7, 12000)-        , (8, 16000)-        , (9, 16000)-        , (10, 16000)-        , (11, 24000)-        , (12, 24000)-        ]--hanToHandName :: Han -> String-hanToHandName 5 = "Mangan"-hanToHandName 6 = "Haneman"-hanToHandName 7 = "Haneman"-hanToHandName 8 = "Baiman"-hanToHandName 9 = "Baiman"-hanToHandName 10 = "Baiman"-hanToHandName 11 = "Sanbaiman"-hanToHandName 12 = "Sanbaiman"-hanToHandName n = if n >= 13 then "Counted Yakuman" else ""

@@ -1,124 +0,0 @@-module Tile where--import Data.Function-import Data.List (intersperse)--data Tile = Honour Honour Dora | Numeric Suit Value Dora deriving (Ord)-type Dora = Integer-type Value = Integer--data Honour = Dragon (Dragon) | Wind (Wind) deriving (Show, Eq, Ord)-data Dragon = White | Green | Red deriving (Show, Eq, Ord)-data Wind = North | East | South | West deriving (Show, Eq, Ord)--data Suit = Man | Pin | Sou deriving (Show, Eq, Ord)---- instance Show Value where---     show (Value int) = show int------ instance Ord Value where---     compare (Value a) (Value b) = compare a b--instance Read Tile where-    readsPrec :: Int -> ReadS Tile-    readsPrec _ (x : []) = [(tile, [])]-      where-        tile = case x of-            'N' -> (Honour $ Wind $ North) 0-            'E' -> (Honour $ Wind $ East) 0-            'S' -> (Honour $ Wind $ South) 0-            'W' -> (Honour $ Wind $ West) 0-            'r' -> (Honour $ Dragon $ Red) 0-            'g' -> (Honour $ Dragon $ Green) 0-            'w' -> (Honour $ Dragon $ White) 0-    readsPrec _ (x : y : _) = do-        let ((value, dora), suit) =-                ( case x of-                    '0' -> (5, 1)-                    '1' -> (1, 0)-                    '2' -> (2, 0)-                    '3' -> (3, 0)-                    '4' -> (4, 0)-                    '5' -> (5, 0)-                    '6' -> (6, 0)-                    '7' -> (7, 0)-                    '8' -> (8, 0)-                    '9' -> (9, 0)-                , case y of-                    'p' -> Pin-                    'm' -> Man-                    's' -> Sou-                )-         in [(Numeric suit value dora, [])]--readTileBlock :: String -> [Tile]-readTileBlock string =-    let-        final = last string-        (stripped, separator) = case final of-            'p' -> (init string, "p ")-            'm' -> (init string, "m ")-            's' -> (init string, "s ")-            _ -> (string, " ")-     in-        stripped & map (\c -> [c]) & intersperse separator & concat & (++ separator) & words & map read--instance Show Tile where-    show (Honour (Dragon Red) _) = "r"-    show (Honour (Dragon Green) _) = "g"-    show (Honour (Dragon White) _) = "w"-    show (Honour (Wind North) _) = "N"-    show (Honour (Wind East) _) = "E"-    show (Honour (Wind South) _) = "S"-    show (Honour (Wind West) _) = "W"-    show (Numeric Pin 5 d) = if d == 0 then "5p" else "5p*"-    show (Numeric Man 5 d) = if d == 0 then "5m" else "5m*"-    show (Numeric Sou 5 d) = if d == 0 then "5s" else "5s*"-    show (Numeric Pin n _) = (show n) ++ "p"-    show (Numeric Man n _) = (show n) ++ "m"-    show (Numeric Sou n _) = (show n) ++ "s"---- We don't care about dora when equating tiles-instance Eq Tile where-    (==) (Honour honour _) (Honour honour' _) = (honour == honour')-    (==) (Numeric suit value _) (Numeric suit' value' _) = (suit == suit') && (value == value')-    (==) _ _ = False--getTileSuit :: Tile -> Either Suit Honour-getTileSuit (Numeric Pin _ _) = Left Pin-getTileSuit (Numeric Man _ _) = Left Man-getTileSuit (Numeric Sou _ _) = Left Sou-getTileSuit (Honour honour _) = Right honour--isSimple :: Tile -> Bool-isSimple (Honour _ _) = False-isSimple (Numeric _ 1 _) = False-isSimple (Numeric _ 9 _) = False-isSimple _ = True--isTerminal :: Tile -> Bool-isTerminal (Numeric _ 1 _) = True-isTerminal (Numeric _ 9 _) = True-isTerminal _ = False--isHonour :: Tile -> Bool-isHonour (Honour _ _) = True-isHonour _ = False--isNumeric :: Tile -> Bool-isNumeric = not . isHonour--isDragon :: Tile -> Bool-isDragon (Honour (Dragon _) _) = True-isDragon _ = False--isWind :: Tile -> Bool-isWind (Honour (Wind _) _) = True-isWind _ = False--honourIsDragon :: Honour -> Bool-honourIsDragon (Dragon _) = True-honourIsDragon _ = False--honourIsWind :: Honour -> Bool-honourIsWind = not . honourIsDragon

@@ -1,66 +0,0 @@-module Waits where--import Data.Function-import Data.List-import Meld-import Tile--getWaits :: Hand -> [Tile]-getWaits hand =-    if length hand < 13-        then []-        else-            -- Check seven pairs-            let pairs = findPairs hand-                sevenPairsWait =-                    ( if length pairs == 6-                        then case (hand & sort & group & filter (\gp -> 1 == length gp)) of-                            [[tile]] -> [tile]-                            _ -> []-                        else []-                    )-                -- Check thirteen orphans-                orphansWaits =-                    if length hand == 13-                        then do-                            let orphans = (mkHand "1p 9p 1s 9s 1m 9m N E S W r g w")-                            let difference = hand \\ orphans-                            case difference of-                                [] -> orphans-                                [tile] | tile `elem` orphans -> orphans \\ hand-                                _ -> []-                        else []-                -- Check waits from standard interpretations-                -- If we have four melds already, a single remaning tile can wait for a pair-                possibleMelds = formMelds hand-                fourMelds = possibleMelds & filter (\melds -> length melds == 4)-                fourMeldsWaits = fourMelds & map (concatMelds) & map (hand \\) & filter (\diff -> length diff == 1) & concat-                -- Finally, we might be waiting with three melds and a pair-                threeMeldWaits = concat $ do-                    (pair, hand') <- findPairs hand-                    melds <- formMelds hand'-                    if length melds /= 3-                        then return []-                        else-                            let diff = hand' \\ (concatMelds melds)-                             in if length diff /= 2-                                    then return []-                                    else let [a, b] = diff in return (meldWait a b)-             in (sevenPairsWait ++ orphansWaits ++ fourMeldsWaits ++ threeMeldWaits) & sort & group & map head--meldWait :: Tile -> Tile -> [Tile]-meldWait a b-    | a == b = [a]-meldWait t1@(Numeric s1 v1 _) t2@(Numeric s2 v2 _)-    | v1 > v2 = meldWait t2 t1-    | s1 /= s2 = []-    -- \| v1 == v2 = [Numeric s1 v1 0]-    | v1 + 1 == v2 =-        if v1 == 1-            then [Numeric s1 (v2 + 1) 0]-            else-                if v2 == 9-                    then [Numeric s1 (v1 - 1) 0]-                    else [Numeric s1 (v1 - 1) 0, Numeric s1 (v2 + 1) 0]-    | v1 + 2 == v2 = [Numeric s1 (v1 + 1) 0]-meldWait _ _ = []

@@ -1,269 +0,0 @@-module Yaku where--import Data.Either (lefts, rights)-import Data.Function-import Data.List-import Data.Set qualified as Set-import Meld-import Tile---- Note that Yaku functions that operate on Hands needn't check that the--- hand is actually valid to begin with. This should be done by the caller,--- by seeing if interpretHand returns an nonempty list of interpretations.--- Some of these could probably be rephrased to be point free but I think--- that would just make them more confusing.--tanyao :: Hand -> Bool-tanyao hand = hand & (map isSimple) & and--allPairs :: Hand -> Bool-allPairs hand = (hand & findPairs & length) * 2 == length hand---- Yakuman-thirteenOrphans :: Hand -> Bool-thirteenOrphans hand =-    ( Set.fromList hand-        == Set.fromList-            [ (Honour $ Dragon $ Red) 0-            , (Honour $ Dragon $ White) 0-            , (Honour $ Dragon $ Green) 0-            , (Honour $ Wind $ North) 0-            , (Honour $ Wind $ South) 0-            , (Honour $ Wind $ East) 0-            , (Honour $ Wind $ West) 0-            , (Numeric Pin 1) 0-            , (Numeric Pin 9) 0-            , (Numeric Man 1) 0-            , (Numeric Man 9) 0-            , (Numeric Sou 1) 0-            , (Numeric Sou 9) 0-            ]-    )-        && (length hand == 14)---- Counts the number of yakuhai pairs. One han each.-yakuhai :: InterpretedHand -> Int-yakuhai (_, melds) =-    melds-        & ( filter-                ( \meld ->-                    meld-                        `elem` [ Pon ((Honour $ Dragon $ Red) 0) False-                               , Pon ((Honour $ Dragon $ Green) 0) False-                               , Pon ((Honour $ Dragon $ White) 0) False-                               ]-                )-          )-        & length--checkPon :: Tile -> InterpretedHand -> Bool-checkPon tile (_, melds) = Pon tile False `elem` melds--haku :: InterpretedHand -> Bool-haku = checkPon ((Honour $ Dragon $ White) 0)--hatsu :: InterpretedHand -> Bool-hatsu = checkPon ((Honour $ Dragon $ Green) 0)--chun :: InterpretedHand -> Bool-chun = checkPon ((Honour $ Dragon $ Red) 0)--checkNorth :: InterpretedHand -> Bool-checkNorth = checkPon ((Honour $ Wind $ North) 0)--checkEast :: InterpretedHand -> Bool-checkEast = checkPon ((Honour $ Wind $ East) 0)--checkSouth :: InterpretedHand -> Bool-checkSouth = checkPon ((Honour $ Wind $ South) 0)--checkWest :: InterpretedHand -> Bool-checkWest = checkPon ((Honour $ Wind $ West) 0)--checkWind :: Wind -> InterpretedHand -> Bool-checkWind East = checkEast-checkWind North = checkNorth-checkWind West = checkWest-checkWind South = checkSouth---- Same sequence in all three suits-sanshokuDoujun :: InterpretedHand -> Bool-sanshokuDoujun (_, melds) =-    let-        chis = melds & (filter meldIsChi)-        suits = chis & (map getMeldSuit)-        bases = chis & (map getMeldBase)-        suits_bases = zip suits bases-     in-        or-            [ ((Left Man, Left base) `elem` suits_bases)-                && ((Left Pin, Left base) `elem` suits_bases)-                && ((Left Sou, Left base) `elem` suits_bases)-            | base <- [1 .. 7]-            ]---- Same triplet (or Kan!) in all three suits-sanshokuDoukou :: InterpretedHand -> Bool-sanshokuDoukou (_, melds) =-    let-        pons = melds & (filter (\meld -> meldIsPon meld || meldIsKan meld))-        suits = pons & (map getMeldSuit)-        bases = pons & (map getMeldBase)-        suits_bases = zip suits bases-     in-        or-            [ ((Left Man, Left base) `elem` suits_bases)-                && ((Left Pin, Left base) `elem` suits_bases)-                && ((Left Sou, Left base) `elem` suits_bases)-            | base <- [1 .. 9]-            ]---- Full flush--- chinitsu :: InterpretedHand -> Bool--- chinitsu (pair, melds) = allEqual ((getPairSuit pair) : (melds & (map getMeldSuit)))-chinitsu :: Hand -> Bool-chinitsu hand = hand & map getTileSuit & allEqual---- Half flush--- Only check equality on the lefts of Either Suit Honour, i.e the suited melds.--- honitsu :: InterpretedHand -> Bool--- honitsu (pair, melds) =---     ((getPairSuit pair) : (melds & (map getMeldSuit)))---         & lefts---         & allEqual-honitsu :: Hand -> Bool-honitsu hand = hand & map getTileSuit & lefts & allEqual--toitoi :: InterpretedHand -> Bool-toitoi (_, melds) = melds & (map (\meld -> meldIsPon meld || meldIsKan meld)) & and--ittsuu :: InterpretedHand -> Bool-ittsuu (_, melds) =-    let-        chis = melds & (filter meldIsChi)-        suits = chis & (map getMeldSuit)-        bases = chis & (map getMeldBase)-        suits_bases = zip suits bases-     in-        or-            [ ((Left suit, Left 1) `elem` suits_bases)-                && ((Left suit, Left 4) `elem` suits_bases)-                && ((Left suit, Left 7) `elem` suits_bases)-            | suit <- [Man, Pin, Sou]-            ]---- Three quads (open or closed)-sankantsu :: InterpretedHand -> Bool-sankantsu (_, melds) = melds & (filter meldIsKan) & length & (3 ==)---- Four quads (open or closed). Yakuman-suukantsu :: InterpretedHand -> Bool-suukantsu (_, melds) = melds & (filter meldIsKan) & length & (4 ==)---- Little three dragons. Worth noting that we permit ourselves to assume that hands--- don't contain more than 4 of a given tile! So no need to worry about multiple melds--- of the same dragon.-shousangen :: InterpretedHand -> Bool-shousangen (Pair tile, melds) =-    (isDragon tile)-        && ( melds-                & (map getMeldSuit)-                & rights-                & (filter honourIsDragon)-                & length-                & (2 ==)-           )---- Big three dragons. Yakuman-daisangen :: InterpretedHand -> Bool-daisangen (_, melds) =-    ( melds-        & (map getMeldSuit)-        & rights-        & (filter honourIsDragon)-        & length-        & (3 ==)-    )---- Little winds. Yakuman-shousuushii :: InterpretedHand -> Bool-shousuushii (Pair tile, melds) =-    (isWind tile)-        && ( melds-                & (map getMeldSuit)-                & rights-                & (filter honourIsWind)-                & length-                & (3 ==)-           )---- Big winds. Double Yakuman-daisuushii :: InterpretedHand -> Bool-daisuushii (_, melds) =-    ( melds-        & (map getMeldSuit)-        & rights-        & (filter honourIsWind)-        & length-        & (4 ==)-    )---- Pure double sequence. Closed only!-iipeikou :: InterpretedHand -> Bool-iipeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (== 1)---- Twice pure double sequence. Note we require the two pairs of sequences to be distinct.-ryanpeikou :: InterpretedHand -> Bool-ryanpeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (>= 2)---- Half outside hand-chanta :: InterpretedHand -> Bool-chanta (Pair tile, melds) = (melds & map getMeldBase & lefts & filter (\x -> x /= 1 && x /= 7)) == [] && (not $ isSimple tile)---- Fully outside hand (chanta + no honours)-junchan :: InterpretedHand -> Bool-junchan ih@(Pair tile, melds) = (isNumeric tile) && (melds & map getMeldBase & rights) == [] && (chanta ih)---- All terminals and honours-honroutou :: Hand -> Bool-honroutou hand = hand & map (\tile -> isHonour tile || isTerminal tile) & and---- All honours. Yakuman-tsuuiisou :: Hand -> Bool-tsuuiisou hand = hand & map isHonour & and---- All terminals. Yakuman-chinroutou :: Hand -> Bool-chinroutou hand = hand & map isTerminal & and---- All green. Yakuman-ryuuiisou :: Hand -> Bool-ryuuiisou hand = hand & map isGreen & and-  where-    isGreen (Numeric Sou v _) = (v `elem` [2, 3, 4, 6, 8])-    isGreen (Honour (Dragon Green) _) = True-    isGreen _ = False---- Nine Gates. Yakuman--- Length == 9 precludes the possibility of a all honours chinitsu.-chuurenPoutou :: Hand -> Bool-chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3)-  where-    list = (hand & sort & group & map length)---- Three concealed triplets-sanankou :: InterpretedHand -> Bool-sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 3---- Four concealed triplets-suuankou :: InterpretedHand -> Bool-suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 4--pinfu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool-pinfu (Pair tile, melds) seatWind roundWind ryanmanWait closedHand =-    (melds & filter (not . meldIsChi)) == []-        && closedHand-        && (not $ isDragon tile)-        && (tile /= (Honour (Wind seatWind) 0))-        && (tile /= (Honour (Wind roundWind) 0))-        && ryanmanWait

@@ -0,0 +1,28 @@+import Test.Tasty+import Test.Tasty.HUnit++import Riichi.Tile++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+    testGroup+        "All tests"+        [ tileTests+        ]++tileTests :: TestTree+tileTests =+    testGroup+        "Tile test group"+        [ testCase "Tile equality ignores dora" $+            (Numeric Pin 7 0 == Numeric Pin 7 1)+                && (Honour (Wind North) 1 == Honour (Wind North) 0) @?= True+        , testCase "Single tile read test" $+            ((read "0m" :: Tile) == (read "5m" :: Tile))+                && (read "r" == Honour (Dragon Red) 1) @?= True+        , testCase "Multi tile read test" $+            (readTileBlock "123p" @?= [Numeric Pin 1 0, Numeric Pin 2 0, Numeric Pin 3 0])+        ]