skat/src/Skat.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Skat where

import Control.Monad.State
import Control.Monad.Reader
import Data.List
import Data.Vector (Vector)

import Skat.Card
import Skat.Pile
import Skat.Player (Players)
import qualified Skat.Player as P

data SkatEnv = SkatEnv { piles :: Piles
                       , turnColour :: Maybe Colour
                       , trumpColour :: Colour
                       , players :: Players
                       , currentHand :: Hand }
               deriving Show

type Skat = StateT SkatEnv IO

instance P.MonadPlayer Skat where
    trumpColour = gets trumpColour
    turnColour = gets turnColour
    showSkat p = case P.team p of
        Single -> fmap (Just . skatCards) $ gets piles
        Team -> return Nothing

instance P.MonadPlayerOpen Skat where
    showPiles = gets piles

modifyp :: (Piles -> Piles) -> Skat ()
modifyp f = modify g
    where g env@(SkatEnv {piles}) = env { piles = f piles}

getp :: (Piles -> a) -> Skat a
getp f = gets piles >>= return . f

modifyPlayers :: (Players -> Players) -> Skat ()
modifyPlayers f = modify g
    where g env@(SkatEnv {players}) = env { players = f players }

setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
setTurnColour col sk = sk { turnColour = col }

setCurrentHand :: Hand -> SkatEnv -> SkatEnv
setCurrentHand hand sk = sk { currentHand = hand }

mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv
mkSkatEnv = SkatEnv

allowedCards :: Skat [CardS Owner]
allowedCards = do
    curHand <- gets currentHand
    pls <- gets players
    turnCol <- gets turnColour
    trumpCol <- gets trumpColour
    getp $ allowed curHand trumpCol turnCol