skat/src/Skat/Preperation.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TupleSections #-}

module Skat.Preperation (
    Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation,
    publishGameResults, bidder, makePrep
) 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)

data PrepEnv = PrepEnv { piles :: Piles
                       , bidders :: Bidders
                       , current :: Bid }
               deriving Show

makePrep :: Piles -> Bidders -> PrepEnv
makePrep ps bd = PrepEnv ps bd 0

type Preperation = StateT PrepEnv IO

class Bidder a where
    hand :: a -> Hand
    onStart :: MonadIO m => a -> m ()
    askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid)
    askResponse :: MonadIO m => a -> Hand -> Bid -> 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
    onBid :: MonadIO m => a -> Maybe Bid -> Hand -> Hand -> m ()
    onBid _ _ _ _ = return ()
    onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m ()
    onResponse _ _ _ _ = return ()
    onGame :: MonadIO m => a -> HideGame -> Hand -> m ()
    onGame _ _ _ = return ()
    onResult :: MonadIO m => a -> Result -> m ()
    onResult _ _ = return ()
    onNoGame :: MonadIO m => a -> m ()
    onNoGame _ = return ()

-- | 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
    onStart (BD b) = onStart b
    onGame (BD b) = onGame b
    onResult (BD b) = onResult b
    onBid (BD b) = onBid b
    onResponse (BD b) = onResponse b
    onNoGame (BD b) = onNoGame 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
    onStart (bidder bds Hand1)
    onStart (bidder bds Hand2)
    onStart (bidder bds Hand3)
    (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1)
    (finalWinner, finalBid) <- runBidding bid (bidder bds Hand3) (bidder bds winner)
    if finalBid == 0 then do
        bid <- askBid (bidder bds finalWinner) finalWinner 0
        publishBid bid finalWinner finalWinner
        case bid of
            Just val -> Just <$> initGame finalWinner val
            Nothing -> publishNoGame >> 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
            | val > startingBid -> do
                publishBid first (hand reizer) (hand gereizter)
                modify $ \env -> env { current = val }
                response <- askResponse gereizter (hand reizer) val
                publishResponse response (hand reizer) (hand gereizter)
                if response then runBidding val reizer gereizter
                else return (hand reizer, val)
            | otherwise -> do
                publishBid Nothing (hand reizer) (hand gereizter)
                return (hand gereizter, startingBid)
        Nothing -> do
            publishBid Nothing (hand reizer) (hand gereizter)
            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 handleSkat (bidder bds single) bid ps
    -- ask for game kind
    game <- handleGame (bidder bds single) bid noSkat
    -- publish game start
    publishGameStart game single
    -- construct skat env
    return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1 single

handleGame :: BD -> Bid -> Bool -> Preperation Game
handleGame bd bid noSkat = do
    cards <- (\ps -> map toCard (handCards (hand bd) ps) ++ skatCards ps) <$> gets piles
    -- ask bidder for game
    proposal <- askGame bd bid
    -- check if proposal is allowed
    if isHand proposal == noSkat then return proposal else handleGame bd bid noSkat

handleSkat :: BD -> Bid -> Piles -> Preperation Piles
handleSkat bd bid ps = do
    let skat = skatCards ps
    skat' <- askSkat bd bid skat
    liftIO $ putStrLn $ "received skat " ++ show skat'
    case moveToSkat (hand bd) skat' ps of
        Just correct -> return correct
        Nothing -> handleSkat bd bid ps

publishGameResults :: MonadIO m => Result -> Bidders -> m ()
publishGameResults res bidders = do
    onResult (bidder bidders Hand1) res
    onResult (bidder bidders Hand2) res
    onResult (bidder bidders Hand3) res

publishGameStart :: Game -> Hand -> Preperation ()
publishGameStart game sglPlayer = mapBidders (\b -> onGame b (HideGame game) sglPlayer)

publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)

publishResponse :: Bool -> Hand -> Hand -> Preperation ()
publishResponse response reizer gereizter = mapBidders (\b -> onResponse b response reizer gereizter)

publishNoGame :: Preperation ()
publishNoGame = mapBidders onNoGame

mapBidders :: (BD -> Preperation ()) -> Preperation ()
mapBidders f = do
    bds <- gets bidders
    f (bidder bds Hand1)
    f (bidder bds Hand2)
    f (bidder bds Hand3)