add game preperation process including bidding

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

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