skat/src/Skat/Preperation.hs

{-# LANGUAGE ExistentialQuantification #-}

module Skat.Preperation (

) where

import Control.Monad.IO.Class
import Control.Monad.State

import Skat.Pile
import Skat.Card
import Skat.Player (PL, Players(..))
import Skat.Bidding
import Skat (SkatEnv, mkSkatEnv)

type Bid = Int

data PrepEnv = PrepEnv { piles :: Piles
                       , currentBid :: Bid
                       , currentHand :: Hand
                       , bidders :: Bidders }
               deriving Show

type Preperation = StateT PrepEnv IO

class Bidder a where
    hand :: a -> Hand
    askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid)
    askResponse :: MonadIO m => a -> Hand -> m Bool
    askGame :: MonadIO m => a -> Bid -> m Game
    askHand :: MonadIO m => a -> Bid -> m Bool
    askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card]
    toPlayer :: a -> Team -> PL

-- | trick to allow heterogenous bidder list
data BD = forall b. (Show b, Bidder b) => BD b

instance Show BD where
    show (BD b) = show b

instance Bidder BD where
    hand (BD b) = hand b
    askBid (BD b) = askBid b
    askGame (BD b) = askGame b
    askHand (BD b) = askHand b
    askSkat (BD b) = askSkat b
    askResponse (BD b) = askResponse b
    toPlayer (BD b) = toPlayer b

data Bidders = Bidders BD BD BD
               deriving Show

bidder :: Bidders -> Hand -> BD
bidder (Bidders b _ _) Hand1 = b
bidder (Bidders _ b _) Hand2 = b
bidder (Bidders _ _ b) Hand3 = b

toPlayers :: Hand -> Bidders -> Players
toPlayers single (Bidders b1 b2 b3) =
    Players (toPlayer b1 $ if single == Hand1 then Single else Team)
            (toPlayer b2 $ if single == Hand2 then Single else Team)
            (toPlayer b3 $ if single == Hand3 then Single else Team)

runPreperation :: Preperation (Maybe SkatEnv)
runPreperation = do
    bds <- gets bidders
    (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1)
    (finalWinner, finalBid) <- runBidding 0 (bidder bds Hand3) (bidder bds winner)
    if finalBid == 0 then do
        bid <- askBid (bidder bds finalWinner) finalWinner 0
        case bid of
            Just val -> Just <$> initGame finalWinner val
            Nothing -> return Nothing
        else Just <$> initGame finalWinner finalBid

runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid)
runBidding startingBid reizer gereizter = do
    first <- askBid reizer (hand gereizter) startingBid
    case first of
        Just val -> do
            response <- askResponse gereizter (hand reizer)
            if response then runBidding val reizer gereizter
            else return (hand reizer, val)
        Nothing -> return (hand gereizter, startingBid)

initGame :: Hand -> Bid -> Preperation SkatEnv
initGame single bid = do
    ps <- gets piles
    bds <- gets bidders
    -- ask if player wants to play hand
    noSkat <- askHand (bidder bds single) bid
    -- either return piles or ask for skat cards and modify piles
    ps' <- if noSkat then return ps else do
        let skat = skatCards ps
        skat' <- askSkat (bidder bds single) bid skat
        return $ moveToSkat single skat' ps
    -- ask for game kind
    (Colour col _) <- askGame (bidder bds single) bid
    -- construct skat env
    return $ mkSkatEnv ps Nothing col (toPlayers single bds) Hand1