{- |
Module : Riichi.Meld
Description : Datatypes representing melds and associated functions.
License : BSD-3-Clause
Maintainer : surplussinewaves@gmail.com
A meld is our catch all term for chis, pons and kans.
-}
module Riichi.Meld where
import Data.Function
import Data.List
import Data.Set qualified as Set
import Riichi.Tile
-- | A type alias. A hand is a list of tiles
type Hand = [Tile]
{- | Build a hand from an input string.
| The string should be in the format as described in the help message
| eg: 123p parses to 1 Pin, 2 Pin, 3 Pin; rgNE parses to Red, Green, North, East
-}
mkHand :: String -> Hand
mkHand tiles = concatMap readTileBlock (tiles & words)
-- | Add dora (in the first argument) a the hand (in the second argument)
addDora :: Hand -> Hand -> Hand
addDora [] hand = hand
addDora dora@(doraTile : rest) hand = do
let hand' = addDora rest hand
tile <- hand'
if doraTile == tile
then return $ case tile of
(Honour x d) -> Honour x (d + 1)
(Numeric s v d) -> Numeric s v (d + 1)
else
return tile
-- | Get the dora of a given tile
getDora :: Tile -> Dora
getDora (Honour _ d) = d
getDora (Numeric _ _ d) = d
-- | The data for a pair is just a tile
newtype Pair = Pair Tile deriving (Show, Eq, Ord)
-- | A meld is a chi, pon, or kan
data Meld = Chi Tile Tile Tile Open | Pon Tile Open | Kan Tile Open deriving (Ord)
-- | Type alias for tracking open / closed melds
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
(==) (Chi tile1 tile2 tile3 _) (Chi tile1' tile2' tile3' _) = Set.fromList [tile1, tile2, tile3] == Set.fromList [tile1', tile2', tile3']
(==) _ _ = False
-- | Using the show instance for tile, show melds as "Open/Closed chi/pon/kan: tile tile tile (tile)"
instance Show Meld where
show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) True) = "Open chi: " ++ concatMap show (sort [v1, v2, v3]) ++ " " ++ show suit
show (Chi (Numeric suit v1 _) (Numeric _ v2 _) (Numeric _ v3 _) False) = "Closed chi: " ++ concatMap show (sort [v1, v2, v3]) ++ " " ++ show suit
show (Pon (Numeric suit v1 _) True) = "Open pon: " ++ (replicate 3 (v1 & show) & concat) ++ " " ++ show suit
show (Pon (Numeric suit v1 _) False) = "Closed pon: " ++ (replicate 3 (v1 & show) & concat) ++ " " ++ show suit
show (Kan (Numeric suit v1 _) True) = "Open kan: " ++ (replicate 4 (v1 & show) & concat) ++ " " ++ show suit
show (Kan (Numeric suit v1 _) False) = "Closed kan: " ++ (replicate 4 (v1 & show) & concat) ++ " " ++ show suit
show (Pon tile True) = "Open pon: " ++ (replicate 3 (tile & show) & concat)
show (Pon tile False) = "Closed pon: " ++ (replicate 3 (tile & show) & concat)
show (Kan tile True) = "Open kan: " ++ (replicate 4 (tile & show) & concat)
show (Kan tile False) = "Closed kan: " ++ (replicate 4 (tile & show) & concat)
-- | Check if all elements of a list of equatable elements are equal
allEqual :: (Eq a) => [a] -> Bool
allEqual [] = True
allEqual [_] = True
allEqual (x : y : ys) = (x == y) && allEqual (y : ys)
-- | Check if all elements of a list of equatable elements are different
allDifferent :: (Eq a) => [a] -> Bool
allDifferent [] = True
allDifferent [_] = True
allDifferent (x : xs) = notElem x xs && allDifferent xs
-- | Check if three tiles form a chi (a sequence)
isChi :: Tile -> Tile -> Tile -> Bool
isChi (Numeric s1 v1 _) (Numeric s2 v2 _) (Numeric s3 v3 _) =
allEqual [s1, s2, s3] && (Set.fromList (map (subtract m) [v1, v2, v3]) == Set.fromList [0, 1, 2])
where
m = minimum [v1, v2, v3]
isChi _ _ _ = False
-- | Check if three tiles form a pon (a triple)
isPon :: Tile -> Tile -> Tile -> Bool
isPon t1 t2 t3 = allEqual [t1, t2, t3]
-- | Check if four tiles form a kan (a quad)
isKan :: Tile -> Tile -> Tile -> Tile -> Bool
isKan t1 t2 t3 t4 = allEqual [t1, t2, t3, t4]
-- | Check if a meld is open
isOpen :: Meld -> Bool
isOpen (Chi _ _ _ x) = x
isOpen (Pon _ x) = x
isOpen (Kan _ x) = x
-- | Check if a meld is closed
meldIsClosed :: Meld -> Bool
meldIsClosed = not . isOpen
-- | Open a meld
openMeld :: Meld -> Meld
openMeld (Chi a b c _) = Chi a b c True
openMeld (Pon a _) = Pon a True
openMeld (Kan a _) = Kan a True
-- | Check if a meld is a chi
meldIsChi :: Meld -> Bool
meldIsChi (Chi{}) = True
meldIsChi _ = False
-- | Check if a meld is a pon
meldIsPon :: Meld -> Bool
meldIsPon (Pon _ _) = True
meldIsPon _ = False
-- | Check if a meld is a kan
meldIsKan :: Meld -> Bool
meldIsKan (Kan _ _) = True
meldIsKan _ = False
{- | Get the "base" of a Meld. For a chi this is the lowest value. Otherwise it is the common value or
| honour instance of the tiles.
-}
getMeldBase :: Meld -> Either Value Honour
getMeldBase (Chi (Numeric _ v1 _) (Numeric _ v2 _) (Numeric _ v3 _) _) = Left (minimum [v1, v2, v3])
getMeldBase (Pon (Numeric _ v1 _) _) = Left v1
getMeldBase (Kan (Numeric _ v1 _) _) = Left v1
getMeldBase (Pon (Honour honour _) _) = Right honour
getMeldBase (Kan (Honour honour _) _) = Right honour
-- | Get a meld's suit. This considers each dragon and wind to be its own suit.
getMeldSuit :: Meld -> Either Suit Honour
getMeldSuit (Chi (Numeric suit _ _) _ _ _) = Left suit
getMeldSuit (Pon (Numeric suit _ _) _) = Left suit
getMeldSuit (Kan (Numeric suit _ _) _) = Left suit
getMeldSuit (Pon (Honour honour _) _) = Right honour
getMeldSuit (Kan (Honour honour _) _) = Right honour
-- | Get a pair's suit. Treats each dargon and wind as its own suit.
getPairSuit :: Pair -> Either Suit Honour
getPairSuit (Pair (Numeric suit _ _)) = Left suit
getPairSuit (Pair (Honour honour _)) = Right honour
{- | Some functions can be evaluated on each suit separately. In particular, when forming melds, different
| suits don't interact so we can speed up recursive algorithms by first splitting the hand by suits.
-}
splitAcrossSuits :: (Hand -> [[a]]) -> (Hand -> [[a]])
splitAcrossSuits f hand = do
let hs = f (filter isHonour hand)
let ss = f (filter isSou hand)
let ps = f (filter isPin hand)
let ms = f (filter isMan hand)
h <- hs
s <- ss
p <- ps
m <- ms
return (m ++ p ++ s ++ h)
-- f (filter isHonour hand) ++ f (filter isSou hand) ++ f (filter isPin hand) ++ f (filter isMan hand)
-- | Given a hand, return all the possible ways of pulling out chis and pons, in increasing order of length
form3Melds :: Hand -> [[Meld]]
form3Melds [] = [[]]
form3Melds [_] = [[]]
form3Melds [_, _] = [[]]
form3Melds hand@(tile : tiles) =
let
-- Form all possible sets of melds with the first meld including the first tile:
triples = do
(tile2 : rest) <- tiles & tails & init
tile3 <- rest
return [tile, tile2, tile3]
possible_melds =
form3Melds (tail hand)
++ concat
( do
triple@(tile1 : tile2 : tile3 : _) <- triples
let nextMelds = form3Melds (hand \\ triple)
if isChi tile1 tile2 tile3
then
return $ map (Chi tile1 tile2 tile3 False :) nextMelds
else
if isPon tile1 tile2 tile3
then
return $ map (Pon tile1 False :) nextMelds
else
return []
)
in
concatMap
(((map head . group) . sort) . map sort)
( possible_melds
& sortBy (\x y -> compare (length x) (length y))
& groupBy (\x y -> length x == length y)
)
{- | Given a hand, return all the possible ways of interpreting it as a sequence of melds, including those that do not use all tiles
| (but still ensuring there are never more than 4 melds). We need to know the size of the original hand to limit how many kans are possible
| (eg can't have a kan in a 13 tile hand). Sometimes a pair has already been trimmed off a hand before being fed to this function, hence the
| need to pass the size value manually.
-}
formMelds :: Int -> Hand -> [[Meld]]
formMelds size hand = do
(kans, hand') <-
findKans hand
& filter (\(kans, _) -> let num = length kans in size - 14 <= num && num <= size - 13)
melds <- splitAcrossSuits form3Melds hand'
let kans_melds = kans ++ melds
if length kans_melds <= 4
then return kans_melds
else []
-- | Use this when the size of the size of the original hand is just the length of the hand being passed in.
formMelds' :: Hand -> [[Meld]]
formMelds' hand = formMelds (length hand) hand
-- | Given a hand, return all the possible ways of spliting the entire hand into chis, pons and kans
formComplete3Melds :: Hand -> [[Meld]]
formComplete3Melds [] = [[]]
formComplete3Melds [_] = [[]]
formComplete3Melds hand@(tile : tiles) =
let
-- Form all possible sets of melds with the first meld including the first tile:
triples = do
(tile2 : rest) <- tiles & tails & init
tile3 <- rest
return [tile, tile2, tile3]
possible_melds =
( concat $ do
triple@(tile1 : tile2 : tile3 : _) <- triples
let nextMelds = form3Melds (hand \\ triple)
if isChi tile1 tile2 tile3
then
return $ map (Chi tile1 tile2 tile3 False :) nextMelds
else
if isPon tile1 tile2 tile3
then
return $ map (Pon tile1 False :) nextMelds
else
return []
)
in
possible_melds
& filter (\x -> length x * 3 == length hand)
& map sort
& sort
& group
& map head
{- | Given a hand, return all the possible ways of interpreting it as a sequence of melds which includes all tiles.
| In other words, formCompleteMelds always returns a strict subset of what formMelds returns. We need to know the
| size of the original hand to limit how many kans are possible (eg can't have a kan in a 13 tile hand). Sometimes
| a pair has already been trimmed off a hand before being fed to this function, hence the need to pass the size value
| manually.
-}
formCompleteMelds :: Int -> Hand -> [[Meld]]
formCompleteMelds size hand = do
(kans, hand') <-
findKans hand
& filter (\(kans, _) -> let num = length kans in size - 14 <= num && num <= size - 13)
melds <- splitAcrossSuits formComplete3Melds hand'
let kans_melds = kans ++ melds
if length kans_melds == 4
then return kans_melds
else []
-- | Use this when the size of the size of the original hand is just the length of the hand being passed in.
formCompleteMelds' :: Hand -> [[Meld]]
formCompleteMelds' hand = formCompleteMelds (length hand) hand
-- | Count the tiles in a list of melds
meldsLength :: [Meld] -> Int
meldsLength [] = 0
meldsLength ((Kan _ _) : rest) = 4 + meldsLength rest
meldsLength (_ : rest) = 3 + meldsLength rest
-- | Reverse form melds. Concatenate a list of melds back into a hand.
concatMelds :: [Meld] -> Hand
concatMelds [] = []
concatMelds (Pon tile _ : rest) = [tile, tile, tile] ++ concatMelds rest
concatMelds (Kan tile _ : rest) = [tile, tile, tile, tile] ++ concatMelds rest
concatMelds (Chi tile1 tile2 tile3 _ : rest) = [tile1, tile2, tile3] ++ concatMelds rest
-- | 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
& sort
& group
& filter (\list -> 2 <= length list)
& map ((\tile -> (Pair tile, hand \\ [tile, tile])) . head)
-- | Find all the ways of pulling kans out of a hand. In each case pair the set of kans with what remains of the hand.
findKans :: Hand -> [([Meld], Hand)]
findKans hand =
hand
& sort
& group
& filter (\list -> 4 == length list)
& map ((`Kan` False) . head)
& subsequences
-- & tail
& map (\kans -> (kans, hand \\ concat [replicate 4 tile | Kan tile _ <- kans]))
-- | Count the kans in a list of melds
countKans :: [Meld] -> Int
countKans melds = length (filter meldIsKan melds)
-- interpretHand assumes the hand consists of a pair and 4 melds (chis pons or kans).
-- An InterpretedHand can then be passed on to other functions to check for yakus.
-- Seven pairs, thirteen orphans etc are handeled in other functions, that should be
-- checked separately.
-- | A pair and four melds, constituting a complete hand
type InterpretedHand = (Pair, [Meld])
-- | Find all the ways of interpreting a hand as a pair and four melds.
interpretHand :: Hand -> [InterpretedHand]
interpretHand hand =
let
possible_pairs = hand & findPairs
pairs_melds = do
(pair, hand') <- possible_pairs
melds <- formCompleteMelds (length hand) hand'
return (pair, melds)
in
pairs_melds
& filter (\(_, melds) -> length hand == 2 + meldsLength melds)
-- | Show a full interpreted hand
showInterpretedHand :: InterpretedHand -> String
showInterpretedHand (pair, melds) = show pair : map show melds & intercalate ", "
-- | Ask which meld was opened by ron. Return modified melds with that meld opened.
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 $ zipWith (\i meld -> (if i == index then openMeld meld else meld)) [0 ..] melds
{- | Ask which melds are open in a set of melds. Return modified melds with this data added. Opens the specified melds,
| but if a meld is already open it stays that way. (This may change in the future)
-}
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] = map (read . return) input
return $ zipWith (\i meld -> (if i `elem` indices then openMeld meld else meld)) [0 ..] melds