christian/skat
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement grand and null mechanics, fix some online player issues

Browse Source
This commit is contained in:
christian
2020-03-31 01:27:27 +02:00
parent 5241033cb3
commit 2567bf4cd9
17 changed files with 291 additions and 174 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Skat/Preperation.hs
+35 -10
View File
@@ -1,7 +1,9 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TupleSections #-}
module Skat.Preperation (
Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation
Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation,
publishGameResults
) where
import Control.Monad.IO.Class
@@ -30,6 +32,10 @@ class Bidder a where
askHand :: MonadIO m => a -> Bid -> m Bool
askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card]
toPlayer :: a -> Team -> PL
onGame :: MonadIO m => a -> Game -> Hand -> m ()
onGame _ _ _ = return ()
onResult :: MonadIO m => a -> Result -> m ()
onResult _ _ = return ()
-- | trick to allow heterogenous bidder list
data BD = forall b. (Show b, Bidder b) => BD b
@@ -46,6 +52,8 @@ instance Bidder BD where
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
data Bidders = Bidders BD BD BD
deriving Show
@@ -61,29 +69,31 @@ toPlayers single (Bidders b1 b2 b3) =
(toPlayer b2 $ if single == Hand2 then Single else Team)
(toPlayer b3 $ if single == Hand3 then Single else Team)
runPreperation :: Preperation (Maybe SkatEnv)
runPreperation :: Preperation (Maybe (Hand, SkatEnv))
runPreperation = do
bds <- asks 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 0 (bidder bds Hand3) (bidder bds winner)
(finalWinner, finalBid) <- runBidding bid (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
Just val -> (Just . (finalWinner,)) <$> initGame finalWinner val
Nothing -> return Nothing
else Just <$> initGame finalWinner finalBid
else (Just . (finalWinner,)) <$> 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) val
if response then runBidding val reizer gereizter
else return (hand reizer, val)
Just val
| val > startingBid -> do
response <- askResponse gereizter (hand reizer) val
if response then runBidding val reizer gereizter
else return (hand reizer, val)
| otherwise -> return (hand gereizter, startingBid)
Nothing -> return (hand gereizter, startingBid)
initGame :: Hand -> Bid -> Preperation SkatEnv
@@ -96,8 +106,10 @@ initGame single bid = do
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 Spades (toPlayers single bds) Hand1
return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1
handleGame :: BD -> Bid -> Bool -> Preperation Game
handleGame bd bid noSkat = do
@@ -119,3 +131,16 @@ handleSkat bd bid ps = do
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 = do
bds <- asks bidders
onGame (bidder bds Hand1) game sglPlayer
onGame (bidder bds Hand2) game sglPlayer
onGame (bidder bds Hand3) game sglPlayer