Go-Fish Haskell

Main.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Control.Lens
import Control.Lens.Internal.Zoom
import Control.Monad.Loops (whileM_)
import Control.Monad.Reader ( ReaderT (ReaderT), runReaderT )
import Control.Monad.State
    ( StateT
    , state
    , get
    , put
    , modify
    , forM_
    , MonadIO
    , MonadState
    , liftIO
    , execStateT
    )
import Data.IORef
import Data.List (foldl')
import Data.Map (Map)
import Data.Monoid (First (First), getFirst)
import System.Random (RandomGen, getStdGen)
import System.Random.Shuffle (shuffle')

import qualified Data.Map as Map

-- Abstracts over pure game functions
class CardGame g where
    -- | Returns true if the game is won.
    hasWon :: g -> Bool

-- Abstracts over effectful game functions
class (MonadIO m) => CardGameM m where
    -- | Shuffles the deck.
    shuffleDeck :: m ()

    -- | Deal a certain amount of cards to each player.
    deal :: Int -> m ()

    -- | Runs through a turn of the game.
    runTurn :: m ()

data Suite
    = Diamonds
    | Clubs
    | Hearts
    | Spades
    deriving (Show, Eq)

data Card = Card
    { cardSuite :: Suite
    , cardValue :: Int
    } deriving (Show, Eq)
makeFields ''Card

data Response = GiveCard Card | Fish deriving (Show)

data Player = Player
    { playerCards    :: [Card]
    , playerNumBooks :: Int
    } deriving (Show, Eq)
makeFields ''Player

data Game = Game
    { gamePlayers    :: Map Int Player
    , gameTurnCycle  :: [Int]
    , gameDeck       :: [Card]
    , gameMainPlayer :: Int
    } deriving (Show)
makeFields ''Game

newtype GameT s m a = GameT
    { unGameT :: StateT s m a }
    deriving (Functor, Applicative, Monad, MonadIO, MonadState s)

type instance Zoomed (GameT s m) = Focusing m
instance (Monad m) => Zoom (GameT s m) (GameT t m) s t where
    zoom l = GameT . zoom l . unGameT

execGameT :: (Monad m) => GameT s m a -> s -> m s
execGameT = execStateT . unGameT

-- Alternative implementation of GameT using ReaderT (IORef s).
newtype GameT' s m a = GameT'
    { unGameT' :: ReaderT (IORef s) m a }
    deriving (Functor, Applicative, Monad, MonadIO)

instance (MonadIO m) => MonadState s (GameT' s m) where
    get = GameT' $ ReaderT $ liftIO . readIORef
    put x = GameT' $ ReaderT $ \ref -> liftIO $ writeIORef ref x

type instance Zoomed (GameT' s m) = Focusing m
instance (MonadIO m) => Zoom (GameT' s m) (GameT' t m) s t where
    zoom l (GameT' r) =
        GameT' $ ReaderT $ \ref -> do
            s <- liftIO $ readIORef ref
            (v', s') <- unfocusing . l (runSubstate r) $ s
            liftIO $ writeIORef ref s'
            return v'
      where
        -- t is a substate of s, and m is the ReaderT effect to apply.
        runSubstate m t = Focusing $ do
            ref' <- liftIO (newIORef t)
            v <- runReaderT m ref'
            t' <- liftIO (readIORef ref')
            return (v, t')

execGameT' :: (MonadIO m) => GameT' s m a -> s -> m s
execGameT' (GameT' (ReaderT f)) s = do
    ref <- liftIO $ newIORef s
    f ref
    liftIO $ readIORef ref

-- Replace with GameT' to use ReaderT IORef version.
type GoFishT m = GameT Game m

createDeck :: [Card]
createDeck = Card <$> [Diamonds, Clubs, Hearts, Spades] <*> [1..13]

createGame :: Int -> Game
createGame numOtherPlayers =
    Game playerMap turnCycle createDeck 1
  where
    playerMap = foldl' buildPlayerMap Map.empty [1..numOtherPlayers + 1]
    buildPlayerMap map player = Map.insert player emptyPlayer map
    turnCycle = cycle [1..numOtherPlayers + 1]

emptyPlayer :: Player
emptyPlayer = Player [] 0

takeCard :: Card -> Player -> Player
takeCard c p = p & cards .~ cards'
  where
    cards' = filter (/= c) $ p ^. cards

addCard :: Card -> Player -> Player
addCard c p = removeBooks $ p & cards .~ c:p ^. cards

removeBooks :: Player -> Player
removeBooks p = setPlayer . reduceMap (p ^. numBooks) . buildMap $ p ^. cards
  where
    buildMap = foldl' buildBookCounts Map.empty
    buildBookCounts map card = Map.insertWith (+) (card ^. value) 1 map
    reduceMap numBooks = foldl' reduceBooks (numBooks, p ^. cards) . Map.toList
    reduceBooks (books, cards) (value, count)
        | count >= 4 = (books + 1, removeCards value cards)
        | otherwise  = (books, cards)
    removeCards value' = filter (\c -> c ^. value /= value')
    setPlayer (books, cards') = p & numBooks .~ books & cards .~ cards'

requestCard :: (MonadState Player m) => Int -> m Response
requestCard rank = state $ \p ->
    case filter equalsRank (p ^. cards) of
        (c:_) -> (GiveCard c, takeCard c p)
        _     -> (Fish, p)
  where
    equalsRank c = c ^. value == rank

dealCard :: (MonadIO m, MonadState [Card] m) => m Card
dealCard = do
    cards <- get
    gen <- liftIO getStdGen
    case cards of
        (card:rest) -> do
            put rest
            return card
        _ -> do
            put $ shuffleList gen createDeck
            dealCard

mapKeys :: Map a b -> [a]
mapKeys = map fst . Map.toList

runAI :: (MonadIO m, MonadState Player m) => [Int] -> Int -> m (Int, Int)
runAI keys player = do
    cards <- use cards
    gen <- liftIO getStdGen
    let shuffledCards   = shuffleList gen cards
        shuffledPlayers = shuffleList gen otherPlayers
    case (shuffledCards, shuffledPlayers) of
        (card:_, key:_) -> return (key, card ^. value)
        _               -> return (1, 1)
  where
    otherPlayers = filter (/= player) keys

askAction :: Player -> [Int] -> Int -> IO (Int, Int)
askAction player keys playerIdx = do
    putStrLn $ "Number of books: " ++ show (player ^. numBooks)
    printCards (player ^. cards)
    putStrLn "Enter the player to ask: "
    let filteredKeys = filter (/= playerIdx) keys
    forM_ filteredKeys $ \key ->
        putStrLn $ "Player " ++ show key
    idx <- read <$> getLine
    if idx `notElem` filteredKeys
        then do
            putStrLn "Invalid player"
            askAction player keys playerIdx
        else do
            putStrLn "Enter the value of the card to ask for: "
            value <- read <$> getLine
            if value < 1 || value > 13
                then do
                    putStrLn "Invalid value (must be between 1 and 13)"
                    askAction player keys playerIdx
                else return (idx, value)

printCards :: [Card] -> IO ()
printCards cards =
    forM_ cards $ \c ->
        putStrLn $ show (c ^. value) ++ " of " ++ show (c ^. suite)

shuffleList :: (RandomGen gen) => gen -> [a] -> [a]
shuffleList gen list = shuffle' list (length list) gen

instance CardGame Game where
    hasWon =
        not . null . Map.filter emptyPlayer . gamePlayers
      where
        emptyPlayer (Player cards _) = null cards

-- Zooms in on a Maybe traversal and returns result as Maybe.
prezoom :: (Zoom m f s t) => LensLike' (Zoomed m (First a)) t s -> m a -> f (Maybe a)
prezoom l m = getFirst <$> zoom l (First . Just <$> m)

instance (MonadIO m) => CardGameM (GoFishT m) where
    shuffleDeck = liftIO getStdGen >>= zoom deck . modify . shuffleList

    deal num = do
        keys <- mapKeys <$> use players
        forM_ (const <$> keys <*> [1..num]) $ \id -> do
            card <- zoom deck dealCard
            zoom (players . at id . _Just) $ modify $ addCard card

    runTurn = do
        (currPlayer:rest) <- use turnCycle
    
        liftIO $ putStrLn $ "Player " ++ show currPlayer ++ "'s turn"
    
        keys <- mapKeys <$> use players
        mainPlayer <- use mainPlayer
        Just p <- preuse (players . ix currPlayer)
        Just (askPlayer, value') <- if currPlayer == mainPlayer
            then Just <$> liftIO (askAction p keys currPlayer)
            else prezoom (players . at currPlayer . _Just) $ runAI keys currPlayer
    
        liftIO $ putStrLn $ "Player " ++ show currPlayer ++ " is asking Player " ++
            show askPlayer ++ " for a card of value " ++ show value'
    
        Just result <- prezoom (players . at askPlayer . _Just) $ requestCard value'
        case result of
            GiveCard card -> do
                liftIO $ putStrLn $ "Player " ++ show currPlayer ++ " got " ++ show card
                zoom (players . at currPlayer . _Just) $ modify $ addCard card
                runTurn
            Fish -> do
                liftIO $ putStrLn $ "Player " ++ show currPlayer ++ " fished"
                card <- zoom deck dealCard
                zoom (players . at currPlayer . _Just) $ modify $ addCard card
                if card ^. value == value'
                    then runTurn
                    else turnCycle .= rest

runGame :: (CardGameM m, MonadState s m, CardGame s) => Int -> m ()
runGame numDeal = do
    shuffleDeck
    deal numDeal
    whileM_ (not . hasWon <$> get) runTurn

main :: IO ()
main = do
    let game = createGame 4
    -- Replace with execGameT' to use ReaderT IORef version.
    execGameT (runGame 7) game
    return ()