diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/riichi-scoring.cabal b/riichi-scoring.cabal --- a/riichi-scoring.cabal +++ b/riichi-scoring.cabal @@ -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 diff --git a/src/Riichi/Context.hs b/src/Riichi/Context.hs new file mode 100644 --- /dev/null +++ b/src/Riichi/Context.hs @@ -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) diff --git a/src/Riichi/Display.hs b/src/Riichi/Display.hs --- a/src/Riichi/Display.hs +++ b/src/Riichi/Display.hs @@ -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." diff --git a/src/Riichi/Meld.hs b/src/Riichi/Meld.hs --- a/src/Riichi/Meld.hs +++ b/src/Riichi/Meld.hs @@ -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) diff --git a/src/Riichi/Scoring.hs b/src/Riichi/Scoring.hs --- a/src/Riichi/Scoring.hs +++ b/src/Riichi/Scoring.hs @@ -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 = diff --git a/src/Riichi/Yaku.hs b/src/Riichi/Yaku.hs --- a/src/Riichi/Yaku.hs +++ b/src/Riichi/Yaku.hs @@ -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)) == []