diff --git a/skat.cabal b/skat.cabal index 07b541f..9566bdd 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 895218d6f377b3f153114174aa1ff9de34b3afa1b38042608421753054da7e2c +-- hash: 0b9b42e767fdfcdc821bfc31f5c002e1f6752ba6af032ff402339ef667f60209 name: skat version: 0.1.0.1 @@ -41,6 +41,7 @@ library Skat.Pile Skat.Player Skat.Player.Utils + Skat.Preperation Skat.Render Skat.Utils Skat.WebSocketServer diff --git a/src/Skat/Pile.hs b/src/Skat/Pile.hs index 29ec513..981d481 100644 --- a/src/Skat/Pile.hs +++ b/src/Skat/Pile.hs @@ -110,6 +110,14 @@ playCard :: HasCard c => Hand -> c -> Piles -> Piles playCard hand card' ps = (removeFromHand hand card ps) { _table = (CardS card (P hand)) : _table ps } where card = toCard card' +moveToSkat :: HasCard c => Hand -> [c] -> Piles -> Piles +moveToSkat hand cards' piles = removed { _skat = newSkat } + where cards = map toCard cards' + skat = skatCards piles + notSkatYet = filter (not . (`elem` skat)) cards + newSkat = map (putAt S) $ skat ++ notSkatYet + removed = foldr (\card ps -> removeFromHand hand card ps) piles cards + unplayCard :: Hand -> Card -> Team -> Piles -> Piles unplayCard hand card winner ps | null table = case winner of diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs new file mode 100644 index 0000000..17538a0 --- /dev/null +++ b/src/Skat/Preperation.hs @@ -0,0 +1,100 @@ +{-# 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