hoc

hoc.hs

{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, ConstraintKinds  #-}
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Data.List

{- Card definition -}

data CardType = Inherits | Land deriving Show
data SubType = Maid | None deriving Show

data Card = Card { coin :: Int
                 , cardType :: CardType
                 , subType :: SubType
                 , name :: String
                 , description :: String
                 } deriving Show


data Field = Field { discardPile :: [Card]
                   , deck :: [Card]
                   } deriving Show


daMaid = Card { coin = 0
              , cardType = Inherits
              , subType = Maid
              , name = "見習い次女"
              , description = "" }

farmVillage = Card { coin = 1
                   , cardType =  Land
                   , subType = None
                   , name = "農村"
                   , description ="" }


initDeck = (replicate 7 farmVillage) ++ (replicate 3 daMaid)

{- Game -}

newtype PlayT m a = PlayT { playT :: StateT Field m a }
   deriving (Functor, Applicative, Monad, MonadTrans, MonadPlus, MonadIO, MonadState Field)


runPlay :: IO ((), Field)
runPlay = run play $ Field { deck = initDeck {- TODO: shuffle -}, discardPile = [] }
    where run = runStateT . playT


type Playable m = (MonadIO m, Monad m, Applicative m, MonadPlus m)


play :: Playable m => PlayT m ()
play = do
  hands <- draw 5
  deck <- getDeck
  discards <- getDiscardPile
  print hands deck discards
  discard hands
  play
    where
      print hands deck discards =
          liftIO $ do putStrLn "-----"
                      putStrLn "[Hand Cards]"
                      mapM_ (putStrLn . show) hands
                      putStrLn "[Deck]"
                      mapM_ (putStrLn . show) deck
                      putStrLn "[Discard]"
                      mapM_ (putStrLn . show) discards
                      threadDelay $ 2 * 1000 * 1000


draw :: Playable m => Int -> PlayT m [Card]
draw maxHands = do
  (hands, deck) <- splitAt maxHands <$> getDeck
  if length hands < maxHands
  then
      do reshuffle
         let rest = maxHands - (length hands)
         (remain, deck') <- splitAt rest <$> getDeck
         putDeck deck'
         return $ hands ++ remain
  else
      do
        putDeck deck
        return hands


discard :: Playable m => [Card] -> PlayT m ()
discard cards = do
  discards <- getDiscardPile
  putDiscardPile $ discards ++ cards


reshuffle :: Playable m => PlayT m ()
reshuffle = do
  deck <- getDeck
  guard $ length deck <= 0
  discards <- getDiscardPile
  -- TODO: reshuffle discards then put those cards to deck
  putDiscardPile []
  putDeck discards


getDeck :: (Applicative m, Monad m) => PlayT m [Card]
getDeck = deck <$> get


getDiscardPile :: (Applicative m, Monad m) => PlayT m [Card]
getDiscardPile = discardPile <$> get


putDeck :: (Applicative m, Monad m) => [Card] -> PlayT m ()
putDeck cards = do
    f <- get
    put $ f { deck = cards }


putDiscardPile :: (Applicative m, Monad m) => [Card] -> PlayT m ()
putDiscardPile cards = do
  f <- get
  put $ f { discardPile = cards }