riichi-scoring 0.2.0.2 → 0.3.0.0

raw patch · 7 files changed

+890/−242 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• riichi-scoring.cabal +2/−1
• src/Riichi/Context.hs +363/−0
• src/Riichi/Display.hs +260/−177
• src/Riichi/Meld.hs +23/−2
• src/Riichi/Scoring.hs +150/−6
• src/Riichi/Yaku.hs +80/−56

@@ -18,3 +18,15 @@  ## 0.2.0.2 Internal library now unnamed. Hoping this fixes Hackage build fail.++## 0.2.0.3+Added docs for yaku functions.+Reworked seven pairs detection to ensure hand has 14 tiles.+9 gates now checks that the hand is closed.++## 0.3.0.0+Fixed error in scoring triple triplets, was previously scored as 1 han open.+Implemented new backend for scoring and yaku detection via "context" based+approach, defined in new Context submodule. This helps simplify function+signatures for operations that need many pieces of information besides just the+superficial composition of a hand.

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.2.0.2+version: 0.3.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.@@ -54,6 +54,7 @@  library   exposed-modules:+    Riichi.Context     Riichi.Display     Riichi.Meld     Riichi.Scoring

@@ -0,0 +1,363 @@+module Riichi.Context where++import Data.Function ((&))+import Riichi.Meld+import Riichi.Tile+import Riichi.Yaku++askYesNo :: String -> IO Bool+askYesNo string = do+    putStrLn string+    input <- getLine+    if input == "y" then return True else return False++{- | Record to track the additional context for a hand. Fields with a Maybe type are information that+we may not need in order to fully understand the hand.+-}+data HandContext = HandContext+    { isClosed :: Bool+    , isTsumo :: Bool+    , riichi :: RiichiContext+    , wait :: WaitContext+    , wind :: WindContext+    , isSevenPairs :: Bool+    , isThirteenOrphans :: Bool+    , dora :: Integer+    }++getMinimalHandContext :: Hand -> Bool -> HandContext+getMinimalHandContext hand sevenPairs =+    let+        orphans = thirteenOrphans hand+     in+        HandContext+            { isClosed = True+            , isTsumo = False+            , riichi = RiichiContext{isRiichi = False, isIppatsu = False}+            , wait = WaitContext{isRyanmanWait = False, isShanponWait = False}+            , wind = WindContext{seatWind = East, roundWind = East}+            , isSevenPairs = sevenPairs+            , isThirteenOrphans = orphans+            , dora = hand & map getDora & sum+            }++openHandContext :: HandContext -> HandContext+openHandContext handContext = handContext{isClosed = False}++closeHandContext :: HandContext -> HandContext+closeHandContext handContext = handContext{isClosed = True}++addRiichiContext :: HandContext -> IO HandContext+addRiichiContext handContext = do+    riichiContext <- askRiichiContext+    return handContext{riichi = riichiContext}++addWaitContext :: HandContext -> IO HandContext+addWaitContext handContext = do+    waitContext <- askWaitContext+    return handContext{wait = waitContext}++addWindContext :: HandContext -> IO HandContext+addWindContext handContext = do+    windContext <- askWindContext+    return handContext{wind = windContext}++addTsumoContext :: HandContext -> IO HandContext+addTsumoContext handContext = do+    tsumo <- askYesNo "Tsumo? [y/n]:"+    return handContext{isTsumo = tsumo}++-- The context must already know riichi and tsumo values for this to work+addClosedContext :: Maybe InterpretedHand -> HandContext -> IO (Maybe InterpretedHand, HandContext)+addClosedContext (Just (tile, melds)) handContext = do+    let HandContext{isTsumo = t, riichi = RiichiContext{isRiichi = r}} = handContext+    melds' <- case (r, t) of+        (True, True) -> return melds+        (True, False) -> getRonMeld melds+        (False, _) -> getOpenMelds melds+    let numOpen = melds' & filter isOpen & length+    closedHand <- case numOpen of+        0 -> return True+        _+            | numOpen > 1 -> return False+            | otherwise -> case (r, t) 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) -> askYesNo "Damaten? [y/n]:"+    return (Just (tile, melds'), handContext{isClosed = closedHand})+addClosedContext Nothing handContext = return (Nothing, handContext{isClosed = True})++data WaitContext = WaitContext+    { isRyanmanWait :: Bool+    , isShanponWait :: Bool+    }++askWaitContext :: IO (WaitContext)+askWaitContext = do+    ryanmanWait <- askYesNo "Did the hand have an open wait? [y/n]: "+    shanponWait <-+        if ryanmanWait+            then return False+            else askYesNo "Did the hand have a dual pair wait? [y/n]: "+    return WaitContext{isRyanmanWait = ryanmanWait, isShanponWait = shanponWait}++data WindContext = WindContext+    {seatWind :: Wind, roundWind :: Wind}++askWindContext :: IO (WindContext)+askWindContext = do+    putStrLn "Input round and seat wind: "+    (Honour (Wind r) _) : (Honour (Wind s) _) : _ <- mkHand <$> getLine+    return WindContext{seatWind = s, roundWind = r}++data RiichiContext = RiichiContext+    {isRiichi :: Bool, isIppatsu :: Bool}++askRiichiContext :: IO (RiichiContext)+askRiichiContext = do+    riichi <- askYesNo "Riichi? [y/n]: "+    ippatsu <-+        if riichi+            then askYesNo "Ippatsu? [y/n]: "+            else return False+    return RiichiContext{isRiichi = riichi, isIppatsu = ippatsu}++data YakuContext = YakuContext+    -- , isTsumo :: Bool+    { isPinfu :: Bool+    , isTanyao :: Bool+    , isHaku :: Bool+    , isHatsu :: Bool+    , isChun :: Bool+    , isSeatWind :: Bool+    , isRoundWind :: Bool+    , isSanshokuDoujun :: Bool+    , isSanshokuDoukou :: Bool+    , isSanankou :: Bool+    , isToitoi :: Bool+    , isIttsuu :: Bool+    , isSankantsu :: Bool+    , isShousangen :: Bool+    , isChinitsu :: Bool+    , isHonitsu :: Bool+    , isRyanpeikou :: Bool+    , isIipeikou :: Bool+    , isJunchan :: Bool+    , isChanta :: Bool+    , isHonroutou :: Bool+    , isMenzenTsumo :: Bool+    , yakuHandContext :: HandContext+    , -- , isThirteenOrphans :: Bool+      isChiitoitsu :: Bool+    }++mkYakuContext :: Hand -> Maybe InterpretedHand -> HandContext -> YakuContext+mkYakuContext hand (Just ih) handContext =+    let+        HandContext+            { wind = WindContext{seatWind = sw, roundWind = rw}+            , wait = WaitContext{isRyanmanWait = isRyanman}+            , isClosed = closure+            , isTsumo = tsumo+            } = handContext+        (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)+        (twicePure, singlePure) = (ryanpeikou ih, iipeikou ih)+        (fullyOutside, halfOutside, terminalsHonours) = (junchan ih, chanta ih, honroutou hand)+     in+        YakuContext+            { isPinfu = pinfu ih sw rw isRyanman closure+            , isTanyao = tanyao hand+            , isHaku = haku ih+            , isHatsu = hatsu ih+            , isChun = chun ih+            , isSeatWind = checkWind sw ih+            , isRoundWind = checkWind rw ih+            , isSanshokuDoujun = sanshokuDoujun ih+            , isSanshokuDoukou = sanshokuDoukou ih+            , isSanankou = sanankou ih+            , isToitoi = toitoi ih+            , isIttsuu = ittsuu ih+            , isSankantsu = sankantsu ih+            , isShousangen = shousangen ih+            , isChinitsu = fullFlush+            , isHonitsu = halfFlush && (not fullFlush)+            , -- Should these check for closed, or do we want to include them anyway?+              isRyanpeikou = twicePure && closure+            , isIipeikou = singlePure && (not twicePure) && closure+            , isJunchan = fullyOutside+            , isChanta = halfOutside && (not fullyOutside) && (not terminalsHonours)+            , isHonroutou = terminalsHonours && (not fullyOutside)+            , yakuHandContext = handContext+            , isMenzenTsumo = tsumo && closure+            , isChiitoitsu = False+            }+-- Seven pairs case+mkYakuContext hand Nothing handContext@HandContext{isTsumo = tsumo} =+    let+        (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)+        terminalsHonours = honroutou hand+     in+        YakuContext+            { isPinfu = False+            , isTanyao = tanyao hand+            , isHaku = False+            , isHatsu = False+            , isChun = False+            , isSeatWind = False+            , isRoundWind = False+            , isSanshokuDoujun = False+            , isSanshokuDoukou = False+            , isSanankou = False+            , isToitoi = False+            , isIttsuu = False+            , isSankantsu = False+            , isShousangen = False+            , isChinitsu = fullFlush+            , isHonitsu = halfFlush && (not fullFlush)+            , -- Should these check for closed, or do we want to include them anyway?+              isRyanpeikou = False+            , isIipeikou = False+            , isJunchan = False+            , isChanta = False+            , isHonroutou = terminalsHonours+            , yakuHandContext = handContext+            , isMenzenTsumo = tsumo+            , isChiitoitsu = chiitoitsu hand+            }++data YakumanContext = YakumanContext+    { isSuuankou :: Bool+    , isSuukantsu :: Bool+    , isDaisangen :: Bool+    , isShousuushii :: Bool+    , isTsuuiisou :: Bool+    , isChinroutou :: Bool+    , isRyuuiisou :: Bool+    , isChuurenPoutou :: Bool+    , isDaisuushii :: Bool+    , isKokushiMusou :: Bool+    }++-- maybeClosure var allows us to shortcicuit the IO check. If we already know whether the hand is closed or not,+-- we don't ask. This way, the yaku command doesn't ask, and the score command does.+mkYakumanContext :: Hand -> Maybe InterpretedHand -> Maybe Bool -> IO (Maybe YakumanContext)+mkYakumanContext hand (Just ih) maybeClosure =+    do+        let isSuuaa = suuankou ih+        let isSuuka = suukantsu ih+        let isDaisa = daisangen ih+        let isShous = shousuushii ih+        let isTsuui = tsuuiisou hand+        let isChinr = chinroutou hand+        let isRyuui = ryuuiisou hand+        isChuur <-+            if chuurenPoutou hand+                then case maybeClosure of+                    Nothing -> askYesNo "Is the hand closed? [y/n]: "+                    Just True -> return True+                    Just False -> return False+                else return False+        let isDaisu = daisuushii ih+        if or [isSuuaa, isSuuka, isDaisa, isShous, isTsuui, isChinr, isRyuui, isChuur, isDaisu]+            then+                return $+                    Just+                        YakumanContext+                            { isSuuankou = isSuuaa+                            , isSuukantsu = isSuuka+                            , isDaisangen = isDaisa+                            , isShousuushii = isShous+                            , isTsuuiisou = isTsuui+                            , isChinroutou = isChinr+                            , isRyuuiisou = isRyuui+                            , isChuurenPoutou = isChuur+                            , isDaisuushii = isDaisu+                            , isKokushiMusou = False+                            }+            else+                return $ Nothing+mkYakumanContext hand Nothing _ =+    let+        isTsuui = tsuuiisou hand+        isChinr = chinroutou hand+        isRyuui = ryuuiisou hand+     in+        if (or [isTsuui, isChinr, isRyuui]) && chiitoitsu hand+            then+                return $+                    Just+                        YakumanContext+                            { isSuuankou = False+                            , isSuukantsu = False+                            , isDaisangen = False+                            , isShousuushii = False+                            , isTsuuiisou = isTsuui+                            , isChinroutou = isChinr+                            , isRyuuiisou = isRyuui+                            , isChuurenPoutou = False+                            , isDaisuushii = False+                            , isKokushiMusou = False+                            }+            else+                if thirteenOrphans hand+                    then+                        return $+                            Just+                                YakumanContext+                                    { isSuuankou = False+                                    , isSuukantsu = False+                                    , isDaisangen = False+                                    , isShousuushii = False+                                    , isTsuuiisou = False+                                    , isChinroutou = False+                                    , isRyuuiisou = False+                                    , isChuurenPoutou = False+                                    , isDaisuushii = False+                                    , isKokushiMusou = True+                                    }+                    else return Nothing+data Context = Context (Maybe InterpretedHand) HandContext (Either YakuContext YakumanContext)++mkContext :: Hand -> IO Context+mkContext hand = do+    sevenPairs <-+        if chiitoitsu hand+            then askYesNo "Seven pairs? [y/n]: "+            else return False+    let handContext@HandContext{isThirteenOrphans = orphans} = getMinimalHandContext hand sevenPairs+    maybeIh <-+        if sevenPairs || orphans+            then+                return Nothing+            else do+                let ihs = interpretHand hand+                if length ihs == 0+                    then undefined+                    else do+                        ih <-+                            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+                                    putStrLn ""+                                    return (ihs !! n)+                                else do+                                    putStrLn "Found one way to interpret this hand: "+                                    let ih = head ihs+                                    putStrLn (showInterpretedHand ih)+                                    putStrLn ""+                                    return ih+                        return $ Just ih+    maybeYakumanContext <- mkYakumanContext hand maybeIh Nothing+    case maybeYakumanContext of+        Nothing -> do+            handContext' <-+                if not sevenPairs+                    then pure handContext >>= addWindContext >>= addRiichiContext >>= addTsumoContext >>= addWaitContext+                    else pure handContext >>= addRiichiContext >>= addTsumoContext+            (maybeIh', handContext'') <- addClosedContext maybeIh handContext'+            let yakuContext = mkYakuContext hand maybeIh' handContext''+            return $ Context maybeIh' handContext'' (Left yakuContext)+        Just yakumanContext -> do+            return $ Context maybeIh handContext (Right yakumanContext)

@@ -7,9 +7,12 @@ module Riichi.Display where  import ColourStrings+import Control.Monad (forM)+import Control.Monad.Trans import Data.Function import Data.List (intersperse, sort) import Data.Monoid (getSum)+import Riichi.Context import Riichi.Meld import Riichi.Scoring import Riichi.Tile@@ -30,26 +33,51 @@             if num >= 1                 then do                     if num == 1-                        then putStrLn $ "Found " ++ show num ++ " way to interpret this hand:\n"+                        then putStrLn $ "Found 1 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"+                    _ <- forM ihs $ \ih -> do+                        let handString = showInterpretedHand ih+                        let handContext = getMinimalHandContext hand False+                        maybeYakumanContext <- mkYakumanContext hand (Just ih) (Just True)+                        let context = case maybeYakumanContext of+                                Nothing ->+                                    let yakuContext = mkYakuContext hand (Just ih) handContext+                                     in (Context (Just ih) handContext (Left yakuContext))+                                Just yakumanContext -> (Context (Just ih) handContext (Right yakumanContext))+                        let string = formContextString context+                        let hanOrYakumans = getContextHansOrYakumans context+                        case hanOrYakumans of+                            Left (hanClosed, hanOpen) ->+                                putStrLn $+                                    handString+                                        ++ "\n"+                                        ++ string+                                        ++ "\t\t"+                                        ++ toGreen (show (getSum hanClosed))+                                        ++ " Han total if closed, "+                                        ++ toGreen (show (getSum hanOpen))+                                        ++ " if open\n"+                            Right yakumans -> putStrLn $ handString ++ "\n" ++ string ++ "\t\t" ++ toGreen (show yakumans) ++ " Yakuman total\n"+                    return ()                 else return ()-            if allPairs hand || thirteenOrphans hand+            if (chiitoitsu 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"+                    let handString = hand & sort & map show & intersperse ", " & concat+                    let handContext = getMinimalHandContext hand True+                    maybeYakumanContext <- mkYakumanContext hand Nothing (Just True)+                    let context = case maybeYakumanContext of+                            Nothing ->+                                let yakuContext = mkYakuContext hand Nothing handContext+                                 in (Context Nothing handContext (Left yakuContext))+                            Just yakumanContext -> (Context Nothing handContext (Right yakumanContext))+                    let string = formContextString context+                    let hanOrYakumans = getContextHanOrYakumans context+                    putStrLn $ case hanOrYakumans of+                        Left han -> handString ++ "\n" ++ string ++ "\t\t" ++ toGreen (show (getSum han)) ++ " Han total, closed by definition\n"+                        Right yakumans -> handString ++ "\n" ++ string ++ "\t\t" ++ toGreen (show yakumans) ++ " Yakuman total\n"                 else                     if num == 0                         then putStrLn $ toRed "This hand is not valid"@@ -64,170 +92,225 @@ -- | Implements the "score" command for the CLI. In need of a refactor, logic is rather serpentine at the moment. 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)+    if length hand < 14+        then putStrLn "Hand is the wrong size"+        else do+            putStrLn "Input dora (or leave blank):"+            dora <- mkHand <$> getLine+            if dora /= []+                then+                    putStrLn ""+                else return () -            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 ""-                           )+            let hand' = addDora dora hand+            context@(Context _ handContext _) <- mkContext hand'+            let string = formContextString context+            let tsumo = isTsumo handContext+            let closure = isClosed handContext+            let hanOrYakumans = getContextHanOrYakumans context+            case hanOrYakumans of+                Left han -> do+                    let fu = getContextFu context+                    let name = hanToHandName han+                    putStrLn $+                        "\tYaku:\n"+                            ++ 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: "+                    openClosed = if closure 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 ()+                    putStrLn $+                        string+                            ++ "\t\t"+                            ++ toGreen (show (yakumans))+                            ++ " Yakuman total\n"+                            ++ "\n\t"+                            ++ toGreen (show (yakumans * 48000))+                            ++ " points for Dealer, "+                            ++ toGreen (show (yakumans * 32000))+                            ++ " points for Non-Dealer."++-- putStrLn "Input round and seat wind: "+-- (Honour (Wind roundWind) _) : (Honour (Wind seatWind) _) : _ <- mkHand <$> getLine+-- putStrLn "Riichi? [y/n]: "+-- riichi <- (== "y") <$> getLine+-- ippatsu <-+--     if riichi+--         then do+--             putStrLn "Ippatsu? [y/n]: "+--             (== "y") <$> getLine+--         else return False+-- putStrLn "Tsumo? [y/n]: "+-- input <- getLine+-- let tsumo = (input == "y")+--+-- sevenPairs <-+--     if chiitoitsu hand'+--         then do+--             putStrLn "Seven pairs? [y/n]: "+--             input <- getLine+--             if input == "y"+--                 then+--                     return True+--                 else+--                     return False+--         else return False++-- if sevenPairs == True+--     then do+--         let (value, yaku_string) = getYaku hand' Nothing riichi ippatsu tsumo False seatWind roundWind True+--         putStrLn $ case value of+--             Left (han, _) ->+--                 yaku_string+--                     ++ "\t\t"+--                     ++ toGreen (show (getSum han))+--                     ++ " Han total, closed by definition\n"+--                     ++ "\n\t"+--                     ++ toGreen (show (getScore han 25 True tsumo))+--                     ++ " points for Dealer, "+--                     ++ toGreen (show (getScore han 25 False tsumo))+--                     ++ " points for Non-Dealer."+--                     ++ ( if name /= ""+--                             then+--                                 " ("+--                                     ++ toMagenta name+--                                     ++ ")."+--                             else ""+--                        )+--               where+--                 name = hanToHandName han+--             Right yakumans ->+--                 yaku_string+--                     ++ "\t\t"+--                     ++ toGreen (show (getSum yakumans))+--                     ++ " Yakuman total\n"+--                     ++ "\n\t"+--                     ++ toGreen (show (getSum yakumans * 48000))+--                     ++ " points for Dealer, "+--                     ++ toGreen (show (getSum yakumans * 32000))+--                     ++ " points for Non-Dealer."+--     else do+--         let ihs = interpretHand hand'+--         maybeIh <-+--             if thirteenOrphans hand'+--                 then return Nothing+--                 else do+--                     (pair, melds) <-+--                         if length ihs > 1+--                             then do+--                                 putStrLn "Select hand interpretation: "+--                                 sequence_ $ [("[" ++ show n ++ "]: " ++ (ih & showInterpretedHand)) & putStrLn | (n :: Integer, ih) <- zip [0 ..] ihs]+--                                 n <- read <$> getLine :: IO Int+--                                 return (ihs !! n)+--                             else do+--                                 putStrLn "Found one way to interpret this hand: "+--                                 let ih = head ihs+--                                 putStrLn (showInterpretedHand ih)+--                                 return ih+--+--                     melds' <- case (riichi, tsumo) of+--                         (True, True) -> return melds+--                         (True, False) -> getRonMeld melds+--                         -- putStrLn "Which meld was opened by Ron? (enter an index): "+--                         -- sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]+--                         -- input <- getLine+--                         -- let index :: Int = input & read+--                         -- return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld+--                         (False, _) -> getOpenMelds melds+--                     -- putStrLn "Which melds are open? (enter a string of indices, or leave blank if all closed): "+--                     -- sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]+--                     -- input <- getLine+--                     -- let indices :: [Int] = input & map return & (map read)+--                     -- return $ (zip [0 ..] melds) & map (\(i, meld) -> if i `elem` indices then openMeld meld else meld)+--                     return $ Just (pair, melds')+--+--         putStrLn "Did the hand have an open wait? [y/n]: "+--         ryanmanWait <- (== "y") <$> getLine+--         shanponWait <-+--             if ryanmanWait+--                 then return False+--                 else do+--                     putStrLn "Did the hand have a dual pair wait? [y/n]: "+--                     (== "y") <$> getLine+--         let goodWait = not (ryanmanWait || shanponWait)+--+--         closedHand <- case maybeIh of+--             Just (_, melds) ->+--                 case numOpen of+--                     0 -> return True+--                     _+--                         | numOpen > 1 -> return False+--                         | otherwise -> case (riichi, tsumo) of+--                             (True, _) -> return True+--                             (False, True) -> return False -- Already know there is an open meld. Now we know it wasn't opened by Ron.+--                             (False, False) ->+--                                 ( do+--                                     putStrLn "Damaten? [y/n]:"+--                                     (== "y") <$> getLine+--                                 )+--               where+--                 numOpen = melds & filter isOpen & length+--             Nothing -> return $ True+--         let (value, yaku_string) = getYaku hand' maybeIh riichi ippatsu tsumo ryanmanWait seatWind roundWind closedHand+--         let fu = case maybeIh of+--                 Just ih ->+--                     if pinfu ih seatWind roundWind ryanmanWait closedHand+--                         then if tsumo then 20 else 30+--                         else getFu ih seatWind roundWind goodWait tsumo closedHand+--                 -- Seven pairs already taken care of, so Nothing signifies thirteen orphans or an invalid hand.+--                 -- So yakuman or invalid - 0 Fu, we will say.+--                 Nothing -> 0+--         putStrLn $ case value of+--             Left (hanClosed, hanOpen) ->+--                 "\tYaku:\n"+--                     ++ yaku_string+--                     ++ "\t\t"+--                     ++ openClosed+--                     ++ toGreen (show (getSum han))+--                     ++ " Han total, with "+--                     ++ toBlue (show fu)+--                     ++ " Fu\n"+--                     ++ "\n\t"+--                     ++ toGreen (show (getScore han fu True tsumo))+--                     ++ " points for Dealer, "+--                     ++ toGreen (show (getScore han fu False tsumo))+--                     ++ " points for Non-Dealer"+--                     ++ ( if name /= ""+--                             then+--                                 " ("+--                                     ++ toMagenta name+--                                     ++ ")."+--                             else ""+--                        )+--               where+--                 han = if (closedHand) then hanClosed else hanOpen+--                 name = hanToHandName han+--                 openClosed = if closedHand then "Closed hand: " else "Open hand: "+--             Right yakumans ->+--                 yaku_string+--                     ++ "\t\t"+--                     ++ toGreen (show (getSum yakumans))+--                     ++ " Yakuman total\n"+--                     ++ "\n\t"+--                     ++ toGreen (show (getSum yakumans * 48000))+--                     ++ " points for Dealer, "+--                     ++ toGreen (show (getSum yakumans * 32000))+--                     ++ " points for Non-Dealer."

@@ -39,6 +39,7 @@ data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord) type Open = Bool +-- | Almost identical to what deriving Eq would generate, except we consider open and closed melds that are otherwise equal to be the same. instance Eq Meld where     (==) (Pon tile1 _) (Pon tile2 _) = tile1 == tile2     (==) (Kan tile1 _) (Kan tile2 _) = tile1 == tile2@@ -85,8 +86,8 @@ isOpen (Pon _ x) = x isOpen (Kan _ x) = x -isClosed :: Meld -> Bool-isClosed = not . isOpen+meldIsClosed :: Meld -> Bool+meldIsClosed = not . isOpen  openMeld :: Meld -> Meld openMeld (Chi a b c _) = Chi a b c True@@ -170,6 +171,7 @@ concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest +-- | Find the unique pairs in a hand. Returns a list of pairs, each along with the remaining tiles in the hand not in the pair. findPairs :: Hand -> [(Pair, Hand)] findPairs hand =     hand@@ -223,3 +225,22 @@  showInterpretedHand :: InterpretedHand -> String showInterpretedHand (pair, melds) = (show pair) : (map show melds) & intersperse ", " & concat++getRonMeld :: [Meld] -> IO [Meld]+getRonMeld melds = do+    putStrLn "Which meld was opened by Ron? (leave blank if it was the pair): "+    sequence_ $ [("[" ++ show i ++ "]: " ++ (meld & show)) & putStrLn | (i :: Integer, meld) <- zip [0 ..] melds]+    input <- getLine+    if input == ""+        then return melds+        else+            let index :: Int = input & read+             in return $ (zip [0 ..] melds) & map (\(i, meld) -> if i == index then openMeld meld else meld)++getOpenMelds :: [Meld] -> IO [Meld]+getOpenMelds melds = 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)

@@ -11,7 +11,8 @@ import Control.Monad.Writer import Data.Function ((&)) import Data.Map qualified as M-import Data.Monoid (Sum)+import Data.Monoid (Sum (..))+import Riichi.Context import Riichi.Meld import Riichi.Tile import Riichi.Yaku@@ -33,14 +34,14 @@             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 (chuurenPoutou hand && closedHand) $ 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 (tsumo && and (map meldIsClosed 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")@@ -49,7 +50,7 @@             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 (sanshokuDoukou ih) $ tell (2, 2, toCyan "\t2 Han: Triple triplets\n")             when (sanankou ih) $ tell (2, 2, toCyan "\t2 Han: Three concealed triplets\n")             let (fullFlush, halfFlush) = (chinitsu hand, honitsu hand)             if fullFlush@@ -111,7 +112,6 @@             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")@@ -137,7 +137,7 @@         if yakumans > 0             then (Right yakumans, yakumanOutput)             else-                if sevenPairs+                if chiitoitsu hand                     then                         (Left (han + 2, 0), toCyan "\t2 Han: Seven pairs\n" ++ output)                     else@@ -203,6 +203,150 @@                         else case M.lookup (han, fu) scoreTableRonNonDealer of                             Just score -> score                             Nothing -> 0++formYakuString :: YakuContext -> String+formYakuString yakuContext@YakuContext{yakuHandContext = handContext@HandContext{riichi = riichiContext, dora}} =+    let hanWriter :: Writer String () = do+            when (isRiichi riichiContext) $ tell $ toCyan "\t1 Han: Riichi\n"+            when (isIppatsu riichiContext) $ tell $ toCyan "\t1 Han: Ippatsu\n"+            when (isMenzenTsumo yakuContext) $ tell $ toCyan "\t1 Han: Fully concealed hand\n"+            when (isChiitoitsu yakuContext) $ tell $ toCyan "\t2 Han: Seven pairs\n"+            when (isPinfu yakuContext) $ tell $ toCyan "\t1 Han: Pinfu\n"+            when (isTanyao yakuContext) $ tell $ toCyan "\t1 Han: All simples\n"+            when (isHaku yakuContext) $ tell $ toCyan "\t1 Han: Haku (White Dragon)\n"+            when (isHatsu yakuContext) $ tell $ toCyan "\t1 Han: Hatsu (Green Dragon)\n"+            when (isChun yakuContext) $ tell $ toCyan "\t1 Han: Chun (Red Dragon)\n"+            when (isSeatWind yakuContext) $ tell $ toCyan "\t1 Han: Seat wind\n"+            when (isRoundWind yakuContext) $ tell $ toCyan "\t1 Han: Round wind\n"+            when (isSanshokuDoujun yakuContext) $ tell $ toCyan "\t2 Han: Mixed triple sequence (-1 Han if open)\n"+            when (isSanshokuDoukou yakuContext) $ tell $ toCyan "\t2 Han: Triple triplets\n"+            when (isSanankou yakuContext) $ tell $ toCyan "\t2 Han: Three concealed triplets\n"+            when (isChinitsu yakuContext) $ tell $ toCyan "\t6 Han: Full flush (-1 Han if open)\n"+            when (isHonitsu yakuContext) $ tell $ toCyan "\t3 Han: Half flush (-1 Han if open)\n"+            when (isToitoi yakuContext) $ tell $ toCyan "\t2 Han: All triplets\n"+            when (isIttsuu yakuContext) $ tell $ toCyan "\t2 Han: Pure straight (-1 Han if open)\n"+            when (isSankantsu yakuContext) $ tell $ toCyan "\t2 Han: Three kans\n"+            when (isShousangen yakuContext) $ tell $ toCyan "\t2 Han: Little three dragons\n"+            when (isRyanpeikou yakuContext) $ tell $ toCyan "\t3 Han: Twice pure double sequence (Closed only)\n"+            when (isIipeikou yakuContext) $ tell $ toCyan "\t1 Han: Pure double sequence (Closed only)\n"+            when (isJunchan yakuContext) $ tell $ toCyan "\t3 Han: Fully outside hand (-1 Han if open)\n"+            when (isHonroutou yakuContext) $ tell $ toCyan "\t2 Han: All terminals and honours\n"+            when (isChanta yakuContext) $ tell $ toCyan "\t2 Han: Half outside hand (-1 Han if open)\n"+            when (dora > 0) $ tell $ toCyan ("\t" ++ show dora ++ " Han: Dora\n")+        (_, string) = runWriter hanWriter+     in string++getYakuHan :: YakuContext -> Han+getYakuHan yakuContext@YakuContext{yakuHandContext = handContext@HandContext{riichi = riichiContext, dora}} =+    let+        closedBonus = if (isClosed handContext == True) then 1 else 0+        hanWriter :: Writer Han () = do+            when (isRiichi riichiContext) $ tell $ 1+            when (isIppatsu riichiContext) $ tell $ 1+            when (isMenzenTsumo yakuContext) $ tell $ 1+            when (isChiitoitsu yakuContext) $ tell $ 2+            when (isPinfu yakuContext) $ tell $ 1+            when (isTanyao yakuContext) $ tell $ 1+            when (isHaku yakuContext) $ tell $ 1+            when (isHatsu yakuContext) $ tell $ 1+            when (isChun yakuContext) $ tell $ 1+            when (isSeatWind yakuContext) $ tell $ 1+            when (isRoundWind yakuContext) $ tell $ 1+            when (isSanshokuDoujun yakuContext) $ tell $ 1 + closedBonus+            when (isSanshokuDoukou yakuContext) $ tell $ 2+            when (isSanankou yakuContext) $ tell $ 2+            when (isChinitsu yakuContext) $ tell $ 5 + closedBonus+            when (isHonitsu yakuContext) $ tell $ 2 + closedBonus+            when (isToitoi yakuContext) $ tell $ 2+            when (isIttsuu yakuContext) $ tell $ 1 + closedBonus+            when (isSankantsu yakuContext) $ tell $ 2+            when (isShousangen yakuContext) $ tell $ 2+            when (isRyanpeikou yakuContext) $ tell $ 3 * closedBonus+            when (isIipeikou yakuContext) $ tell $ closedBonus+            when (isJunchan yakuContext) $ tell $ 2 + closedBonus+            when (isHonroutou yakuContext) $ tell $ 2+            when (isChanta yakuContext) $ tell $ 1 + closedBonus+            tell $ fromInteger dora+        (_, han) = runWriter hanWriter+     in+        han++formYakumanString :: YakumanContext -> String+formYakumanString yakumanContext =+    let+        yakumanWriter :: Writer String () = do+            when (isSuuankou yakumanContext) $ tell $ toMagenta "\tYakuman: Four Concealed Triplets\n"+            when (isSuukantsu yakumanContext) $ tell $ toMagenta "\tYakuman: Four Kans\n"+            when (isDaisangen yakumanContext) $ tell $ toMagenta "\tYakuman: Big Four Dragons\n"+            when (isShousuushii yakumanContext) $ tell $ toMagenta "\tYakuman: Little Winds\n"+            when (isTsuuiisou yakumanContext) $ tell $ toMagenta "\tYakuman: All Honours\n"+            when (isChinroutou yakumanContext) $ tell $ toMagenta "\tYakuman: All Terminals\n"+            when (isRyuuiisou yakumanContext) $ tell $ toMagenta "\tYakuman: All Green\n"+            when (isChuurenPoutou yakumanContext) $ tell $ toMagenta "\tYakuman: Nine Gates\n"+            when (isDaisuushii yakumanContext) $ tell $ toMagenta "\tDouble Yakuman: Big Winds\n"+            when (isKokushiMusou yakumanContext) $ tell $ toMagenta "\tYakuman: Thirteen Orphans\n"+        (_, string) = runWriter yakumanWriter+     in+        string+getYakumanCount :: YakumanContext -> Int+getYakumanCount yakumanContext =+    let+        yakumanWriter :: Writer (Sum Int) () = do+            when (isSuuankou yakumanContext) $ tell 1+            when (isSuukantsu yakumanContext) $ tell 1+            when (isDaisangen yakumanContext) $ tell 1+            when (isShousuushii yakumanContext) $ tell 1+            when (isTsuuiisou yakumanContext) $ tell 1+            when (isChinroutou yakumanContext) $ tell 1+            when (isRyuuiisou yakumanContext) $ tell 1+            when (isChuurenPoutou yakumanContext) $ tell 1+            when (isDaisuushii yakumanContext) $ tell 2+            when (isKokushiMusou yakumanContext) $ tell 1+        (_, yakumans) = runWriter yakumanWriter+     in+        getSum yakumans++formContextString :: Context -> String+formContextString (Context _ _ (Left yakuContext)) = formYakuString yakuContext+formContextString (Context _ _ (Right yakumanContext)) = formYakumanString yakumanContext++getContextHanOrYakumans :: Context -> Either Han Int+getContextHanOrYakumans (Context _ _ (Left yakuContext)) = Left $ getYakuHan yakuContext+getContextHanOrYakumans (Context _ _ (Right yakumanContext)) = Right $ getYakumanCount yakumanContext++getContextHansOrYakumans :: Context -> Either (Han, Han) Int+getContextHansOrYakumans (Context _ _ (Left yakuContext@YakuContext{yakuHandContext = handContext})) =+    Left $+        ( getYakuHan yakuContext{yakuHandContext = closeHandContext handContext}+        , getYakuHan yakuContext{yakuHandContext = openHandContext handContext}+        )+getContextHansOrYakumans (Context _ _ (Right yakumanContext)) = Right $ getYakumanCount yakumanContext++_getFu :: InterpretedHand -> HandContext -> Fu+_getFu (Pair tile, melds) c =+    let+        sw = seatWind $ wind c+        rw = roundWind $ wind c+        goodWait = not $ (isRyanmanWait $ wait c) || (isShanponWait $ wait c)+        tsumo = isTsumo c+        closure = isClosed c+        meldsFu = melds & map getMeldFu & sum+        waitFu = if goodWait then 2 else 0+        yakuhaiFu =+            (if (tile & isDragon) then 2 else 0)+                + (if (tile == (Honour (Wind rw) 0)) then 2 else 0)+                + (if (tile == (Honour (Wind sw) 0)) then 2 else 0)+        ronClosedFu = if (not tsumo) && closure 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))++-- Partial function!+getContextFu :: Context -> Fu+getContextFu (Context (Just ih) handContext _) = _getFu ih handContext+getContextFu (Context Nothing handContext _) = 25  scoreTableTsumoDealer :: M.Map (Han, Fu) Integer scoreTableTsumoDealer =

@@ -6,7 +6,7 @@ -} module Riichi.Yaku where -import Data.Either (lefts, rights)+import Data.Either (isLeft, lefts, rights) import Data.Function import Data.List import Data.Set qualified as Set@@ -19,37 +19,45 @@ -- Some of these could probably be rephrased to be point free but I think -- that would just make them more confusing. +-- | Check a hand for tanyao, aka all simples tanyao :: Hand -> Bool tanyao hand = hand & (map isSimple) & and +{- | Check if a hand is composed entirely of unique pairs.+Note this doesn't check the hand has the right size to be seven pairs.+-} allPairs :: Hand -> Bool allPairs hand = (hand & findPairs & length) * 2 == length hand --- Yakuman+-- | Check a hand for the yaku seven pairs+chiitoitsu :: Hand -> Bool+chiitoitsu hand = (allPairs hand) && (length hand == 14)++-- | Check if a hand is thirteen orphans, a 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)+    (length hand == 14)+        && ( 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+                    ]+           ) --- Counts the number of yakuhai pairs. One han each.-yakuhai :: InterpretedHand -> Int-yakuhai (_, melds) =+-- | Counts the number of yakuhai dragon triplets. One han each.+yakuhaiDragons :: InterpretedHand -> Int+yakuhaiDragons (_, melds) =     melds         & ( filter                 ( \meld ->@@ -62,37 +70,46 @@           )         & length +-- | Check for the presence of a triplet in an interpreted hand. checkPon :: Tile -> InterpretedHand -> Bool checkPon tile (_, melds) = Pon tile False `elem` melds +-- | Check for the presence of a white dragon triplet in an interpreted hand. haku :: InterpretedHand -> Bool haku = checkPon ((Honour $ Dragon $ White) 0) +-- | Check for the presence of a green dragon triplet in an interpreted hand. hatsu :: InterpretedHand -> Bool hatsu = checkPon ((Honour $ Dragon $ Green) 0) +-- | Check for the presence of a red dragon triplet in an interpreted hand. chun :: InterpretedHand -> Bool chun = checkPon ((Honour $ Dragon $ Red) 0) +-- | Check for the presence of a north wind triplet in an interpreted hand. checkNorth :: InterpretedHand -> Bool checkNorth = checkPon ((Honour $ Wind $ North) 0) +-- | Check for the presence of a east wind triplet in an interpreted hand. checkEast :: InterpretedHand -> Bool checkEast = checkPon ((Honour $ Wind $ East) 0) +-- | Check for the presence of a south wind triplet in an interpreted hand. checkSouth :: InterpretedHand -> Bool checkSouth = checkPon ((Honour $ Wind $ South) 0) +-- | Check for the presence of a west wind triplet in an interpreted hand. checkWest :: InterpretedHand -> Bool checkWest = checkPon ((Honour $ Wind $ West) 0) +-- | Check for the presence of a given wind triplet in an interpreted hand. checkWind :: Wind -> InterpretedHand -> Bool checkWind East = checkEast checkWind North = checkNorth checkWind West = checkWest checkWind South = checkSouth --- Same sequence in all three suits+-- | Check for the same sequence in all three suit sanshokuDoujun :: InterpretedHand -> Bool sanshokuDoujun (_, melds) =     let@@ -108,7 +125,7 @@             | base <- [1 .. 7]             ] --- Same triplet (or Kan!) in all three suits+-- | Check for the same triplet (or quad) in all three suits sanshokuDoukou :: InterpretedHand -> Bool sanshokuDoukou (_, melds) =     let@@ -124,25 +141,20 @@             | base <- [1 .. 9]             ] --- Full flush--- chinitsu :: InterpretedHand -> Bool--- chinitsu (pair, melds) = allEqual ((getPairSuit pair) : (melds & (map getMeldSuit)))+-- | Check if a hand is a full flush chinitsu :: Hand -> Bool-chinitsu hand = hand & map getTileSuit & allEqual+chinitsu hand = (hand & map getTileSuit & allEqual) && (hand & head & getTileSuit & isLeft) --- 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+-- | Check if a hand is a half flush honitsu :: Hand -> Bool+-- Only check equality on the lefts of Either Suit Honour, i.e the suited melds. honitsu hand = hand & map getTileSuit & lefts & allEqual +-- | Check if a hand is all triplets toitoi :: InterpretedHand -> Bool toitoi (_, melds) = melds & (map (\meld -> meldIsPon meld || meldIsKan meld)) & and +-- | Check if a hand has 1-9 in a single suit ittsuu :: InterpretedHand -> Bool ittsuu (_, melds) =     let@@ -158,17 +170,19 @@             | suit <- [Man, Pin, Sou]             ] --- Three quads (open or closed)+-- | Check a hand for three quads (open or closed) sankantsu :: InterpretedHand -> Bool sankantsu (_, melds) = melds & (filter meldIsKan) & length & (3 ==) --- Four quads (open or closed). Yakuman+-- | Check a hand for 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.++-- | Check a hand for little three dragons shousangen :: InterpretedHand -> Bool shousangen (Pair tile, melds) =     (isDragon tile)@@ -180,7 +194,7 @@                 & (2 ==)            ) --- Big three dragons. Yakuman+-- | Check a hand for big three dragons. Yakuman daisangen :: InterpretedHand -> Bool daisangen (_, melds) =     ( melds@@ -191,7 +205,7 @@         & (3 ==)     ) --- Little winds. Yakuman+-- | Check a hand for little winds. Yakuman shousuushii :: InterpretedHand -> Bool shousuushii (Pair tile, melds) =     (isWind tile)@@ -203,7 +217,7 @@                 & (3 ==)            ) --- Big winds. Double Yakuman+-- | Check a hand for big winds. Double Yakuman daisuushii :: InterpretedHand -> Bool daisuushii (_, melds) =     ( melds@@ -214,35 +228,41 @@         & (4 ==)     ) --- Pure double sequence. Closed only!+-- | Check for pure double sequence. Closed only, but this function doesn't check that. 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.+-- | Check for twice pure double sequence. Closed only, but this function doesn't check that. ryanpeikou :: InterpretedHand -> Bool ryanpeikou (_, melds) = melds & filter meldIsChi & sort & group & map length & filter (< 4) & filter (>= 2) & length & (>= 2) --- Half outside hand+-- | Check for 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)+-- | Check for fully outside hand (chanta + no honnours) junchan :: InterpretedHand -> Bool junchan ih@(Pair tile, melds) = (isNumeric tile) && (melds & map getMeldBase & rights) == [] && (chanta ih) --- All terminals and honours+-- | Check for all terminals and honours honroutou :: Hand -> Bool honroutou hand = hand & map (\tile -> isHonour tile || isTerminal tile) & and --- All honours. Yakuman+{- | Check for all honours. Yakuman.+Does not check that the hand is valid to begin with.+-} tsuuiisou :: Hand -> Bool tsuuiisou hand = hand & map isHonour & and --- All terminals. Yakuman+{- | Check for all terminals. Yakuman.+Does not check that the hand is valid to begin with.+-} chinroutou :: Hand -> Bool chinroutou hand = hand & map isTerminal & and --- All green. Yakuman+{- | Check for all green. Yakuman.+Does not check that the hand is valid to begin with.+-} ryuuiisou :: Hand -> Bool ryuuiisou hand = hand & map isGreen & and   where@@ -250,21 +270,25 @@     isGreen (Honour (Dragon Green) _) = True     isGreen _ = False --- Nine Gates. Yakuman--- Length == 9 precludes the possibility of a all honours chinitsu.+{- | Check for nine gates. Yakuman.+Does not check that the hand is valid to begin with, nor that it is closed.+(Indeed, checking closure of the hand would require more information, thus complicating the function signature).+Note that kans are dissalowed by rule. A valid hand + length == 14 (which this function checks) ensures this.+-} chuurenPoutou :: Hand -> Bool-chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3)+chuurenPoutou hand = (chinitsu hand) && (length list == 9) && (head list >= 3) && (last list >= 3) && (length hand == 14)   where     list = (hand & sort & group & map length) --- Three concealed triplets+-- | Check for three concealed triplets. Note that a closed hand may have a triplet that is not concealed, if won by ron. sanankou :: InterpretedHand -> Bool-sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 3+sanankou (_, melds) = (melds & filter (not . meldIsChi) & filter (meldIsClosed) & length) == 3 --- Four concealed triplets+-- | Check for four concealed triplets. Yakuman. suuankou :: InterpretedHand -> Bool-suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (isClosed) & length) == 4+suuankou (_, melds) = (melds & filter (not . meldIsChi) & filter (meldIsClosed) & length) == 4 +-- | Check for pinfu. Takes the hand, the seat wind, round wind, whether the wait was ryanman, and whether it is closed (in that order). pinfu :: InterpretedHand -> Wind -> Wind -> Bool -> Bool -> Bool pinfu (Pair tile, melds) seatWind roundWind ryanmanWait closedHand =     (melds & filter (not . meldIsChi)) == []